start results from the CPAN

AcePerl

### Returns the object's model (as an Ace::Model object)
sub model {
  my $self = shift;
  return unless $self->db && $self->isObject;
  return $self->db->model($self->class);
}

### Return the class in which to bless all objects retrieved from
# database. Might want to override in other classes
sub factory {
  return __PACKAGE__;
}

#####################################################################
#####################################################################
############### mostly private functions from here down #############
#####################################################################
#####################################################################
# simple clone
sub clone {
  my $self = shift;
  return bless {%$self},ref $self;
}

# selective clone
sub _clone {
    my $self = shift;
    my $pack = ref($self);
    my @public_keys = grep {substr($_,0,1) ne '.'} keys %$self;
    my %newobj;
    @newobj{@public_keys} = @{$self}{@public_keys};

    # Turn into a toplevel object
    $newobj{'.root'}++;
    return bless \%newobj,$pack;
}

sub _fill {
    my $self = shift;
    return if $self->filled;
    return unless $self->db && $self->isObject;

    my $data = $self->db->pick($self->class,$self->name);
    return unless $data;

    # temporary object, don't cache it.
    my $new = $self->newFromText($data,$self->db);
    %{$self}=%{$new};

    $new->{'.nocache'}++; # this line prevents the thing from being cached

    $self->_dirty(1);
}

sub _parse {
  my $self = shift;
  return unless my $raw = $self->{'.raw'};
  my $ts = $self->db->timestamps;
  my $col = $self->{'.col'};
  my $current_obj = $self;
  my $current_row = $self->{'.start_row'};
  my $db = $self->db;
  my $changed;

  for (my $r=$current_row+1; $r<=$self->{'.end_row'}; $r++) {
    next unless $raw->[$r][$col] ne '';
    $changed++;

    my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$r-1,$db);

    # comment handling
    if ( defined($obj_right) ) {
      my ($t,$i);
      my $row = $current_row+1;
      while ($obj_right->isComment) {
	$current_obj->comment($obj_right)   if $obj_right->isComment;
	$t = $obj_right;
	last unless defined ($obj_right = $self->_fromRaw($raw,$row++,$col+1,$r-1,$db));
      }
    }
    $current_obj->{'.right'} = $obj_right;

    my ($class,$name,$timestamp) = Ace->split($raw->[$r][$col]);
    my $obj_down = $self->new($class,$name,$db);
    $obj_down->timestamp($timestamp) if $ts && $timestamp;

    # comments never occur at down pointers
    $current_obj = $current_obj->{'.down'} = $obj_down;
    $current_row = $r;
  }

  my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$self->{'.end_row'},$db);

  # comment handling
  if (defined($obj_right)) {
    my ($t,$i);
    my $row = $current_row + 1;
    while ($obj_right->isComment) {
      $current_obj->comment($obj_right)   if $obj_right->isComment;
      $t = $obj_right;
      last unless defined($obj_right = $self->_fromRaw($raw,$row++,$col+1,$self->{'.end_row'},$db));
    }
  }
  $current_obj->{'.right'} = $obj_right;
  $self->_dirty(1) if $changed;
  delete @{$self}{qw[.raw .start_row .end_row .col]};
}

sub _fromRaw {
  my $pack = shift;

  # this breaks inheritance...
  #  $pack = $pack->factory();

  my ($raw,$start_row,$col,$end_row,$db) = @_;
  $db = "$db" if ref $db;
  return unless defined $raw->[$start_row][$col];

  # HACK! Some LongText entries may begin with newlines. This is within the Acedb spec.
  # Let's purge text entries of leading space and format them appropriate.
  # This should probably be handled in Freesubs.xs / Ace::split
  my $temp = $raw->[$start_row][$col];
#  if ($temp =~ /^\?txt\?\s*\n*/) {
#    $temp =~ s/^\?txt\?(\s*\\n*)/\?txt\?/;
#    $temp .= '?';
#  }
  my ($class,$name,$ts) = Ace->split($temp);

  my $self = $pack->new($class,$name,$db,!($start_row || $col));
  @{$self}{qw(.raw .start_row .end_row .col db)} = ($raw,$start_row,$end_row,$col,$db);
  $self->{'.timestamp'} = $ts if defined $ts;
  return $self;
}


# Return partial ace subtree at indicated tag
sub _at {
    my ($self,$tag) = @_;
    my $pos=0;

    # Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999

    if ($tag=~/(.*?)\[(\d+)\]$/) {
      $pos=$2;
      $tag=$1;
    }
    my $p;
    my $o = $self->right;
    while ($o) {
	return ($o->right($pos),$p,$self) if (lc($o) eq lc($tag));
	$p = $o;
	$o = $o->down;
    }
    return;
}


# Used to munge special data types.  Right now dates are the
# only examples.
sub _ace_format {
  my $self = shift;
  my ($class,$name) = @_;
  return undef unless defined $class && defined $name;
  return $class eq 'date' ? $self->_to_ace_date($name) : $name;
}

# It's an object unless it is one of these things
sub _isObject {
    return unless defined $_[0];
    $_[0] !~ /^(float|int|date|tag|txt|peptide|dna|scalar|[Tt]ext|comment)$/;
}

# utility routine used to split a tag path into individual components
# allows components to contain dots.
sub _split_tags {
  my $self = shift;
  my $tag = shift;
  $tag =~ s/\\\./$;/g; # protect backslashed dots
  return map { (my $x=$_)=~s/$;/./g; $x } split(/\./,$tag);
}


1;

__END__

=head1 NAME

Ace::Object - Manipulate  Ace Data Objects

