view release on metacpan or  search on metacpan

Ace/Object.pm  view on Meta::CPAN

  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");
    }

    $tagname = $self->_xmlNumber($tagname) if $tagname =~ /^\d/;
    
    unless (defined $self->right) { # lone tag
      $$out .= $self->isTag || !$opts->{content} ? qq($tab<$tagname$attributes />\n) 
	                                         : qq($tab<$tagname$attributes>$content</$tagname>\n);
    } elsif ($self->isTag) { # most tags are implicit in the XML tag names
      if (!XML_COLLAPSE_TAGS or $self->right->isTag) {
	$$out .= qq($tab<$tagname$attributes>\n);
	$level = $self->right->_asXML($out,$position,$level+1,$current_tag,$tag_level + !XML_COLLAPSE_TAGS,$opts);
	$$out .= qq($tab</$tagname>\n);
      } else {
	$level = $self->right->_asXML($out,$position+1,$level+1,$current_tag,$tag_level,$opts);
      }
    } else {
      $$out .=  qq($tab<$tagname$attributes>$content\n);
      $level = $self->right->_asXML($out,$position,$level+1,$current_tag,$tag_level+1,$opts);
      $$out  .= qq($tab</$tagname>\n);
    }

    $self = $self->down;
  } while defined $self;

  return --$level;
}

sub escapeXML {
  my ($self,$string) = @_;
  $string =~ s/&/&amp;/g;
  $string =~ s/\"/&quot;/g;
  $string =~ s/</&lt;/g;
  $string =~ s/>/&gt;/g;
  return $string;
}

sub _xmlNumber {
  my $self = shift;
  my $tag  = shift;
  $tag =~ s/^(\d)/
        $1 eq '0' ? 'zero'
      : $1 eq '1' ? 'one'
      : $1 eq '2' ? 'two'
      : $1 eq '3' ? 'three'
      : $1 eq '4' ? 'four'
      : $1 eq '5' ? 'five'
      : $1 eq '6' ? 'six'
      : $1 eq '7' ? 'seven'
      : $1 eq '8' ? 'eight'
      : $1 eq '9' ? 'nine'
      : $1/ex;
  $tag;
}