[system] / trunk / pg / lib / Value / Context / Data.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Value/Context/Data.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5509 - (download) (as text) (annotate)
Sat Sep 15 00:56:51 2007 UTC (12 years, 3 months ago) by dpvc
File size: 5344 byte(s)
Formula objects and Context objects contain reference loops, which
prevent them from being freed properly by perl when they are no longer
needed.  This is a source of an important memory leak in WeBWorK.  The
problem has been fixed by using Scalar::Util::weaken for these
recursive references, so these objects can be freed properly when they
go out of scope.  This should cause an improvement in the memory usage
of the httpd child processes.

    1 #########################################################################
    2 #
    3 #  Implements base class for data list in Context objects.
    4 #
    5 package Value::Context::Data;
    6 use strict;
    7 use Scalar::Util;
    8 
    9 sub new {
   10   my $self = shift; my $class = ref($self) || $self;
   11   my $parent = shift;
   12   my $data = bless {
   13     context => $parent,     # parent context
   14     dataName => {},         # name of data storage in context hash
   15     tokens => {},           # hash of id => type specifications that will be made into a pattern
   16     patterns => {},         # hash of pattern => [type,precedence] specification for extra patterns
   17     tokenType => {},        # type of Parser token for these pattern
   18     namePattern => '',      # pattern for allowed names for new items
   19     name => '', Name => '', # lower- and upper-case names for the class of items
   20   }, $class;
   21   $data->weaken;
   22   $data->init();
   23   $parent->{$data->{dataName}} = {};
   24   push @{$parent->{data}{objects}},"_$data->{dataName}";
   25   $data->add(@_);
   26   return $data;
   27 }
   28 
   29 #
   30 #  Implemented in sub-classes
   31 #
   32 sub init {}
   33 sub create {shift; shift}
   34 sub uncreate {shift; shift}
   35 
   36 #
   37 #  Copy the context data
   38 #
   39 sub copy {
   40   my $self = shift; my $orig = shift;
   41   my $data = $orig->{context}->{$orig->{dataName}};
   42   my $copy = $self->{context}->{$self->{dataName}};
   43   foreach my $name (keys %{$data}) {
   44     if (ref($data->{$name}) eq 'ARRAY') {
   45       $copy->{$name} = [@{$data->{$name}}];
   46     } elsif (ref($data->{$name}) eq 'HASH') {
   47       $copy->{$name} = {%{$data->{$name}}};
   48     } else {
   49       $copy->{$name} = $data->{$name};
   50     }
   51   }
   52   $self->{tokens} = {%{$orig->{tokens}}};
   53   foreach my $p (keys %{$orig->{patterns}}) {
   54     $self->{patterns}{$p} =
   55       (ref($orig->{patterns}{$p}) ? [@{$orig->{patterns}{$p}}] : $orig->{patterns}{$p});
   56   }
   57 }
   58 
   59 #
   60 #  Make context pointer a weak pointer (avoids reference loops)
   61 #
   62 sub weaken {Scalar::Util::weaken((shift)->{context})}
   63 
   64 #
   65 #  Update the context patterns
   66 #
   67 sub update {(shift)->{context}->update}
   68 
   69 sub addToken {
   70   my $self = shift; my $token = shift;
   71   $self->{tokens}{$token} = $self->{tokenType}
   72     unless $self->{context}{$self->{dataName}}{$token}{hidden};
   73 }
   74 
   75 sub removeToken {
   76   my $self = shift; my $token = shift;
   77   delete $self->{tokens}{$token};
   78 }
   79 
   80 
   81 #
   82 #  Add one or more new items to the list
   83 #
   84 sub add {
   85   my $self = shift; my %D = (@_); return if scalar(@_) == 0;
   86   my $data = $self->{context}{$self->{dataName}};
   87   foreach my $x (keys %D) {
   88     Value::Error("Illegal %s name '%s'",$self->{name},$x) unless $x =~ m/^$self->{namePattern}$/;
   89     warn "$self->{Name} '$x' already exists" if defined($data->{$x});
   90     $data->{$x} = $self->create($D{$x});
   91     $self->addToken($x);
   92   }
   93   $self->update;
   94 }
   95 
   96 #
   97 #  Remove one or more items
   98 #
   99 sub remove {
  100   my $self = shift;
  101   my $data = $self->{context}{$self->{dataName}};
  102   foreach my $x (@_) {
  103     warn "$self->{Name} '$x' doesn't exist" unless defined($data->{$x});
  104     $self->removeToken($x);
  105     delete $data->{$x};
  106   }
  107   $self->update;
  108 }
  109 
  110 #
  111 #  Replace an item with a new definition
  112 #
  113 sub replace {
  114   my $self = shift; my %list = (@_);
  115   $self->remove(keys %list);
  116   $self->add(@_);
  117 }
  118 
  119 #
  120 #  Clear all items
  121 #
  122 sub clear {
  123   my $self = shift;
  124   $self->{context}{$self->{dataName}} = {};
  125   $self->{tokens} = {};
  126   $self->update;
  127 }
  128 
  129 #
  130 #  Make the data be only these items
  131 #
  132 sub are {
  133   my $self = shift;
  134   $self->clear;
  135   $self->add(@_);
  136 }
  137 
  138 #
  139 #  Make one or more items become undefined, but still recognized.
  140 #  (Implemented in the sub-classes.)
  141 #
  142 sub undefine {my $self = shift; $self->remove(@_)}
  143 
  144 #
  145 #  Redefine items from the default context, or a given one
  146 #
  147 sub redefine {
  148   my $self = shift; my $X = shift;
  149   my %options = (using => undef, from => "Full", @_);
  150   my $Y = $options{using}; my $from = $options{from};
  151   $from = $Parser::Context::Default::context{$from} unless ref($from);
  152   $Y = $X if !defined($Y) && !ref($X);
  153   $X = [$X] unless ref($X) eq 'ARRAY';
  154   my @data = (); my @remove = ();
  155   foreach my $x (@{$X}) {
  156     my $y = defined($Y)? $Y: $x;
  157     Value::Error("No definition for %s '%s' in the given context",$self->{name},$y)
  158       unless $from->{$self->{dataName}}{$y};
  159     push(@remove,$x) if $self->get($x);
  160     push(@data,$x => $self->uncreate($from->{$self->{dataName}}{$y}));
  161   }
  162   $self->remove(@remove);
  163   $self->add(@data);
  164 }
  165 
  166 
  167 #
  168 #  Get hash for an item
  169 #
  170 sub get {
  171   my $self = shift; my $x = shift;
  172   return $self->{context}{$self->{dataName}}{$x};
  173 }
  174 
  175 #
  176 #  Set flags for one or more items
  177 #
  178 sub set {
  179   my $self = shift; my %D = (@_);
  180   my $data = $self->{context}{$self->{dataName}};
  181   foreach my $x (keys(%D)) {
  182     my $xref = $data->{$x};
  183     if (defined($xref) && ref($xref) eq 'HASH') {
  184       foreach my $id (keys %{$D{$x}}) {$xref->{$id} = $D{$x}{$id}}
  185     } else {
  186       $data->{$x} = $self->create($D{$x});
  187       $self->addToken($x);
  188     }
  189   };
  190 }
  191 
  192 #
  193 #  Get the names of all items
  194 #
  195 sub names {
  196   my $self = shift;
  197   return sort(keys %{$self->{context}{$self->{dataName}}});
  198 }
  199 
  200 #
  201 #  Get the complete data hash
  202 #
  203 sub all {
  204   my $self = shift;
  205   $self->{context}{$self->{dataName}};
  206 }
  207 
  208 #########################################################################
  209 #
  210 #  Load the subclasses.
  211 #
  212 
  213 END {
  214   use Value::Context::Flags;
  215   use Value::Context::Lists;
  216   use Value::Context::Diagnostics;
  217 }
  218 
  219 #########################################################################
  220 
  221 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9