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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5787 - (download) (as text) (annotate)
Wed Jun 25 19:46:38 2008 UTC (11 years, 7 months ago) by apizer
File size: 4494 byte(s)
Added
no strict "refs"
to try to avoid new error checking in Perl 5.10.

    1 #########################################################################
    2 #
    3 #  The basic context (Parser::Context is a subclass of this)
    4 #
    5 
    6 package Value::Context;
    7 my $pkg = "Value::Context";
    8 use strict; no strict "refs";
    9 use UNIVERSAL;
   10 
   11 #
   12 #  Create a new Context object and initialize its data lists
   13 #
   14 sub new {
   15   my $self = shift; my $class = ref($self) || $self;
   16   my $context = bless {
   17     pattern => {
   18       number => '(?:\d+(?:\.\d*)?|\.\d+)(?:E[-+]?\d+)?',
   19       signedNumber => '[-+]?(?:\d+(?:\.\d*)?|\.\d+)(?:E[-+]?\d+)?',
   20     },
   21     format => {
   22       number => '%g',  # default format for Reals
   23     },
   24     error => {
   25       string => '',
   26       pos => undef,
   27       message => '',
   28       flag => 0,
   29       msg => {},  # for localization
   30     },
   31     data => {
   32       hashes => ['cmpDefaults'],
   33       arrays => ['data'],
   34       values => ['pattern','format','value'],
   35       objects => [],
   36     },
   37     value => {
   38       Formula => "Value::Formula"
   39     },
   40   }, $class;
   41   my %data = (lists=>{},flags=>{},diagnostics=>{},@_);
   42   $context->{_lists} = new Value::Context::Lists($context,%{$data{lists}});
   43   $context->{_flags} = new Value::Context::Flags($context,%{$data{flags}});
   44   $context->{_diagnostics} = new Value::Context::Diagnostics($context,%{$data{diagnostics}});
   45   $context->{_initialized} = 1;
   46   $context->update;
   47   return $context;
   48 }
   49 
   50 #
   51 #  Implemented in subclasses
   52 #
   53 sub update {}
   54 
   55 #
   56 #  Access to the data lists
   57 #
   58 sub lists         {(shift)->{_lists}}
   59 sub flags         {(shift)->{_flags}}
   60 sub flag          {(shift)->{_flags}->get(shift)}
   61 sub diagnostics   {(shift)->{_diagnostics}}
   62 
   63 #
   64 #  Make a copy of a Context object
   65 #
   66 sub copy {
   67   my $self = shift;
   68   my $context = $self->new();
   69   $context->{_initialized} = 0;
   70   foreach my $data (@{$context->{data}{objects}}) {
   71     $context->{$data}->copy($self->{$data});
   72   }
   73   foreach my $data (@{$context->{data}{hashes}}) {
   74     $context->{$data} = {};
   75     foreach my $x (keys %{$self->{$data}}) {
   76       $context->{$data}{$x} = {%{$self->{$data}{$x}}};
   77     }
   78   }
   79   foreach my $data (@{$context->{data}{arrays}}) {
   80     $context->{$data} = {};
   81     foreach my $x (keys %{$self->{$data}}) {
   82       $context->{$data}{$x} = [@{$self->{$data}{$x}}];
   83     }
   84   }
   85   foreach my $data (@{$context->{data}{values}}) {
   86     $context->{$data} = {%{$self->{$data}}};
   87   }
   88   $context->{error}{msg} = {%{$self->{error}{msg}}};
   89   $context->{error}{convert} = $self->{error}{convert}
   90     if defined $self->{error}{convert};
   91   $context->{name} = $self->{name};
   92   $context->{_initialized} = 1;
   93   return $context;
   94 }
   95 
   96 #
   97 #  Returns the package name for the specificied Value object class
   98 #  (as specified by the context's {value} hash, or "Value::name").
   99 #
  100 sub Package {
  101   my $context = shift; my $class = shift;
  102   return $context->{value}{$class} if defined $context->{value}{$class};
  103   $class =~ s/\(\)$//;
  104   return $context->{value}{$class} if defined $context->{value}{$class};
  105   return "Value::$class" if defined @{"Value::${class}::ISA"};
  106   Value::Error("No such package 'Value::%s'",$class) unless $_[0];
  107 }
  108 
  109 #
  110 #  Make these available to Contexts
  111 #
  112 sub isa {UNIVERSAL::isa(@_)}
  113 sub can {UNIVERSAL::can(@_)}
  114 
  115 #
  116 #  Make stringify produce TeX or regular strings
  117 #
  118 sub texStrings {shift->flags->set(StringifyAsTeX=>1)}
  119 sub normalStrings {shift->flags->set(StringifyAsTeX=>0)}
  120 
  121 #
  122 #  Clear error flags
  123 #
  124 sub clearError {
  125   my $error = (shift)->{error};
  126   $error->{string} = '';
  127   $error->{pos} = undef;
  128   $error->{message} = '';
  129   $error->{original} = '';
  130   $error->{flag} = 0;
  131 }
  132 
  133 #
  134 #  Set the error flags
  135 #
  136 sub setError {
  137   my $error = (shift)->{error};
  138   my ($message,$string,$pos,$more,$flag) = @_;
  139   my @args = ();
  140   ($message,@args) = @{$message} if ref($message) eq 'ARRAY';
  141   $error->{original} = $message;
  142   while ($message && $error->{msg}{$message}) {$message = $error->{msg}{$message}}
  143   while ($more && $error->{msg}{$more}) {$more = $error->{msg}{$more}}
  144   $message = sprintf($message,@args) if scalar(@args) > 0;
  145   $message .= sprintf($more,$pos->[0]+1) if $more;
  146   while ($message && $error->{msg}{$message}) {$message = $error->{msg}{$message}}
  147   $message = &{$error->{convert}}($message) if defined $error->{convert};
  148   $error->{message} = $message;
  149   $error->{string} = $string;
  150   $error->{pos} = $pos;
  151   $error->{flag} = $flag || 1;
  152 }
  153 
  154 #########################################################################
  155 #
  156 #  Load the subclasses.
  157 #
  158 
  159 END {
  160   use Value::Context::Data;
  161 }
  162 
  163 #########################################################################
  164 
  165 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9