File Coverage

blib/lib/XML/Filter/Sort.pm

Criterion	Covered	Total	%
statement	147	202	72.7
branch	49	92	53.2
condition	7	25	28.0
subroutine	15	20	75.0
pod	9	15	60.0
total	227	354	64.1

package XML::Filter::Sort;

use strict;
use Carp;

require XML::SAX::Base;


##############################################################################
#                     G L O B A L   V A R I A B L E S
##############################################################################

use vars qw($VERSION @ISA);

$VERSION = '1.01';

@ISA = qw(XML::SAX::Base);

use constant DEFAULT_BUFFER_MANAGER_CLASS => 'XML::Filter::Sort::BufferMgr';
use constant DISK_BUFFER_MANAGER_CLASS    => 'XML::Filter::Sort::DiskBufferMgr';


##############################################################################
#                             M E T H O D S
##############################################################################

##############################################################################
# Contructor: new()
#
# Set defaults for required properties and parse 'Keys' value from scalar to
# a list of lists if required.
#

sub new {
  my $proto = shift;

  my $class = ref($proto) || $proto;
  my $self = $class->SUPER::new(@_);

  croak "You must set the 'Record' option" unless($self->{Record});


  # Select memory vs disk buffering (or custom buffering class)

  if($self->{TempDir}) {
    $self->{BufferManagerClass} ||= DISK_BUFFER_MANAGER_CLASS;
  }
  unless($self->{BufferManagerClass}) {
    $self->{BufferManagerClass} = DEFAULT_BUFFER_MANAGER_CLASS;
  }
  my $mod_path = join('/', split(/::/, $self->{BufferManagerClass} . '.pm'));
  require $mod_path;


  # Organise sort keys into a list of 3-element lists

  $self->{Keys} = '.' unless($self->{Keys});
  unless(ref($self->{Keys})) {     # parse scalar to a list of lists
    my @keys = ();
    foreach (split(/[\r\n;]/, $self->{Keys})) {
      next unless(/\S/);
      s/,/ /g;
      my @key = /(\S+)/g;
      push @keys, \@key;
    }
    $self->{Keys} = \@keys;
  }
  foreach my $key (@{$self->{Keys}}) {
    croak "Keys must be a list of lists" unless(ref($key));
    $key->[1] ||= 'alpha';
    unless(ref($key->[1])) {
      $key->[1] = ($key->[1] =~ /^n/i ? 'num'  : 'alpha');
    }
    $key->[2] = ($key->[2] && $key->[2] =~ /^d/i ? 'desc' : 'asc');
  }


  # Precompile a closure to match each key

  if($self->{BufferManagerClass}->can('compile_matches')) {
    $self->{_match_subs} = [
      $self->{BufferManagerClass}->compile_matches($self->{Keys})
    ];
  }


  # Build up a list of options to be passed to buffers/buffer managers

  if($self->{MaxMem}) {
    if(uc($self->{MaxMem}) =~ /^\s*(\d+)(K|M)?$/) {
      $self->{MaxMem} = $1;
      $self->{MaxMem} *= 1024        if($2 and $2 eq 'K');
      $self->{MaxMem} *= 1024 * 1024 if($2 and $2 eq 'M');
    }
    else {
      croak "Illegal value for 'MaxMem': $self->{MaxMem}";
    }
  }

  $self->{BufferOpts} = {
    Keys              => [ @{$self->{Keys}} ],
    _match_subs       => $self->{_match_subs},
    IgnoreCase        => $self->{IgnoreCase},
    NormaliseKeySpace => $self->{NormaliseKeySpace} ||
                         $self->{NormalizeKeySpace},
    KeyFilterSub      => $self->{KeyFilterSub},
    TempDir           => $self->{TempDir},
    MaxMem            => $self->{MaxMem},
  };


  return(bless($self,$class));
}


##############################################################################
# Method: start_document()
#
# Initialise handler structures and propagate event.
#

