1#!/usr/bin/perl 2 3# version 2.01 12-19-02 michael@bizsystems.com 4# Copyright Michael Robinton and BizSystems 5# all rights reserved 6# 7use strict; 8 9if (@ARGV) { 10 &crypt_mod(@ARGV); 11} 12 13sub crypt_mod { 14 15 my $seed = 'BizSystems'; 16 17 my ( $in, $out, $end, $crypt, $discrypt ) = @_; 18 19 eval qq{use Crypt::C_LockTite;}; 20 if ( $@ ) { 21 $crypt = 0; 22 $end = 'sorry charlie'; 23 } 24 25 my $syntax = <<EOF; 26 27syntax: mod_parser.pl in out [END cutoff] [crypt key] [disable ENCRYPT] 28 29 pod to STDOUT unless END cutoff is enabled 30 31 END cutoff = save 32 save comments to output to stripped .pm file 33 34 do NOT use with C or xs files 35 36EOF 37 38 if (@_ < 2) { 39 print $syntax; 40 exit; 41 } 42 43 unlink $out if (-e $out && -l $out); # don't OOPS if linked source 44 my $slurp; 45 46 unless (open (IN, "$in")) { 47 print "ERROR, not found $in\n"; 48 $syntax; 49 exit; 50 } 51 my $pod = 0; 52 while (<IN>) { 53 if ( $pod ) { 54 if ( $_ =~ /^=cut/ ) { 55 $pod = 0; # kill pod printing 56 next; 57 } 58 print $_ unless $end && $end ne 'save'; 59 next; 60 } 61 if ($_ =~ /^=\w/ && $_ !~ /^=cut/ ) { 62 print $_ unless $end && $end ne 'save'; 63 $pod = 1; # on if any =www except =cut 64 next; 65 } 66 next if $end && $end ne 'save' && 67 ( $_ =~ /^\s*#/ || # comment and blank only lines 68 $_ !~ /\S/ ); 69 last if $_ =~ /^__END__/ && $end && $end ne 'save'; 70 $slurp .= $_; 71 } 72 73 close IN; 74 75 unless (open(OUT, ">$out")) { 76 print "open for output on $out failed\n"; 77 exit; 78 } 79 80 if ( $crypt ) { 81 $slurp = "# Module $out\n" . $slurp; 82 unless ( $discrypt ) { # ENCRYPTION suspended for DEBUG 83 my $p = Crypt::C_LockTite->new; 84 my $tmp = $p->md5($crypt); # md5 of client ID 85 my $key = $p->new_md5_crypt($seed)->encrypt($tmp); # encrypt with seed 86 $p->new_crypt($key)->encrypt($slurp); 87 } 88 $slurp = "use Crypt::License;\n" . $slurp; 89 } 90 print OUT $slurp; 91 close OUT; 92} 93