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