git.rot13.org Git - webpac2/blob - lib/WebPAC/Output/MARC.pm

   1 package WebPAC::Output::MARC;
   2
   3 use warnings;
   4 use strict;
   5
   6 use base qw/WebPAC::Common/;
   7
   8 use MARC::Record;
   9 use MARC::File::XML;
  10 use MARC::Lint;
  11 use Data::Dump qw/dump/;
  12
  13 =head1 NAME
  14
  15 WebPAC::Output::MARC - Create MARC records from C<marc_*> normalisation rules
  16
  17 =head1 VERSION
  18
  19 Version 0.04
  20
  21 =cut
  22
  23 our $VERSION = '0.04';
  24
  25 =head1 SYNOPSIS
  26
  27 Create MARC records from C<marc_*> normalisation rules described in
  28 L<WebPAC::Normalize>.
  29
  30
  31 =head1 FUNCTIONS
  32
  33 =head2 new
  34
  35   my $marc = new WebPAC::Output::MARC(
  36         path => '/path/to/output.marc',
  37         marc_encoding => 'utf-8',
  38         lint => 1,
  39         dump => 0,
  40   )
  41
  42 =cut
  43
  44 sub new {
  45         my $class = shift;
  46         my $self = {@_};
  47         bless($self, $class);
  48
  49         my $log = $self->_get_logger;
  50
  51         if ($self->{lint}) {
  52                 $self->{lint}= new MARC::Lint or
  53                         $log->warn("Can't create MARC::Lint object, linting is disabled");
  54         }
  55
  56         $self->{marc_encoding} ||= 'utf-8';
  57
  58         if (my $path = $self->{path}) {
  59                 open($self->{fh}, '>', $path) ||
  60                         $log->logdie("can't open MARC output $path: $!");
  61                 binmode($self->{fh}, ':utf8');
  62
  63                 $log->info("Creating MARC export file $path", $self->{lint} ? ' (with lint)' : '', " encoding ", $self->{marc_encoding}, "\n");
  64                 if ( $ENV{MARCXML} ) {
  65                         open($self->{fh_marcxml}, '>:utf8', "$path.marcxml");
  66                         print {$self->{fh_marcxml}} qq{<?xml version="1.0" encoding="UTF-8"?>\n<collection>\n};
  67                 }
  68         } else {
  69                 $log->logconfess("new called without path");
  70         }
  71
  72         $self ? return $self : return undef;
  73 }
  74
  75 =head2 add
  76
  77   $marc->add(
  78         id => $mfn,
  79         fields => WebPAC::Normalize::_get_marc_fields(),
  80         leader => WebPAC::Normalize::_get_marc_leader(),
  81         row => $row,
  82   );
  83
  84 C<row> is optional parametar which is used when dumping original row to
  85 error log.
  86
  87 =cut
  88
  89 sub add {
  90         my $self = shift;
  91
  92         my $arg = {@_};
  93
  94         my $log = $self->_get_logger;
  95
  96         $log->logconfess("add needs fields and id arguments")
  97                 unless ($arg->{fields} && defined $arg->{id});
  98
  99         my $marc = new MARC::Record;
 100         $marc->encoding( $self->{marc_encoding} );
 101
 102         my $id = $arg->{id};
 103
 104         $log->logconfess("fields isn't array") unless (ref($arg->{fields}) eq 'ARRAY');
 105
 106         my $fields = $arg->{fields};
 107
 108         $log->debug("original fields = ", sub { dump( $fields ) });
 109
 110         # recode fields to marc_encoding
 111         foreach my $j ( 0 .. $#$fields ) {
 112                 foreach my $i ( 0 .. ( ( $#{$fields->[$j]} - 3 ) / 2 ) ) {
 113                         my $f = $fields->[$j]->[ ($i * 2) + 4 ];
 114                         $fields->[$j]->[ ($i * 2) + 4 ] = $f;
 115                 }
 116         }
 117
 118         # sort fields
 119         @$fields = sort { $a->[0] <=> $b->[0] } @$fields;
 120
 121         $log->debug("recode fields = ", sub { dump( $fields ) });
 122
 123         $marc->add_fields( @$fields );
 124
 125         # tweak leader
 126         if (my $new_l = $arg->{leader}) {
 127
 128                 my $leader = $marc->leader;
 129
 130                 foreach my $o ( sort { $a <=> $b } keys %$new_l ) {
 131                         my $insert = $new_l->{$o};
 132                         $leader = substr($leader, 0, $o) .
 133                                 $insert . substr($leader, $o+length($insert));
 134                 }
 135                 $marc->leader( $leader );
 136         }
 137
 138         if ($self->{lint}) {
 139                 $self->{lint}->check_record( $marc );
 140                 my @w = $self->{lint}->warnings;
 141                 if (@w) {
 142                         $log->error("MARC lint detected warning on record $id\n",
 143                                 "<<<<< Original input row:\n",dump($arg->{row}), "\n",
 144                                 ">>>>> Normalized MARC row: leader: [", $marc->leader(), "]\n", dump( $fields ), "\n",
 145                                 "!!!!! MARC lint warnings:\n",join("\n",@w),"\n"
 146                         );
 147                         map { $self->{_marc_lint_warnings}->{$_}++ } @w;
 148                 }
 149         }
 150
 151         if ($self->{dump}) {
 152                 $log->info("MARC record on record $id\n",
 153                         "<<<<< Original imput row:\n",dump($arg->{row}), "\n",
 154                         ">>>>> Normalized MARC row: leader: [", $marc->leader(), "]\n", dump( $fields ), "\n",
 155                 );
 156         }
 157
 158         print {$self->{fh}} $marc->as_usmarc;
 159
 160         if ( $self->{fh_marcxml} ) {
 161                 my $xml = $marc->as_xml_record;
 162                 $xml =~ s/\Q<?xml version="1.0" encoding="UTF-8"?>\E//;
 163                 print {$self->{fh_marcxml}} $xml;
 164         }
 165 }
 166
 167 =head2 finish
 168
 169 Close MARC output file
 170
 171   $marc->finish;
 172
 173 It will also dump MARC lint warnings summary if called with C<lint>.
 174
 175 =cut
 176
 177 sub finish {
 178         my $self = shift;
 179
 180         my $log = $self->get_logger;
 181
 182         close( $self->{fh} ) or $log->logdie("can't close ", $self->{path}, ": $!");
 183
 184         if ( $self->{fh_marcxml} ) {
 185                 print {$self->{fh_marcxml}} qq{</collection>\n};
 186                 $log->info("MARCXML file size ", -s $self->{fh_marcxml}, " bytes");
 187                 close( $self->{fh_marcxml} );
 188         }
 189         if (my $w = $self->{_marc_lint_warnings}) {
 190                 $log->error("MARC lint warnings summary:\n",
 191                         join ("\n",
 192                                 map { $w->{$_} . "\t" . $_ }
 193                                 sort { $w->{$b} <=> $w->{$a} } keys %$w
 194                         )
 195                 );
 196         }
 197 }
 198
 199 =head1 AUTHOR
 200
 201 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 202
 203 =head1 COPYRIGHT & LICENSE
 204
 205 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 206
 207 This program is free software; you can redistribute it and/or modify it
 208 under the same terms as Perl itself.
 209
 210 =cut
 211
 212 1; # End of WebPAC::Output::MARC