lib/CXGN/Tools/Class.pm

   1 use strict;
   2 package CXGN::Tools::Class;
   3 use Carp;
   4
   5 BEGIN {
   6   our @EXPORT_OK = qw/parricide super_autoload/;
   7 }
   8 use base qw/Exporter/;
   9 our @EXPORT_OK;
  10
  11 =head1 NAME
  12
  13 CXGN::Tools::Class - a bundle of little code snippets that make writing
  14    robust object-oriented code a little easier
  15
  16 =head1 DEPRECATED
  17
  18 This module is deprecated.  Do not use in new code.  Build new code with Moose instead, and sidestep the multiple-inheritance DESTROY problem that parricide() was meant to solve.
  19
  20 =cut
  21
  22
  23 # =head1 DESCRIPTION
  24
  25 # none yet
  26
  27 # =head1 SYNOPSIS
  28
  29 # none yet
  30
  31 # =head1 FUNCTIONS
  32
  33 # All of the below functions are EXPORT_OK.
  34
  35 # =head2 parricide
  36
  37 #   Desc: Call DESTROY on all the classes in a list, making sure
  38 #         not to do any one of them twice (originally from Conway
  39 #         p. 176, modified significantly to not try to store state
  40 #         in the destroyed object)
  41 #   Args: (Object, @ISA of that object)
  42 #   Ret : A list of all classes whose destructors get called by recursing
  43 #         up the class inheritance graph.
  44 #   Side Effects: Calls the DESTROY of all of the classes listed in ISA
  45 #                 (and so recursively on all their superclasses, etc.)
  46 #                 with the given object as the first argument.
  47 #   Example:
  48
  49 #     #in my witchy little class with multiple parent classes...
  50 #     sub DESTROY {
  51 #       # <any cleanups specific to your class>
  52 #       return parricide ($self, our @ISA);
  53 #     }
  54
  55
  56 #   If all of your classes use this little jimmy, the destructors get
  57 #   automagically chained together, which is usually a good thing.
  58
  59 #   Note: you *must* make sure that the return value from parricide gets
  60 #   returned by your destructor, so that parricide can know which
  61 #   superclasses it has destroyed.  Really, this is important.
  62
  63 # =cut
  64
  65 #my $indentation = 0;
  66 sub parricide {
  67 #  $indentation += 2;
  68   $| = 1;
  69   my ($object,@isa) = @_;
  70
  71 #   print "isa: " . ref($object) . ": ";
  72 #   print join ", ", @isa;
  73 #   print "\n";
  74
  75   # What's going on here is that if your object is of class C, where
  76   # class C is a subclass of A and B, *and* A is a subclass of B, we
  77   # must ensure that we call A's destructor before B's (if we call B's
  78   # destructor first, and then A's destructor call's B's again, all
  79   # sorts of badness may occur.  So we'll topologically sort the @isa
  80   # array into @toposort (sort things such that if one class is a
  81   # descendant class of another in @isa, the subclass occurs first
  82   # in the sorting).
  83   my @toposort = ();
  84   while (@isa) {                            # until @isa is empty,
  85     foreach my $class (@isa) {              # take a class in @isa
  86       my $degree = 0;                       # assume it's not anybody's superclass
  87       foreach my $otherclass (@isa) {       # for each otherclass in @isa
  88         unless ($class eq $otherclass) {    #
  89           if ($otherclass->isa($class)) {   # if class is an ancestor of otherclass
  90             $degree=1;                      # then class is not a leaf of the class graph.
  91           }
  92         }
  93       }
  94       if ($degree == 0) {                   # if the class is a leaf (no subclasses)
  95         push @toposort, $class;             # push it onto the sorted array
  96         @isa = grep { !/$class/ } @isa;     # and remove it from @isa.
  97       }
  98     }
  99   }
 100
 101 #  warn ' 'x$indentation,"toposort: " . (join(", ", @toposort)). "\n";
 102
 103   # Here's where we call destructors.  Each time we call a destructor,
 104   # we get back a list of all the ancestor classes whose destructors
 105   # get called when destroying any of the object's parents.  We need
 106   # to hold onto the names of classes that have already been killed, to
 107   # avoid calling their destructors more than once.
 108   my @already_dead = ();
 109   foreach my $parent (@toposort) {
 110 #    warn ' 'x$indentation,"parent: " . $parent . "\n";
 111     my $destructor = $parent->can('DESTROY');
 112 #    warn ' 'x$indentation, "already_dead 1: ".(join(" ", @already_dead))."\n";
 113     if ($destructor) {
 114       unless (grep {$parent eq $_} @already_dead) {
 115 #       warn ' 'x$indentation,"calling DESTROY on $parent\n";
 116         my @killed = $object->$destructor();
 117         push @already_dead, ($parent,@killed);
 118       }
 119     }
 120 #    warn ' 'x$indentation, "already_dead 2: ".(join(" ", @already_dead))."\n";
 121   }
 122
 123 #  warn ' 'x$indentation, "all done\n";
 124
 125   # Finally, we return the class of our object.
 126 #  $indentation -= 2;
 127   return @already_dead;
 128 }
 129
 130
 131 =head2 super_autoload
 132
 133   Desc: check whether this object's superclass has an AUTOLOAD, and if so,
 134         call it as the given method name, with the rest of the given
 135         arguments, and return the result.  Otherwise, croak with a
 136         'method not found'.  This function is useful when you're writing
 137         an AUTOLOAD method, but your superclass also has an AUTOLOAD method,
 138         and you want to pass control to that AUTOLOAD method if your AUTOLOAD
 139         doesn't know how to handle the request.
 140
 141         If the method name you pass is qualified with a package name
 142         (e.g. 'MySuperPackage::methodname'), this will call the method on
 143         that particular class.  Otherwise, it will call 'SUPER::methodname'.
 144   Args: the current object, the requested method name, array of arguments
 145   Ret : the results of the superclass function call
 146   Side Effects: calls
 147   Example:
 148
 149     sub AUTOLOAD {
 150       my $this = shift;
 151       my $methodname = (split /::/,$AUTOLOAD)[-1];
 152       if($methodname =~ /get_/) {
 153         return 'something';
 154       } else {
 155         return supercall($this,$methodname,@_);
 156       }
 157     }
 158
 159 =cut
 160
 161 sub super_autoload {
 162   no strict 'refs';
 163
 164   my $this = shift;
 165   my $method = shift;
 166
 167   my ($package) = $method =~ /(.+)::[^:]+$/;
 168   $package ||= 'SUPER';
 169   my $fullmethod = "${package}::${method}";
 170
 171   if($package->can($method) || $package->can('AUTOLOAD') ) {
 172     return $this->$fullmethod(@_);
 173   } else {
 174     croak "Method '$method' not found";
 175   }
 176 }
 177
 178
 179 # =head1 AUTHOR
 180
 181 # Robert Buels and Marty Kreuter
 182
 183 # =cut
 184
 185 ###
 186 1;#
 187 ###