cvs commit: xml-xerces/perl RTTI.pm

[ja...@apache.org]

jasons      01/03/07 08:11:16

  Added:       perl     RTTI.pm
  Log:
  Submitted by:	jason@openinformatics.com
  
  	* RTTI.pm (Repository):
  	Special module added by Harmon for Run Time Type Inference
  
  Revision  Changes    Path
  1.1                  xml-xerces/perl/RTTI.pm
  
  Index: RTTI.pm
  ===================================================================
  
  package RTTI;
  
  use Exporter ();
  unshift @ISA, 'Exporter';
  
  @EXPORT = qw(isa reinterpret_cast);
  @EXPORT_OK = ();
  %EXPORT_TAGS = ();
  
  
  # isa decends the inheritance hierachy to determine
  # if the object is-a member of the specified class.
    sub isa_aux {
          my $derived = $_[0];
        return 1 if $derived eq $base;
    
          $package_hash{$derived} = 1;
          for my $immediate_base (eval "\@$derived\::ISA;") {
                  next if exists $package_hash{$immediate_base};
        return 1 if RTTI::isa_aux $immediate_base;
          }
        return 0;
    }
  
  sub isa {
    return 0 unless defined $_[0];
    local %package_hash = ();
    local $base = $_[1];
  
    return isa_aux $_[0];
  }
  
  
  # these functions are based on the new casting
  # operators defined in C++
  
  #---------------------------------------
  # used for recasting objects by changing the encoding scheme
  # associated with it.
  sub reinterpret_cast {
  
     return undef unless ref $_[1];
  
     bless $_[1], $_[0];
  
     my($raw_ref, $tied) = ($_[1] =~ m[=(.*)\(]);
  
     if ($raw_ref eq 'SCALAR')       { $tied = tied ${$_[1]}; }
     elsif ($raw_ref eq 'ARRAY')     { $tied = tied @{$_[1]}; }
     elsif ($raw_ref eq 'HASH')      { $tied = tied %{$_[1]}; }
  
     return $_[1] unless $tied;
  
     bless $tied, $_[0];
     return $_[1];
  }
  
  #---------------------------------------
  # used for performing "safe" casts down or across an 
  # inheritance hierarchy.
  # Basically the same as reinterpret cast but involves some
  # checking to make sure that cast is legal (according to the
  # inheritance hierarchy.
  sub dynamic_cast {
    my $class = shift;
    my $reference = shift;
  
    return reinterpret_cast($class, $reference);
  }
  
  #---------------------------------------
  # used for casting away "const"ness
  # don't know how this would work in Perl as constness is
  # imposed by making a function.
  sub const_cast {
    warn "const_cast not implemented\n";
  }
  
  #---------------------------------------
  # effectivly changes the type of an object invoking 
  # the appropriate constructors
  sub static_cast {
    warn "reinterpret_cast not implemented\n";
  }
  
  #---------------------------------------
  1;