File Coverage

blib/lib/MAB2/Record/Base.pm

Criterion	Covered	Total	%
statement	174	202	86.1
branch	50	66	75.7
condition	6	9	66.6
subroutine	15	20	75.0
pod	0	10	0.0
total	245	307	79.8

package MAB2::Record::Base;
our $VERSION = '0.03';

use Encode::MAB2;

=head1 NAME

MAB2::Record::Base - Access an MAB2 record

=head1 SYNOPSIS

 use MAB2::Record::Base;

 # Constructor
 my $mab2raw = "00296nM2.01200024      k001 1000016-1\c^002a19890418".
    "\c^004 20010812\c^028b1000016-1\c^029 HK00158537\c^030 aa1dc".
    "|m\c^036aIT\c^066 |\c^070 9002\c^070aHBZ\c^800 Accademia Na".
    "zionale di San Luca \c^810 Accademia di San Luca
    "ccademia Nazionale di San Luca>\c^850aReale Accademia di San Lu".
    "ca \c^852a45335-3\c^\c]";
 my $mab2 = MAB2::Record::Base->new($mab2raw);
 # $mab2 now blessed into MAB2::Record::gkd because it is a gkd record

 # various representations:
 print $mab2->id;             # just the ID
 print $mab2->readable;       # quite readable
 print $mab2->as_string;      # the raw string we put into it
 print $mab2->dump;           # only useful for debugging the module itself


=head1 DESCRIPTION

C is the common base class for all classes
implementing MAB2 record types:

 MAB2::Record::gkd
 MAB2::Record::lokal
 MAB2::Record::pnd
 MAB2::Record::swd
 MAB2::Record::titel

The constructor C takes a raw MAB2 record as argument and returns
an object which is blessed into one of the five above listed classes.
Some level of proficiency in dealing with MAB2 records is needed for
the user of this module for further processing of the objects. It is
recommended to use C to get acquainted with the raw format
of the created objects.

For illustration purpose, here is the Data::Dumper output of the full
object into which the sample record from the SYNOPSIS section is
transformed:

  $VAR1 = bless( [
                   '...',
                   undef,
                   [
                     {
                       'nicht_benutzt' => [
                                            '      '
                                          ],
                       'datenanfangsadresse' => [
                                                  '00024'
                                                ],
                       'satztyp' => [
                                      'k',
                                      'Koerperschaftsnamensatz (MAB-GKD)'
                                    ],
                       'versionsangabe' => [
                                             'M2.0'
                                           ],
                       'satzstatus' => [
                                         'n',
                                         'neuer Datensatz'
                                       ],
                       'indikatorlaenge' => [
                                              '1'
                                            ],
                       'satzlaenge' => [
                                         '00296'
                                       ],
                       'teilfeldkennungslaenge' => [
                                                     '2'
                                                   ]
                     },
                     [
                       [
                         '001',
                         ' ',
                         '1000016-1',
                         'identifikationsnummer des datensatzes'
                       ],
                       [
                         '002',
                         'a',
                         '19890418',
                         'datum der ersterfassung / fremddatenuebernahme'
                       ],
                       [
                         '004',
                         ' ',
                         '20010812',
                         'erstellungsdatum des austauschsatzes'
                       ],
                       ...
                       [
                         '810',
                         ' ',
                         'Accademia di San Luca
  Luca>',
                         '1. verweisungsform zum namen der koerperschaft'
                       ],
                       [
                         '850',
                         'a',
                         'Reale Accademia di San Luca ',
                         '1. frueherer, zeitweiser oder spaeterer name der koerper
  schaft'
                       ],
                       [
                         '852',
                         'a',
                         '45335-3',
                         'identifikationsnummer des 1. frueheren, zeitweisen oder
  spaeteren namens'
                       ]
                     ]
                   ],
                   '...'
                 ], 'MAB2::Record::gkd' );


Please note that the object contains both the original string in its
own byte oriented encoding and all fields in Unicode. The conversion
is done by the C module.

The normal way of accessing MAB2 records is through the use of either
the C or C class. The C
class binds an MAB2 file to an array and each record in the original
MAB2 file to an array element starting with element 0. The
C class binds to a hash with the MAB2 identifier as the
key.

=head1 Overloading

The tied objects have their stringifier overloaded to the
C method so that

    print $tie[1234];

always prints the record as the unaltered original input record.

