style results from the CPAN

AcePerl


No actual database deletion occurs until you call commit().  The
delete() result code indicates whether the deletion was successful.
Currently it is always true, since the database model is not checked.
    
=head2 replace() method

    $result_code = $object->replace($tag_path,$oldvalue,$newvalue);
    $result_code = $object->replace(-path=>$tag_path,
				    -old=>$oldvalue,
				    -new=>$newvalue);

Replaces the indicated tag and value with the new value.  This example
changes the address line "FRANCE" to "LANGUEDOC" in the Author's
mailing address:

    $object->delete('Address.Mail','FRANCE','LANGUEDOC');

No actual database changes occur until you call commit().  The
delete() result code indicates whether the replace was successful.
Currently is true if the old value was identified.

=head2 commit() method

     $result_code = $object->commit;

Commits all add(), replace() and delete() operations to the database.
It can also be used to write a completely new object into the
database.  The result code indicates whether the object was
successfully written.  If an error occurred, further details can be
found in the Ace->error() error string.

=head2 rollback() method

    $object->rollback;

Discard all adds, deletions and replacements, returning the object to
the state it was in prior to the last commit().

rollback() works by deleting the object from Perl memory and fetching
the object anew from AceDB.  If someone has changed the object in the
database while you were working with it, you will see this version,
ot the one you originally fetched.

If you are creating an entirely new object, you I<must> add at least
one tag in order to enter the object into the database.

=head2 kill() method

    $result_code = $object->kill;

This will remove the object from the database immediately and
completely.  It does not wait for a commit(), and does not respond to
a rollback().  If successful, you will be left with an empty object
that contains just the class and object names.  Use with care!

In the case of failure, which commonly happens when the database is
not open for writing, this method will return undef.  A description of
the problem can be found by calling the error() method.

=head2 date_style() method

   $object->date_style('ace');

This is a convenience method that can be used to set the date format
for all objects returned by the database.  It is exactly equivalent to

   $object->db->date_style('ace');

Note that the text representation of the date will change for all
objects returned from this database, not just the current one.

=head2 isRoot() method

    print "Top level object" if $object->isRoot;

This method will return true if the object is a "top level" object,
that is the root of an object tree rather than a subtree.

=head2 model() method

    $model = $object->model;

This method will return the object's model as an Ace::Model object, or
undef if the object does not have a model. See L<Ace::Model> for
details.

=head2 timestamp() method

   $stamp = $object->timestamp;

The B<timestamp()> method will retrieve the modification time and date
from the object.  This works both with top level objects and with
subtrees.  Timestamp handling must be turned on in the database, or
B<timestamp()> will return undef.

The returned timestamp is actually a UserSession object which can be
printed and explored like any other object.  However, there is
currently no useful information in UserSession other than its name.

=head2 comment() method

   $comment = $object->comment;

This returns the comment attached to an object or object subtree, if
any.  Comments are I<Comment> objects and have the interesting
property that a single comment can refer to multiple objects.  If
there is no comment attached to the current subtree, this method will
return undef.

Currently you cannot create a new comment in AcePerl or edit an old
one.

=head2 error() method
    
    $error = $object->error;

Returns the error from the previous operation, if any.  As in
Ace::error(), this string will only have meaning if the previous
operation returned a result code indicating an error.

=head2 factory() method

WARNING - THIS IS DEFUNCT AND NO LONGER WORKS.  USE THE Ace->class() METHOD INSTEAD

    $package = $object->factory;

When a root Ace object instantiates its tree of tags and values, it

Ace/Object.pm view on Meta::CPAN

    1;
}