Ace/Object.pm view on Meta::CPAN

  return "$string\n\n";
}

### Pretty-printed version ###
sub asString {
  my $self = shift;
  my $MAXWIDTH = shift || $DEFAULT_WIDTH;
  my $tabs = $self->asTable;
  return "$self" unless $tabs;
  my(@lines) = split("\n",$tabs);
  my($result,@max);
  foreach (@lines) {
    my(@fields) = split("\t");
    for (my $i=0;$i<@fields;$i++) {
      $max[$i] = length($fields[$i]) if
	!defined($max[$i]) or $max[$i] < length($fields[$i]);
    }
  }
  foreach (@max) { $_ = $MAXWIDTH if $_ > $MAXWIDTH; } # crunch long lines
  my $format1 = join(' ',map { "^"."<"x $max[$_] } (0..$#max)) . "\n";
  my $format2 =   ' ' . join('  ',map { "^"."<"x ($max[$_]-1) } (0..$#max)) . "~~\n";
  $^A = '';
  foreach (@lines) {
    my @data = split("\t");
    push(@data,('')x(@max-@data));
    formline ($format1,@data);
    formline ($format2,@data);
  }
  return ($result = $^A,$^A='')[0];
}

# run a series of GIF commands and return the Gif and the semi-parsed
# "boxes" structure.  Commands is typically a series of mouseclicks
# ($gif,$boxes) = $aceObject->asGif(-clicks=>[[$x1,$y1],[$x2,$y2]...],
#                                   -dimensions=>[$x,$y]);
sub asGif {
  my $self = shift;
  my ($clicks,$dimensions,$display,$view,$coords,$getcoords) = rearrange(['CLICKS',
									  ['DIMENSIONS','DIM'],
									  'DISPLAY',
									  'VIEW',
									  'COORDS',
									  'GETCOORDS',
									  ],@_);
  $display = "-D $display" if $display;
  $view    = "-view $view" if $view;
  my $c;
  if ($coords) {
    $c    =  ref($coords) ? "-coords @$coords" : "-coords $coords";
  }
  my @commands;
  if ($view || $c || $self->class =~ /Map/i) {
      @commands = "gif map \"@{[$self->name]}\" $view $c";
  } else {
      @commands = "gif display $display $view @{[$self->class]} \"@{[$self->name]}\"";
  }
  push(@commands,"Dimensions @$dimensions") if ref($dimensions);
  push(@commands,map { "mouseclick @{$_}" } @$clicks) if ref($clicks);

  if ($getcoords) { # just want the coordinates
    my ($start,$stop);
    my $data = $self->db->raw_query(join(' ; ',@commands));    
    return unless $data =~ /\"[^\"]+\" ([\d.-]+) ([\d.-]+)/;
    ($start,$stop) = ($1,$2);
    return ($start,$stop);
  }

  push(@commands,"gifdump -");

  # do the query
  my $data = $self->db->raw_query(join(' ; ',@commands));

  # A $' has been removed here to improve speed -- tim.cutts@incyte.com 2 Sep 1999

  # did this query succeed?
  my ($bytes, $trim);
  return unless ($bytes, $trim) = $data=~m!^// (\d+) bytes\n\0*(.+)!sm;

  my $gif = substr($trim,0,$bytes);

  # now process the boxes
  my @b;
  my @boxes = split("\n",substr($trim,$bytes));
  foreach (@boxes) {
    last if m!^//!;
    chomp;
    my ($left,$top,$right,$bottom,$class,$name,$comments) = 
      m/^\s*\d*\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\w+):"(.+)"\s*(.*)/;
    next unless defined $left;
    $comments=~s/\s+$//; # sometimes there's extra white space at the end
    my $box = {'coordinates'=>[$left,$top,$right,$bottom],
	       'class'=>$class,
	       'name' =>$name,
	       'comment'=>$comments};
    push (@b,$box);
  }
  return ($gif,\@b);
}

############## timestamp and comment information ############
sub timestamp {
    my $self = shift;
    return $self->{'.timestamp'} = $_[0] if defined $_[0];
    if ($self->db && !$self->{'.timestamp'}) {
      $self->_fill;
      $self->_parse;
    }
    return $self->{'.timestamp'} if $self->{'.timestamp'};
    return unless defined $self->right;
    return $self->{'.timestamp'} = $self->right->timestamp;
}

sub comment {
    my $self = shift;
    return $self->{'.comment'} = $_[0] if defined $_[0];
    if ($self->db && !$self->{'.comment'}) {
      $self->_fill;
      $self->_parse;
    }
    return $self->{'.comment'};
}

### Return list of all the tags in the object ###
sub tags {
    my $self = shift;

Ace/Object.pm view on Meta::CPAN

    $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
# will be placed inside a <TD></TD> tag.  There's nothing you can do about that.
sub _default_makeHTML {
  my $self = shift;
  my ($string,$prune) = ("$self",0);
  return ($string,$prune) unless $self->isObject || $self->isTag;

  if ($self->isTag) {
    $string = "<B>$self</B>";
  } elsif ($self->isComment) {
    $string = "<I>$self</I>";
  }  else {
    $string = qq{<FONT COLOR="blue">$self</FONT>} ;
  }
  return ($string,$prune);
}

# Insert a new tag or value.
# Local only. Will not affect the database.
# Returns the inserted tag, or the preexisting
# tag, if already there.
sub _insert {
    my ($self,$tag) = @_;
    my $p = $self->{'.right'};
    return $self->{'.right'} = $self->new('tag',$tag)
	unless $p;
    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;

( run in 0.467 second using v1.01-cache-2.11-cpan-437f7b0c052 )