C4/Record.pm

   1 package C4::Record;
   2 #
   3 # Copyright 2006 (C) LibLime
   4 # Joshua Ferraro <jmf@liblime.com>
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 2 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along with
  18 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  19 # Suite 330, Boston, MA  02111-1307 USA
  20 #
  21 # $Id$
  22 #
  23 use strict; use warnings; #FIXME: turn off warnings before release
  24
  25 # please specify in which methods a given module is used
  26 use MARC::Record; # marc2marcxml, marcxml2marc, html2marc, changeEncoding
  27 use MARC::File::XML; # marc2marcxml, marcxml2marc, html2marcxml, changeEncoding
  28 use MARC::Crosswalk::DublinCore; # marc2dcxml
  29 use Unicode::Normalize; # _entity_encode
  30
  31 use vars qw($VERSION @ISA @EXPORT);
  32
  33 # set the version for version checking
  34 $VERSION = do { my @v = '$Revision$' =~ /\d+/g;
  35                 shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
  36
  37 @ISA = qw(Exporter);
  38
  39 # only export API methods
  40
  41 @EXPORT = qw(
  42   &marc2marc
  43   &marc2marcxml
  44   &marcxml2marc
  45   &marc2dcxml
  46   &marc2modsxml
  47
  48   &html2marcxml
  49   &html2marc
  50   &changeEncoding
  51 );
  52
  53 =head1 NAME
  54
  55 C4::Record - MARC, MARCXML, DC, MODS, XML, etc. Record Management Functions and API
  56
  57 =head1 SYNOPSIS
  58
  59 New in Koha 3.x. This module handles all record-related management functions.
  60
  61 =head1 API (EXPORTED FUNCTIONS)
  62
  63 =head2 marc2marc - Convert from one flavour of ISO-2709 to another
  64
  65 =over 4
  66
  67 my ($error,$newmarc) = marc2marc($marc,$to_flavour,$from_flavour,$encoding);
  68
  69 Returns an ISO-2709 scalar
  70
  71 =back
  72
  73 =cut
  74
  75 sub marc2marc {
  76         my ($marc,$to_flavour,$from_flavour,$encoding) = @_;
  77         my $error = "Feature not yet implemented\n";
  78         return ($error,$marc);
  79 }
  80
  81 =head2 marc2marcxml - Convert from ISO-2709 to MARCXML
  82
  83 =over 4
  84
  85 my ($error,$marcxml) = marc2marcxml($marc,$encoding,$flavour);
  86
  87 Returns a MARCXML scalar
  88
  89 =over 2
  90
  91 C<$marc> - an ISO-2709 scalar or MARC::Record object
  92
  93 C<$encoding> - UTF-8 or MARC-8 [UTF-8]
  94
  95 C<$flavour> - MARC21 or UNIMARC
  96
  97 C<$dont_entity_encode> - a flag that instructs marc2marcxml not to entity encode the xml before returning (optional)
  98
  99 =back
 100
 101 =back
 102
 103 =cut
 104
 105 sub marc2marcxml {
 106         my ($marc,$encoding,$flavour,$dont_entity_encode) = @_;
 107         my $error; # the error string
 108         my $marcxml; # the final MARCXML scalar
 109
 110         # test if it's already a MARC::Record object, if not, make it one
 111         my $marc_record_obj;
 112         if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
 113                 $marc_record_obj = $marc;
 114         } else { # it's not a MARC::Record object, make it one
 115                 eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
 116
 117                 # conversion to MARC::Record object failed, populate $error
 118                 if ($@) { $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR };
 119         }
 120         # only proceed if no errors so far
 121         unless ($error) {
 122
 123                 # check the record for warnings
 124                 my @warnings = $marc_record_obj->warnings();
 125                 if (@warnings) {
 126                         warn "\nWarnings encountered while processing ISO-2709 record with title \"".$marc_record_obj->title()."\":\n";
 127                         foreach my $warn (@warnings) { warn "\t".$warn };
 128                 }
 129                 unless($encoding) {$encoding = "UTF-8"}; # set default encoding
 130                 unless($flavour) {$flavour = C4::Context->preference("marcflavour")}; # set default MARC flavour
 131
 132                 # attempt to convert the record to MARCXML
 133                 eval { $marcxml = $marc_record_obj->as_xml_record($flavour) }; #handle exceptions
 134
 135                 # record creation failed, populate $error
 136                 if ($@) {
 137                         $error .= "Creation of MARCXML failed:".$MARC::File::ERROR;
 138                         $error .= "Additional information:\n";
 139                         my @warnings = $@->warnings();
 140                         foreach my $warn (@warnings) { $error.=$warn."\n" };
 141
 142                 # record creation was successful
 143         } else {
 144
 145                         # check the record for warning flags again (warnings() will be cleared already if there was an error, see above block
 146                         @warnings = $marc_record_obj->warnings();
 147                         if (@warnings) {
 148                                 warn "\nWarnings encountered while processing ISO-2709 record with title \"".$marc_record_obj->title()."\":\n";
 149                                 foreach my $warn (@warnings) { warn "\t".$warn };
 150                         }
 151                 }
 152
 153                 # only proceed if no errors so far
 154                 unless ($error) {
 155
 156                         # entity encode the XML unless instructed not to
 157                 unless ($dont_entity_encode) {
 158                         my ($marcxml_entity_encoded) = _entity_encode($marcxml);
 159                         $marcxml = $marcxml_entity_encoded;
 160                 }
 161                 }
 162         }
 163         # return result to calling program
 164         return ($error,$marcxml);
 165 }
 166
 167 =head2 marcxml2marc - Convert from MARCXML to ISO-2709
 168
 169 =over 4
 170
 171 my ($error,$marc) = marcxml2marc($marcxml,$encoding,$flavour);
 172
 173 Returns an ISO-2709 scalar
 174
 175 =over 2
 176
 177 C<$marcxml> - a MARCXML record
 178
 179 C<$encoding> - UTF-8 or MARC-8 [UTF-8]
 180
 181 C<$flavour> - MARC21 or UNIMARC
 182
 183 =back
 184
 185 =back
 186
 187 =cut
 188
 189 sub marcxml2marc {
 190     my ($marcxml,$encoding,$flavour) = @_;
 191         my $error; # the error string
 192         my $marc; # the final ISO-2709 scalar
 193         unless($encoding) {$encoding = "UTF-8"}; # set the default encoding
 194         unless($flavour) {$flavour = C4::Context->preference("marcflavour")}; # set the default MARC flavour
 195
 196         # attempt to do the conversion
 197         eval { $marc = MARC::Record->new_from_xml($marcxml,$encoding,$flavour) }; # handle exceptions
 198
 199         # record creation failed, populate $error
 200         if ($@) {$error .="\nCreation of MARCXML Record failed: ".$@;
 201                 $error.=$MARC::File::ERROR if ($MARC::File::ERROR);
 202                 };
 203         # return result to calling program
 204         return ($error,$marc);
 205 }
 206
 207 =head2 marc2dcxml - Convert from ISO-2709 to Dublin Core
 208
 209 =over 4
 210
 211 my ($error,$dcxml) = marc2dcxml($marc,$qualified);
 212
 213 Returns a DublinCore::Record object, will eventually return a Dublin Core scalar
 214
 215 FIXME: should return actual XML, not just an object
 216
 217 =over 2
 218
 219 C<$marc> - an ISO-2709 scalar or MARC::Record object
 220
 221 C<$qualified> - specify whether qualified Dublin Core should be used in the input or output [0]
 222
 223 =back
 224
 225 =back
 226
 227 =cut
 228
 229 sub marc2dcxml {
 230         my ($marc,$qualified) = @_;
 231         my $error;
 232     # test if it's already a MARC::Record object, if not, make it one
 233     my $marc_record_obj;
 234     if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
 235         $marc_record_obj = $marc;
 236     } else { # it's not a MARC::Record object, make it one
 237                 eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
 238
 239                 # conversion to MARC::Record object failed, populate $error
 240                 if ($@) {
 241                         $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR;
 242                 }
 243         }
 244         my $crosswalk = MARC::Crosswalk::DublinCore->new;
 245         if ($qualified) {
 246                 $crosswalk = MARC::Crosswalk::DublinCore->new( qualified => 1 );
 247         }
 248         my $dcxml = $crosswalk->as_dublincore($marc_record_obj);
 249         return ($error,$dcxml);
 250 }
 251 =head2 marc2modsxml - Convert from ISO-2709 to MODS
 252
 253 =over 4
 254
 255 my ($error,$modsxml) = marc2modsxml($marc);
 256
 257 Returns a MODS scalar
 258
 259 =back
 260
 261 =cut
 262
 263 sub marc2modsxml {
 264         my ($marc) = @_;
 265         return ("Feature not yet implemented\n");
 266 }
 267 =head2 html2marcxml
 268
 269 =over 4
 270
 271 my ($error,$marcxml) = html2marcxml($tags,$subfields,$values,$indicator,$ind_tag);
 272
 273 Returns a MARCXML scalar
 274
 275 this is used in addbiblio.pl and additem.pl to build the MARCXML record from
 276 the form submission.
 277
 278 FIXME: this could use some better code documentation
 279
 280 =back
 281
 282 =cut
 283
 284 sub html2marcxml {
 285     my ($tags,$subfields,$values,$indicator,$ind_tag) = @_;
 286         my $error;
 287         # add the header info
 288     my $marcxml= MARC::File::XML::header(C4::Context->preference('TemplateEncoding'),C4::Context->preference('marcflavour'));
 289
 290         # some flags used to figure out where in the record we are
 291     my $prevvalue;
 292     my $prevtag=-1;
 293     my $first=1;
 294     my $j = -1;
 295
 296         # handle characters that would cause the parser to choke FIXME: is there a more elegant solution?
 297     for (my $i=0;$i<=@$tags;$i++){
 298                 @$values[$i] =~ s/&/&amp;/g;
 299                 @$values[$i] =~ s/</&lt;/g;
 300                 @$values[$i] =~ s/>/&gt;/g;
 301                 @$values[$i] =~ s/"/&quot;/g;
 302                 @$values[$i] =~ s/'/&apos;/g;
 303
 304                 if ((@$tags[$i] ne $prevtag)){
 305                         $j++ unless (@$tags[$i] eq "");
 306                         #warn "IND:".substr(@$indicator[$j],0,1).substr(@$indicator[$j],1,1)." ".@$tags[$i];
 307                         if (!$first){
 308                                 $marcxml.="</datafield>\n";
 309                                 if ((@$tags[$i] > 10) && (@$values[$i] ne "")){
 310                         my $ind1 = substr(@$indicator[$j],0,1);
 311                                         my $ind2 = substr(@$indicator[$j],1,1);
 312                                         $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
 313                                         $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
 314                                         $first=0;
 315                                 } else {
 316                                         $first=1;
 317                                 }
 318                         } else {
 319                                 if (@$values[$i] ne "") {
 320                                         # handle the leader
 321                                         if (@$tags[$i] eq "000") {
 322                                                 $marcxml.="<leader>@$values[$i]</leader>\n";
 323                                                 $first=1;
 324                                         # rest of the fixed fields
 325                                         } elsif (@$tags[$i] < 010) { #FIXME: <10 was the way it was, there might even be a better way
 326                                                 $marcxml.="<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
 327                                                 $first=1;
 328                                         } else {
 329                                                 my $ind1 = substr(@$indicator[$j],0,1);
 330                                                 my $ind2 = substr(@$indicator[$j],1,1);
 331                                                 $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
 332                                                 $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
 333                                                 $first=0;
 334                                         }
 335                                 }
 336                         }
 337                 } else { # @$tags[$i] eq $prevtag
 338                         if (@$values[$i] eq "") {
 339                         } else {
 340                                 if ($first){
 341                                         my $ind1 = substr(@$indicator[$j],0,1);
 342                                         my $ind2 = substr(@$indicator[$j],1,1);
 343                                         $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
 344                                         $first=0;
 345                                 }
 346                                 $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
 347                         }
 348                 }
 349                 $prevtag = @$tags[$i];
 350         }
 351         $marcxml.= MARC::File::XML::footer();
 352         #warn $marcxml;
 353         return ($error,$marcxml);
 354 }
 355
 356 =head2 html2marc
 357
 358 =over 4
 359
 360 Probably best to avoid using this ... it has some rather striking problems:
 361
 362 =over 2
 363
 364 * saves blank subfields
 365
 366 * subfield order is hardcoded to always start with 'a' for repeatable tags (because it is hardcoded in the addfield routine).
 367
 368 * only possible to specify one set of indicators for each set of tags (ie, one for all the 650s). (because they were stored in a hash with the tag as the key).
 369
 370 * the underlying routines didn't support subfield reordering or subfield repeatability.
 371
 372 =back
 373
 374 I've left it in here because it could be useful if someone took the time to fix it. -- kados
 375
 376 =back
 377
 378 =cut
 379
 380 sub html2marc {
 381     my ($dbh,$rtags,$rsubfields,$rvalues,%indicators) = @_;
 382     my $prevtag = -1;
 383     my $record = MARC::Record->new();
 384 #   my %subfieldlist=();
 385     my $prevvalue; # if tag <10
 386     my $field; # if tag >=10
 387     for (my $i=0; $i< @$rtags; $i++) {
 388         # rebuild MARC::Record
 389 #           warn "0=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ";
 390         if (@$rtags[$i] ne $prevtag) {
 391             if ($prevtag < 10) {
 392                 if ($prevvalue) {
 393                     if (($prevtag ne '000') && ($prevvalue ne "")) {
 394                         $record->add_fields((sprintf "%03s",$prevtag),$prevvalue);
 395                     } elsif ($prevvalue ne ""){
 396                         $record->leader($prevvalue);
 397                     }
 398                 }
 399             } else {
 400                 if (($field) && ($field ne "")) {
 401                     $record->add_fields($field);
 402                 }
 403             }
 404             $indicators{@$rtags[$i]}.='  ';
 405                 # skip blank tags, I hope this works
 406                 if (@$rtags[$i] eq ''){
 407                 $prevtag = @$rtags[$i];
 408                 undef $field;
 409                 next;
 410             }
 411             if (@$rtags[$i] <10) {
 412                 $prevvalue= @$rvalues[$i];
 413                 undef $field;
 414             } else {
 415                 undef $prevvalue;
 416                 if (@$rvalues[$i] eq "") {
 417                 undef $field;
 418                 } else {
 419                 $field = MARC::Field->new( (sprintf "%03s",@$rtags[$i]), substr($indicators{@$rtags[$i]},0,1),substr($indicators{@$rtags[$i]},1,1), @$rsubfields[$i] => @$rvalues[$i]);
 420                 }
 421 #           warn "1=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ".$field->as_formatted;
 422             }
 423             $prevtag = @$rtags[$i];
 424         } else {
 425             if (@$rtags[$i] <10) {
 426                 $prevvalue=@$rvalues[$i];
 427             } else {
 428                 if (length(@$rvalues[$i])>0) {
 429                     $field->add_subfields(@$rsubfields[$i] => @$rvalues[$i]);
 430 #           warn "2=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ".$field->as_formatted;
 431                 }
 432             }
 433             $prevtag= @$rtags[$i];
 434         }
 435     }
 436     #}
 437     # the last has not been included inside the loop... do it now !
 438     #use Data::Dumper;
 439     #warn Dumper($field->{_subfields});
 440     $record->add_fields($field) if (($field) && $field ne "");
 441     #warn "HTML2MARC=".$record->as_formatted;
 442     return $record;
 443 }
 444
 445 =head2 changeEncoding - Change the encoding of a record
 446
 447 =over 4
 448
 449 my ($error, $newrecord) = changeEncoding($record,$format,$flavour,$to_encoding,$from_encoding);
 450
 451 Changes the encoding of a record
 452
 453 =over 2
 454
 455 C<$record> - the record itself can be in ISO-2709, a MARC::Record object, or MARCXML for now (required)
 456
 457 C<$format> - MARC or MARCXML (required)
 458
 459 C<$flavour> - MARC21 or UNIMARC, if MARC21, it will change the leader (optional) [defaults to Koha system preference]
 460
 461 C<$to_encoding> - the encoding you want the record to end up in (optional) [UTF-8]
 462
 463 C<$from_encoding> - the encoding the record is currently in (optional, it will probably be able to tell unless there's a problem with the record)
 464
 465 =back
 466
 467 FIXME: the from_encoding doesn't work yet
 468
 469 FIXME: better handling for UNIMARC, it should allow management of 100 field
 470
 471 FIXME: shouldn't have to convert to and from xml/marc just to change encoding someone needs to re-write MARC::Record's 'encoding' method to actually alter the encoding rather than just changing the leader
 472
 473 =back
 474
 475 =cut
 476
 477 sub changeEncoding {
 478         my ($record,$format,$flavour,$to_encoding,$from_encoding) = @_;
 479         my $newrecord;
 480         my $error;
 481         unless($flavour) {$flavour = C4::Context->preference("marcflavour")};
 482         unless($to_encoding) {$to_encoding = "UTF-8"};
 483
 484         # ISO-2709 Record (MARC21 or UNIMARC)
 485         if (lc($format) =~ /^marc$/o) {
 486                 # if we're converting encoding of an ISO2709 file, we need to roundtrip through XML
 487                 #       because MARC::Record doesn't directly provide us with an encoding method
 488                 #       It's definitely less than idea and should be fixed eventually - kados
 489                 my $marcxml; # temporary storage of MARCXML scalar
 490                 ($error,$marcxml) = marc2marcxml($record,$to_encoding,$flavour);
 491                 unless ($error) {
 492                         ($error,$newrecord) = marcxml2marc($marcxml,$to_encoding,$flavour);
 493                 }
 494
 495         # MARCXML Record
 496         } elsif (lc($format) =~ /^marcxml$/o) { # MARCXML Record
 497                 my $marc;
 498                 ($error,$marc) = marcxml2marc($record,$to_encoding,$flavour);
 499                 unless ($error) {
 500                         ($error,$newrecord) = marc2marcxml($record,$to_encoding,$flavour);
 501                 }
 502         } else {
 503                 $error.="Unsupported record format:".$format;
 504         }
 505         return ($error,$newrecord);
 506 }
 507
 508 =head1 INTERNAL FUNCTIONS
 509
 510 =head2 _entity_encode - Entity-encode an array of strings
 511
 512 =over 4
 513
 514 my ($entity_encoded_string) = _entity_encode($string);
 515
 516 or
 517
 518 my (@entity_encoded_strings) = _entity_encode(@strings);
 519
 520 Entity-encode an array of strings
 521
 522 =back
 523
 524 =cut
 525
 526 sub _entity_encode {
 527         my @strings = @_;
 528         my @strings_entity_encoded;
 529         foreach my $string (@strings) {
 530                 my $nfc_string = NFC($string);
 531                 $nfc_string =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 532                 push @strings_entity_encoded, $nfc_string;
 533         }
 534         return @strings_entity_encoded;
 535 }
 536
 537 END { }       # module clean-up code here (global destructor)
 538 1;
 539 __END__
 540
 541 =back
 542
 543 =head1 AUTHOR
 544
 545 Joshua Ferraro <jmf@liblime.com>
 546
 547 =head1 MODIFICATIONS
 548
 549 # $Id$
 550
 551 =cut