# commit changes from local copy to database copy
sub commit {
  my $self = shift;
  return unless my $db = $self->db;
  
  my ($retval,@cmd);
  my $name = $self->{'name'};
  return unless defined $name;
  
  $name =~ s/([^a-zA-Z0-9_-])/\\$1/g;
  return 1 unless exists $self->{'.update'} && $self->{'.update'};

  $Ace::Error = '';
  my $result = '';

  # bad design alert: the following breaks encapsulation
  if ($db->db->can('write')) { # new way for socket server
    my $cmd = join "\n","$self->{'class'} : $name",@{$self->{'.update'}};
    warn $cmd if $self->debug;
    $result = $db->raw_query($cmd,0,'parse');  # sets Ace::Error for us
  } else {   # old way for RPC server and local
    my $cmd = join('; ',"$self->{'class'} : $name",
		   @{$self->{'.update'}});
    warn $cmd if $self->debug;
    $result = $db->raw_query("parse = $cmd");
  }

  if (defined($result) and $result=~/write( or admin)? access/im) {  # this keeps changing
    $Ace::Error = "Write access denied";
  } elsif (defined($result) and $result =~ /sorry|parse error/mi) {
    $Ace::Error = $result;
  }
  return if $Ace::Error;
  undef $self->{'.update'};
  # this will force a fresh retrieval of the object
  # and synchronize our in-memory copy with the db
  delete $self->{'.right'};
  delete $self->{'.PATHS'};
  return 1;
}

# undo changes
sub rollback {
    my $self = shift;
    undef $self->{'.update'};
    # this will force object to be reloaded from database
    # next time it is needed.
    delete $self->{'.right'};
    delete $self->{'.PATHS'};
    1;
}

sub debug {
    my $self = shift;
    Ace->debug(@_);
}

### Get or set the date style (actually calls through to the database object) ###
sub date_style {
  my $self = shift;
  return unless $self->db;
  return $self->db->date_style(@_);
}

sub _asHTML {
  my($self,$out,$position,$level,$morph_code) = @_;
  do {
    $$out .= "<TR ALIGN=LEFT VALIGN=TOP>" unless $position;
    $$out .= "<TD></TD>" x ($level-$position-1);
    my ($cell,$prune,$did_it_myself) = $morph_code->($self);
    $$out .= $did_it_myself ? $cell : "<TD>$cell</TD>";
    if ($self->comment) {
      my ($cell,$p,$d) = $morph_code->($self->comment);
      $$out .= $d ? $cell : "<TD>$cell</TD>";
      $$out .= "</TR>\n" . "<TD></TD>" x $level unless $self->down && !defined($self->right);
    }
    $level = $self->right->_asHTML($out,$level,$level+1,$morph_code) if defined($self->right) && !$prune;
    $$out .= "</TR>\n" if defined($self = $self->down);
    $position = 0;
  } while defined $self;
  return --$level;
}


