view release on metacpan or  search on metacpan

Util/Util.pm  view on Meta::CPAN

package Crypt::License::Util;
require Exporter;
use vars qw($VERSION $ptr2_License @ISA @EXPORT);
@ISA		= qw(Exporter);
@EXPORT		= qw( license4server path2License chain2next chain2prevLicense exportNext2 
		     requireLicense4 requirePrivateLicense4 modules4privateList);
$VERSION	= do { my @r = (q$Revision: 2.00 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
$ptr2_License	= {'next' => ''};

sub license4server {
  die "user $> may not access Server License" if $>;
  die "Server License missing" unless defined $main::ptr2_License;
  my $m = caller;
    unless (defined ($p = ${"${m}::ptr2_License"})) {
    $p = &_createPointer2License($m);
  }
  $p->{path} = $main::ptr2_License->{path};
}
sub path2License {
  my($n) = @_;
  $n = 'README.LICENSE' unless $n;
  my ($m,$f) = caller;
  my $p;
  unless (defined ($p = ${"${m}::ptr2_License"})) {
    $p = &_createPointer2License($m);
  }
  $p->{path} = (getpwuid((stat($f))[4]))[7] .'/'.$n;
}
sub chain2next {
  my($p2L) = @_;
  $p2L->{next} = caller(1);
}
sub chain2prevLicense {
  my $m = caller;
  my $p;
  unless (defined ($p = ${"${m}::ptr2_License"})) {
    $p = &_createPointer2License($m);
  }
  $p->{next} = caller(1);
}
sub exportNext2 {
#  my @c1 = caller(1);
#  my $c = (@c1 && $c1[3] =~ /useLicense4$/) 
#	? $c1[0] : caller;
  my $c = caller;
  my $rv = 0;
  foreach my $m (@_) {
    next if defined ${"${m}::ptr2_License"};
    ++$rv;
    &_createPointer2License($m)->{next} = $c;
  }
  return $rv;
}
sub requireLicense4 {
  $ptr2_License->{next} = caller;
  my @m = @_;
  foreach my $m ( @m ) {
    ($m .= '.pm') =~ s#::#/#g; 
    require $m;
  }
  goto &exportNext2;
}
sub requirePrivateLicense4 {
  my $c = caller;
  $ptr2_License->{next} = $c;
  &_array2privateList($c,@_);
  my @m = @_;
  foreach $m ( @m ) {
    ($m .= '.pm') =~ s#::#/#g;
    require $m;
  }
  goto &exportNext2;
}
sub modules4privateList {
  my $c = caller;
  return &_array2privateList($c,@_);
}
sub _array2privateList {
  my ($m, @m) = @_;
  my $p;
  if (defined ($p = ${"${m}::ptr2_License"})) {
    if (exists $p->{private}) {
      push(@m, split(',',$p->{private}));
      my @dups = sort @m;
      @m = ();
      foreach $m (@dups) {
	next if @m && $m eq $m[0];