File Coverage

blib/lib/WARC/Index/File/CDX.pm

Criterion	Covered	Total	%
statement	124	124	100.0
branch	53	54	98.1
condition	11	12	100.0
subroutine	15	15	100.0
pod	5	5	100.0
total	208	210	99.5

package WARC::Index::File::CDX;					# -*- CPerl -*-

use strict;
use warnings;

require WARC::Index;
our @ISA = qw(WARC::Index);

require WARC; *WARC::Index::File::CDX::VERSION = \$WARC::VERSION;

use Carp;
use File::Spec;
use Fcntl 'SEEK_SET';
require File::Spec::Unix;

require WARC::Date;
require WARC::Index::File::CDX::Entry;
require WARC::Volume;

WARC::Index::register(filename => qr/[.]cdx$/);

our %CDX_Field_Index_Key_Map =
  (a => 'url', b => 'time', u => 'record_id');

our %CDX_Import_Map =
  (time => sub {
     my $cdx_date = shift;
     croak "invalid CDX datestamp"
       unless $cdx_date =~ m/^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/;
     return WARC::Date->from_string(sprintf('%04d-%02d-%02dT%02d:%02d:%02dZ',
					       $1,  $2,  $3,  $4,  $5,  $6))},
  );

# This implementation uses a hash as the underlying structure.
#  Keys defined by this class:
#
#   cdx_file
#	file name of CDX file
#   delimiter
#	delimiter character used in CDX file
#   fields
#	array of CDX field codes, in order
#   field_index
#	hash mapping CDX field code letter => position
#   key_index
#	hash mapping WARC::Index search keys => position
#   volumes
#	hash mapping WARC file names => WARC::Volume objects

sub _dbg_dump {
  my $self = shift;

  my $out = __PACKAGE__ . "\n in " . $self->{cdx_file} . "\n";
  $out .= sprintf ' delimiter ASCII %d/%d  ',
    (ord $self->{delimiter})/16, (ord $self->{delimiter})%16;
  $out .= ' '.join(' ', 'CDX', @{$self->{fields}})."\n";

  return $out;
}

sub attach {
  my $class = shift;
  my $cdx_file = shift;

  local $/ = "\012";	# ASCII 0/10 LF
  open my $cdx, '<', $cdx_file or croak "$cdx_file: $!";
  binmode $cdx, ':raw';

  my $header = <$cdx>;
  croak "could not read CDX header line from $cdx_file: $!"
    unless defined $header;

  chomp $header;
  my $delimiter = substr $header, 0, 1;
  croak "no CDX marker found in $cdx_file"
    unless 'CDX' eq substr $header, 1, 3
      and $delimiter eq substr $header, 4, 1;

  my @fields = split /\Q$delimiter/, substr $header, 5;

  my %field_index = map {$fields[$_] => $_} 0 .. $#fields;
  my %key_index =
    map {$CDX_Field_Index_Key_Map{$fields[$_]} => $_}
      grep defined $CDX_Field_Index_Key_Map{$fields[$_]}, 0 .. $#fields;

  croak "CDX file $cdx_file does not index WARC file name"
    unless defined $field_index{g};
  croak "CDX file $cdx_file does not index record offset"
    unless defined $field_index{v} or defined $field_index{V};

  bless {cdx_file => $cdx_file, delimiter => $delimiter, fields => \@fields,
	 field_index => \%field_index, key_index => \%key_index}, $class
}

sub _get_volume {
  my $self = shift;
  my $name = shift;

  return $self->{volumes}{$name} if defined $self->{volumes}{$name};

  # otherwise...
  my ($vol, $cdx_dirs, $file) = File::Spec->splitpath($self->{cdx_file});
  my @cdx_dirs = File::Spec->splitdir($cdx_dirs);
  my ($wvol, $warc_dirs, $warc_file) = File::Spec::Unix->splitpath($name);
  my @warc_dirs = File::Spec::Unix->splitdir($warc_dirs);
  my $warcfilename =
    File::Spec->catpath($vol, File::Spec->catdir(@cdx_dirs,
						 @warc_dirs), $warc_file);
  return $self->{volumes}{$name} = mount WARC::Volume ($warcfilename);
}