=head1 SEE ALSO

C, C, C


=cut

use constant RAW => 0;
use constant INTERNALS => 1; # maybe nonsense: sometimes recno,
                             # sometimes id, whatever the *caller*
                             # wants to have there
use constant STRUCT => 2;
use constant DUMPVALUE => 3;

use strict;
use overload '""' => "as_string";

use Dumpvalue;
our $DV = Dumpvalue->new(unctrl => "quote");

our $DEBUG;
$DEBUG = 1 unless defined $DEBUG;
our $NAMESPACE = "MAB2::Record";
my $KDocs;
my $RDocs;
our(%type2pack) = qw(
                  h titel
                  y titel
                  u titel
                  v titel
                  p pnd
                  t pnd
                  k gkd
                  w gkd
                  r swd
                  s swd
                  x swd
                  l lokal
                  e lokal
                  z lokal
                 );

{
  local $/;
  my $strdocs = ;
  close DATA;
  ($KDocs, $RDocs) = __PACKAGE__->parsedoc($strdocs);
}

{
  my %seen;
  for my $pack (grep !$seen{$_}++, values %type2pack) {
    my $req = "MAB2/Record/$pack.pm";
    require $req;
  }
}

sub parsedoc {
  my $self = shift;
  my $strdocs = shift;

  $strdocs =~ s/ ^ .*?\n ( ?=\d ) //sx; # remove header

  my @docs = $strdocs =~ /\G(\d.*?\n)(?=\d|$)/sgc; # split into subdocuments
  my @kennungdocs;
  my @realrecdocs;
  for my $doc (@docs) {
    $doc =~ s/\s+\z//;
    if ($doc =~ /^\d\d?\s/) {
      push @kennungdocs, [$doc];
    } elsif ($doc =~ /^\d\d\d-/) {
      next;
    } elsif ($doc =~ /^\d--/) {
      next;
    } else {
      push @realrecdocs, [$doc];
    }
  }
  my %seen = ();
  for my $k (0..$#kennungdocs) {
    my $kdoc = $kennungdocs[$k];
    my $doc = $kdoc->[0];
    my($line1,$kexplain) = $doc =~ /(^[^\n]+)(?:\n(.+))?/s;
    # print "line1: $line1\n";
    my($start,$to,$name) = $line1 =~ m{ ^ (\d+) (.{8}) \s+ (.*) }x; #
    my $length = 0;
    if ($to =~ /-\s(\d+)/) {
      $length = $1 - $start;
    }
    $length++;                  # 0->1, 4->5 :-)
    $name = lc $name;
    $name =~ s/[^a-z0-9_]/_/g;
    die if $seen{$name}++;
    # print "start: $start\n";
    # print "name: $name\n";
    # print "kexplain: $kexplain\n" if defined $kexplain;
    my %kexplain;
    if ($kexplain && length $kexplain) {
      my @code = $kexplain =~ /\G\s+([a-z])\s=\s(.*?)(?=\n\s+[a-z]\s=\s|$)/sgc;
      %kexplain = @code;
      for my $e (keys %kexplain) {
        $kexplain{$e} =~ s/^\s+//;
        $kexplain{$e} =~ s/\s+$//;
        $kexplain{$e} =~ s/\s+/ /gs;
        # print "ex $e: $kexplain{$e}\n";
      }
    }
    $kdoc->[1] = $start;
    $kdoc->[2] = $length;
    $kdoc->[3] = $name; # all uppercase hurts
    $kdoc->[4] = \%kexplain;
  }
  %seen = ();
  local $| = 1;
  for my $r (0..$#realrecdocs) {
    my $rdoc = $realrecdocs[$r];
    my $doc = $rdoc->[0];
    # print "========>\n", $doc, "\n<========";

    # very different from above, because "line1" can be more than one line
    my($line1,$rexplain) = $doc =~ /^((?:[^\n]|\n(?!\n))+)(?:\n\n(.+))?/s;
    $line1 =~ s/^\s+//;
    $line1 =~ s/\s+$//;
    $line1 =~ s/\s+/ /g;
    $line1 =~ s/^(\d+)\s+//;
    my($codenr) = $1;
    die "seeing again $codenr???" if $seen{$codenr}++;
    if ($rexplain) {
      # $rexplain =~ s/^\s+Indikator:\s+//g;
      $rexplain =~ s/^\s+//g;
    } else {
      $rexplain = "";
    }
    # print "self[$self]codenr[$codenr]rexplain[$rexplain]\n" if defined $rexplain;
    $rdoc->[1] = $codenr;
    $rdoc->[2] = undef;
    $rdoc->[3] = $line1;
    $rdoc->[4] = $rexplain;  # XXX this needs to become more useful
    # than just plain text
  }
  my $end = $#realrecdocs;
  for my $r (0..$end) {
    next unless $realrecdocs[$r][4] && $realrecdocs[$r][4] eq "...";
    my $after_yadda = $realrecdocs[$r+1][1];
    # print "Found >>...<< in $realrecdocs[$r][1], need to fill upto $after_yadda";

    # Ich will vielleicht eine Zahl in diesem Text hochzaehlen
    if (my($foundnumber) = $realrecdocs[$r][3] =~ /(\d+)/) {
      my $step = 1;
      my $rr3 = $realrecdocs[$r][3];
      if ($rr3 eq "ZUSAETZLICHE ANGABEN ZUR 2. VERWEISUNGSFORM") {
        $step = 2;
      } elsif ($rr3 eq "IDENTIFIKATIONSNUMMER DES 2. FRUEHEREN, ZEITWEISEN ODER SPAETEREN NAMENS DER KOERPERSCHAFT") {
        # gkd
        $step = 3;
      } elsif ($rr3 eq "ERLAEUTERUNGEN ZUR 2. SCHLAGWORTKETTE") {
        $step = 5;
      } elsif ($rr3 eq "KOERPERSCHAFT, BEI DER DIE 2. PERSON BESCHAEFTIGT IST") {
        $step = 4;
      } elsif ($rr3 eq "IDENTIFIKATIONSNUMMER DES KOERPERSCHAFTSNAMENSATZES DER 2. KOERPERSCHAFT") {
        $step = 2;
      } elsif ($rr3 eq "ZUSAETZE ZUM 2. PARALLELSACHTITEL") {
        $step = 4;
      } elsif ($rr3 eq "SACHTITEL DER 2. NE") {
        $step = 6;
      }
      my $before_yadda = $realrecdocs[$r][1];
      for my $offset (1..$step) {
        # warn "offset[$offset]";
        my $first = $before_yadda + $offset;
        my $blueprint = $first - $step;
        # warn "first[$first]blueprint[$blueprint]";
        my $blueprintrec;
        for my $rr (@realrecdocs) {
          # warn "DEBUG: rr1[$rr->[1]]";
          next unless $rr->[1] == $blueprint;
          $blueprintrec = $rr;
          last;
        }
        next unless $blueprintrec;
        die "Unexpected blueprintrec3[$blueprintrec->[3]]"
            unless $blueprintrec->[3] =~ /2/;
        my $sprintf = $blueprintrec->[3];
        $sprintf =~ s/2/%d/;
        my $foundnumber = 2;
        for (my $nr = $first; $nr<$after_yadda; $nr+=$step) {
          push @realrecdocs, [
                              ">>>generated<<<",
                              sprintf("%03d", $nr),
                              undef,
                              sprintf($sprintf,++$foundnumber),
                              undef
                             ];
        }
      }
    } else {
      for my $i ($realrecdocs[$r][1]+1..$after_yadda-1) { # $after_yadda (sans -1) XXX
        push @realrecdocs, [
                            ">>>same as $realrecdocs[$r][1]<<<",
                            sprintf("%03d", $i),
                            undef,
                            $realrecdocs[$r][3],
                            undef
                           ];
      }
    }
  }
  # Now realrecdocs is unsorted, but we prefer it as a hash anyway
  my %realrecdocs;
  for my $rdoc (@realrecdocs) {
    $realrecdocs{$rdoc->[1]} = $rdoc;
  }

  return(\@kennungdocs,\%realrecdocs);
}