# This function is overly long because it is optimized to prevent parsing
# parts of the tree that haven't previously been parsed.
sub _asTable {
    my($self,$out,$position,$level) = @_;
    do {
      if ($self->{'.raw'}) {  # we still have raw data, so we can optimize
	my ($a,$start,$end) = @{$self}{ qw(.col .start_row .end_row) };
	my @to_append = map { join("\t",@{$_}[$a..$#{$_}]) } @{$self->{'.raw'}}[$start..$end];
	my $new_row;
	foreach (@to_append) {
	  # hack alert
	  s/(\?.*?[^\\]\?.*?[^\\]\?)\S*/$self->_ace_format(Ace->split($1))/eg;
	  if ($new_row++) {
	    $$out .= "\n";
	    $$out .= "\t" x ($level-1) 
	  }
	  $$out .= $_;
	}
	return $level-1;
      }

      $$out .= "\t" x ($level-$position-1);
      $$out .= $self->name . "\t";
      if ($self->comment) {
	$$out .= $self->comment;
	$$out .= "\n" . "\t" x $level unless $self->down && !defined($self->right);
      }
      $level = $self->right->_asTable($out,$level,$level+1)
	if defined $self->right;
      $$out .= "\n" if defined($self = $self->down);
      $position = 0;
    } while defined $self;
    return --$level;
}

# This is the default code that will be called during construction of
# the HTML table.  It returns a two-member list consisting of the modified
# entry and (optionally) a true value if we are to prune here.  The returned string

Ace/Object.pm view on Meta::CPAN

    while ($p) {
	return $p if "$p" eq $tag;
	last unless $p->{'.down'};
	$p = $p->{'.down'};
    }
    # if we get here, then we didn't find it, so
    # insert at the bottom
    return $p->{'.down'} = $self->new('tag',$tag);
}

# This is unsatisfactory because it duplicates much of the code
# of asTable.
sub _asAce {
  my($self,$out,$level,$tags) = @_;

  # ugly optimization for speed
  if ($self->{'.raw'}){
    my ($a,$start,$end) = @{$self}{qw(.col .start_row .end_row)};
    my (@last);
    foreach (@{$self->{'.raw'}}[$start..$end]){
      my $j=1;
      $$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags);
      my (@to_modify) = @{$_}[$a..$#{$_}];
      foreach (@to_modify) {
	my ($class,$name) =Ace->split($_);
	if (defined($name)) {
	  $name = $self->_ace_format($class,$name);
	  if (_isObject($class) || $name=~/[^\w.-]/) {
	    $name=~s/"/\\"/g; #escape quotes with slashes
	    $name = qq/\"$name\"/;
	  } 
	} else {
	  $name = $last[$j] if $name eq '';
	}
	$_ = $last[$j++] = $name;  
	$$out .= "$_\t";
      }
      $$out .= "\n";
      $level = 0;
    }
    chop($$out);
    return;
  }
  
  $$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags);
  $$out .= $self->escape . "\t";
  if (defined $self->right) {
    push(@$tags,$self->escape);
    $self->right->_asAce($out,$level+1,$tags);
    pop(@$tags);
  }
  if ($self->down) {
    $$out .= "\n";
    $self->down->_asAce($out,0,$tags);
  }
}

sub _to_ace_date {
  my $self = shift;
  my $string = shift;
  return $string unless lc($self->date_style) eq 'ace';
  %MO = (Jan=>1,Feb=>2,Mar=>3,
	 Apr=>4,May=>5,Jun=>6,
	 Jul=>7,Aug=>8,Sep=>9,
	 Oct=>10,Nov=>11,Dec=>12) unless %MO;
  my ($day,$mo,$yr) = split(" ",$string);
  return "$yr-$MO{$mo}-$day";
}

### Return an XML syntax representation  ###
### Consider this feature experimental   ###
sub asXML {
    my $self = shift;
    return unless defined($self->right);

    my ($do_content,$do_class,$do_value,$do_timestamps) = rearrange([qw(CONTENT CLASS VALUE TIMESTAMPS)],@_);
    $do_content    = 0 unless defined $do_content;
    $do_class      = 1 unless defined $do_class;
    $do_value      = 1 unless defined $do_value;
    $do_timestamps = 1 unless (defined $do_timestamps && !$do_timestamps) || !$self->db->timestamps;
    my %options = (content    => $do_content,
		   class      => $do_class,
		   value      => $do_value,
		   timestamps => $do_timestamps);
    my $name = $self->escapeXML($self->name);
    my $class = $self->class;
    my $string = '';
    $self->_asXML(\$string,0,0,'',0,\%options);
    return $string;
}

sub _asXML {
  my($self,$out,$position,$level,$current_tag,$tag_level,$opts) = @_;

  do {
    my $name = $self->escapeXML($self->name);
    my $class = $self->class;
    my ($tagname,$attributes,$content) = ('','',''); # prevent uninitialized variable warnings
    my $tab = "    " x ($level-$position); # four spaces
    $current_tag ||= $class;
    $content = $name if $opts->{content};

    if ($self->isTag) {
      $current_tag = $tagname = $name;
      $tag_level = 0;
    } else {
      $tagname = $tag_level > 0 ? sprintf "%s-%d",$current_tag,$tag_level + 1 : $current_tag;
      $class = "#$class" unless $self->isObject;
      $attributes .= qq( class="$class") if $opts->{class};
      $attributes .= qq( value="$name")  if $opts->{value};
    }

    if (my $c = $self->comment) {
      $c = $self->escapeXML($c);
      $attributes .= qq( comment="$c");
    }

    if ($opts->{timestamps} && (my $timestamp = $self->timestamp)) {
      $timestamp = $self->escapeXML($timestamp);
      $attributes .= qq( timestamp="$timestamp");
    }

( run in 0.507 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )