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                         my $status = $acp->status()->name();
 536                         eval {
 537                             local $SIG{__WARN__} = sub {
 538                                 my $message = "Warning from bibliographic record " . $r->id() . ": "
 539                                     . shift;
 540                                 warn($message);
 541                             };
 542                             $marc->insert_grouped_field(
 543                             MARC::Field->new(
 544                                 '852', '4', ' ',
 545                                 ($location ? ('a' => $location) : ()),
 546                                 b => Encode::decode_utf8($acp->call_number()->owning_lib()->shortname()),
 547                                 b => Encode::decode_utf8($acp->circ_lib()->shortname()),
 548                                 c => Encode::decode_utf8($acp->location()->name()),
 549                                 ($prefix ? (k => Encode::decode_utf8($prefix)) : ()),
 550                                 j => Encode::decode_utf8($acp->call_number()->label()),
 551                                 ($suffix ? (m => Encode::decode_utf8($suffix)) : ()),
 552                                 ($acp->circ_modifier() ? (g => Encode::decode_utf8($acp->circ_modifier())) : ()),
 553                                 p => Encode::decode_utf8($acp->barcode()),
 554                                 s => Encode::decode_utf8($status),
 555                                 ($price ? (y => Encode::decode_utf8($price)) : ()),
 556                                 ($acp->copy_number() ? (t => $acp->copy_number()) : ()),
 557                                 ($U->is_true($acp->ref()) ? (x => 'reference') : ()),
 558                                 (!$U->is_true($acp->holdable()) ? (x => 'unholdable') : ()),
 559                                 (!$U->is_true($acp->circulate()) ? (x => 'noncirculating') : ()),
 560                                 (!$U->is_true($acp->opac_visible()) ? (x => 'hidden') : ())
 561                             ));
 562                         };
 563                         if ($@) {
 564                             warn("Error in bibliographic record " . $r->id() . ": $@");
 565                             import MARC::File::XML; # Reset SAX Parser.
 566                             return $self->next();
 567                         }
 568                     }
 569                 }
 570                 if ($Marque::config->option_value('mfhd')) {
 571                     $self->{mfhds} = [$self->sres_for_bre($r)];
 572                 }
 573             }
 574         }
 575     }
 576     # Common stuff that doesn't depend on record type.
 577     if ($marc) {
 578         if ($Marque::config->option_value('since')) {
 579             my $leader = $marc->leader();
 580             if ($U->is_true($r->deleted())) {
 581                 substr($leader, 5, 1) = 'd';
 582                 $marc->leader($leader);
 583             } else {
 584                 my $create_date = Date::Manip::Date->new;
 585                 $create_date->parse($r->create_date());
 586                 my $edit_date = Date::Manip::Date->new;
 587                 $edit_date->parse($r->edit_date());
 588                 if ($self->{since_date}->cmp($create_date) < 0) {
 589                     substr($leader, 5, 1) = 'n';
 590                     $marc->leader($leader);
 591                 } elsif ($self->{since_date}->cmp($edit_date) < 0) {
 592                     substr($leader, 5, 1) = 'c';
 593                     $marc->leader($leader);
 594                 }
 595             }
 596         }
 597         if ($Marque::config->option_value('format') eq 'XML') {
 598             eval {
 599                 local $SIG{__WARN__} = sub {
 600                     my $message = "Warning from bibliographic record " . $r->id() . ": "
 601                         . shift;
 602                     warn($message);
 603                 };
 604                 $output = $marc->as_xml_record;
 605                 $output =~ s/^<\?.+?\?>$//mo;
 606             };
 607             if ($@) {
 608                 warn("Error in bibliographic record " . $r->id() . ": $@");
 609                 return $self->next();
 610             }
 611         } else {
 612             eval {
 613                 local $SIG{__WARN__} = sub {
 614                     my $message = "Warning from bibliographic record " . $r->id() . ": "
 615                         . shift;
 616                     warn($message);
 617                 };
 618                 $output = $marc->as_usmarc;
 619             };
 620             if ($@) {
 621                 warn("Error in bibliographic record " . $r->id() . ": $@");
 622                 return $self->next();
 623             }
 624         }
 625     }
 626     return $output;
 627 }
 628
 629 # Returns a list of aou objects in an array.
 630 sub orgs {
 631     my $self = shift;
 632     unless ($self->{orgs} && @{$self->{orgs}}) {
 633         my $fmClass = Fieldmapper::class_for_hint('aou');
 634         my @classFields = $fmClass->real_fields();
 635         my $classTable = $fmClass->Table();
 636         my $query = 'select ' . join(',', @classFields);
 637         $query .= "\nfrom $classTable";
 638         my $sth = $self->{handle}->prepare($query);
 639         if ($sth->execute()) {
 640             my $result = $sth->fetchall_arrayref({});
 641             my @orgs = map {$fmClass->from_bare_hash($_)} @{$result};
 642             $self->{orgs} = \@orgs;
 643         } else {
 644             $self->{orgs} = [];
 645         }
 646     }
 647     return @{$self->{orgs}};
 648 }
 649
 650 # Returns an array of acpl objects.
 651 sub shelves {
 652     my $self = shift;
 653
 654     unless ($self->{shelves} && @{$self->{shelves}}) {
 655         my $fmClass = Fieldmapper::class_for_hint('acpl');
 656         my @classFields = $fmClass->real_fields();
 657         my $classTable = $fmClass->Table();
 658         my $query = 'select ' . join(',', @classFields);
 659         $query .= "\nfrom $classTable";
 660         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 661         my @shelves = map {$fmClass->from_bare_hash($_)} @{$result};
 662         $self->{shelves} = \@shelves;
 663     }
 664
 665     return @{$self->{shelves}};
 666 }
 667
 668 # Returns an array of ccs objects.
 669 sub statuses {
 670     my $self = shift;
 671
 672     unless ($self->{statuses} && @{$self->{statuses}}) {
 673         my $fmClass = Fieldmapper::class_for_hint('ccs');
 674         my @classFields = $fmClass->real_fields();
 675         my $classTable = $fmClass->Table();
 676         my $query = 'select ' . join(',', @classFields);
 677         $query .= "\nfrom $classTable";
 678         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 679         my @statuses = map {$fmClass->from_bare_hash($_)} @{$result};
 680         $self->{statuses} = \@statuses;
 681     }
 682
 683     return @{$self->{statuses}};
 684 }
 685
 686 # Returns an array of acnp objects.
 687 sub prefixes {
 688     my $self = shift;
 689
 690     unless ($self->{prefixes} && @{$self->{prefixes}}) {
 691         my $fmClass = Fieldmapper::class_for_hint('acnp');
 692         my @classFields = $fmClass->real_fields();
 693         my $classTable = $fmClass->Table();
 694         my $query = 'select ' . join(',', @classFields);
 695         $query .= "\nfrom $classTable";
 696         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 697         my @prefixes = map {$fmClass->from_bare_hash($_)} @{$result};
 698         $self->{prefixes} = \@prefixes;
 699     }
 700
 701     return @{$self->{prefixes}};
 702 }
 703
 704 # Returns an array of acns objects.
 705 sub suffixes {
 706     my $self = shift;
 707
 708     unless ($self->{suffixes} && @{$self->{suffixes}}) {
 709         my $fmClass = Fieldmapper::class_for_hint('acns');
 710         my @classFields = $fmClass->real_fields();
 711         my $classTable = $fmClass->Table();
 712         my $query = 'select ' . join(',', @classFields);
 713         $query .= "\nfrom $classTable";
 714         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 715         my @suffixes = map {$fmClass->from_bare_hash($_)} @{$result};
 716         $self->{suffixes} = \@suffixes;
 717     }
 718
 719     return @{$self->{suffixes}};
 720 }
 721
 722 # Returns an array of acn objects for a given bre object or id.
 723 sub acns_for_bre {
 724     my $self = shift;
 725     my $bre = shift;
 726     $bre = $bre->id() if (ref($bre));
 727
 728     unless ($self->{acnHandle}) {
 729         my $query = "select " . join(',', $self->{acnClass}->real_fields());
 730         $query .= "\nfrom " . $self->{acnClass}->Table();
 731         $query .= "\nwhere record = ?";
 732         if (@{$self->{libs}}) {
 733             $query .= "\nand owning_lib in (";
 734             $query .= join(',', @{$self->{libs}}) . ")";
 735         }
 736         $query .= "\nand deleted = 'f'" unless($Marque::config->option_value('since'));
 737         $self->{acnHandle} = $self->{handle}->prepare($query);
 738     }
 739
 740     if ($self->{acnHandle}->execute($bre)) {
 741         my $result = $self->{acnHandle}->fetchall_arrayref({});
 742         return map {$self->{acnClass}->from_bare_hash($_)} @{$result};
 743     }
 744
 745     # If for some reason, we don't find anything.
 746     return undef;
 747 }
 748
 749 # Returns an array of acp objects for a given bre object or id.
 750 sub acps_for_bre {
 751     my $self = shift;
 752     my $bre = shift;
 753     $bre = $bre->id() if (ref($bre));
 754
 755     my @orgs = $self->orgs();
 756     my @locations = $self->shelves();
 757     my @prefixes = $self->prefixes();
 758     my @suffixes = $self->suffixes();
 759     my @statuses = $self->statuses();
 760
 761     my @acns = $self->acns_for_bre($bre);
 762     if (@acns) {
 763         my $query = 'select ' . join(',', $self->{acpClass}->real_fields());
 764         $query .= "\nfrom " . $self->{acpClass}->Table();
 765         $query .= "\nwhere call_number in (";
 766         $query .= join(',', map {$_->id()} @acns);
 767         $query .= ")";
 768         $query .= "\nand deleted = 'f'" unless ($Marque::config->option_value('since'));
 769         my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 770         if ($result && @{$result}) {
 771             my @acps = map {$self->{acpClass}->from_bare_hash($_)} @{$result};
 772             foreach (@acps) {
 773                 my $cn = $_->call_number();
 774                 my $clib = $_->circ_lib();
 775                 my $loc = $_->location();
 776                 my $stat = $_->status();
 777                 my ($org) = grep {$_->id() == $clib} @orgs;
 778                 my ($acn) = grep {$_->id() == $cn} @acns;
 779                 my ($location) = grep {$_->id() == $loc} @locations;
 780                 my $olib = $acn->owning_lib();
 781                 my $pre = $acn->prefix();
 782                 my $suf = $acn->suffix();
 783                 my ($ccs) = grep {$_->id() == $stat} @statuses;
 784                 my ($acnp) = grep {$_->id() == $pre} @prefixes;
 785                 my ($acns) = grep {$_->id() == $suf} @suffixes;
 786                 my ($owner) = grep {$_->id() == $olib} @orgs;
 787                 $acn->owning_lib($owner);
 788                 $_->call_number($acn);
 789                 $_->circ_lib($org);
 790                 $_->location($location);
 791                 $_->call_number->prefix($acnp);
 792                 $_->call_number->suffix($acns);
 793                 $_->status($ccs);
 794             }
 795             return @acps;
 796         }
 797     }
 798
 799     # If for some reason, we don't find anything.
 800     return undef;
 801 }
 802
 803 # Retreive an array for sre objects when the --mfhd option is used.
 804 sub sres_for_bre {
 805     my $self = shift;
 806     my $bre = shift;
 807     $bre = $bre->id() if (ref($bre));
 808     my @sres;
 809     # Build a query to retrieve SREs when the MFHD option is passed.
 810     if ($Marque::config->option_value('mfhd')) {
 811         # Create a persistent handle as needed.
 812         unless ($self->{sreSth}) {
 813             my $query = "select " . join(',', $self->{sreClass}->real_fields());
 814             $query .= "\nfrom " . $self->{sreClass}->Table();
 815             $query .= "\nwhere record = ?";
 816             $query .= "\nand deleted = 'f'" unless ($Marque::config->option_value('since'));
 817             $self->{sreSth} = $self->{handle}->prepare($query);
 818         }
 819         if ($self->{sreSth}->execute($bre)) {
 820             while (my $data = $self->{sreSth}->fetchrow_hashref) {
 821                 push @sres, $self->{sreClass}->from_bare_hash($data);
 822             }
 823             $self->{sreSth}->finish; # Sometimes DBI complains.
 824         }
 825     }
 826     # May be empty.
 827     return @sres;
 828 }
 829
 830 # Get authority records from the database.
 831 package Marque::Authority;
 832
 833 sub new {
 834     my $class = shift;
 835     my $idlist = shift;
 836     my $self = {idlist => $idlist};
 837     $self->{handle} = Marque::Connector::connect(
 838         $Marque::config->database_settings);
 839     $self->{fmClass} = Fieldmapper::class_for_hint('are');
 840     $self->{since_date} = Date::Manip::Date->new;
 841     $self->{since_date}->parse($Marque::config->option_value('since'));
 842     bless $self, $class;
 843     return $self;
 844 }
 845
 846 sub build_query {
 847     my $self = shift;
 848
 849     # Get the information for are object from the Fieldmapper:
 850     my @fields  = $self->{fmClass}->real_fields();
 851     my $table = $self->{fmClass}->Table();
 852
 853     # Build the actual query.
 854     my $select = "select " . join(',', @fields);
 855     my $from = "from $table";
 856     my $where = 'where ';
 857
 858     # If we have an idlist, we pretty much ignore anything else.
 859     if ($self->{idlist} && @{$self->{idlist}}) {
 860         $where .= 'id in (' . join(',', @{$self->{idlist}}) . ')';
 861     } elsif ($Marque::config->option_value('since')) {
 862         my $since_str = Marque::Connector::db_date($self->{since_date});
 863         $where .= "edit_date > '$since_str'";
 864         $where .= " or create_date > '$since_str'";
 865     } else {
 866         # We want all non-deleted records.
 867         $where .= "deleted = 'f'";
 868     }
 869
 870     $self->{query} = $select . "\n" . $from . "\n" . $where;
 871 }
 872
 873 sub execute_query {
 874     my $self = shift;
 875     $self->build_query() unless ($self->{query});
 876     $self->{sth} = $self->{handle}->prepare($self->{query});
 877     return $self->{sth}->execute;
 878 }
 879
 880 sub next {
 881     my $self = shift;
 882     my $output;
 883     my $data = $self->{sth}->fetchrow_hashref;
 884
 885     if ($data) {
 886         my $format = $Marque::config->option_value('format');
 887         my $r = $self->{fmClass}->from_bare_hash($data);
 888         if ($format eq 'ARE') {
 889             $output = OpenSRF::Utils::JSON->perl2JSON($r);
 890         } else {
 891             my $marc;
 892             eval {
 893                 local $SIG{__WARN__} = sub {
 894                     my $message = "Warning from authority record " . $r->id() . ": "
 895                         . shift;
 896                     warn($message);
 897                 };
 898                 $marc = MARC::Record->new_from_xml($r->marc(),
 899                                                 $Marque::config->option_value('encoding'),
 900                                                 $Marque::config->option_value('format'));
 901             };
 902             if ($@) {
 903                 warn("Error in authority record " . $r->id() . ": $@");
 904                 import MARC::File::XML; # Reset SAX Parser.
 905                 return $self->next();
 906             }
 907             if ($Marque::config->option_value('replace_001')) {
 908                 my $tcn = $marc->field('001');
 909                 if ($tcn) {
 910                     $tcn->update($r->id());
 911                 } else {
 912                     $tcn = MARC::Field->new('001', $r->id());
 913                     $marc->insert_fields_ordered($tcn);
 914                 }
 915             }
 916             if ($Marque::config->option_value('since')) {
 917                 my $leader = $marc->leader();
 918                 if ($U->is_true($r->deleted())) {
 919                     substr($leader, 5, 1) = 'd';
 920                     $marc->leader($leader);
 921                 } else {
 922                     my $create_date = Date::Manip::Date->new;
 923                     $create_date->parse($r->create_date());
 924                     my $edit_date = Date::Manip::Date->new;
 925                     $edit_date->parse($r->edit_date());
 926                     if ($self->{since_date}->cmp($create_date) < 0) {
 927                         substr($leader, 5, 1) = 'n';
 928                         $marc->leader($leader);
 929                     } elsif ($self->{since_date}->cmp($edit_date) < 0) {
 930                         substr($leader, 5, 1) = 'c';
 931                         $marc->leader($leader);
 932                     }
 933                 }
 934             }
 935             if ($Marque::config->option_value('format') eq 'XML') {
 936                 eval {
 937                     local $SIG{__WARN__} = sub {
 938                         my $message = "Warning from authority record " . $r->id() . ": "
 939                             . shift;
 940                         warn($message);
 941                     };
 942                     $output = $marc->as_xml_record;
 943                     $output =~ s/^<\?.+?\?>$//mo;
 944                 };
 945                 if ($@) {
 946                     warn("Error in authority record " . $r->id() . ": $@");
 947                     return $self->next();
 948                 }
 949             } else {
 950                 eval {
 951                     local $SIG{__WARN__} = sub {
 952                         my $message = "Warning from authority record " . $r->id() . ": "
 953                             . shift;
 954                         warn($message);
 955                     };
 956                     $output = $marc->as_usmarc;
 957                 };
 958                 if ($@) {
 959                     warn("Error in authority record " . $r->id() . ": $@");
 960                     return $self->next();
 961                 }
 962             }
 963         }
 964     }
 965
 966     return $output;
 967 }
 968
 969 # ------------------------------------------------------------------
 970 # Since the ultimate output is largely independent of the type of the
 971 # records, we use a single subpackage to group our output routines.
 972 package Marque::Output;
 973
 974 sub output {
 975     my $extractor = shift;
 976     if ($extractor->execute_query) {
 977         if ($Marque::config->option_value('encoding') eq 'UTF-8') {
 978             binmode(STDOUT, ':utf8');
 979         } else {
 980             binmode(STDOUT, ':raw');
 981         }
 982
 983         &preamble;
 984         while (my $output = $extractor->next()) {
 985             print $output;
 986         }
 987         &postamble;
 988     } else {
 989         print STDERR $extractor->{query} if ($Marque::config->option_value('debug'));
 990         die "Database query failed!";
 991     }
 992 }
 993
 994 sub preamble {
 995     if ($Marque::config->option_value('format') eq 'XML') {
 996         my $encoding = $Marque::config->option_value('encoding');
 997         print <<PREAMBLE;
 998 <?xml version="1.0" encoding="$encoding"?>
 999 <collection xmlns='http://www.loc.gov/MARC21/slim'>
1000 PREAMBLE
1001     }
1002 }
1003
1004 sub postamble {
1005     if ($Marque::config->option_value('format') eq 'XML') {
1006         print "</collection>\n";
1007     }
1008 }
1009
1010 1;