sub new {
  my($me,$raw,$key) = @_;
  my $self = bless [$raw,$key], ref $me || $me;
  if ( my $pack = $self->_class() ) { # was $struct->[0]{satztyp}[0]
    bless $self, "MAB2::Record::$pack";
  } else {
    die "Couldn't determine class.";
  }
  $self;
}

sub as_string {
  my($self) = @_;
  $self->[RAW];
}

sub readable {
  my($self) = @_;
  $self->_struct;
  my @m;
  my $base = $self->[STRUCT][0];
  my $cont = $self->[STRUCT][1];
  for my $k (sort keys %$base) {
    my $v;
    if (@{$base->{$k}}>1) {
      $v = sprintf "%s (%s)", @{$base->{$k}};
    } else {
      $v = $base->{$k}[0];
    }
    push @m, sprintf "%-25s: %s", $k, $v;
  }
  for my $sr (@$cont) {
    my $print = sprintf "%3s %1s %s [%s]", map { Dumpvalue::unctrl($_); } @$sr;
    if (0 && $print =~ /[^\040-\177]/) {
      $print .= sprintf("\n=%s\n=%s",
                        Encode::encode("ascii",$sr->[2],Encode::FB_XMLCREF()),
                        $sr->[2],
                       );
    }
    push @m, $print;
  }
  join "\n", @m;
}

