Open-ILS/src/support-scripts/marc_export.in

   1 #!/usr/bin/perl
   2 # ---------------------------------------------------------------
   3 # Copyright © 2013 Merrimack Valley Library Consortium
   4 # Jason Stephenson <jstephenson@mvlc.org>
   5 #
   6 # This program is part of Evergreen; you can redistribute it and/or
   7 # modify it under the terms of the GNU General Public License as
   8 # published by the Free Software Foundation; either version 2 of the
   9 # License, or (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 # ---------------------------------------------------------------
  16 use strict;
  17 use warnings;
  18 use OpenILS::Utils::Fieldmapper;
  19 use OpenILS::Application::AppUtils;
  20 use OpenSRF::Utils::JSON;
  21 use MARC::Field;
  22 use MARC::Record;
  23 use MARC::File::XML (BinaryEncoding => 'UTF-8');
  24 use Date::Manip::Date;
  25 use Encode;
  26 my $U = 'OpenILS::Application::AppUtils';
  27
  28 binmode(STDERR, ':utf8');
  29
  30 package Marque;
  31
  32 our $config = Marque::Config->new();
  33 Fieldmapper->import(IDL => $config->option_value('xml-idl'));
  34
  35 # Look for passed in ids:
  36 my @ids = ();
  37 if ($config->need_ids()) {
  38     print STDERR "Waiting for input\n" if (-t);
  39     while (my $i = <>) {
  40         push @ids, $i if ($i =~ /^\s*[0-9]+\s*$/);
  41     }
  42 }
  43
  44 my $exporter;
  45 if ($config->option_value('type') eq 'authority') {
  46     $exporter = Marque::Authority->new(\@ids);
  47 } else {
  48     $exporter = Marque::Biblio->new(\@ids);
  49 }
  50
  51 Marque::Output::output($exporter);
  52
  53 # ------------------------------------------------------------------
  54 package Marque::Config;
  55
  56 use Getopt::Long;
  57 use List::MoreUtils qw(none);
  58 use OpenSRF::System;
  59 use OpenSRF::Utils::SettingsClient;
  60
  61 use constant FORMATS => qw(USMARC UNIMARC XML BRE ARE);
  62 use constant STORES => qw(reporter cstore storage);
  63 use constant TYPES => qw(authority biblio);
  64
  65
  66 sub new {
  67     my $class = shift;
  68
  69     my $self = {};
  70
  71     # For command line options.
  72     my %opts;
  73
  74     # set some default values
  75     $opts{'format'} = 'USMARC';
  76     $opts{'encoding'} = 'MARC8';
  77     $opts{'type'} = 'biblio';
  78     $opts{'money'} = '$';
  79     $opts{'timeout'} = 0;
  80     $opts{'config'} = '@sysconfdir@/opensrf_core.xml';
  81     $opts{'store'} = 'reporter';
  82
  83     GetOptions(\%opts,
  84                'help',
  85                'items',
  86                'mfhd',
  87                'all',
  88                'replace_001',
  89                'location=s',
  90                'money=s',
  91                'config=s',
  92                'format=s',
  93                'type=s',
  94                'xml-idl=s',
  95                'encoding=s',
  96                'timeout=i',
  97                'library=s@',
  98                'descendants=s@',
  99                'since=s',
 100                'store=s',
 101                'uris',
 102                'debug');
 103
 104     if ($opts{help}) {
 105         print <<"HELP";
 106 This script exports MARC authority, bibliographic, and serial holdings
 107 records from an Evergreen database.
 108
 109 Input to this script can consist of a list of record IDs, with one record ID
 110 per line, corresponding to the record ID in the Evergreen database table of
 111 your requested record type.
 112
 113 Alternately, passing the --all option will attempt to export all records of
 114 the specified type from the Evergreen database. The --all option starts at
 115 record ID 1 and increments the ID by 1 until the largest ID in the database
 116 is retrieved. This may not be very efficient for databases with large gaps
 117 in their ID sequences.
 118
 119 Usage: $0 [options]
 120  --help or -h       This screen.
 121  --config or -c     Configuration file [@sysconfdir@/opensrf_core.xml]
 122  --format or -f     Output format (USMARC, UNIMARC, XML, BRE, ARE) [USMARC]
 123  --encoding or -e   Output encoding (UTF-8, ISO-8859-?, MARC8) [MARC8]
 124  --xml-idl or -x    Location of the IDL XML
 125  --timeout          Remains for backward compatibility. No longer used.
 126  --type or -t       Record type (BIBLIO, AUTHORITY) [BIBLIO]
 127  --all or -a        Export all records; ignores input list
 128  --replace_001      Replace the 001 field value with the record ID
 129  --store            Use the given storage backend to connect to the database.
 130                     Choices are (reporter, cstore, storage) [reporter]
 131  --since            Export records modified since a certain date and time.
 132
 133  Additional options for type = 'BIBLIO':
 134  --items or -i      Include items (holdings) in the output
 135  --money            Currency symbol to use in item price field [\$]
 136  --mfhd             Export serial MFHD records for associated bib records
 137                     Not compatible with --format=BRE
 138  --location or -l   MARC Location Code for holdings from
 139                     http://www.loc.gov/marc/organizations/orgshome.html
 140  --library          Export the bibliographic records that have attached
 141                     holdings for the listed library or libraries as
 142                     identified by shortname
 143  --descendants      Like the --library option, but org. tree aware. It
 144                     exports records that have attached holdings for the
 145                     specified org. unit and all of its descendants in
 146                     the tree.
 147  --uris or -u       Include records with located URIs in the output
 148
 149 Examples:
 150
 151 To export a set of USMARC records in a file named "output_file" based on the
 152 IDs contained in a file named "list_of_ids":
 153   cat list_of_ids | $0 > output_file
 154
 155 To export a set of MARC21XML authority records in a file named "output.xml"
 156 for all authority records in the database:
 157   $0 --format XML --type AUTHORITY --all > output.xml
 158
 159 To export a set of USMARC bibliographic records encoded in UTF-8 in a file
 160 named "sys1_bibs.mrc" based on records which have attached callnumbers for the
 161 libraries with the short names "BR1" and "BR2":
 162
 163   $0 --library BR1 --library BR2 --encoding UTF-8 > sys1_bibs.mrc
 164
 165 HELP
 166         exit;
 167     }
 168
 169     OpenSRF::System->bootstrap_client( config_file => $opts{config} );
 170     my $sclient = OpenSRF::Utils::SettingsClient->new();
 171     unless ($opts{'xml-idl'}) {
 172         $opts{'xml-idl'} = $sclient->config_value('IDL');
 173     }
 174
 175     # Validate some of the settings.
 176     if ($opts{all} && ($opts{library} || $opts{descendants})) {
 177         die('Incompatible arguments: you cannot combine a request for all ' .
 178                 'records with a request for records by library');
 179     }
 180     if ($opts{all} && $opts{since}) {
 181         die('Incompatible arguments: you cannot combine a request for all ' .
 182                 'records with a request for records added or changed since a certain date');
 183     }
 184     $opts{type} = lc($opts{type});
 185     if (none {$_ eq $opts{type}} (TYPES)) {
 186         die "Please select a supported type.  ".
 187             "Right now that means one of [".
 188                 join('|',(FORMATS)). "]\n";
 189     }
 190     $opts{format} = uc($opts{format});
 191     if (none {$_ eq $opts{format}} (FORMATS)) {
 192         die "Please select a supported format.  ".
 193             "Right now that means one of [".
 194                 join('|',(FORMATS)). "]\n";
 195     }
 196
 197     if ($opts{format} eq 'ARE' && $opts{type} ne 'authority') {
 198         die "Format ARE is not compatible with type " . $opts{type};
 199     }
 200     if ($opts{format} eq 'BRE' && $opts{type} ne 'biblio') {
 201         die "Format BRE is not compatible with type " . $opts{type};
 202     }
 203     if ($opts{format} eq 'BRE' && $opts{items}) {
 204         die "Format BRE is not compatible with exporting holdings."
 205     }
 206
 207     if ($opts{mfhd}) {
 208         if ($opts{type} ne 'biblio') {
 209             die "MFHD export only works with bibliographic records.";
 210         } elsif ($opts{format} eq 'BRE') {
 211             die "MFHD export incompatible with format BRE.";
 212         }
 213     }
 214
 215     $opts{store} = lc($opts{store});
 216     if (none {$_ eq $opts{store}} (STORES)) {
 217         die "Please select a supported store.  ".
 218             "Right now that means one of [".
 219                 join('|',(STORES)). "]\n";
 220     } else {
 221         my $app;
 222         if ($opts{store} eq 'reporter') {
 223             $app = 'open-ils.reporter-store';
 224         } else {
 225             $app = 'open-ils.' . $opts{store};
 226         }
 227         if ($app eq 'open-ils.storage') {
 228             $self->{dbsettings} = $sclient->config_value(
 229                 apps => $app => app_settings => databases => 'database');
 230         } else {
 231             $self->{dbsettings} = $sclient->config_value(
 232                 apps => $app => app_settings => 'database');
 233         }
 234     }
 235     $opts{encoding} = uc($opts{encoding});
 236
 237     $self->{'options'} = \%opts;
 238     bless $self, $class;
 239     return $self;
 240 }
 241
 242 sub option_value {
 243     my ($self, $option) = @_;
 244     return $self->{options}->{$option};
 245 }
 246
 247 sub database_settings {
 248     my $self = shift;
 249     return $self->{dbsettings};
 250 }
 251
 252 sub need_ids {
 253     my $self = shift;
 254     my $rv = 1;
 255
 256     $rv = 0 if ($self->{options}->{all});
 257     $rv = 0 if ($self->{options}->{since});
 258     $rv = 0 if ($self->{options}->{library});
 259     $rv = 0 if ($self->{options}->{descendants});
 260
 261     return $rv;
 262 }
 263
 264 # ------------------------------------------------------------------
 265 # This package exists to get a connection to the database.  Since
 266 # we'll need one for both biblio records and authorities, we've made a
 267 # single subpackage with a function so that we don't have to duplicate
 268 # code.
 269 package Marque::Connector;
 270
 271 use DBI;
 272
 273 # Pass a Marque::Config object's database_settings return value into
 274 # this to get a DBI connection.
 275 # ex:
 276 # my $db = Marque::Connector::connect($config->database_settings);
 277 sub connect {
 278     my $args = shift;
 279
 280     # Build a connect string from the args.
 281     my $connect_string = 'DBI:Pg:';
 282     $connect_string .= 'dbname=' . $args->{db} . ';';
 283     $connect_string .= 'host=' . $args->{host} . ';';
 284     $connect_string .= 'port=' . $args->{port};
 285
 286     my $db_handle = DBI->connect($connect_string,
 287                                  $args->{user}, $args->{pw});
 288     return $db_handle;
 289 }
 290
 291 # A function to get the date into a format better for PostgreSQL.
 292 sub db_date {
 293     my $input = shift;
 294     my $date;
 295     if (ref($input) eq 'Date::Manip::Date') {
 296         $date = $input;
 297     } else {
 298         $date = Date::Manip::Date->new();
 299         if ($date->parse($input)) {
 300             die "Can't parse date $input";
 301         }
 302     }
 303     return $date->printf("%Y-%m-%dT%H:%M:%S%z");
 304  }
 305
 306 # ------------------------------------------------------------------
 307 # You would typically have the next two packages inherit from a common
 308 # superclass, but ineritance doesn't seem to work when all packages
 309 # are in single file, so we have some duplicated code between these
 310 # two.
 311
 312 # Get bibliographic records from the database.
 313 package Marque::Biblio;
 314
 315 sub new {
 316     my $class = shift;
 317     my $idlist = shift;
 318     my $self = {idlist => $idlist};
 319     $self->{handle} = Marque::Connector::connect(
 320         $Marque::config->database_settings);
 321     $self->{since_date} = Date::Manip::Date->new;
 322     $self->{since_date}->parse($Marque::config->option_value('since'));
 323
 324     # We need multiple fieldmapper classes depending on our
 325     # options. We'll just get the information that we'll need for them
 326     # all right here instead of only fetching the information when
 327     # needed.
 328     $self->{breClass} = Fieldmapper::class_for_hint('bre');
 329     $self->{acnClass} = Fieldmapper::class_for_hint('acn');
 330     $self->{acpClass} = Fieldmapper::class_for_hint('acp');
 331     $self->{sreClass} = Fieldmapper::class_for_hint('sre');
 332     $self->{acnpClass} = Fieldmapper::class_for_hint('acnp');
 333     $self->{acnsClass} = Fieldmapper::class_for_hint('acns');
 334     $self->{auricnmClass} = Fieldmapper::class_for_hint('auricnm');
 335
 336     # Make an arrayref of shortname ids if the library option was
 337     # specified:
 338     $self->{libs} = [];
 339     if ($Marque::config->option_value('library')) {
 340         # This is done not only for speed, but to prevent SQL injection.
 341         my $sth = $self->{handle}->prepare('select id from actor.org_unit where shortname=any(?::text[])');
 342         if ($sth->execute($Marque::config->option_value('library'))) {
 343             my $r = $sth->fetchall_arrayref();
 344             my @ids = map {$_->[0]} @{$r};
 345             $self->{libs} = \@ids;
 346             $sth->finish();
 347         }
 348     }
 349     # Ditto for descendants.  We don't worry about redundancy, the db can deal with it.
 350     if ($Marque::config->option_value('descendants')) {
 351         # Unlike the above, we're looping to make this simpler in the database.
 352         my $sth = $self->{handle}->prepare(
 353                 'select id from actor.org_unit_descendants((select id from actor.org_unit where shortname=?))');
 354         foreach my $shortname (@{$Marque::config->option_value('descendants')}) {
 355             if ($sth->execute($shortname)) {
 356                 my $r = $sth->fetchall_arrayref();
 357                 my @ids = map {$_->[0]} @{$r};
 358                 push(@{$self->{libs}}, @ids);
 359                 $sth->finish();
 360             }
 361         }
 362     }
 363
 364     bless $self, $class;
 365     return $self;
 366 }
 367
 368 sub build_query {
 369     my $self = shift;
 370
 371     # TODO: There is some unfortunate code repetition in this
 372     # subroutine and it is now about 93 lines long with comments and
 373     # whitespace.  It should probably be refactored into a series of
 374     # smaller subroutines to avoid the repetition.
 375
 376     # Get the field names and tables for our classes. We add the fully
 377     # qualified table names to the fields so that the joins will work.
 378     my $breTable = $self->{breClass}->Table();
 379     my @breFields = map {$breTable . '.' . $_} $self->{breClass}->real_fields();
 380     my $acnTable = $self->{acnClass}->Table();
 381     my $acpTable = $self->{acpClass}->Table();
 382     my $acnpTable = $self->{acnpClass}->Table();
 383     my $acnsTable = $self->{acnsClass}->Table();
 384     my $auricnmTable = $self->{auricnmClass}->Table();
 385
 386     # Now we build the query in pieces:
 387
 388     # We always select the bre fields:
 389     my $select = 'select distinct ' . join(',', @breFields);
 390     # We always use the bre table.
 391     my $from = "from $breTable";
 392
 393     # If have the libraries or items options, we need to join the
 394     # asset.call_number table. If we have both, this variable checks
 395     # that it has already been joined so we don't create an invalid
 396     # query.
 397     my $acn_joined = 0;
 398     # Join to the acn table as needed for the library option.
 399     if (@{$self->{libs}}) {
 400         $acn_joined = 1;
 401         $from .= <<ACN_JOIN;
 402
 403 join $acnTable on $acnTable.record = $breTable.id
 404 and $acnTable.owning_lib in (
 405 ACN_JOIN
 406         $from .= join(',', @{$self->{libs}}) . ")";
 407         $from .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 408     }
 409
 410     if ($Marque::config->option_value('items')) {
 411         unless ($acn_joined) {
 412             $from .= "\njoin $acnTable on $acnTable.record = $breTable.id";
 413             $from .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 414         }
 415         $from .= "\njoin $acpTable on $acpTable.call_number = $acnTable.id";
 416         $from .= "\nand $acpTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 417         $from .= "\nleft outer join $acnpTable on $acnTable.prefix = $acnpTable.id";
 418         $from .= "\nleft outer join $acnsTable on $acnTable.suffix = $acnsTable.id";
 419     }
 420
 421     # The where really depends on a few options:
 422     my $where = "where $breTable.id > 0 and ";
 423     # We fill in the where as necessary.
 424     if ($self->{idlist} && @{$self->{idlist}}) {
 425         $where .= "$breTable.id in (" . join(',', @{$self->{idlist}}) . ')';
 426     } elsif ($Marque::config->option_value('since')) {
 427         my $since_str = Marque::Connector::db_date($self->{since_date});
 428         $where .= "($breTable.edit_date > '$since_str'";
 429         $where .= " or $breTable.create_date > '$since_str')";
 430     } else {
 431         # We want all non-deleted records.
 432         $where .= "$breTable.deleted = 'f'";
 433     }
 434
 435     # Support the --uris option.  It is orthogonal to --items, so we
 436     # may have to build a second query to use with a UNION DISTINCT.
 437     my $uri_union = "";
 438     if ($Marque::config->option_value('uris')) {
 439         if ($Marque::config->option_value('items')) {
 440             # Build UNION DISTINCT for main query.
 441             $uri_union = "\nunion distinct\n";
 442             $uri_union .= $select;
 443             $uri_union .= "\nfrom $breTable";
 444             $uri_union .= "\njoin $acnTable on $acnTable.record = $breTable.id";
 445             $uri_union .= "\nand $acnTable.owning_lib in (" . join(',', @{$self->{libs}}) . ")" if (@{$self->{libs}});
 446             $uri_union .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 447             $uri_union .= "\njoin $auricnmTable on $auricnmTable.call_number = $acnTable.id";
 448             $uri_union .= "\n$where";
 449         } else {
 450             unless ($acn_joined) {
 451                 $from .= "\njoin $acnTable on $acnTable.record = $breTable.id";
 452                 $from .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 453             }
 454             $from .= "\njoin $auricnmTable on $auricnmTable.call_number = $acnTable.id";
 455         }
 456     }
 457
 458     $self->{query} = $select . "\n" . $from . "\n" . $where;
 459     $self->{query} .= $uri_union if ($uri_union);
 460 }
 461
 462 sub execute_query {
 463     my $self = shift;
 464     $self->build_query() unless ($self->{query});
 465     $self->{sth} = $self->{handle}->prepare($self->{query});
 466     return $self->{sth}->execute;
 467 }
 468
 469 sub next {
 470     my $self = shift;
 471     my $output;
 472
 473     # $r holds the record object, either sre or bre.  $marc holds the
 474     # current record's MARC, either sre.marc or bre.marc
 475     my ($r,$marc);
 476     # If we have the mfhd option and we've previously retrieved some
 477     # sres, then we output one of the retrieved sres for each call
 478     # until we run out.  These sres "go with" the previous bib record.
 479     if ($Marque::config->option_value('mfhd') && $self->{mfhds} && @{$self->{mfhds}}) {
 480         $r = shift(@{$self->{mfhds}});
 481         eval {
 482             local $SIG{__WARN__} = sub {
 483                 my $message = "Warning from serial record " . $r->id() . ": "
 484                     . shift;
 485                 warn($message);
 486             };
 487             $marc = MARC::Record->new_from_xml($r->marc(),
 488                                                $Marque::config->option_value('encoding'),
 489                                                $Marque::config->option_value('format'));
 490         };
 491         if ($@) {
 492             warn("Error in serial record " . $r->id() . ": $@");
 493             import MARC::File::XML; # Reset SAX Parser.
 494             return $self->next();
 495         }
 496     } else {
 497         my $data = $self->{sth}->fetchrow_hashref;
 498         if ($data) {
 499             $r = $self->{breClass}->from_bare_hash($data);
 500             if ($Marque::config->option_value('format') eq 'BRE') {
 501                 $output = OpenSRF::Utils::JSON->perl2JSON($r);
 502             } else {
 503                 eval {
 504                     local $SIG{__WARN__} = sub {
 505                         my $message = "Warning from bibliographic record " . $r->id() . ": "
 506                             . shift;
 507                         warn($message);
 508                     };
 509                     $marc = MARC::Record->new_from_xml($r->marc(),
 510                                                        $Marque::config->option_value('encoding'),
 511                                                        $Marque::config->option_value('format'));
 512                 };
 513                 if ($@) {
 514                     warn("Error in bibliographic record " . $r->id() . ": $@");
 515                     import MARC::File::XML; # Reset SAX Parser.
 516                     return $self->next();
 517                 }
 518                 if ($Marque::config->option_value('replace_001')) {
 519                     my $tcn = $marc->field('001');
 520                     if ($tcn) {
 521                         $tcn->update($r->id());
 522                     } else {
 523                         $tcn = MARC::Field->new('001', $r->id());
 524                         $marc->insert_fields_ordered($tcn);
 525                     }
 526                 }
 527                 if ($Marque::config->option_value('items')) {
 528                     my @acps = $self->acps_for_bre($r);
 529                     foreach my $acp (@acps) {
 530                         next unless ($acp);
 531                         my $location = $Marque::config->option_value('location');
 532                         my $price = ($acp->price() ? $Marque::config->option_value('money').$acp->price() : '');
 533                         my $prefix = $acp->call_number()->prefix()->label();
 534                         my $suffix = $acp->call_number()->suffix()->label();
 535                         eval {
 536                             local $SIG{__WARN__} = sub {
 537                                 my $message = "Warning from bibliographic record " . $r->id() . ": "
 538                                     . shift;
 539                                 warn($message);
 540                             };
 541                             $marc->insert_grouped_field(
 542                             MARC::Field->new(
 543                                 '852', '4', ' ',
 544                                 ($location ? ('a' => $location) : ()),
 545                                 b => Encode::decode_utf8($acp->call_number()->owning_lib()->shortname()),
 546                                 b => Encode::decode_utf8($acp->circ_lib()->shortname()),
 547                                 c => Encode::decode_utf8($acp->location()->name()),
 548                                 ($prefix ? (k => Encode::decode_utf8($prefix)) : ()),
 549                                 j => Encode::decode_utf8($acp->call_number()->label()),
 550                                 ($suffix ? (m => Encode::decode_utf8($suffix)) : ()),
 551                                 ($acp->circ_modifier() ? (g => Encode::decode_utf8($acp->circ_modifier())) : ()),
 552                                 p => Encode::decode_utf8($acp->barcode()),
 553                                 ($price ? (y => Encode::decode_utf8($price)) : ()),
 554                                 ($acp->copy_number() ? (t => $acp->copy_number()) : ()),
 555                                 ($U->is_true($acp->ref()) ? (x => 'reference') : ()),
 556                                 (!$U->is_true($acp->holdable()) ? (x => 'unholdable') : ()),
 557                                 (!$U->is_true($acp->circulate()) ? (x => 'noncirculating') : ()),
 558                                 (!$U->is_true($acp->opac_visible()) ? (x => 'hidden') : ())
 559                             ));
 560                         };
 561                         if ($@) {
 562                             warn("Error in bibliographic record " . $r->id() . ": $@");
 563                             import MARC::File::XML; # Reset SAX Parser.
 564                             return $self->next();
 565                         }
 566                     }
 567                 }
 568                 if ($Marque::config->option_value('mfhd')) {
 569                     $self->{mfhds} = [$self->sres_for_bre($r)];
 570                 }
 571             }
 572         }
 573     }
 574     # Common stuff that doesn't depend on record type.
 575     if ($marc) {
 576         if ($Marque::config->option_value('since')) {
 577             my $leader = $marc->leader();
 578             if ($U->is_true($r->deleted())) {
 579                 substr($leader, 5, 1) = 'd';
 580                 $marc->leader($leader);
 581             } else {
 582                 my $create_date = Date::Manip::Date->new;
 583                 $create_date->parse($r->create_date());
 584                 my $edit_date = Date::Manip::Date->new;
 585                 $edit_date->parse($r->edit_date());
 586                 if ($self->{since_date}->cmp($create_date) < 0) {
 587                     substr($leader, 5, 1) = 'n';
 588                     $marc->leader($leader);
 589                 } elsif ($self->{since_date}->cmp($edit_date) < 0) {
 590                     substr($leader, 5, 1) = 'c';
 591                     $marc->leader($leader);
 592                 }
 593             }
 594         }
 595         if ($Marque::config->option_value('format') eq 'XML') {
 596             eval {
 597                 local $SIG{__WARN__} = sub {
 598                     my $message = "Warning from bibliographic record " . $r->id() . ": "
 599                         . shift;
 600                     warn($message);
 601                 };
 602                 $output = $marc->as_xml_record;
 603                 $output =~ s/^<\?.+?\?>$//mo;
 604             };
 605             if ($@) {
 606                 warn("Error in bibliographic record " . $r->id() . ": $@");
 607                 return $self->next();
 608             }
 609         } else {
 610             eval {
 611                 local $SIG{__WARN__} = sub {
 612                     my $message = "Warning from bibliographic record " . $r->id() . ": "
 613                         . shift;
 614                     warn($message);
 615                 };
 616                 $output = $marc->as_usmarc;
 617             };
 618             if ($@) {
 619                 warn("Error in bibliographic record " . $r->id() . ": $@");
 620                 return $self->next();
 621             }
 622         }
 623     }
 624     return $output;
 625 }
 626
 627 # Returns a list of aou objects in an array.
 628 sub orgs {
 629     my $self = shift;
 630     unless ($self->{orgs} && @{$self->{orgs}}) {
 631         my $fmClass = Fieldmapper::class_for_hint('aou');
 632         my @classFields = $fmClass->real_fields();
 633         my $classTable = $fmClass->Table();
 634         my $query = 'select ' . join(',', @classFields);
 635         $query .= "\nfrom $classTable";
 636         my $sth = $self->{handle}->prepare($query);
 637         if ($sth->execute()) {
 638             my $result = $sth->fetchall_arrayref({});
 639             my @orgs = map {$fmClass->from_bare_hash($_)} @{$result};
 640             $self->{orgs} = \@orgs;
 641         } else {
 642             $self->{orgs} = [];
 643         }
 644     }
 645     return @{$self->{orgs}};
 646 }
 647
 648 # Returns an array of acpl objects.
 649 sub shelves {
 650     my $self = shift;
 651
 652     unless ($self->{shelves} && @{$self->{shelves}}) {
 653         my $fmClass = Fieldmapper::class_for_hint('acpl');
 654         my @classFields = $fmClass->real_fields();
 655         my $classTable = $fmClass->Table();
 656         my $query = 'select ' . join(',', @classFields);
 657         $query .= "\nfrom $classTable";
 658         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 659         my @shelves = map {$fmClass->from_bare_hash($_)} @{$result};
 660         $self->{shelves} = \@shelves;
 661     }
 662
 663     return @{$self->{shelves}};
 664 }
 665
 666 # Returns an array of acnp objects.
 667 sub prefixes {
 668     my $self = shift;
 669
 670     unless ($self->{prefixes} && @{$self->{prefixes}}) {
 671         my $fmClass = Fieldmapper::class_for_hint('acnp');
 672         my @classFields = $fmClass->real_fields();
 673         my $classTable = $fmClass->Table();
 674         my $query = 'select ' . join(',', @classFields);
 675         $query .= "\nfrom $classTable";
 676         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 677         my @prefixes = map {$fmClass->from_bare_hash($_)} @{$result};
 678         $self->{prefixes} = \@prefixes;
 679     }
 680
 681     return @{$self->{prefixes}};
 682 }
 683
 684 # Returns an array of acns objects.
 685 sub suffixes {
 686     my $self = shift;
 687
 688     unless ($self->{suffixes} && @{$self->{suffixes}}) {
 689         my $fmClass = Fieldmapper::class_for_hint('acns');
 690         my @classFields = $fmClass->real_fields();
 691         my $classTable = $fmClass->Table();
 692         my $query = 'select ' . join(',', @classFields);
 693         $query .= "\nfrom $classTable";
 694         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 695         my @suffixes = map {$fmClass->from_bare_hash($_)} @{$result};
 696         $self->{suffixes} = \@suffixes;
 697     }
 698
 699     return @{$self->{suffixes}};
 700 }
 701
 702 # Returns an array of acn objects for a given bre object or id.
 703 sub acns_for_bre {
 704     my $self = shift;
 705     my $bre = shift;
 706     $bre = $bre->id() if (ref($bre));
 707
 708     unless ($self->{acnHandle}) {
 709         my $query = "select " . join(',', $self->{acnClass}->real_fields());
 710         $query .= "\nfrom " . $self->{acnClass}->Table();
 711         $query .= "\nwhere record = ?";
 712         if (@{$self->{libs}}) {
 713             $query .= "\nand owning_lib in (";
 714             $query .= join(',', @{$self->{libs}}) . ")";
 715         }
 716         $query .= "\nand deleted = 'f'" unless($Marque::config->option_value('since'));
 717         $self->{acnHandle} = $self->{handle}->prepare($query);
 718     }
 719
 720     if ($self->{acnHandle}->execute($bre)) {
 721         my $result = $self->{acnHandle}->fetchall_arrayref({});
 722         return map {$self->{acnClass}->from_bare_hash($_)} @{$result};
 723     }
 724
 725     # If for some reason, we don't find anything.
 726     return undef;
 727 }
 728
 729 # Returns an array of acp objects for a given bre object or id.
 730 sub acps_for_bre {
 731     my $self = shift;
 732     my $bre = shift;
 733     $bre = $bre->id() if (ref($bre));
 734
 735     my @orgs = $self->orgs();
 736     my @locations = $self->shelves();
 737     my @prefixes = $self->prefixes();
 738     my @suffixes = $self->suffixes();
 739
 740     my @acns = $self->acns_for_bre($bre);
 741     if (@acns) {
 742         my $query = 'select ' . join(',', $self->{acpClass}->real_fields());
 743         $query .= "\nfrom " . $self->{acpClass}->Table();
 744         $query .= "\nwhere call_number in (";
 745         $query .= join(',', map {$_->id()} @acns);
 746         $query .= ")";
 747         $query .= "\nand deleted = 'f'" unless ($Marque::config->option_value('since'));
 748         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 749         if ($result && @{$result}) {
 750             my @acps = map {$self->{acpClass}->from_bare_hash($_)} @{$result};
 751             foreach (@acps) {
 752                 my $cn = $_->call_number();
 753                 my $clib = $_->circ_lib();
 754                 my $loc = $_->location();
 755                 my ($org) = grep {$_->id() == $clib} @orgs;
 756                 my ($acn) = grep {$_->id() == $cn} @acns;
 757                 my ($location) = grep {$_->id() == $loc} @locations;
 758                 my $olib = $acn->owning_lib();
 759                 my $pre = $acn->prefix();
 760                 my $suf = $acn->suffix();
 761                 my ($acnp) = grep {$_->id() == $pre} @prefixes;
 762                 my ($acns) = grep {$_->id() == $suf} @suffixes;
 763                 my ($owner) = grep {$_->id() == $olib} @orgs;
 764                 $acn->owning_lib($owner);
 765                 $_->call_number($acn);
 766                 $_->circ_lib($org);
 767                 $_->location($location);
 768                 $_->call_number->prefix($acnp);
 769                 $_->call_number->suffix($acns);
 770             }
 771             return @acps;
 772         }
 773     }
 774
 775     # If for some reason, we don't find anything.
 776     return undef;
 777 }
 778
 779 # Retreive an array for sre objects when the --mfhd option is used.
 780 sub sres_for_bre {
 781     my $self = shift;
 782     my $bre = shift;
 783     $bre = $bre->id() if (ref($bre));
 784     my @sres;
 785     # Build a query to retrieve SREs when the MFHD option is passed.
 786     if ($Marque::config->option_value('mfhd')) {
 787         # Create a persistent handle as needed.
 788         unless ($self->{sreSth}) {
 789             my $query = "select " . join(',', $self->{sreClass}->real_fields());
 790             $query .= "\nfrom " . $self->{sreClass}->Table();
 791             $query .= "\nwhere record = ?";
 792             $query .= "\nand deleted = 'f'" unless ($Marque::config->option_value('since'));
 793             $self->{sreSth} = $self->{handle}->prepare($query);
 794         }
 795         if ($self->{sreSth}->execute($bre)) {
 796             while (my $data = $self->{sreSth}->fetchrow_hashref) {
 797                 push @sres, $self->{sreClass}->from_bare_hash($data);
 798             }
 799             $self->{sreSth}->finish; # Sometimes DBI complains.
 800         }
 801     }
 802     # May be empty.
 803     return @sres;
 804 }
 805
 806 # Get authority records from the database.
 807 package Marque::Authority;
 808
 809 sub new {
 810     my $class = shift;
 811     my $idlist = shift;
 812     my $self = {idlist => $idlist};
 813     $self->{handle} = Marque::Connector::connect(
 814         $Marque::config->database_settings);
 815     $self->{fmClass} = Fieldmapper::class_for_hint('are');
 816     $self->{since_date} = Date::Manip::Date->new;
 817     $self->{since_date}->parse($Marque::config->option_value('since'));
 818     bless $self, $class;
 819     return $self;
 820 }
 821
 822 sub build_query {
 823     my $self = shift;
 824
 825     # Get the information for are object from the Fieldmapper:
 826     my @fields  = $self->{fmClass}->real_fields();
 827     my $table = $self->{fmClass}->Table();
 828
 829     # Build the actual query.
 830     my $select = "select " . join(',', @fields);
 831     my $from = "from $table";
 832     my $where = 'where ';
 833
 834     # If we have an idlist, we pretty much ignore anything else.
 835     if ($self->{idlist} && @{$self->{idlist}}) {
 836         $where .= 'id in (' . join(',', @{$self->{idlist}}) . ')';
 837     } elsif ($Marque::config->option_value('since')) {
 838         my $since_str = Marque::Connector::db_date($self->{since_date});
 839         $where .= "edit_date > '$since_str'";
 840         $where .= " or create_date > '$since_str'";
 841     } else {
 842         # We want all non-deleted records.
 843         $where .= "deleted = 'f'";
 844     }
 845
 846     $self->{query} = $select . "\n" . $from . "\n" . $where;
 847 }
 848
 849 sub execute_query {
 850     my $self = shift;
 851     $self->build_query() unless ($self->{query});
 852     $self->{sth} = $self->{handle}->prepare($self->{query});
 853     return $self->{sth}->execute;
 854 }
 855
 856 sub next {
 857     my $self = shift;
 858     my $output;
 859     my $data = $self->{sth}->fetchrow_hashref;
 860
 861     if ($data) {
 862         my $format = $Marque::config->option_value('format');
 863         my $r = $self->{fmClass}->from_bare_hash($data);
 864         if ($format eq 'ARE') {
 865             $output = OpenSRF::Utils::JSON->perl2JSON($r);
 866         } else {
 867             my $marc;
 868             eval {
 869                 local $SIG{__WARN__} = sub {
 870                     my $message = "Warning from authority record " . $r->id() . ": "
 871                         . shift;
 872                     warn($message);
 873                 };
 874                 $marc = MARC::Record->new_from_xml($r->marc(),
 875                                                 $Marque::config->option_value('encoding'),
 876                                                 $Marque::config->option_value('format'));
 877             };
 878             if ($@) {
 879                 warn("Error in authority record " . $r->id() . ": $@");
 880                 import MARC::File::XML; # Reset SAX Parser.
 881                 return $self->next();
 882             }
 883             if ($Marque::config->option_value('replace_001')) {
 884                 my $tcn = $marc->field('001');
 885                 if ($tcn) {
 886                     $tcn->update($r->id());
 887                 } else {
 888                     $tcn = MARC::Field->new('001', $r->id());
 889                     $marc->insert_fields_ordered($tcn);
 890                 }
 891             }
 892             if ($Marque::config->option_value('since')) {
 893                 my $leader = $marc->leader();
 894                 if ($U->is_true($r->deleted())) {
 895                     substr($leader, 5, 1) = 'd';
 896                     $marc->leader($leader);
 897                 } else {
 898                     my $create_date = Date::Manip::Date->new;
 899                     $create_date->parse($r->create_date());
 900                     my $edit_date = Date::Manip::Date->new;
 901                     $edit_date->parse($r->edit_date());
 902                     if ($self->{since_date}->cmp($create_date) < 0) {
 903                         substr($leader, 5, 1) = 'n';
 904                         $marc->leader($leader);
 905                     } elsif ($self->{since_date}->cmp($edit_date) < 0) {
 906                         substr($leader, 5, 1) = 'c';
 907                         $marc->leader($leader);
 908                     }
 909                 }
 910             }
 911             if ($Marque::config->option_value('format') eq 'XML') {
 912                 eval {
 913                     local $SIG{__WARN__} = sub {
 914                         my $message = "Warning from authority record " . $r->id() . ": "
 915                             . shift;
 916                         warn($message);
 917                     };
 918                     $output = $marc->as_xml_record;
 919                     $output =~ s/^<\?.+?\?>$//mo;
 920                 };
 921                 if ($@) {
 922                     warn("Error in authority record " . $r->id() . ": $@");
 923                     return $self->next();
 924                 }
 925             } else {
 926                 eval {
 927                     local $SIG{__WARN__} = sub {
 928                         my $message = "Warning from authority record " . $r->id() . ": "
 929                             . shift;
 930                         warn($message);
 931                     };
 932                     $output = $marc->as_usmarc;
 933                 };
 934                 if ($@) {
 935                     warn("Error in authority record " . $r->id() . ": $@");
 936                     return $self->next();
 937                 }
 938             }
 939         }
 940     }
 941
 942     return $output;
 943 }
 944
 945 # ------------------------------------------------------------------
 946 # Since the ultimate output is largely independent of the type of the
 947 # records, we use a single subpackage to group our output routines.
 948 package Marque::Output;
 949
 950 sub output {
 951     my $extractor = shift;
 952     if ($extractor->execute_query) {
 953         if ($Marque::config->option_value('encoding') eq 'UTF-8') {
 954             binmode(STDOUT, ':utf8');
 955         } else {
 956             binmode(STDOUT, ':raw');
 957         }
 958
 959         &preamble;
 960         while (my $output = $extractor->next()) {
 961             print $output;
 962         }
 963         &postamble;
 964     } else {
 965         print STDERR $extractor->{query} if ($Marque::config->option_value('debug'));
 966         die "Database query failed!";
 967     }
 968 }
 969
 970 sub preamble {
 971     if ($Marque::config->option_value('format') eq 'XML') {
 972         my $encoding = $Marque::config->option_value('encoding');
 973         print <<PREAMBLE;
 974 <?xml version="1.0" encoding="$encoding"?>
 975 <collection xmlns='http://www.loc.gov/MARC21/slim'>
 976 PREAMBLE
 977     }
 978 }
 979
 980 sub postamble {
 981     if ($Marque::config->option_value('format') eq 'XML') {
 982         print "</collection>\n";
 983     }
 984 }
 985
 986 1;