#!/usr/bin/perl

# Coded by Trizen under the GPL.
# Latest edit on: 01 October 2011
# Email: echo dHJpemVueEBnbWFpbC5jb20K | base64 -d
# Website: http://trizen.go.ro

use warnings;
use strict;

print "
            **************************************************
                            Perl script deparser
            **************************************************
\nUsage:
    $0 <script1> <script2> <script3> <...>
    $0 *.pl /some/path/*.pl '/another/path/my script.pl'
\nBase options:
    -n, --no-backup
    -F, --format_sub_call ( &sub; -> sub(); )
    -D, --dont-deparse (perltidy and newline replacer only)
\nLines options:
    -l <value>    : length line limit (default: 130)
\nPerltidy options:
    -ANY   : any unknown argument will be passed to the perltidy line\n\n"
  and exit
  unless scalar @ARGV;

my $no_backup       = 0;
my $dont_deparse    = 0;
my $format_sub_call = 0;
my $line_limit      = 131;
my $arg_ord         = 0;
my (@files, $perltidy);

my (@keywords) = (
                  'and',        'for',            'foreach',          'if',          'elsif',         'else',
                  'unless',     'or',             'not',              'x',           'sprintf',       'substr',
                  'tr',         'uc',             'ucfirst',          'y',           'm',             'pos',
                  'qr',         'quotemeta',      's',                'chomp',       'chop',          'split',
                  'study',      'abs',            'atan2',            'cos',         'exp',           'hex',
                  'int',        'log',            'oct',              'rand',        'sin',           'sqrt',
                  'srand',      'pop',            'push',             'shift',       'splice',        'unshift',
                  'grep',       'join',           'map',              'qw',          'reverse',       'sort',
                  'unpack',     'delete',         'each',             'exists',      'keys',          'values',
                  'binmode',    'close',          'closedir',         'dbmclose',    'dbmopen',       'die',
                  'eof',        'fileno',         'flock',            'format',      'getc',          'print',
                  'printf',     'read',           'readdir',          'readline',    'rewinddir',     'seek',
                  'seekdir',    'select',         'syscall',          'sysread',     'sysseek',       'syswrite',
                  'tell',       'telldir',        'truncate',         'warn',        'write',         'pack',
                  'read',       'syscall',        'sysread',          'sysseek',     'syswrite',      'unpack',
                  'vec',        'chdir',          'chmod',            'chown',       'chroot',        'fcntl',
                  'glob',       'ioctl',          'link',             'lstat',       'mkdir',         'open',
                  'opendir',    'readlink',       'rename',           'rmdir',       'stat',          'symlink',
                  'sysopen',    'umask',          'unlink',           'utime',       'caller',        'continue',
                  'die',        'do',             'dump',             'eval',        'exit',          'goto',
                  'last',       'next',           'prototype',        'redo',        'return',        'sub',
                  'wantarray',  'caller',         'import',           'local',       'my',            'our',
                  'package',    'use',            'defined',          'dump',        'eval',          'formline',
                  'local',      'my',             'our',              'prototype',   'reset',         'scalar',
                  'undef',      'wantarray',      'alarm',            'exec',        'fork',          'getpgrp',
                  'getppid',    'getpriority',    'kill',             'pipe',        'qx',            'readpipe',
                  'setpgrp',    'setpriority',    'sleep',            'system',      'times',         'wait',
                  'waitpid',    'do',             'import',           'no',          'package',       'require',
                  'use',        'bless',          'dbmclose',         'dbmopen',     'package',       'ref',
                  'tie',        'tied',           'untie',            'use',         'accept',        'bind',
                  'connect',    'getpeername',    'getsockname',      'getsockopt',  'listen',        'recv',
                  'send',       'setsockopt',     'shutdown',         'socket',      'socketpair',    'msgctl',
                  'msgget',     'msgrcv',         'msgsnd',           'semctl',      'semget',        'semop',
                  'shmctl',     'shmget',         'shmread',          'shmwrite',    'endgrent',      'endhostent',
                  'endnetent',  'endpwent',       'getgrent',         'getgrgid',    'getgrnam',      'getlogin',
                  'getpwent',   'getpwnam',       'getpwuid',         'setgrent',    'setpwent',      'endprotoent',
                  'endservent', 'gethostbyaddr',  'gethostbyname',    'gethostent',  'getnetbyaddr',  'getnetbyname',
                  'getnetent',  'getprotobyname', 'getprotobynumber', 'getprotoent', 'getservbyname', 'getservbyport',
                  'getservent', 'sethostent',     'setnetent',        'setprotoent', 'setservent',    'gmtime',
                  'localtime',  'time',           'times'
                 );

my $keywords = join('|', grep(($_ ne 'elsif' && $_ ne 'else'), @keywords));
$keywords = qr/$keywords/;

foreach $_ (@ARGV) {
    ++$arg_ord;

    if ($_ eq '-l' and $ARGV[$arg_ord] and $ARGV[$arg_ord] =~ /^\d+$/) {
        $line_limit         = ++$ARGV[$arg_ord];
        $ARGV[$arg_ord - 1] = '';
        $ARGV[$arg_ord]     = '';
    }
}

my $perltidy_options =
  '-l=' . ($line_limit - 1) . ' -f -kbl=1 -bbb -bbc -bbs -b -ple -bt=2 -pt=2 -sbt=2 -bvt=0 -sbvt=1 -cti=1 -bar -lp -anl';

foreach $_ (split(m?:?, $ENV{'PATH'}, 0), @INC) {

    if (-e "$_/perltidy") {
        $perltidy = "perl $_/perltidy";
        last;
    }
}

foreach $_ (@ARGV) {

    if (substr($_, 0, 1) eq '-') {

        if (/^-+(?:n|no.?backup)$/) {
            $no_backup = 1;
            next;
        }
        elsif (/^-+(?:D|dont.?deparse)$/) {
            $dont_deparse = 1;
            next;
        }
        elsif (/^-+(?:F|format_sub_call)$/) {
            $format_sub_call = 1;
            next;
        }
        elsif (/^-+[a-z]/) {
            $perltidy_options .= ' ' . $_;
            next;
        }
    }
    else {
        push @files, glob($_);
    }
}

foreach my $arg (@files) {
    next unless -f $arg;

    my $file1 = quotemeta $arg;
    my $file2 = $file1 . '.tmp';
    my @comments;
    my $strict_refs = 0;
    my $original_file;

    open READ, '<', $arg;
    sysread READ, $original_file, -s $arg;

    unless ($dont_deparse) {
        $strict_refs = 1 if $original_file =~ /(?:^|\n) *use *strict *(?:(?:q[wq]?)? *\W[^\n]*|'|")refs\b/;

        foreach $_ (split(/\n/, $original_file, 0)) {
            next if substr($_, 0, 2) eq '#!';

            last unless /^ *(?:#|$)/;
            push @comments, "$_\n";
        }
    }

    if ($dont_deparse) {
        warn $! && next unless open WRITE, ">$arg.tmp";

        print WRITE $original_file;

        close WRITE;
        close READ;
    }
    else {
        system "perl -MO=Deparse $file1 > $file2";
    }

    my $backup = "$arg.bak";
    my $n      = 0;

    if (-e $backup) {

        while (-e $backup) {
            ++$n;
            $backup = "${arg}_$n.bak";
        }
    }

    rename $arg, $backup;

    print "* Backup file: $backup\n" if -f $backup;

    if ($perltidy) {
        print $perltidy . "\n";
        system "$perltidy $perltidy_options $file2";
    }

    my @file;
    my $changed_lines = 0;

    warn $! and next unless open FILE, '<', "$arg.tmp";

    while (defined($_ = <FILE>)) {
        next if /^\s*use File::Glob \(\);\s*$/;

        s/split(\s*)(\(?)(\s*)\?/split$1$2$3m?/g if /\bsplit\s*\(\s*\?/;
        push @file, "1;\n" and next if $_ eq "'???';\n";

        if (length $_ > $line_limit) {

            if (/\\n.+\\n/ or /\\n.{5}/) {
                s/([^\\])\\n(.{5})/$1\n$2/g;
                $changed_lines = 1 unless $changed_lines;
            }
        }

        push @file, $_;
    }

    print "* Adding some newline characters...\n" if $changed_lines;

    my $file = join('', @file);

    unless ($dont_deparse) {
        $file =~ s/\s*(?:sub *)?BEGIN *\{\s*(?:\$\^H\{'\w+'\} *= *q? *\(? *1 *\)?;\s*)+\s*\}[^\n]*\n//gs;
        $file =~
s/\s*sub +BEGIN *\{\s*(?:\s*use +(?:strict|warnings);?\s*(?:['"]refs['"]\s*;)?)*\s*require *([v.\d]+);?\s*\}[^\n]*/use $1;/gs;

        foreach my $regxp (qr/( *(?:until|if|unless|do|while|for(?:each)?|eval)\b[^\n]+\{) *\n+/) {
            $file =~ s/^$regxp/\n$1\n/gms;
        }

        $file =~ s/\s*(?:sub)? *BEGIN *\{\s*\$\^W\s*=\s*1;\s*\}\n//g if $file =~ /^\s*use warnings;/m;
        print "* Adding top comments...\n" if scalar @comments;
        $file = "#!/usr/bin/perl\n" . join('', @comments) . $file;

        unless ($strict_refs) {
            $file =~ s/\buse strict 'refs';/use strict;/g;
        }

        my (@tmp_file) = split(/\n/, $file, 0);
        my $l = 0;

        foreach $_ (@tmp_file) {
            $tmp_file[$l - 1] = $tmp_file[$l - 1] . "\n" and last if /^my\b/;
            ++$l;
        }

        my $use = 0;
        $l = 0;

        foreach $_ (@tmp_file) {

            if (defined $_ and /^ *use\b/) {
                $use = 1;
            }
            elsif ($use) {
                $tmp_file[$l - 1] = $tmp_file[$l - 1] . "\n" unless $tmp_file[$l - 1] =~ /\n\z/;
                last;
            }
            ++$l;
        }

        my $my;
        $l = 0;

        foreach $_ (@tmp_file) {

            if (defined $_ and /^my *\(? *[\$\@\%]+.*; *$/) {
                $my = 1;
            }
            elsif ($my) {
                $my = 0;
            }

            if (defined $my and not $my) {
                $tmp_file[$l - 1] = $tmp_file[$l - 1] . "\n" unless $tmp_file[$l - 1] =~ /\n\z/;
                last;
            }
            ++$l;
        }

        my $close;
        $l = 0;

        foreach $_ (@tmp_file) {

            if (/^ *close(?:dir)?\b/) {
                $close = 1;
            }
            elsif ($close) {
                $close = 0;
            }

            if (defined $close and not $close) {
                $tmp_file[$l - 1] = $tmp_file[$l - 1] . "\n" unless $tmp_file[$l] =~ /^ *.$/ or $tmp_file[$l] =~ /\n\z/;
                undef $close;
            }
            ++$l;
        }

        foreach my $l (1 .. $#tmp_file) {

            if ($tmp_file[$l] =~ /^\s*my\b/ and not $tmp_file[$l - 1] =~ /^\s*my\b/ and not $tmp_file[$l - 1] =~ /\{\s*$/) {
                $tmp_file[$l] = "\n" . $tmp_file[$l] unless $tmp_file[$l] =~ /^\n/ or $tmp_file[$l - 1] =~ /\n\z/;
            }
        }

        $l = 0;

        foreach $_ (@tmp_file) {

            if (defined $_ and /^ *\}$/ and defined $tmp_file[$l + 1] and $tmp_file[$l + 1] =~ /^ *(?:(\\)?\$\w|$keywords\b)/) {
                $tmp_file[$l] = $tmp_file[$l] . "\n" unless $tmp_file[$l] =~ /\n\z/;
            }
            ++$l;
        }

        foreach my $l (0 .. $#tmp_file) {
            if ($tmp_file[$l] =~ /^ *($keywords)\b/ and not $tmp_file[$l] =~ /^ *(?:[msy]|tr)\b/ and not $tmp_file[$l] =~ /\{ *$/)
            {
                my $keyword = $1;

                if (
                    defined $tmp_file[$l + 1]

                    and $tmp_file[$l + 1]     =~ /^ *$keywords\b/o
                    and not $tmp_file[$l + 1] =~ /^ *$keyword\b/
                    and not $tmp_file[$l]     =~ /\n\z/
                    and not $tmp_file[$l + 1] =~ /\n\z/
                  ) {

                    if (defined $tmp_file[$l + 2]) {

                        unless ($tmp_file[$l + 2] =~ /\}$/) {
                            $tmp_file[$l] .= "\n";
                        }
                    }
                    else {
                        $tmp_file[$l] .= "\n";
                    }
                }
            }
        }

        $file = join("\n", @tmp_file);

        if ($format_sub_call) {
            $file = format_sub_call($file);
        }
    }

    open FILE, ">$arg.tmp";
    print FILE "$file\n";
    close FILE;

    if ($perltidy and $changed_lines) {
        print $perltidy . "\n";
        system "$perltidy $perltidy_options $file2";
    }

    rename "$arg.tmp", $arg;

    unlink "$arg.tmp.bak" if -f "$arg.tmp.bak";

    if ($no_backup) {
        print "* Removing backup: $backup\n";
        unlink $backup;
    }

    system "perl -MO=Lint $file1";
    undef @file;
}

sub format_sub_call {
    use warnings;
    use strict;

    my $file = shift();

    foreach $_ ($file =~ /\bsub\s+(\w+)\s*(?:\([^\)]*\))?\s*\{/g) {

        unless ($_ ~~ \@keywords) {
            $file =~ s/(\n *)&?$_(?:\(\s*\))?;/$1$_();/g;
            $file =~ s/(\n *)&?$_\(\s*\)?(\s+)($keywords)\b/$1$_()$2$3/g;
        }
    }

    return $file;
}