File Coverage

blib/lib/XML/TiePYX.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package XML::TiePYX;
use strict;
use vars qw($VERSION);
use Carp;
use IO::File;
use XML::Parser;

use base 'Tie::Handle';

$VERSION = '0.05';

sub TIEHANDLE {
  my $class=shift;
  my $source=shift;
  my %args=(Condense=>1,Validating=>0,Latin=>0,Catalog=>0,@_);
  my $self={output=>[],EOF=>0,offset=>0,in_tag=>0};
  my $parser;
  $self->{condense}=delete $args{Condense};
  $self->{latin}=delete $args{Latin};
  my $catname=delete $args{Catalog};
  if ($args{Validating}) {
    require XML::Checker::Parser;
    $parser=XML::Checker::Parser->new(%args) or croak "$!";
  } else {
    $parser=XML::Parser->new(%args) or croak "$!";
  }
  $parser->setHandlers(Start=>\&start,End=>\&end,Char=>\&char,Proc=>\&proc);
  if ($catname) {
    require XML::Catalog;
    my $catalog=XML::Catalog->new($catname) or croak "$!";
    $parser->setHandlers(ExternEnt=>$catalog->get_handler($parser));
  }
  $self->{parser}=$parser->parse_start(TiePYX=>$self) or croak "$!";
  if (ref($source) eq 'SCALAR') {
    $self->{src}=$source;
    $self->{src_offset}=0;
  }
  elsif (ref($source)=~/^IO:|^GLOB$/) {
    $self->{srcfile}=$source;
  }
  else {
    $self->{srcfile}=IO::File->new($source) or return undef;
    $self->{opened}=1;
  }
  bless $self,$class;
}

sub CLOSE {
  my $self=shift;
  $self->{srcfile}->close() if $self->{opened};
  $self->{parser}=undef;
}

sub DESTROY {
  my $self=shift;
  $self->{parser}=undef;
}

sub READLINE {
  my $self=shift;
  $self->parsechunks(wantarray());
  if (wantarray()) {
    if (@{$self->{output}}) {
      $self->{output}[0]=substr($self->{output}[0],$self->{offset});
      return @{$self->{output}};
    }
    else {
      return undef;
    }
  }
  my $buf=substr((shift @{$self->{output}}) || '',$self->{offset});
  $self->{offset}=0;
  return $buf||undef;
}

sub READ {
  my ($self,$data,$length,$offset)=@_;
  my $buf;
  while (length($buf)<$length && !$self->{EOF}) {
    $self->parsechunks(0);
    my $t=$self->{output}[0] or last;
    my $t1=$length-length($buf);
    if ($t1>=length(substr($t,$self->{offset}))) {
      $buf.=$t;
      shift @{$self->{output}};
      $self->{offset}=0;
    }
    else {
      $buf.=substr($t,$self->{offset},$t1);
      $self->{offset}+=$t1;
    }
  }
  substr($_[1],$offset||0,$length)=$buf;
  return length($buf);
}

sub PRINTF {
  my $self=shift;
  my $fmt=shift;
  my $buf=sprintf($fmt,@_);
  $self->WRITE($buf,length($buf),0);
}

sub WRITE {
  my ($self,$data)=@_;
  if ($self->{latin} && $self->{offset}==0) {
    $self->output(qq{\n});
  }
  ++$self->{offset};
  foreach my $line (split /\n/,$data) {
    my $type=substr($line,0,1);
    $line=substr($line,1);
    if ($type eq 'A') {
      my ($attr,$val)=split(/\s+/,$line,2);
      my $quote='"';
      $self->output(" $attr=",0);
      if ($val=~tr/"//) {
        $quote="'";
        $val=~s/'/'/g if $val=~tr/'//;
      }
      $self->output("${quote}$val$quote",1);
      next;
    }
    if ($self->{in_tag}) {
      $self->output('>',0);
      $self->{in_tag}=0;
    }
    if ($type eq '(') {
      $self->output("<$line",0);
      $self->{in_tag}=1;
    }
    elsif ($type eq ')') {
      $self->output("",0);
    }
    elsif ($type eq '-') {
      $self->output($line,1);
    }
    elsif ($type eq '?') {
      $self->output('
      $self->output($line,1);
      $self->output('?>',0);
    }
  }
}

sub output {
  my ($self,$line,$encode)=@_;
  my %enc=('&'=>'&','<'=>'<','>'=>'>');
  my $enc=join '',keys %enc;
  $line=~s/\\n/\n/g;
  $line=~s/([$enc])(?!apos)/$enc{$1}/go if $encode;
  if (exists $self->{src}) {
    ${$self->{src}}.=$line;
  }
  else {
    $self->{srcfile}->print($line);
  }
}

sub parsechunks {
  my ($self,$goforit)=@_;
  my $buf;
  while ((!@{$self->{output}}
         || (substr($self->{output}[-1],0,1) eq '-' && $self->{condense})
         || $goforit)
         && !$self->{EOF}) {
    if (exists $self->{src}) {
      $buf=substr(${$self->{src}},$self->{src_offset},4096);
      $self->{src_offset}+=4096;
    }
    else {
      read($self->{srcfile},$buf,4096);
    }
    if (length($buf)==0) {
      $self->{EOF}=1;
      $self->{parser}->parse_done();
    }
    else {
      $self->{parser}->parse_more($buf);
    }
  }
}

sub start {
  my ($parser,$element,@attrs)=@_;
  my $self=$parser->{TiePYX};
  if (@{$self->{output}} && substr($self->{output}[-1],0,1) eq '-' && $self->{condense}) {
    $self->{output}[-1].="\n";
  }
  push @{$self->{output}},'('.$self->nsname($element)."\n";
  while (@attrs) {
    my ($name,$val)=(shift @attrs,shift @attrs);
    push @{$self->{output}},'A'.$self->nsname($name).' '.$self->encode($val)."\n";
  }
}

sub end {
  my ($parser,$element)=@_;
  my $self=$parser->{TiePYX};
  if (@{$self->{output}} && substr($self->{output}[-1],0,1) eq '-' && $self->{condense}) {
    $self->{output}[-1].="\n";
  }
  push @{$self->{output}},')'.$self->nsname($element)."\n";
}

sub char {
  my ($parser,$text)=@_;
  my $self=$parser->{TiePYX};
  if (@{$self->{output}} && substr($self->{output}[-1],0,1) eq '-' && $self->{condense}) {
    $self->{output}[-1].=$self->encode($text);
  }
  else {
    push @{$self->{output}},'-'.$self->encode($text).($self->{condense}?'':"\n");
  }
}

sub proc {
  my ($parser,$target,$value)=@_;
  my $self=$parser->{TiePYX};
  if (@{$self->{output}} && substr($self->{output}[-1],0,1) eq '-' && $self->{condense}) {
    $self->{output}[-1].="\n";
  }
  push @{$self->{output}},"?$target ".$self->encode($value)."\n";
}

sub nsname {
  my ($self,$name)=@_;
  my $parser=$self->{parser};
  if ($parser->{Namespaces}) {
    my $ns=$parser->namespace($name)||'';
    $name="{$ns}".$name;
  }
  return $self->encode($name);
}

sub encode {
  my ($self,$text)=@_;
  $text=~s/\x0a/\\n/g;
  if ($self->{latin}) {
    $text=~s{([\xc0-\xc3])(.)}{
      my $hi = ord($1);
      my $lo = ord($2);
      chr((($hi & 0x03) <<6) | ($lo & 0x3F))
     }ge;
  }
  return $text;
}

1;
__END__