File Coverage

blib/lib/XML/Records.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package XML::Records;
use strict;
use vars qw($VERSION);
$VERSION = '0.12';

use base 'XML::TokeParser';

sub new {
  my $class=shift;
  $class=ref $class || $class;
  my $self=$class->SUPER::new(@_);
  $self->{rectypes}=[{}];
  bless $self,$class;
}

sub set_records {
  my $self=shift;
  $self->{rectypes}[-1]={map {$_=>1} @_};
}

sub get_record {
  my $self=shift;
  my ($rec,$rectype);
  if ($self->skip_to(@_)) {
    my $token=$self->get_token();
    $rectype=$token->[1];
    my $t=$self->{noempty};
    $self->{noempty}=1;
    $rec=$self->get_hash($token);
    $self->{noempty}=$t;
  }
  ($rectype,$rec);
}

sub get_hash {
  my ($self,$token)=@_;
  my ($field,$buf,$field_token);
  my $rectype=$token->[1];
  my $nest=0;
  my $h={};
  # treat attributes of record or subrecord as fields
  foreach (keys %{$token->[2]}) {
    $h->{$_}=$token->[2]{$_};
  }
  while ($token=$self->get_token()) {
    my $t=$token->[0];
    if ($t eq 'S') {
      if ($self->{rectypes}[-1]{"-$token->[1]"}) { # record ended by start
        $self->unget_token($token);
        last;
      }
      if ($nest++) { # start tag inside field, get subrecord
        $self->unget_token($token);
        add_hash($h,$field,$self->get_hash($field_token));
        $nest-=2; # we won't see sub-field's or field's end tag
      }
      else {
        $buf="";
        $field=$token->[1];
        $field_token=$token;
      }
    }
    elsif ($t eq 'T') {
      $buf=$token->[1] unless $token->[1] =~ /^\s*$/;
    }
    elsif ($t eq 'E') {
      last if $token->[1] eq $rectype;
      add_hash($h,$field,$buf);
      if (--$nest==0 && keys %{$field_token->[2]}) {
        add_hash($h,$field,{%{$field_token->[2]}});
      }
    }
  }
  $h;
}

sub add_hash {
  my ($h,$field,$val)=@_;
  if (defined $h->{$field}) { # duplicate fields become arrays
    my $t=$h->{$field};
    $t=[$t] unless ref $t eq 'ARRAY';
    push @$t,$val;
    $val=$t;
  }
  $h->{$field}=$val;
}

sub get_simple_tree {
  my $self=shift;
  return undef unless ($self->skip_to(@_));
  my $lists=[];
  my $tree=[];
  my $curlist=$tree;
  my $ecount=0;
  while (my $token=$self->get_token()) {
    my $type=$token->[0];
    if ($type eq 'S') {
      my $newlist=[];
      my $newnode={type=>'e',attrib=>$token->[2],name=>$token->[1],content=>$newlist};
      push @$lists, $curlist;
      push @$curlist,$newnode;
      $curlist=$newlist;
      ++$ecount;
    }
    elsif ($type eq 'E') {
      $curlist=pop @$lists;
      last if --$ecount==0;
    }
    elsif ($type eq 'T') {
      push @$curlist,{type=>'t',content=>$token->[1]};
    }
    elsif ($type eq 'PI') {
      push @$curlist,{type=>'p',target=>$token->[1],content=>$token->[2]};
    }
  }
 $tree->[0];
}

sub drive_SAX {
  my $self=shift;
  my $handler=shift;
  my $wrap=1;
  if (@_ && ref($_[0]) eq 'HASH' && defined $_[0]->{wrap}) {
    $wrap=$_[0]->{wrap};
  }
  return undef unless ($self->skip_to(@_));
  my $ecount=0;
  $handler->start_document({}) if $wrap;
  while (my $token=$self->get_token()) {
    my $type=$token->[0];
    if ($type eq 'S') {
      $handler->start_element({Attributes=>$token->[2],Name=>$token->[1]});
      ++$ecount;
    }
    elsif ($type eq 'E') {
      $handler->end_element({Name=>$token->[1]});
      last if --$ecount==0;
    }
    elsif ($type eq 'T') {
      $handler->characters({Data=>$token->[1]});
    }
    elsif ($type eq 'PI') {
      $handler->processing_instruction({Target=>$token->[1],Data=>$token->[2]});
    }
  }
  $wrap? $handler->end_document({}): 1;
}

sub skip_to {
  my $self=shift;
  my $here=0;
  if (@_ && ref($_[0]) eq 'HASH') {
    my $opts=shift;
    $here ||= $opts->{here};
  }
  my $token;
  push @{$self->{rectypes}},{%{$self->{rectypes}[-1]}};
  $self->set_records(@_) if @_;

  if ($here) { # next non-comment token must be start of record
    my $found=0;
    while (($token=$self->get_token()) && $token->[0] eq 'C') {
      ;
    }
    $found=($token && $token->[0] eq 'S'
            && (!keys(%{$self->{rectypes}[-1]})
                || $self->{rectypes}[-1]{$token->[1]})
           );
    $self->unget_token($token) if $token;
    $token=$found;
  }
  else { # skip to start of record
    while ($token=$self->get_token()) {
      next unless $token->[0] eq 'S';
      next unless !keys(%{$self->{rectypes}[-1]}) || $self->{rectypes}[-1]{$token->[1]};
      $self->unget_token($token);
      last;
    }
  }
  pop @{$self->{rectypes}};
  $token;
}

1;
__END__