fooobject.pm

用于词法分析的词法分析器

# $Id: FooObject.pm,v 1.7 1997/01/19 05:12:39 matt Exp $
#
# Foo object class.
#
# (c) June 96 Matt Phillips.

package FooObject;

sub new
{
  my ($class, @values) = @_;
  my $self = {};

  bless $self, $class;

  $self->addAttrs ('', @values) if @values;

  return $self;
}

# add attr as having value.
sub addAttr
{
  my ($self, $attr, $value) = @_;
  my $values = $$self{$attr};
  if ($values)
  {
    push (@$values, $value);
  } else
  {
    $$self{$attr} = [$value];
  }
}

# add attr as having values @values.
sub addAttrs
{
  my ($self, $attr, @values) = @_;
  my $myvalues = $$self{$attr};
  my $nmyvalues = $#$myvalues;

  if (@$myvalues)
  {
    $$myvalues[$nmyvalues + 1..$nmyvalues + $#values + 2] = @values;
  } else
  {
    my @copies = @values;
    $$self{$attr} = \@copies;
  }
}

# returns an ref to array of values for $attr.
sub getAttrs
{
  my ($self, $attr) = @_;
  my $values = $$self{$attr};
  return defined ($values) ? $values : [];
}

# returns last value in value array of values for attr or undef if no
# values exist.
sub getAttr
{
  my ($self, $attr) = @_;
  my $values = $self->{$attr};
  return defined ($values) ? $$values[$#$values] : undef;
}

# returns the names of all the attributes of object.
sub getAttrNames
{
  my $self = shift;
  return keys (%$self);
}

# returns true if an object has attribute attr.
sub hasAttr
{
  my ($self, $attr) = @_;
  return defined ($self->{$attr});
}

sub nAttrs
{
  my $self = shift;
  my @keys = keys (%$self);

  return $#keys + 1;
}

# similar to getAttr (), but follows a path through multiple
# attributes.  path is specified using a string like 'attr1/attr2'.
# example: this path would produce the value "foo" in the case where
# it was used on '(attr1 (attr2 "foo"))'.
sub getAttrPath
{
  my ($self, $path) = @_;
  my $attr;
  my $object = $self;

  for $attr (split ('/', $path))
  {
    $object = $object->getAttr ($attr);
    return undef if !$object;
  }

  return $object;
}

# similar to getAttrs (), but follows a path through multiple
# attributes.  see getAttrPath () for more info.
sub getAttrsPath
{
  my ($self, $path) = @_;
  my $attr;
  my $object = $self;
  my @path = split ('/', $path);

  for $attr (@path[0..$#path - 1])
  {
    $object = $object->getAttr ($attr);
    return undef if !$object;
  }

  return $object->getAttrs ($path[$#path]);
}

# same as getAttr () but returns string value of object if it has a
# default attribute (ie. '' is a valid attribute).
sub getAttrString
{
  my ($self, $attr) = @_;
  my $values = $self->{$attr};

  if (defined ($values))
  {
    return $$values[$#$values]->getAttr ();
  } else
  {
    return undef;
  }
}

# same as getAttrPath (), but returns string value of object if it has
# a default attribute (ie. '' is a valid attribute).
sub getAttrStringPath
{
  my ($self, $path) = @_;
  my $value = $self->getAttrPath ($path);

  return $value ? $value->getAttr () : undef;
}

# true if object has '' as its one and only attribute.
sub isAtomic
{
  my $self = shift;

  return defined ($self->getAttr ()) && ($self->nAttrs () == 1);
}

1;