sub start_document {
  my $self = shift;


  # Track path to current element

  $self->{path_name} = [];
  $self->{path_ns}   = [];
  $self->{prefixes}  = [];
  $self->{depth}     = 0;


  # Initialise pattern matching for record elements

  my @parts = split(/\//, $self->{Record});
  if($parts[0] eq '') {
    $self->{abs_match} = 1;
    shift @parts;
  }
  else {
    $self->{abs_match} = 0;
  }
  $self->{rec_path_name} = [ ];
  $self->{rec_path_ns}   = [ ];
  foreach (@parts) {
    if(/^(?:\{(.*?)\})?(.*)$/) {
      push @{$self->{rec_path_name}}, $2;
      push @{$self->{rec_path_ns}},   $1;
    }
  }
  $self->{required_depth} = @parts;

  $self->SUPER::start_document(@_);
}


##############################################################################
# Method: start_element()
#
# Marshalls events either to the default handler or to a record buffer.
# Also handles the creation of buffers as record elements are encountered.
# Two extra considerations increase complexity: contiguous character events
# are being merged; and each 'record' element takes it's leading whitespace
# with it.
#

sub start_element {
  my $self    = shift;
  my $element = shift;


  return $self->start_prefixed_element($element) if($self->{passthru});

  # Add this element's details to the end of the list (for recognising records)

  push @{$self->{path_name}}, $element->{LocalName};
  push @{$self->{path_ns}},
    (defined($element->{NamespaceURI}) ? $element->{NamespaceURI} : '');
  $self->{depth}++;


  # Do we have a record buffer open?

  if($self->{buffer}) {
    $self->{record_depth}++;
    $self->send_characters();
    $self->{buffer}->start_element($element);
    return;
  }


  # Any leading (non-whitespace) text?

  if($self->{buffered_text}) {
    $self->flush_buffers();
    $self->send_characters();
  }


  # Is this a record?

  if($self->match_record()) {

    $self->{record_depth} = 1;

    unless($self->{buffer_manager}) {
      $self->{buffer_manager} = $self->{BufferManagerClass}->new(
	%{$self->{BufferOpts}}
      );
    }

    $self->{buffer} = $self->{buffer_manager}->new_buffer();

    $self->send_characters();
    $self->{buffer}->start_element($element);
    return;
  }


  # Send buffered data and this event to the downstream handler

  $self->flush_buffers();
  $self->send_characters();
  $self->start_prefixed_element($element);
}


##############################################################################
# Method: end_element()
#
# Marshalls events either to the default handler or to a record buffer.
# Also handles closing the current buffer object as the end of a record is
# encountered.
#

sub end_element {
  my $self    = shift;
  my $element = shift;


  return $self->end_prefixed_element($element) if($self->{passthru});


  pop @{$self->{path_name}};
  pop @{$self->{path_ns}};
  $self->{depth}--;


  # Do we have a record buffer open?

  if($self->{buffer}) {
    $self->send_characters();
    $self->{buffer}->end_element($element);
    $self->{record_depth}--;
    if($self->{record_depth} == 0) {
      $self->{buffer_manager}->close_buffer($self->{buffer});
      delete($self->{buffer});
    }
    return;
  }

  # No, then do we have any complete buffered records?

  $self->flush_buffers();

  $self->send_characters();
  $self->end_prefixed_element($element);

}


##############################################################################
# Method: characters()
#
# Buffer character events for two reasons:
# - to merge contiguous character data (simplifies pattern matching logic)
# - to enable 'record' elements to take their leading whitespace with them
#

sub characters {
  my $self = shift;
  my $char = shift;

  return $self->SUPER::characters($char) if($self->{passthru});

  unless(exists($self->{char_buffer})) {
    $self->{char_buffer} = '';
    $self->{buffered_text} = 0;
  }
  $self->{char_buffer} .= $char->{Data};
  $self->{buffered_text} |= ($char->{Data} =~ /\S/);
}


##############################################################################
# Method: ignorable_whitespace()
#
# Discard ignorable whitespace if required, otherwise send it on as
# character events.
#
# Yes, this is a dirty hack, but it's getting late and I haven't got a
# parser that generates them anyway.
#

sub ignorable_whitespace {
  my $self = shift;
  my $char = shift;

  $self->characters($char) unless($self->{SkipIgnorableWS});
}


##############################################################################
# Method: start_prefix_mapping()
# Method: end_prefix_mapping()
#
# Suppress these events as they need to remain synchronised with the
# start/end_element events (which may be re-ordered).  Replacement events are
# generated by start/end_prefixed_element().
#

sub start_prefix_mapping { }
sub end_prefix_mapping   { }


##############################################################################
# Method: start_prefixed_element()
#
# Sends a start_element() event to the downstream handler, but re-generates
# start_prefix_mapping() events first.
#

sub start_prefixed_element {
  my $self = shift;
  my $elem = shift;

  my @prefixes;
  foreach my $attr (values %{$elem->{Attributes}}) {
    if($attr->{Name}  and  $attr->{Name} eq 'xmlns') {
      unshift @prefixes, '', $attr->{Value};
    }
    elsif($attr->{Prefix}  and  $attr->{Prefix} eq 'xmlns') {
      push @prefixes, $attr->{LocalName}, $attr->{Value};
    }
  }

  if(@prefixes) {
    push @{$self->{prefixes}}, [ @prefixes ];
    while(@prefixes) {
      my $prefix = shift @prefixes;
      my $uri    = shift @prefixes;
      $self->SUPER::start_prefix_mapping({
	Prefix       => $prefix,
	NamespaceURI => $uri,
      });
    }
  }
  else {
    push @{$self->{prefixes}}, undef;
  }

  $self->SUPER::start_element($elem);
}


##############################################################################
# Method: end_prefixed_element()
#
# Sends an end_element() event to the downstream handler, and follows it with
# re-generated end_prefix_mapping() events.
#

sub end_prefixed_element {
  my $self = shift;
  my $elem = shift;

  $self->SUPER::end_element($elem);

  my $prefixes = pop @{$self->{prefixes}};

  if($prefixes) {
    while(@$prefixes) {
      my $prefix = shift @$prefixes;
      my $uri    = shift @$prefixes;
      $self->SUPER::end_prefix_mapping({
	Prefix       => $prefix,
	NamespaceURI => $uri,
      });
    }
  }

}


##############################################################################
# Method: comment()
#
# Send comments to buffer if we have one open, otherwise flush any buffered
# records before propagating event.
#

sub comment {
  my $self    = shift;
  my $comment = shift;

  return $self->SUPER::comment($comment) if($self->{passthru});

  if($self->{buffer}) {
    $self->send_characters();
    $self->{buffer}->comment($comment);
    return;
  }

  $self->flush_buffers();
  $self->send_characters();
  $self->SUPER::comment($comment);
}


##############################################################################
# Method: processing_instruction()
#
# Send PIs to downstream handler but flush buffered records & text first.
#

sub processing_instruction {
  my $self = shift;
  my $pi   = shift;

  return $self->SUPER::processing_instruction($pi) if($self->{passthru});

  if($self->{buffer}) {
    $self->send_characters();
    $self->{buffer}->processing_instruction($pi);
    return;
  }

  $self->flush_buffers();
  $self->send_characters();
  $self->SUPER::processing_instruction($pi);
}


##############################################################################
# Method: send_characters()
#
# Contiguous character events are concatenated into a buffer.  This routine
# sends the buffer contents to the open buffer if there is one, or the
# downstream handler otherwise.
#

sub send_characters {
  my $self    = shift;

  return unless(exists $self->{char_buffer});
  if($self->{buffer}) {
    $self->{buffer}->characters({Data => $self->{char_buffer}});
  }
  else {
    $self->SUPER::characters({Data => $self->{char_buffer}});
  }
  delete($self->{char_buffer});
  delete($self->{buffered_text});
}


##############################################################################
# Method: flush_buffers()
#
# If there are any records buffered, sends them to the downstream handler.
#

sub flush_buffers {
  my $self    = shift;

  if($self->{buffer_manager}) {
    $self->{passthru} = 1;
    $self->{buffer_manager}->to_sax($self);
    $self->{passthru} = 0;
    delete($self->{buffer_manager});
  }
}


##############################################################################
# Method: match_record()
#
# Returns true if the path to the current element matches the 'Record' option
# passed to the constructor.
#

sub match_record {
  my $self = shift;


  if($self->{abs_match}) {
    return if($self->{depth} != $self->{required_depth});
  }
  else {
    return if($self->{depth} < $self->{required_depth});
  }

  foreach my $i (1..$self->{required_depth}) {
    return unless($self->{path_name}->[-$i] eq $self->{rec_path_name}->[-$i]);
    if(defined($self->{rec_path_ns}->[-$i])) {
      return unless($self->{path_ns}->[-$i] eq $self->{rec_path_ns}->[-$i]);
    }
  }

  return(1);
}


1;
__END__