sub _parse_cdx_entry {
  my $self = shift;
  my $pos = shift;
  my $entry = shift;
  # uncoverable condition right
  my $entry_length = $entry && length $entry;

  return undef unless $entry_length;	# as occurs at end-of-file

  chomp $entry;
  my @fields = split /\Q$self->{delimiter}/, $entry;
  my $volname = $fields[$self->{field_index}{g}];
  my %entry =
    ( _index => $self, _entry_offset => $pos, _entry_length => $entry_length,
      _g__volume => $self->_get_volume($volname),
      _Vv__record_offset =>
      $fields[$self->{field_index}{($volname =~ m/[.]w?arc$/ ? 'v' : 'V')}],
      map {$_ => (defined $CDX_Import_Map{$_}
		  ? $CDX_Import_Map{$_}->($fields[$self->{key_index}{$_}])
		  : $fields[$self->{key_index}{$_}])} keys %{$self->{key_index}}
    );

  bless \%entry, (ref $self).'::Entry';
}

sub searchable {
  my $self = shift;
  my $key = shift;

  return defined $self->{key_index}{url} if $key eq 'url_prefix';
  return defined $self->{key_index}{$key};
}

sub _search_all {
  my $self = shift;

  local $/ = "\012";	# ASCII 0/10 LF
  my @results = ();

  open my $cdx, '<', $self->{cdx_file} or croak "$self->{cdx_file}: $!";
  binmode $cdx, ':raw';

  my $header = <$cdx>;	# skip header to reach first entry
  my $offset = tell $cdx;
  my $entry = $self->_parse_cdx_entry($offset, scalar <$cdx>);
  return () unless defined $entry->distance(@_);

  while (defined $entry) {
    push @results, $entry unless 0 > $entry->distance(@_);
    $offset = tell $cdx;	# ... and advance ...
    $entry = $self->_parse_cdx_entry($offset, scalar <$cdx>);
  }

  return @results;
}

sub _search_best_match {
  my $self = shift;

  local $/ = "\012";	# ASCII 0/10 LF
  my $result = undef;
  my $result_distance = -1;

  open my $cdx, '<', $self->{cdx_file} or croak "$self->{cdx_file}: $!";
  binmode $cdx, ':raw';

  my $header = <$cdx>;	# skip header to reach first entry
  my $offset = tell $cdx;
  my $entry = $self->_parse_cdx_entry($offset, scalar <$cdx>);
  return undef unless defined $entry->distance(@_);

  while (defined $entry) {
    my $distance = $entry->distance(@_);
    unless (0 > $distance) {
      if ($result_distance < 0			# first match found
	  or $distance < $result_distance)	# or better match found
	{ $result = $entry; $result_distance = $distance }
    }
    return $result if $result_distance == 0;	# no better match possible
    $offset = tell $cdx;	# ... and advance ...
    $entry = $self->_parse_cdx_entry($offset, scalar <$cdx>);
  }

  return $result;
}

sub search {
  my $self = shift;

  unless (defined wantarray)
    { carp "calling 'search' method in void context"; return }

  croak "no arguments given to 'search' method"
    unless scalar @_;
  croak "odd number of arguments given to 'search' method"
    if scalar @_ % 2;

  if (wantarray) { return $self->_search_all(@_) }
  else		 { return $self->_search_best_match(@_) }
}

sub first_entry {
  my $self = shift;

  local $/ = "\012";	# ASCII 0/10 LF

  open my $cdx, '<', $self->{cdx_file} or croak "$self->{cdx_file}: $!";
  binmode $cdx, ':raw';

  my $header = <$cdx>;	# skip header to reach first entry
  my $offset = tell $cdx;
  return $self->_parse_cdx_entry($offset, scalar <$cdx>);
}

sub entry_at {
  my $self = shift;
  my $offset = shift;

  local $/ = "\012";	# ASCII 0/10 LF

  open my $cdx, '<', $self->{cdx_file} or croak "$self->{cdx_file}: $!";
  binmode $cdx, ':raw';

  # one octet before requested position must be an end-of-line marker
  seek $cdx, $offset - 1, SEEK_SET or croak "seek $self->{cdx_file}: $!";
  my $eol; defined(read $cdx, $eol, 1) or croak "read $self->{cdx_file}: $!";
  croak "offset $offset in $self->{cdx_file} not a record boundary"
    unless $eol eq $/;

  return $self->_parse_cdx_entry($offset, scalar <$cdx>);
}

1;
__END__