home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / base.pm next >
Text File  |  2006-11-29  |  4KB  |  164 lines
  1. package base;
  2.  
  3. use strict 'vars';
  4. use vars qw($VERSION);
  5. $VERSION = '2.05';
  6.  
  7. # constant.pm is slow
  8. sub SUCCESS () { 1 }
  9.  
  10. sub PUBLIC     () { 2**0  }
  11. sub PRIVATE    () { 2**1  }
  12. sub INHERITED  () { 2**2  }
  13. sub PROTECTED  () { 2**3  }
  14.  
  15. my $Fattr = \%fields::attr;
  16.  
  17. sub has_fields {
  18.     my($base) = shift;
  19.     my $fglob = ${"$base\::"}{FIELDS};
  20.     return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
  21. }
  22.  
  23. sub has_version {
  24.     my($base) = shift;
  25.     my $vglob = ${$base.'::'}{VERSION};
  26.     return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
  27. }
  28.  
  29. sub has_attr {
  30.     my($proto) = shift;
  31.     my($class) = ref $proto || $proto;
  32.     return exists $Fattr->{$class};
  33. }
  34.  
  35. sub get_attr {
  36.     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
  37.     return $Fattr->{$_[0]};
  38. }
  39.  
  40. if ($] < 5.009) {
  41.     *get_fields = sub {
  42.     # Shut up a possible typo warning.
  43.     () = \%{$_[0].'::FIELDS'};
  44.     my $f = \%{$_[0].'::FIELDS'};
  45.  
  46.     # should be centralized in fields? perhaps
  47.     # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
  48.     # is used here anyway, it doesn't matter.
  49.     bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
  50.  
  51.     return $f;
  52.     }
  53. }
  54. else {
  55.     *get_fields = sub {
  56.     # Shut up a possible typo warning.
  57.     () = \%{$_[0].'::FIELDS'};
  58.     return \%{$_[0].'::FIELDS'};
  59.     }
  60. }
  61.  
  62. sub import {
  63.     my $class = shift;
  64.  
  65.     return SUCCESS unless @_;
  66.  
  67.     # List of base classes from which we will inherit %FIELDS.
  68.     my $fields_base;
  69.  
  70.     my $inheritor = caller(0);
  71.  
  72.     foreach my $base (@_) {
  73.         next if $inheritor->isa($base);
  74.  
  75.         if (has_version($base)) {
  76.         ${$base.'::VERSION'} = '-1, set by base.pm' 
  77.           unless defined ${$base.'::VERSION'};
  78.         }
  79.         else {
  80.             local $SIG{__DIE__} = 'IGNORE';
  81.             eval "require $base";
  82.             # Only ignore "Can't locate" errors from our eval require.
  83.             # Other fatal errors (syntax etc) must be reported.
  84.             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  85.             unless (%{"$base\::"}) {
  86.                 require Carp;
  87.                 Carp::croak(<<ERROR);
  88. Base class package "$base" is empty.
  89.     (Perhaps you need to 'use' the module which defines that package first.)
  90. ERROR
  91.  
  92.             }
  93.             ${$base.'::VERSION'} = "-1, set by base.pm"
  94.               unless defined ${$base.'::VERSION'};
  95.         }
  96.         push @{"$inheritor\::ISA"}, $base;
  97.  
  98.         if ( has_fields($base) || has_attr($base) ) {
  99.         # No multiple fields inheritence *suck*
  100.         if ($fields_base) {
  101.         require Carp;
  102.         Carp::croak("Can't multiply inherit %FIELDS");
  103.         } else {
  104.         $fields_base = $base;
  105.         }
  106.         }
  107.     }
  108.  
  109.     if( defined $fields_base ) {
  110.         inherit_fields($inheritor, $fields_base);
  111.     }
  112. }
  113.  
  114. sub inherit_fields {
  115.     my($derived, $base) = @_;
  116.  
  117.     return SUCCESS unless $base;
  118.  
  119.     my $battr = get_attr($base);
  120.     my $dattr = get_attr($derived);
  121.     my $dfields = get_fields($derived);
  122.     my $bfields = get_fields($base);
  123.  
  124.     $dattr->[0] = @$battr;
  125.  
  126.     if( keys %$dfields ) {
  127.         warn "$derived is inheriting from $base but already has its own ".
  128.              "fields!\n".
  129.              "This will cause problems.\n".
  130.              "Be sure you use base BEFORE declaring fields\n";
  131.     }
  132.  
  133.     # Iterate through the base's fields adding all the non-private
  134.     # ones to the derived class.  Hang on to the original attribute
  135.     # (Public, Private, etc...) and add Inherited.
  136.     # This is all too complicated to do efficiently with add_fields().
  137.     while (my($k,$v) = each %$bfields) {
  138.         my $fno;
  139.     if ($fno = $dfields->{$k} and $fno != $v) {
  140.         require Carp;
  141.         Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
  142.     }
  143.  
  144.         if( $battr->[$v] & PRIVATE ) {
  145.             $dattr->[$v] = PRIVATE | INHERITED;
  146.         }
  147.         else {
  148.             $dattr->[$v] = INHERITED | $battr->[$v];
  149.             $dfields->{$k} = $v;
  150.         }
  151.     }
  152.  
  153.     unless( keys %$bfields ) {
  154.         foreach my $idx (1..$#{$battr}) {
  155.             $dattr->[$idx] = $battr->[$idx] & INHERITED;
  156.         }
  157.     }
  158. }
  159.  
  160. 1;
  161.  
  162. __END__
  163.  
  164.