[system] / trunk / pg / lib / Parser / UOP.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Parser/UOP.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, 2 months ago) by dpvc
File size: 6567 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 the base Unary Operator class
    4 #
    5 package Parser::UOP;
    6 use strict;
    7 our @ISA = qw(Parser::Item);
    8 
    9 $Parser::class->{UOP} = 'Parser::UOP';
   10 
   11 sub new {
   12   my $self = shift; my $class = ref($self) || $self;
   13   my $equation = shift; my $context = $equation->{context};
   14   my ($uop,$op,$ref) = @_;
   15   my $def = $context->{operators}{$uop};
   16   my $UOP = bless {
   17     uop => $uop, op => $op,
   18     def => $def, ref => $ref, equation => $equation
   19   }, $def->{class};
   20   $UOP->weaken;
   21   $UOP->{isConstant} = 1 if $op->{isConstant};
   22   $UOP->_check;
   23   $UOP = $UOP->Item("Value")->new($equation,[$UOP->eval])
   24     if $op->{isConstant} && (!$UOP->isNeg || $op->isNeg) &&
   25        ($context->flag('reduceConstants') || $op->{isInfinity});
   26   return $UOP;
   27 }
   28 
   29 #
   30 #  Stub for checking if the BOP can operate on the given operands.
   31 #  (Implemented in subclasses.)
   32 #
   33 sub _check {}
   34 
   35 ##################################################
   36 
   37 #
   38 #  Evaluate the operand and then perform the operation on it
   39 #
   40 sub eval {
   41   my $self = shift;
   42   $self->_eval($self->{op}->eval);
   43 }
   44 #
   45 #  Stub for sub-classes.
   46 #
   47 sub _eval {return $_[1]}
   48 
   49 
   50 #
   51 #  Reduce the operand.
   52 #  If it is constant and we are not negation (we want to be able to factor it out),
   53 #    return the value of the operation.
   54 #
   55 sub reduce {
   56   my $self = shift; my $uop = $self->{def};
   57   my $equation = $self->{equation};
   58   $self->{op} = $self->{op}->reduce;
   59   return $self->Item("Value")->new($equation,[$self->eval])
   60     if $self->{op}{isConstant} && !$self->isNeg;
   61   $self->_reduce;
   62 }
   63 #
   64 #  Stub for sub-classes.
   65 #
   66 sub _reduce {shift}
   67 
   68 sub substitute {
   69   my $self = shift; my $uop = $self->{def};
   70   my $equation = $self->{equation}; my $context = $equation->{context};
   71   $self->{op} = $self->{op}->substitute;
   72   return $self->Item("Value")->new($equation,[$self->eval])
   73     if $self->{op}{isConstant} && $context->flag('reduceConstants');
   74   return $self;
   75 }
   76 
   77 #
   78 #  Copy the operand as well as the rest of the object
   79 #
   80 sub copy {
   81   my $self = shift; my $equation = shift;
   82   my $new = $self->SUPER::copy($equation);
   83   $new->{op} = $self->{op}->copy($equation);
   84   return $new;
   85 }
   86 
   87 ##################################################
   88 #
   89 #  Service routines for checking the types of operands.
   90 #
   91 
   92 
   93 #
   94 #  Error if the operand is a string
   95 #
   96 sub checkString {
   97   my $self = shift; return 0 if $self->context->flag("allowBadOperands");
   98   my $type = $self->{op}->typeRef;
   99   return 0 if ($type->{name} ne 'String');
  100   my $name = $self->{def}{string} || $self->{uop};
  101   $self->Error("Operand of '%s' can't be %s",$name,
  102          ($self->{op}{isInfinite}? 'an infinity': 'a word'));
  103   return 1;
  104 }
  105 
  106 #
  107 #  Error if operand is a list
  108 #
  109 sub checkList {
  110   my $self = shift;  return 0 if $self->context->flag("allowBadOperands");
  111   my $type = $self->{op}->typeRef;
  112   return 0 if ($type->{name} ne 'List');
  113   my $name = $self->{def}{string} || $self->{uop};
  114   $self->Error("Operand of '%s' can't be a list",$name);
  115   return 1;
  116 }
  117 
  118 
  119 #
  120 #  Determine if the operand is an infinity and set the type
  121 #
  122 sub checkInfinite {
  123   my $self = shift;
  124   my $uop = $self->{def};
  125   return 0 unless $self->{op}->{isInfinite} && $uop->{allowInfinite};
  126   $self->{type} = $self->{op}->typeRef;
  127   return 1;
  128 }
  129 
  130 #
  131 #  Determine if the operand is a number, and set the type
  132 #    to complex or number according to the type of operand.
  133 #
  134 sub checkNumber {
  135   my $self = shift;
  136   return 0 if !($self->{op}->isNumber);
  137   if ($self->{op}->isComplex) {$self->{type} = $Value::Type{complex}}
  138   else {$self->{type} = $Value::Type{number}}
  139   return 1;
  140 }
  141 
  142 ##################################################
  143 #
  144 #  Service routines for adjusting the values of operands.
  145 #
  146 
  147 #
  148 #  Produce a reduced negation of an item.
  149 #
  150 sub Neg {
  151   my $self = shift;
  152   my $equation = $self->{equation};
  153   $self->Error("Can't reduce:  negation operator is not defined")
  154     if (!defined($equation->{context}{operators}{'u-'}));
  155   return ($self->Item("UOP")->new($equation,'u-',$self))->reduce;
  156 }
  157 
  158 #
  159 #  Get the variables used in the operand
  160 #
  161 sub getVariables {
  162   my $self = shift;
  163   $self->{op}->getVariables;
  164 }
  165 
  166 ##################################################
  167 #
  168 #  Generate the various output formats.
  169 #
  170 
  171 
  172 #
  173 #  Produce a string version of the equation.
  174 #
  175 #  We add parentheses if the precedence of the operator is less
  176 #    than the parent operation.
  177 #  Add the operator before or after the operand according to the
  178 #    associativity of the operator.
  179 #
  180 sub string {
  181   my ($self,$precedence,$showparens,$position,$outerRight) = @_;
  182   my $string; my $uop = $self->{def}; $position = '' unless defined($position);
  183   my $extraParens = $self->context->flag('showExtraParens');
  184   my $addparens = ((defined($precedence) && $precedence >= $uop->{precedence}) ||
  185                     $position eq 'right' || $outerRight) && $extraParens;
  186   if ($uop->{associativity} eq "right") {
  187     $string = $self->{op}->string($uop->{precedence}).$uop->{string};
  188   } else {
  189     $string = $uop->{string}.$self->{op}->string($uop->{precedence});
  190   }
  191   $string = $self->addParens($string) if $addparens;
  192   return $string;
  193 }
  194 
  195 #
  196 #  Produce the TeX form
  197 #
  198 sub TeX {
  199   my ($self,$precedence,$showparens,$position,$outerRight) = @_;
  200   my $TeX; my $uop = $self->{def}; $position = '' unless defined($position);
  201   my $fracparens = ($uop->{nofractionparens}) ? "nofractions" : "";
  202   my $extraParens = $self->context->flag('showExtraParens');
  203   my $addparens = ((defined($precedence) && $precedence >= $uop->{precedence}) ||
  204                     $position eq 'right' || $outerRight) && $extraParens;
  205   $TeX = (defined($uop->{TeX}) ? $uop->{TeX} : $uop->{string});
  206   if ($uop->{associativity} eq "right") {
  207     $TeX = $self->{op}->TeX($uop->{precedence},$fracparens) . $TeX;
  208   } else {
  209     $TeX = $TeX . $self->{op}->TeX($uop->{precedence},$fracparens);
  210   }
  211   $TeX = '\left('.$TeX.'\right)' if $addparens;
  212   return $TeX;
  213 }
  214 
  215 #
  216 #  Produce a Perl expression
  217 #
  218 sub perl {
  219   my $self = shift; my $parens = shift;
  220   my $uop = $self->{def}; my $perl;
  221   if ($uop->{isCommand}) {
  222     $perl = ($uop->{perl} || ref($self).'->call').'('.$self->{op}->perl.')';
  223   } else {
  224     $perl = ($uop->{perl} || $uop->{string})." ".$self->{op}->perl(1);
  225   }
  226   $perl = '('.$perl.')' if $parens;
  227   return $perl;
  228 }
  229 
  230 #########################################################################
  231 #
  232 #  Load the subclasses.
  233 #
  234 
  235 END {
  236   use Parser::UOP::undefined;
  237   use Parser::UOP::plus;
  238   use Parser::UOP::minus;
  239   use Parser::UOP::factorial;
  240 }
  241 
  242 #########################################################################
  243 
  244 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9