PerlSAX 2.1 locator tests

Hi,

  An experimental module to test PerlSAX 2.1 event location data. The
interface might benefit from some tweaks and I need to come up with a
good name. Specifically it might be good to offer object orientation
to specify entity_lines only once (or rather, whenever an entity is
opened) as well as the locator (as it is constant) and always provide
the diag() message so it can be used from test scripts more easily.

  use strict;
  use warnings;
  
  sub start_element_ok
  {
      my %opts = @_;
  
      return 1 if $opts{char} eq ">"; # literally included
      return 1 if $opts{char} eq ";"; # included through entity ref
      
      $opts{diag}->("'$opts{name}' must end in > or ;");
      return 0;
  }
  
  sub start_dtd_ok
  {
      my %opts = @_;
  
      return 1 if $opts{char} eq "["; # literally included
      return 1 if $opts{char} eq ">"; # included through entity ref
      
      $opts{diag}->("'$opts{name}' must end in [ or >");
      return 0;
  }
  
  sub end_dtd_ok
  {
      my %opts = @_;
  
      return 1 if $opts{char} eq ">"; # included through entity ref
      
      $opts{diag}->("'$opts{name}' must end in >");
      return 0;
  }
  
  sub start_cdata_ok
  {
      my %opts = @_;
  
      return 1 if $opts{char} eq "["; # literally included
      return 1 if $opts{char} eq ";"; # included through entity ref
      
      $opts{diag}->("'$opts{name}' must end in [ or ;");
      return 0;
  }
  
  sub start_entity_ok
  {
      my %opts = @_;
  
      return 1 if $opts{line} == 1 and $opts{colu} == 1;
  
      $opts{diag}->("'$opts{name}' must be at [1,1]");
      return 0;
  }
  
  sub end_entity_ok
  {
      my %opts = @_;
  
      warn "# todo: implement end_entity_ok\n";
  }
  
  sub warning_ok
  {
      my %opts = @_;
      my $exception = $opts{data}{Exception};
      my $l = $opts{loca};
  
      {
          no warnings 'uninitialized';
  
          return 1 if
            $l->{LineNumber}   == $exception->{LineNumber}   and
            $l->{ColumnNumber} == $exception->{ColumnNumber} and
            $l->{PublicId}     eq $exception->{PublicId}     and
            $l->{SystemId}     eq $exception->{SystemId};
      }
      
      $opts{diag}->("'$opts{name}' location must match exception");
      return 0;
  }
  
  sub characters_ok
  {
      my %opts = @_;
  
      my $etext = $opts{data}->{Data};
      return 1 if $opts{text} =~ /($etext|;)$/;
  
      $opts{diag}->("'$opts{name}' must end in '$etext'");
      return 0;
  }
  
  sub attribute_decl_ok
  {
      my %opts = @_;
  
      warn "# todo: implement end_entity_ok\n";
  }
  
  sub skipped_entity_ok
  {
      my %opts = @_;
  
      return 1 if $opts{char} eq ";";
      
      $opts{diag}->("'$opts{name}' must end in ;");
      return 0;
  }
  
  our %handler =
  (
      attribute_decl         => \&attribute_decl_ok,
      characters             => \&characters_ok,
      comment                => \&start_element_ok,
      element_decl           => \&start_element_ok,
      end_cdata              => \&start_element_ok,
      end_document           => \&end_entity_ok,
      end_dtd                => \&end_dtd_ok,
      end_element            => \&start_element_ok,
      end_entity             => \&end_entity_ok,
      end_prefix_mapping     => \&start_element_ok,
      error                  => \&warning_ok,
      external_entity_decl   => \&start_element_ok,
      fatal_error            => \&warning_ok,
      ignorable_whitespace   => \&characters_ok,
      internal_entitiy_decl  => \&start_element_ok,
      notation_decl          => \&start_element_ok,
      processing_instruction => \&start_element_ok,
      resolve_entity         => \&skipped_entity_ok,
      # set_document_locator => \&set_document_locator_ok,
      skipped_entity         => \&skipped_entity_ok,
      start_cdata            => \&start_cdata_ok,
      start_document         => \&start_entity_ok,
      start_dtd              => \&start_dtd_ok,
      start_element          => \&start_element_ok,
      start_entity           => \&start_entity_ok,
      start_prefix_mapping   => \&start_element_ok,
      unparsed_entity_decl   => \&start_element_ok,
      warning                => \&warning_ok,
  );
  
  sub sax_location_ok
  {
      my %opts = @_;
  
      my $docu = $opts{entity_lines};
      my $name = $opts{name};
      my $loca = $opts{locator};
      my $data = $opts{data} || {};
      my $diag = $opts{diag} || sub { };
      
      die "Missing entity_lines argument\n" unless defined $docu;
  
      # auto-magical behavior for undef event name
      ($name) = [caller(1)]->[3] =~ /::([^:]+)$/
        unless defined $name;
        
      if (not exists $handler{$name})
      {
          $diag->("Unknown event '$name'");
          return 0;
      }
      
      if (not defined $loca)
      {
          $diag->("Location must be defined");
          return 0;
      }
      
      # values for set_document_locator implementation defined
      return 1 if ($name eq 'set_document_locator');
  
      my $line = $loca->{LineNumber};
      my $colu = $loca->{ColumnNumber};
      
      if (not defined $line or $line <= 0)
      {
          $diag->("LineNumber must be an integer >= 1");
          return 0;
      }
      
      if (not defined $colu or $colu <= 0)
      {
          $diag->("ColumnNumber must be an integer >= 1");
          return 0;
      }
      
      if (@$docu < $line)
      {
          $diag->("LineNumber must be inside document");
          return 0;
      }
      
      if (length($docu->[$line - 1]) < $colu)
      {
          $diag->("ColumnNumber must be inside document");
          return 0;
      }
  
      my $char = substr($docu->[$line - 1], $colu - 1, 1);
      my $text = substr($docu->[$line - 1], 0, $colu);
  
      return $handler{$name}->
      (
        char => $char, line => $line, name => $name,
        text => $text, colu => $colu, loca => $loca,
        diag => $diag, data => $data, docu => $docu,
      );
  
  }
  
  # Example:
  
  print "ok" if sax_location_ok
  (
    entity_lines => ['<x/>'],
    name         => 'end_element',
    locator      => {LineNumber => 1, ColumnNumber => 3},
    diag         => sub { warn "@_\n" },
  )

regards.

Received on Sunday, 10 October 2004 03:38:34 UTC