view release on metacpan or  search on metacpan

deobfuscator/Deobfuscator/bin/deob_index.pl  view on Meta::CPAN

my @list_holder; # hold all package names so we can sort them before writing.

# record misbehaving BioPerl docs to a file
my $log;    # filehandle
my $logfile = $dest_dir . "/deob_index.log";
open $log, ">$logfile" or die "deob_index.pl: couldn't open $logfile:$!\n";

# create databases
my $meth_file = $dest_dir . '/methods.db';
if ( -e $meth_file ) { unlink($meth_file); }    # remove for production?
my $meth_db = create_db($meth_file) or die "deob_index.pl: couldn't create $meth_file: $!\n";
my $pkg_file = $dest_dir . '/packages.db';
if ( -e $pkg_file ) { unlink($pkg_file); }      # remove for production?
my $pkg_db = create_db($pkg_file) or die "deob_index.pl: couldn't create $pkg_file: $!\n";

# used to make sure we're parsing in the right order
my %FLAG;

# store version string in packages.db
$pkg_db->{'__BioPerl_Version'} = $opt_s ? $opt_s : 'unknown';

# keep stats on our indexing
my %stats = (
              'files'    => 0,
              'pkg_name' => 0,
              'desc'     => 0,
              'synopsis' => 0,
              'methods'  => 0,
            );

# wanted points to the subroutine which is run on each found file
# ( in this program, that subroutine is &extract_pod )
# no_chdir prevents find from chdir'ing into each subsequent directory
my %FIND_OPTIONS = ( wanted => \&extract_pod);#, no_chdir => 1 );

# This is the important line - Find::File actually doing the
# traversal of the directory tree.
find( \%FIND_OPTIONS, $source_dir );

# sort and write out package list
foreach my $sorted_pkg (sort @list_holder) {
    print $list $sorted_pkg, "\n";
}

# store user-supplied BioPerl version number

# output stats
print STDOUT "\nThis indexing run found:\n";
print $log "\nThis indexing run found:\n";
foreach my $stat ( 'files', 'pkg_name', 'desc', 'synopsis', 'methods' ) {
    printf STDOUT "%5d %s\n", $stats{$stat}, $stat;
    printf $log "%5d %s\n", $stats{$stat}, $stat;
}

# close files and DBs
untie $meth_db or die "deob_index.pl: couldn't close $meth_file: $!\n";
untie $pkg_db  or die "deob_index.pl: couldn't close $pkg_file: $!\n";
close $list    or die "deob_index.pl: couldn't close $list: $!\n";
close $log     or die "deob_index.pl: couldn't close $log: $!\n";
my $mode = 0666;
chmod($mode, $pkg_file, $meth_file, $list_file);

### Parsing subroutines ###
sub extract_pod {
    my ($file) = $_;
    my $long_file = $File::Find::name;

    # skip if it's on our exclude list
    foreach my $one (keys %exclude) {
        if ($File::Find::name =~ /$one$/) {
            print STDERR "Excluding $file\n";
            print $log "Excluding $file\n";
            return;
        }
    }

    # skip unless it's a perl file that exists
    return unless ( $file =~ /\.PLS$/ ) or ( $file =~ /\.p[ml]$/ );
    return unless -e $file;

    $stats{'files'}++;

    open my $fh, '<', $File::Find::name or die "deob_index.pl: could not read file '$file': $!\n";

    # these have to be done in order
    my ( $pkg_name, $short_desc ) = get_pkg_name($fh);
    my ($synopsis, $desc);
    LOOP: while (my ($type, $section) = get_generic($fh) ) {
        if    ($type eq 'synopsis')    { $synopsis = $section; }
        elsif ($type eq 'description') { $desc     = $section; }
        else { last LOOP; }
    }

    my $constructors = get_constructors($fh);
    my $methods      = get_methods($fh);

    # record package name to our package list file
    if ($pkg_name) { push @list_holder, $pkg_name; }

    # store valid package data here
    my @pkg_data;

    # error reporting
    if ($pkg_name) {
        $stats{'pkg_name'}++;
        print $pkg_name, "\n" if $DEBUG == 1;
    }
    else {
        print $log " PKG_NAME: $long_file\n";
    }
    if ($short_desc) {
        $stats{'short_desc'}++;
        push @pkg_data, $short_desc;
        print $short_desc, "\n" if $DEBUG == 1;
    }
    else {
		push @pkg_data, 'no short description available'; # store something
        print $log "SHORT_DESC: $long_file\n";
    }
    if ($synopsis) {
        $stats{'synopsis'}++;