home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 June / PCWorld_2005-06_cd.bin / software / vyzkuste / firewally / firewally.exe / framework-2.3.exe / base.pm < prev    next >
Text File  |  2003-11-07  |  5KB  |  204 lines
  1. package base;
  2.  
  3. use strict 'vars';
  4. use vars qw($VERSION);
  5. $VERSION = '2.03';
  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.  
  16. my $Fattr = \%fields::attr;
  17.  
  18. sub has_fields {
  19.     my($base) = shift;
  20.     my $fglob = ${"$base\::"}{FIELDS};
  21.     return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
  22. }
  23.  
  24. sub has_version {
  25.     my($base) = shift;
  26.     my $vglob = ${$base.'::'}{VERSION};
  27.     return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
  28. }
  29.  
  30. sub has_attr {
  31.     my($proto) = shift;
  32.     my($class) = ref $proto || $proto;
  33.     return exists $Fattr->{$class};
  34. }
  35.  
  36. sub get_attr {
  37.     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
  38.     return $Fattr->{$_[0]};
  39. }
  40.  
  41. sub get_fields {
  42.     # Shut up a possible typo warning.
  43.     () = \%{$_[0].'::FIELDS'};
  44.  
  45.     return \%{$_[0].'::FIELDS'};
  46. }
  47.  
  48. sub import {
  49.     my $class = shift;
  50.  
  51.     return SUCCESS unless @_;
  52.  
  53.     # List of base classes from which we will inherit %FIELDS.
  54.     my $fields_base;
  55.  
  56.     my $inheritor = caller(0);
  57.  
  58.     foreach my $base (@_) {
  59.         next if $inheritor->isa($base);
  60.  
  61.         if (has_version($base)) {
  62.         ${$base.'::VERSION'} = '-1, set by base.pm' 
  63.           unless defined ${$base.'::VERSION'};
  64.         }
  65.         else {
  66.             local $SIG{__DIE__} = 'IGNORE';
  67.             eval "require $base";
  68.             # Only ignore "Can't locate" errors from our eval require.
  69.             # Other fatal errors (syntax etc) must be reported.
  70.             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  71.             unless (%{"$base\::"}) {
  72.                 require Carp;
  73.                 Carp::croak(<<ERROR);
  74. Base class package "$base" is empty.
  75.     (Perhaps you need to 'use' the module which defines that package first.)
  76. ERROR
  77.  
  78.             }
  79.             ${$base.'::VERSION'} = "-1, set by base.pm"
  80.               unless defined ${$base.'::VERSION'};
  81.         }
  82.         push @{"$inheritor\::ISA"}, $base;
  83.  
  84.         if ( has_fields($base) || has_attr($base) ) {
  85.         # No multiple fields inheritence *suck*
  86.         if ($fields_base) {
  87.         require Carp;
  88.         Carp::croak("Can't multiply inherit %FIELDS");
  89.         } else {
  90.         $fields_base = $base;
  91.         }
  92.         }
  93.     }
  94.  
  95.     if( defined $fields_base ) {
  96.         inherit_fields($inheritor, $fields_base);
  97.     }
  98. }
  99.  
  100.  
  101. sub inherit_fields {
  102.     my($derived, $base) = @_;
  103.  
  104.     return SUCCESS unless $base;
  105.  
  106.     my $battr = get_attr($base);
  107.     my $dattr = get_attr($derived);
  108.     my $dfields = get_fields($derived);
  109.     my $bfields = get_fields($base);
  110.  
  111.     $dattr->[0] = @$battr;
  112.  
  113.     if( keys %$dfields ) {
  114.         warn "$derived is inheriting from $base but already has its own ".
  115.              "fields!\n".
  116.              "This will cause problems with pseudo-hashes.\n".
  117.              "Be sure you use base BEFORE declaring fields\n";
  118.     }
  119.  
  120.     # Iterate through the base's fields adding all the non-private
  121.     # ones to the derived class.  Hang on to the original attribute
  122.     # (Public, Private, etc...) and add Inherited.
  123.     # This is all too complicated to do efficiently with add_fields().
  124.     while (my($k,$v) = each %$bfields) {
  125.         my $fno;
  126.     if ($fno = $dfields->{$k} and $fno != $v) {
  127.         require Carp;
  128.         Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
  129.     }
  130.  
  131.         if( $battr->[$v] & PRIVATE ) {
  132.             $dattr->[$v] = PRIVATE | INHERITED;
  133.         }
  134.         else {
  135.             $dattr->[$v] = INHERITED | $battr->[$v];
  136.             $dfields->{$k} = $v;
  137.         }
  138.     }
  139.  
  140.     unless( keys %$bfields ) {
  141.         foreach my $idx (1..$#{$battr}) {
  142.             $dattr->[$idx] = $battr->[$idx] & INHERITED;
  143.         }
  144.     }
  145. }
  146.  
  147.  
  148. 1;
  149.  
  150. __END__
  151.  
  152. =head1 NAME
  153.  
  154. base - Establish IS-A relationship with base class at compile time
  155.  
  156. =head1 SYNOPSIS
  157.  
  158.     package Baz;
  159.     use base qw(Foo Bar);
  160.  
  161. =head1 DESCRIPTION
  162.  
  163. Roughly similar in effect to
  164.  
  165.     BEGIN {
  166.         require Foo;
  167.         require Bar;
  168.         push @ISA, qw(Foo Bar);
  169.     }
  170.  
  171. Will also initialize the fields if one of the base classes has it.
  172. Multiple Inheritence of fields is B<NOT> supported, if two or more
  173. base classes each have inheritable fields the 'base' pragma will
  174. croak.  See L<fields>, L<public> and L<protected> for a description of
  175. this feature.
  176.  
  177. When strict 'vars' is in scope, I<base> also lets you assign to @ISA
  178. without having to declare @ISA with the 'vars' pragma first.
  179.  
  180. If any of the base classes are not loaded yet, I<base> silently
  181. C<require>s them (but it won't call the C<import> method).  Whether to
  182. C<require> a base class package is determined by the absence of a global
  183. $VERSION in the base package.  If $VERSION is not detected even after
  184. loading it, I<base> will define $VERSION in the base package, setting it to
  185. the string C<-1, set by base.pm>.
  186.  
  187.  
  188. =head1 HISTORY
  189.  
  190. This module was introduced with Perl 5.004_04.
  191.  
  192.  
  193. =head1 CAVEATS
  194.  
  195. Due to the limitations of the pseudo-hash implementation, you must use
  196. base I<before> you declare any of your own fields.
  197.  
  198.  
  199. =head1 SEE ALSO
  200.  
  201. L<fields>
  202.  
  203. =cut
  204.