view release on metacpan or  search on metacpan

License.pm  view on Meta::CPAN

package Crypt::License;

use Filter::Util::Call 1.04;
use Crypt::CapnMidNite 1.00;
use Time::Local;
use Sys::Hostname;
use vars qw($VERSION $ptr2_License);

$ptr2_License = {'next' => ''};

$VERSION = do { my @r = (q$Revision: 2.04 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

#	put the package name of the segement to print in DEBUG
#	or 'ALL' to print all packages
#
my $DEBUG	= 0;#'ALL';

##### pre-defines
my $seek_caller = sub {
  my ($i) = @_;                    # exclude call to this sub
  $i++;
  my $p;
  while(@_=caller($i)){
    $last = $i;
    ($p = $_[0]) =~ s#::#/#g;
# print STDERR ($i-1),' 0=',$_[0],' 2=', $_[2], ' 3=', $_[3], "\n";
    last if $_[2] > 2 && $_[0] !~ /AutoLoader/ &&
	$_[1] !~ /^\(eval/ && $_[1] !~ m|$p/.+\.al$|;

    ++$i;
  }
  return ($i-1,@_);
};

my $print_err = sub {
  print STDERR @_;
};

# useage: (callerlevel, @caller)
my $pcaller = sub {
  &$print_err('########## level ', (shift @_), "\n") if $DEBUG;
  my @caller = ('package','file','line','subr','hasargs','wantary','evaltxt','require',);
	# ignored => 'hints','bitmask');
  my $end = ($#_ < 7) ? $#_ : 7;
  foreach my $i(0..$end) {
    $_[$i] = '' unless $_[$i];
    &$print_err("$caller[$i]\t= $_[$i]\n") if $DEBUG;
  }
};

my ($user,$grp,$pwd);

$user_info = sub {
  ($pwd) = @_;
  $user = (getpwuid( (stat($pwd))[4] ))[0];
  $grp = (getgrgid( (stat($pwd))[5] ))[0];
  my $i;
  if ( $pwd !~ m|^/| ) {
    $i = `/bin/pwd`;
    $i =~ s/\s+//g;
    $pwd = $i .'/'. $pwd;
  }
  $pwd =~ s#/\./#/#g;
  @_ = split('/',$pwd);
  $pwd= '';
  $#_ -=1;
  while($i = pop @_) {
    do { pop @_; next; } if $i eq '..';
    $pwd = "/$i" . $pwd;
  }
};

##### code

my $host = &Sys::Hostname::hostname;
($host = "\L$host") =~ s/\s+//g;

&$user_info((caller)[1]);	# defaults

sub import {
  my ($alm) = ((caller)[1] =~ m|.+/auto/(.+)/.+\.al$|);
  my $level=0;
  my $i;
  my $ptr;
  while (1) {
    ($level, @_) = &$seek_caller($level);
# package name in [0]
###$i=0;
###while(caller($i)) { ++$i }
###@_ = caller($i-1);
      $ptr = (defined ${"$_[0]::ptr2_License"})
	? ${"$_[0]::ptr2_License"} : '';
      last unless $ptr;
      last unless exists $ptr->{next};
      ++$level;
  }
if($DEBUG){
&$print_err("\n\t\t\tXxXxXxXxXxXxXx $level\n");
$i=0;
while(@_=caller($i)){
&$pcaller($i,@_);
++$i;
}
}

  if ( $ptr ) {
    &$user_info($ptr->{path});
    (my @lic = &get_file($ptr->{path})) ||
	die "could not open license file for $user";
    my %parms;
    $#lic = &extract(\@lic,\%parms) -1;
    my $expire = 0;
    if ( exists $parms{EXP} ) {	# if the EXPiration is present
      ($expire = &date2time($parms{EXP})) ||
	die "invalid expiration date $user license";