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