view release on metacpan or  search on metacpan

License.pm  view on Meta::CPAN

##### 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";
    }
    @_ = split('/',(caller)[1]);	# last element
    if ( $_[$#_] =~ /\.pm$/ ) {
      @_ = split(/\./,$_[$#_]);		# remove extension
    }
    my $key = $_[$#_-1];

    unless ( exists $ptr->{$key} ) {
      @_ = ();
      if (exists $ptr->{private}) {
        @_ = split(',',$ptr->{private});
        foreach $i (0..$#_) {
	  $_[$i] = join('/',split('::',$_[$i]));
	}
      }
      my $match = (caller)[1];
      if (grep($match =~ /$_\.pm$/,@_)) {
        $ptr->{$key} = $parms{KEY} or die "missing private key $user";
      } else {
        $ptr->{$key} = $parms{PKEY} or die "missing public key $user";
      }
    }
    delete $parms{KEY};
    delete $parms{PKEY};
    my %chk;
    &get_vals(\%parms,\%chk);
    @_ = keys %chk;
    @{parms}{@_} = @{chk}{@_};
    @_ = sort keys %parms;
    push @lic,@_,@{parms}{@_},$expire,$ptr->{$key};
    my $bu = Crypt::CapnMidNite->new;
    my $expires = $bu->license(@lic);
    $ptr->{expires} = $expires if $expires;
    my $h = '# Module';
    my $f = length $h;
    my $s = '';
    filter_add(
    sub {
      my $status = filter_read;
      $bu->crypt($_);
      $s .= $_ if $f;
      $f = 0 if $s =~ /^$h/o;
      if ( $f && length($s) > $f) {
	$_ = '';
	$status = -1;
      }
      if (!$status && $alm) {
	$alm =~ s#/#::#g;
	unless (defined ${"${alm}::ptr2_License"}) {
	  %{"${alm}::_LicHash"} = ('next' => $alm);
	  ${"${alm}::ptr2_License"} = \%{"${alm}::_LicHash"};
	}
      }
      return $status;
    });
  }
}


#############################################################
# check each field for validity
#
# input:	parm
#
my $check = {
	'SERV'	=> sub {	# http server domain or input string
		return ( exists $ENV{SERVER_NAME} ) ? "\L$ENV{SERVER_NAME}" : $_[0]; },

	'HOST'	=> sub {	# local fqdn
		return $host; }, 

	'USER'	=> sub {	# local user name
		return $user; },

	'GROUP'	=> sub {	# local group name
		return $grp; },