sub dump {
  my($self) = @_;
  require Data::Dumper;
  $Data::Dumper::Indent = 1;
  $self->_struct;
  my $x = Data::Dumper::Dumper($self);
  $x =~ s/\[\n\s+/[/g;
  $x =~ s/\n\s+\]/]/g;
  $x =~ s/',\n\s+'/', '/g;
  $x;
}

sub _class {
  my $self = shift;
  my $type = substr($self->[RAW],23,1);
  warn "ALERT: type[$type]" unless exists $type2pack{$type};
  $type2pack{$type};
}

sub id {
  my $self = shift;
  my $id;
  if (0) { # 228 secunden fuer Datei 12 (Keywords) ohne debug
    # my $struct = $self->_struct;
    # $id = $struct->[1][0][0] eq "001" ? $struct->[1][0][2] : die;
  } else { # 67 secs fuer gleiche Arbeit, 852 secs fuer 01
    my $raw = $self->as_string;
    ($id) = substr($raw,28) =~ m/([^\c^\c]]+)/;
  }
  # warn "id[$id]";
  # die Dumpvalue::unctrl("id1[$id1]id2[$id2]") unless $id1 eq $id2;
  $id;
}

sub _struct {
  my $self = shift;
  return $self->[STRUCT] if $self->[STRUCT];
  my $struct;
  if ($DEBUG) {
    $self->[DUMPVALUE] = $DV->stringify($self->[RAW]);
  }
  my $derec = Encode::decode("MAB2",$self->[RAW]);
  pos $derec = 0;
  for my $k (@$KDocs) {
    my $re = "."x$k->[2];
    $struct->[0]{$k->[3]}[0] = $1 if $derec =~ /\G($re)/gc;
    ##########^  0=base/kennungsdocs
    if ($DEBUG) {
      $struct->[0]{$k->[3]}[1] = $k->[4]{$1} if %{$k->[4]};
    }
  }
  warn "ALERT: Datenanfangsadresse nicht 24!" unless
      (my $daa = $struct->[0]{datenanfangsadresse}[0]) == 24;
  #    ^^^^^^^^^

  # avoid using stringdata in numeric context, because it turns on IOK
  # or something and the next print prints "24" instead of "00024"

  # strp = structpart of the record
  my(@strp) = $derec =~ / \G (\d\d\d) (.) ([^\c^]+) (?: \c] | \c^ )/xgc; #
  my(@str);
  while (@strp) {
    die "Invalid strp" unless @strp >=3;
    my $str = [ splice @strp, 0, 3 ];
    if ($DEBUG) {
      # die Bezeichnung des Feldes im "real" Record. Da dort alles
      # Uppercase ist, muessen wir lc nehmen, sonst erschlaegt uns das
      $str->[3] = $str->[0] ? lc $self->segmentname($str->[0]) : "UNDEF";
    }
    push @str, $str;
  }
  $struct->[1] = \@str;
  $self->[STRUCT] = $struct;
}

sub segmentname {
  my $self = shift;
  my $rec = shift;
  $RDocs->{$rec}[3];
}

sub subrecords {
  my($self) = shift;
  $self->_struct;
  @{$self->[STRUCT][1]};
}

sub subrecords_ref {
  my($self) = shift;
  $self->_struct;
  $self->[STRUCT][1];
}

sub date_004 {
  my($self) = @_;
  my $sr = $self->subrecords_ref;
  for my $i (0..$#$sr) {
    next unless $sr->[$i][0] eq "004";
    return $sr->[$i][2];
  }
}

1;

# segm000.txt
__DATA__