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 die "IDs required but none entered, exiting\n" if ($config->need_ids() && !@ids);
  45
  46 my $exporter;
  47 if ($config->option_value('type') eq 'authority') {
  48     $exporter = Marque::Authority->new(\@ids);
  49 } else {
  50     $exporter = Marque::Biblio->new(\@ids);
  51 }
  52
  53 Marque::Output::output($exporter);
  54
  55 # ------------------------------------------------------------------
  56 package Marque::Config;
  57
  58 use Getopt::Long;
  59 use List::MoreUtils qw(none);
  60 use OpenSRF::System;
  61 use OpenSRF::Utils::SettingsClient;
  62
  63 use constant FORMATS => qw(USMARC UNIMARC XML BRE ARE);
  64 use constant STORES => qw(reporter cstore storage);
  65 use constant TYPES => qw(authority biblio);
  66
  67
  68 sub new {
  69     my $class = shift;
  70
  71     my $self = {};
  72
  73     # For command line options.
  74     my %opts;
  75
  76     # set some default values
  77     $opts{'format'} = 'USMARC';
  78     $opts{'encoding'} = 'UTF-8';
  79     $opts{'type'} = 'biblio';
  80     $opts{'money'} = '$';
  81     $opts{'timeout'} = 0;
  82     $opts{'config'} = '@sysconfdir@/opensrf_core.xml';
  83     $opts{'store'} = 'reporter';
  84     $opts{'852b'} = 'both';
  85     $opts{'batch-size'} = 10000;
  86
  87     GetOptions(\%opts,
  88                'help',
  89                'items',
  90                '852b=s',
  91                'exclude-hidden',
  92                'mfhd',
  93                'all',
  94                'replace_001',
  95                'strip=s@',
  96                'location=s',
  97                'money=s',
  98                'config=s',
  99                'format=s',
 100                'type=s',
 101                'xml-idl=s',
 102                'encoding|e=s',
 103                'timeout=i',
 104                'library=s@',
 105                'descendants=s@',
 106                'since=s',
 107                'store=s',
 108                'uris',
 109                'debug',
 110                'pipe',
 111                'batch-size=i');
 112
 113     if ($opts{help}) {
 114         print <<"HELP";
 115 This script exports MARC authority, bibliographic, and serial holdings
 116 records from an Evergreen database.
 117
 118 Input to this script can consist of a list of record IDs, with one record ID
 119 per line, corresponding to the record ID in the Evergreen database table of
 120 your requested record type.
 121
 122 Alternately, passing the --all option will attempt to export all records of
 123 the specified type from the Evergreen database. The --all option starts at
 124 record ID 1 and increments the ID by 1 until the largest ID in the database
 125 is retrieved. This may not be very efficient for databases with large gaps
 126 in their ID sequences.
 127
 128 Usage: $0 [options]
 129  --help or -h       This screen.
 130  --config or -c     Configuration file [@sysconfdir@/opensrf_core.xml]
 131  --format or -f     Output format (USMARC, UNIMARC, XML, BRE, ARE) [USMARC]
 132  --encoding or -e   Output encoding (UTF-8, ISO-8859-?, MARC8) [UTF-8]
 133  --xml-idl or -x    Location of the IDL XML
 134  --timeout          Remains for backward compatibility. No longer used.
 135  --type or -t       Record type (BIBLIO, AUTHORITY) [BIBLIO]
 136  --all or -a        Export all records; ignores input list
 137  --replace_001      Replace the 001 field value with the record ID
 138  --strip tagRE/subRE
 139                     Strip fields or subfields matching regular expressions
 140  --store            Use the given storage backend to connect to the database.
 141                     Choices are (reporter, cstore, storage) [reporter]
 142  --since            Export records modified since a certain date and time.
 143  --pipe             Force record ids to be read from list on standard input,
 144                     despite other options to the contrary
 145  --batch-size       Number of records to fetch at a time for processing
 146                     (default 10000). This option can be adjusted
 147                     depending on your database performance or
 148                     environment. Doing smaller batch sizes can
 149                     sometimes speed up the extraction. Finding the
 150                     best value for your situation requires
 151                     experimentation.
 152
 153  Additional options for type = 'BIBLIO':
 154  --items or -i      Include items (holdings) in the output
 155  --852b             Accepts 'owning_lib', 'circ_lib', or 'both' to
 156                     control whether the 852$b in exported embedded
 157                     holdings has the owning library, the circulation
 158                     library, or both in separate repeats of the $b.
 159                     If not supplied, defaults to 'both', which is the
 160                     legacy behavior.
 161  --money            Currency symbol to use in item price field [\$]
 162  --mfhd             Export serial MFHD records for associated bib records
 163                     Not compatible with --format=BRE
 164  --location or -l   MARC Location Code for holdings from
 165                     http://www.loc.gov/marc/organizations/orgshome.html
 166  --library          Export the bibliographic records that have attached
 167                     holdings for the listed library or libraries as
 168                     identified by shortname
 169  --descendants      Like the --library option, but org. tree aware. It
 170                     exports records that have attached holdings for the
 171                     specified org. unit and all of its descendants in
 172                     the tree.
 173  --uris or -u       Include records with located URIs in the output
 174  --exclude-hidden   Exclude records and items if the item is not
 175                     OPAC-visible per its org unit, status, shelving,
 176                     location, or flag on the item record. This option
 177                     is effective only if the --library and/or --items
 178                     flags are supplied. This option takes precedence;
 179                     for example, if the org unit specified by --library
 180                     is not OPAC-visible, its records will not be included
 181                     in the export.
 182
 183 Examples:
 184
 185 To export a set of USMARC records in a file named "output_file" based on the
 186 IDs contained in a file named "list_of_ids":
 187   cat list_of_ids | $0 > output_file
 188
 189 To export a set of MARC21XML authority records in a file named "output.xml"
 190 for all authority records in the database:
 191   $0 --format XML --type AUTHORITY --all > output.xml
 192
 193 To export a set of USMARC bibliographic records encoded in UTF-8 in a file
 194 named "sys1_bibs.mrc" based on records which have attached callnumbers for the
 195 libraries with the short names "BR1" and "BR2":
 196
 197   $0 --library BR1 --library BR2 --encoding UTF-8 > sys1_bibs.mrc
 198
 199 The --strip option can be used more than once which imples an "OR" operation.
 200 If the field argument is omitted (e.g., "/0", it is treated like "..." (all fields).
 201 If the subfield argument is omitted (e.g. "100/", it is treated like "."
 202 (all subfields).  Examples:
 203
 204   --strip /0      Remove all 0 subfields
 205   --strip 1[23].  Remove fields with tags 120 through 139, inclusive.
 206   --strip 856/x   Remove subfield x from 856 tags
 207 HELP
 208         exit;
 209     }
 210
 211     OpenSRF::System->bootstrap_client( config_file => $opts{config} );
 212     my $sclient = OpenSRF::Utils::SettingsClient->new();
 213     unless ($opts{'xml-idl'}) {
 214         $opts{'xml-idl'} = $sclient->config_value('IDL');
 215     }
 216
 217     # Validate some of the settings.
 218     if ($opts{all} && ($opts{library} || $opts{descendants})) {
 219         die('Incompatible arguments: you cannot combine a request for all ' .
 220                 'records with a request for records by library');
 221     }
 222     if ($opts{all} && $opts{since}) {
 223         die('Incompatible arguments: you cannot combine a request for all ' .
 224                 'records with a request for records added or changed since a certain date');
 225     }
 226     if ($opts{all} && $opts{pipe}) {
 227         die('Incompatible arguments: you cannot combine a request for all ' .
 228                 'records with the option to read record ids via standard input');
 229     }
 230     if ($opts{since} && $opts{pipe}) {
 231         die('Incompatible arguments: you cannot combine a request for records added or '.
 232                 'changed since a certain date with ' .
 233                 'the option to read record ids via standard input');
 234     }
 235     $opts{type} = lc($opts{type});
 236     if (none {$_ eq $opts{type}} (TYPES)) {
 237         die "Please select a supported type.  ".
 238             "Right now that means one of [".
 239                 join('|',(TYPES)). "]\n";
 240     }
 241     $opts{format} = uc($opts{format});
 242     if (none {$_ eq $opts{format}} (FORMATS)) {
 243         die "Please select a supported format.  ".
 244             "Right now that means one of [".
 245                 join('|',(FORMATS)). "]\n";
 246     }
 247     # Process --strip arguments.  They are in the form tagRE/subRE.  Note
 248     # that the RE pieces cannot contain a slash (/), as this would create
 249     # ambiguity.  If there is no /subRE, then it's OK, and just the tagRE
 250     # is specified.
 251     # $opts{strip} is an array-ref for this multi-valued option.
 252     my @strip = ();
 253
 254     foreach my $strip_value (@{$opts{strip}}) {
 255         my $trec = {};
 256         if ($strip_value eq "/") {
 257             print STDERR "Ignoring empty --strip parameter; all records would be empty.\n";
 258             next;
 259         }
 260         if ($strip_value =~ /\//) {
 261             $trec->{tag} = $`;
 262             $trec->{tag} = "..." if ($` eq "");
 263             $trec->{subfield} = $';
 264             $trec->{subfield} = "." if ($' eq "");
 265         } else {
 266             # No slash case
 267             $trec->{tag} = $strip_value;
 268             $trec->{subfield} = '';
 269         }
 270         push @strip, $trec;
 271     }
 272
 273     if ($opts{format} eq 'ARE' && $opts{type} ne 'authority') {
 274         die "Format ARE is not compatible with type " . $opts{type};
 275     }
 276     if ($opts{format} eq 'BRE' && $opts{type} ne 'biblio') {
 277         die "Format BRE is not compatible with type " . $opts{type};
 278     }
 279     if ($opts{format} eq 'BRE' && $opts{items}) {
 280         die "Format BRE is not compatible with exporting holdings."
 281     }
 282
 283     if ($opts{mfhd}) {
 284         if ($opts{type} ne 'biblio') {
 285             die "MFHD export only works with bibliographic records.";
 286         } elsif ($opts{format} eq 'BRE') {
 287             die "MFHD export incompatible with format BRE.";
 288         }
 289     }
 290
 291     if ($opts{'852b'} ne 'circ_lib' &&
 292         $opts{'852b'} ne 'owning_lib' &&
 293         $opts{'852b'} ne 'both') {
 294         die "Invalid value '" . $opts{'852b'} . "' for --852b; must be 'circ_lib', 'owning_lib', or 'both'";
 295     }
 296
 297     $opts{store} = lc($opts{store});
 298     if (none {$_ eq $opts{store}} (STORES)) {
 299         die "Please select a supported store.  ".
 300             "Right now that means one of [".
 301                 join('|',(STORES)). "]\n";
 302     } else {
 303         my $app;
 304         if ($opts{store} eq 'reporter') {
 305             $app = 'open-ils.reporter-store';
 306         } else {
 307             $app = 'open-ils.' . $opts{store};
 308         }
 309         if ($app eq 'open-ils.storage') {
 310             $self->{dbsettings} = $sclient->config_value(
 311                 apps => $app => app_settings => databases => 'database');
 312         } else {
 313             $self->{dbsettings} = $sclient->config_value(
 314                 apps => $app => app_settings => 'database');
 315         }
 316     }
 317     $opts{encoding} = uc($opts{encoding});
 318
 319     $opts{strip} = \@strip;
 320
 321     $self->{'options'} = \%opts;
 322     bless $self, $class;
 323     return $self;
 324 }
 325
 326 sub option_value {
 327     my ($self, $option) = @_;
 328     return $self->{options}->{$option};
 329 }
 330
 331 sub database_settings {
 332     my $self = shift;
 333     return $self->{dbsettings};
 334 }
 335
 336 sub need_ids {
 337     my $self = shift;
 338     my $rv = 1;
 339
 340     $rv = 0 if ($self->{options}->{since});
 341     $rv = 0 if ($self->{options}->{library});
 342     $rv = 0 if ($self->{options}->{descendants});
 343     # --pipe trumps the above.
 344     $rv = 1 if ($self->{options}->{pipe});
 345     # --all trumps --pipe, but we should throw an error before we get here.
 346     $rv = 0 if ($self->{options}->{all});
 347
 348     return $rv;
 349 }
 350
 351 # ------------------------------------------------------------------
 352 # This package exists to get a connection to the database.  Since
 353 # we'll need one for both biblio records and authorities, we've made a
 354 # single subpackage with a function so that we don't have to duplicate
 355 # code.
 356 package Marque::Connector;
 357
 358 use DBI;
 359
 360 # Pass a Marque::Config object's database_settings return value into
 361 # this to get a DBI connection.
 362 # ex:
 363 # my $db = Marque::Connector::connect($config->database_settings);
 364 sub connect {
 365     my $args = shift;
 366
 367     # Build a connect string from the args.
 368     my $connect_string = 'DBI:Pg:';
 369     $connect_string .= 'dbname=' . $args->{db} . ';';
 370     $connect_string .= 'host=' . $args->{host} . ';';
 371     $connect_string .= 'port=' . $args->{port};
 372
 373     my $db_handle = DBI->connect($connect_string,
 374                                  $args->{user}, $args->{pw});
 375     return $db_handle;
 376 }
 377
 378 # A function to get the date into a format better for PostgreSQL.
 379 sub db_date {
 380     my $input = shift;
 381     my $date;
 382     if (ref($input) eq 'Date::Manip::Date') {
 383         $date = $input;
 384     } else {
 385         $date = Date::Manip::Date->new();
 386         if ($date->parse($input)) {
 387             die "Can't parse date $input";
 388         }
 389     }
 390     return $date->printf("%Y-%m-%dT%H:%M:%S%z");
 391  }
 392
 393 # ------------------------------------------------------------------
 394 # You would typically have the next two packages inherit from a common
 395 # superclass, but ineritance doesn't seem to work when all packages
 396 # are in single file, so we have some duplicated code between these
 397 # two.
 398
 399 # Get bibliographic records from the database.
 400 package Marque::Biblio;
 401
 402 sub new {
 403     my $class = shift;
 404     my $idlist = shift;
 405     my $self = {idlist => $idlist};
 406     $self->{handle} = Marque::Connector::connect(
 407         $Marque::config->database_settings);
 408     $self->{since_date} = Date::Manip::Date->new;
 409     $self->{since_date}->parse($Marque::config->option_value('since'));
 410
 411     # We need multiple fieldmapper classes depending on our
 412     # options. We'll just get the information that we'll need for them
 413     # all right here instead of only fetching the information when
 414     # needed.
 415     $self->{breClass} = Fieldmapper::class_for_hint('bre');
 416     $self->{acnClass} = Fieldmapper::class_for_hint('acn');
 417     $self->{acpClass} = Fieldmapper::class_for_hint('acp');
 418     $self->{sreClass} = Fieldmapper::class_for_hint('sre');
 419     $self->{acnpClass} = Fieldmapper::class_for_hint('acnp');
 420     $self->{acnsClass} = Fieldmapper::class_for_hint('acns');
 421     $self->{auricnmClass} = Fieldmapper::class_for_hint('auricnm');
 422
 423     # Make an arrayref of shortname ids if the library option was
 424     # specified:
 425     $self->{libs} = [];
 426     if ($Marque::config->option_value('library')) {
 427         # This is done not only for speed, but to prevent SQL injection.
 428         my $query = 'select id from actor.org_unit where shortname=any(?::text[])';
 429         if ($Marque::config->option_value('exclude-hidden')) {
 430             $query .= ' AND opac_visible';
 431         }
 432         my $sth = $self->{handle}->prepare($query);
 433         if ($sth->execute($Marque::config->option_value('library'))) {
 434             my $r = $sth->fetchall_arrayref();
 435             my @ids = map {$_->[0]} @{$r};
 436             $self->{libs} = \@ids;
 437             $sth->finish();
 438         }
 439     }
 440     # Ditto for descendants.  We don't worry about redundancy, the db can deal with it.
 441     if ($Marque::config->option_value('descendants')) {
 442         # Unlike the above, we're looping to make this simpler in the database.
 443         my $query = 'select id, opac_visible from actor.org_unit_descendants((select id from actor.org_unit where shortname=?))';
 444         my $sth = $self->{handle}->prepare($query);
 445         foreach my $shortname (@{$Marque::config->option_value('descendants')}) {
 446             if ($sth->execute($shortname)) {
 447                 my $r = $sth->fetchall_arrayref();
 448                 my @ids = ();
 449                 if ($Marque::config->option_value('exclude-hidden')) {
 450                     @ids = map {$_->[0]} grep {$_->[1]} @{$r};
 451                 } else {
 452                     @ids = map {$_->[0]} @{$r};
 453                 }
 454                 push(@{$self->{libs}}, @ids);
 455                 $sth->finish();
 456             }
 457         }
 458     }
 459
 460     bless $self, $class;
 461     return $self;
 462 }
 463
 464 sub build_query {
 465     my $self = shift;
 466
 467     # TODO: There is some unfortunate code repetition in this
 468     # subroutine and it is now about 93 lines long with comments and
 469     # whitespace.  It should probably be refactored into a series of
 470     # smaller subroutines to avoid the repetition.
 471
 472     # Get the field names and tables for our classes. We add the fully
 473     # qualified table names to the fields so that the joins will work.
 474     my $breTable = $self->{breClass}->Table();
 475     my @breFields = map {$breTable . '.' . $_} $self->{breClass}->real_fields();
 476     my $acnTable = $self->{acnClass}->Table();
 477     my $acpTable = $self->{acpClass}->Table();
 478     my $acnpTable = $self->{acnpClass}->Table();
 479     my $acnsTable = $self->{acnsClass}->Table();
 480     my $auricnmTable = $self->{auricnmClass}->Table();
 481
 482     # Now we build the query in pieces:
 483
 484     # We always select the bre fields:
 485     my $select = 'select distinct ' . join(',', @breFields);
 486     # We always use the bre table.
 487     my $from = "from $breTable";
 488
 489     # If have the libraries or items options, we need to join the
 490     # asset.call_number table. If we have both, this variable checks
 491     # that it has already been joined so we don't create an invalid
 492     # query.
 493     my $acn_joined = 0;
 494     # Join to the acn table as needed for the library option.
 495     if (@{$self->{libs}}) {
 496         $acn_joined = 1;
 497         $from .= <<ACN_JOIN;
 498
 499 join $acnTable on $acnTable.record = $breTable.id
 500 and $acnTable.owning_lib in (
 501 ACN_JOIN
 502         $from .= join(',', @{$self->{libs}}) . ")";
 503         $from .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 504     }
 505
 506     if ($Marque::config->option_value('items')) {
 507         unless ($acn_joined) {
 508             $from .= "\njoin $acnTable on $acnTable.record = $breTable.id";
 509             if ($Marque::config->option_value('exclude-hidden')) {
 510                 $from .= "\n AND $acnTable.owning_lib in (select id from actor.org_unit where opac_visible)";
 511             }
 512             $from .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 513         }
 514         $from .= "\njoin $acpTable on $acpTable.call_number = $acnTable.id";
 515         $from .= "\nand $acpTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 516         $from .= "\nand $acpTable.opac_visible" if ($Marque::config->option_value('exclude-hidden'));
 517         $from .= "\nleft outer join $acnpTable on $acnTable.prefix = $acnpTable.id";
 518         $from .= "\nleft outer join $acnsTable on $acnTable.suffix = $acnsTable.id";
 519     }
 520
 521     # The where really depends on a few options:
 522     my $where = "where $breTable.id > 0 and ";
 523     # We fill in the where as necessary.
 524     if ($self->{idlist} && @{$self->{idlist}}) {
 525         $where .= "$breTable.id in (" . join(',', @{$self->{idlist}}) . ')';
 526     } elsif ($Marque::config->option_value('since')) {
 527         my $since_str = Marque::Connector::db_date($self->{since_date});
 528         $where .= "($breTable.edit_date > '$since_str'";
 529         $where .= " or $breTable.create_date > '$since_str')";
 530     } else {
 531         # We want all non-deleted records.
 532         $where .= "$breTable.deleted = 'f'";
 533     }
 534
 535     # Support the --uris option.  It is orthogonal to --items, so we
 536     # may have to build a second query to use with a UNION DISTINCT.
 537     my $uri_union = "";
 538     if ($Marque::config->option_value('uris')) {
 539         if ($Marque::config->option_value('items')) {
 540             # Build UNION DISTINCT for main query.
 541             $uri_union = "\nunion distinct\n";
 542             $uri_union .= $select;
 543             $uri_union .= "\nfrom $breTable";
 544             $uri_union .= "\njoin $acnTable on $acnTable.record = $breTable.id";
 545             $uri_union .= "\nand $acnTable.owning_lib in (" . join(',', @{$self->{libs}}) . ")" if (@{$self->{libs}});
 546             $uri_union .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 547             $uri_union .= "\njoin $auricnmTable on $auricnmTable.call_number = $acnTable.id";
 548             $uri_union .= "\n$where";
 549         } else {
 550             unless ($acn_joined) {
 551                 $from .= "\njoin $acnTable on $acnTable.record = $breTable.id";
 552                 $from .= "\nand $acnTable.deleted = 'f'" unless ($Marque::config->option_value('since'));
 553             }
 554             $from .= "\njoin $auricnmTable on $auricnmTable.call_number = $acnTable.id";
 555         }
 556     }
 557
 558     $self->{query} = $select . "\n" . $from . "\n" . $where;
 559     $self->{query} .= $uri_union if ($uri_union);
 560     $self->{query} .= "\n" . "order by id"; #sort results by bre id.
 561 }
 562
 563 sub execute_query {
 564     my $self = shift;
 565     $self->build_query() unless ($self->{query});
 566     unless ($self->{cursor}) {
 567         $self->{cursor} = 'DECLARE bibs CURSOR WITH HOLD FOR ' . $self->{query};
 568         $self->{handle}->do($self->{cursor});
 569         $self->{fetchcmd} = 'fetch ' . $Marque::config->option_value('batch-size') . ' from bibs';
 570     }
 571     $self->{sth} = $self->{handle}->prepare($self->{fetchcmd});
 572     return $self->{sth}->execute;
 573 }
 574
 575 sub next {
 576     my $self = shift;
 577     my $output;
 578
 579     # $r holds the record object, either sre or bre.  $marc holds the
 580     # current record's MARC, either sre.marc or bre.marc
 581     my ($r,$marc);
 582     # If we have the mfhd option and we've previously retrieved some
 583     # sres, then we output one of the retrieved sres for each call
 584     # until we run out.  These sres "go with" the previous bib record.
 585     if ($Marque::config->option_value('mfhd') && $self->{mfhds} && @{$self->{mfhds}}) {
 586         $r = shift(@{$self->{mfhds}});
 587         eval {
 588             local $SIG{__WARN__} = sub {
 589                 my $message = "Warning from serial record " . $r->id() . ": "
 590                     . shift;
 591                 warn($message);
 592             };
 593             $marc = MARC::Record->new_from_xml($r->marc(),
 594                                                $Marque::config->option_value('encoding'),
 595                                                $Marque::config->option_value('format'));
 596         };
 597         if ($@) {
 598             warn("Error in serial record " . $r->id() . ": $@");
 599             import MARC::File::XML; # Reset SAX Parser.
 600             return $self->next();
 601         }
 602     } else {
 603         my $data = $self->{sth}->fetchrow_hashref;
 604
 605         unless ($data){
 606             # We ran out of data, so fetch the next batch.
 607             if ($self->execute_query()) {
 608                 $data = $self->{sth}->fetchrow_hashref;
 609             }
 610         }
 611
 612         if ($data) {
 613             $r = $self->{breClass}->from_bare_hash($data);
 614             if ($Marque::config->option_value('format') eq 'BRE') {
 615                 $output = OpenSRF::Utils::JSON->perl2JSON($r);
 616             } else {
 617                 eval {
 618                     local $SIG{__WARN__} = sub {
 619                         my $message = "Warning from bibliographic record " . $r->id() . ": "
 620                             . shift;
 621                         warn($message);
 622                     };
 623                     $marc = MARC::Record->new_from_xml($r->marc(),
 624                                                        $Marque::config->option_value('encoding'),
 625                                                        $Marque::config->option_value('format'));
 626                 };
 627                 if ($@) {
 628                     warn("Error in bibliographic record " . $r->id() . ": $@");
 629                     import MARC::File::XML; # Reset SAX Parser.
 630                     return $self->next();
 631                 }
 632                 if ($Marque::config->option_value('replace_001')) {
 633                     my $tcn = $marc->field('001');
 634                     if ($tcn) {
 635                         $tcn->update($r->id());
 636                     } else {
 637                         $tcn = MARC::Field->new('001', $r->id());
 638                         $marc->insert_fields_ordered($tcn);
 639                     }
 640                 }
 641
 642                 my $strip_arg_ref = $Marque::config->option_value('strip');
 643                 my @strip = @{$strip_arg_ref};
 644                 foreach my $strip_ref (@strip) {
 645                     my $tagRE = $strip_ref->{tag};
 646                     my $subfieldRE = $strip_ref->{subfield};
 647
 648                     if ( $subfieldRE eq "") {
 649                         # Case 1: Field only check, e.g. "--strip 5.[0,1]"
 650                         # If the supplied regexp matches the field, then
 651                         # delete that field.
 652                         foreach my $test_field ($marc->fields()) {
 653                             if ($test_field->tag() =~ /$tagRE/) {
 654                                 # A hit!
 655                                 $marc->delete_field($test_field);
 656                             }
 657                         }
 658                     } elsif ($subfieldRE ne "" && $tagRE ne "") {
 659                         # Case 2: Field & subfield supplied.
 660                         # Note a blank tag will be wildcarded to "*".
 661                         # Traverse fields, then traverse subfields if match
 662                         # is found.
 663                         foreach my $test_field ($marc->fields()) {
 664                             if ( !$test_field->is_control_field() &&
 665                                  $test_field->tag() =~ /$tagRE/) {
 666                                 # Traverse all subfields:
 667                                 foreach my $test_subfield ($test_field->subfields()) {
 668                                     my $sfcode = @{$test_subfield}[0];
 669                                     if ($sfcode =~ /$subfieldRE/) {
 670                                         $test_field->delete_subfield($sfcode);
 671                                     }
 672                                 }
 673                             }
 674                         }
 675                     }
 676                 }
 677
 678                 if ($Marque::config->option_value('items')) {
 679                     # If --items was passed discard any static 852 fields; they're either dupes, out-of-sync, or junk.
 680                     $marc->delete_fields($marc->field('852'));
 681                     my @acps = $self->acps_for_bre($r);
 682                     my @itemtags = ();
 683                     my $itemcount = 0;
 684
 685                     foreach my $acp (@acps) {
 686                         next unless ($acp);
 687                         if ($Marque::config->option_value('exclude-hidden')) {
 688                             next unless $U->is_true($acp->status()->opac_visible());
 689                             next unless $U->is_true($acp->location()->opac_visible());
 690                         }
 691                         my $location = $Marque::config->option_value('location');
 692                         my $price = ($acp->price() ? $Marque::config->option_value('money').$acp->price() : '');
 693                         my $prefix = $acp->call_number()->prefix()->label();
 694                         my $suffix = $acp->call_number()->suffix()->label();
 695                         my $status = $acp->status()->name();
 696                         eval {
 697                             local $SIG{__WARN__} = sub {
 698                                 my $message = "Warning from bibliographic record " . $r->id() . ": "
 699                                     . shift;
 700                                 warn($message);
 701                             };
 702
 703                             my @sfb = ();
 704                             my $f852b_option = $Marque::config->option_value('852b');
 705                             if      ($f852b_option eq 'owning_lib') {
 706                                 @sfb = (
 707                                     b => Encode::decode_utf8($acp->call_number()->owning_lib()->shortname()),
 708                                 );
 709                             } elsif ($f852b_option eq 'circ_lib') {
 710                                 @sfb = (
 711                                     b => Encode::decode_utf8($acp->circ_lib()->shortname()),
 712                                 );
 713                             } else {
 714                                 @sfb = (
 715                                     b => Encode::decode_utf8($acp->call_number()->owning_lib()->shortname()),
 716                                     b => Encode::decode_utf8($acp->circ_lib()->shortname()),
 717                                 );
 718                             }
 719
 720                             $itemcount++;
 721                             push(
 722                                 @itemtags,
 723                                 MARC::Field->new(
 724                                     '852', '4', ' ',
 725                                     ($location ? ('a' => $location) : ()),
 726                                     @sfb,
 727                                     c => Encode::decode_utf8($acp->location()->name()),
 728                                     ($prefix ? (k => Encode::decode_utf8($prefix)) : ()),
 729                                     j => Encode::decode_utf8($acp->call_number()->label()),
 730                                     ($suffix ? (m => Encode::decode_utf8($suffix)) : ()),
 731                                     ($acp->circ_modifier() ? (g => Encode::decode_utf8($acp->circ_modifier())) : ()),
 732                                     p => Encode::decode_utf8($acp->barcode()),
 733                                     s => Encode::decode_utf8($status),
 734                                     ($price ? (y => Encode::decode_utf8($price)) : ()),
 735                                     ($acp->copy_number() ? (t => $acp->copy_number()) : ()),
 736                                     ($U->is_true($acp->ref()) ? (x => 'reference') : ()),
 737                                     (!$U->is_true($acp->holdable()) ? (x => 'unholdable') : ()),
 738                                     (!$U->is_true($acp->circulate()) ? (x => 'noncirculating') : ()),
 739                                     (!$U->is_true($acp->opac_visible()) ? (x => 'hidden') : ())
 740                                 ));
 741                         };
 742                         if ($@) {
 743                             warn("Error in bibliographic record " . $r->id() . ": $@");
 744                             import MARC::File::XML; # Reset SAX Parser.
 745                             return $self->next();
 746                         }
 747                     }
 748                     my $firsttag = shift @itemtags;
 749                     if ($firsttag) {
 750                         $marc->insert_grouped_field($firsttag);
 751                         if (@itemtags) {
 752                             $marc->insert_fields_after($firsttag,@itemtags);
 753                         }
 754                     }
 755
 756                     #Check if no items are visible, skip bib if empty and exclude-hidden is enabled
 757                     #Finally check if there are located uris and skip excluding the bib
 758                     return $self->next() if (!$itemcount
 759                                              and $Marque::config->option_value('exclude-hidden')
 760                                              and !($Marque::config->option_value('uris') and $self->uris_exist_for_bre($r)));
 761                 }
 762                 if ($Marque::config->option_value('mfhd')) {
 763                     $self->{mfhds} = [$self->sres_for_bre($r)];
 764                 }
 765             }
 766         }
 767     }
 768     # Common stuff that doesn't depend on record type.
 769     if ($marc) {
 770         if ($Marque::config->option_value('since')) {
 771             my $leader = $marc->leader();
 772             if ($U->is_true($r->deleted())) {
 773                 substr($leader, 5, 1) = 'd';
 774                 $marc->leader($leader);
 775             } else {
 776                 my $create_date = Date::Manip::Date->new;
 777                 $create_date->parse($r->create_date());
 778                 my $edit_date = Date::Manip::Date->new;
 779                 $edit_date->parse($r->edit_date());
 780                 if ($self->{since_date}->cmp($create_date) < 0) {
 781                     substr($leader, 5, 1) = 'n';
 782                     $marc->leader($leader);
 783                 } elsif ($self->{since_date}->cmp($edit_date) < 0) {
 784                     substr($leader, 5, 1) = 'c';
 785                     $marc->leader($leader);
 786                 }
 787             }
 788         }
 789         if ($Marque::config->option_value('format') eq 'XML') {
 790             eval {
 791                 local $SIG{__WARN__} = sub {
 792                     my $message = "Warning from bibliographic record " . $r->id() . ": "
 793                         . shift;
 794                     warn($message);
 795                 };
 796                 $output = $marc->as_xml_record;
 797                 $output =~ s/^<\?.+?\?>$//mo;
 798             };
 799             if ($@) {
 800                 warn("Error in bibliographic record " . $r->id() . ": $@");
 801                 return $self->next();
 802             }
 803         } else {
 804             eval {
 805                 local $SIG{__WARN__} = sub {
 806                     my $message = "Warning from bibliographic record " . $r->id() . ": "
 807                         . shift;
 808                     warn($message);
 809                 };
 810                 $output = $marc->as_usmarc;
 811             };
 812             if ($@) {
 813                 warn("Error in bibliographic record " . $r->id() . ": $@");
 814                 return $self->next();
 815             }
 816         }
 817     }
 818     return $output;
 819 }
 820
 821 # Returns a hash reference to aou objects in a hash, id as key.
 822 sub orgs {
 823     my $self = shift;
 824     unless ($self->{orgs} && %{$self->{orgs}}) {
 825         my $fmClass = Fieldmapper::class_for_hint('aou');
 826         my @classFields = $fmClass->real_fields();
 827         my $classTable = $fmClass->Table();
 828         my $query = 'select ' . join(',', @classFields);
 829         $query .= "\nfrom $classTable";
 830         my $sth = $self->{handle}->prepare($query);
 831         if ($sth->execute()) {
 832             my $result = $sth->fetchall_hashref('id');
 833             my %orgs = map {$_ => $fmClass->from_bare_hash($$result{$_})} keys %{ $result }; #translate with fieldmapper
 834             $self->{orgs} = \%orgs;
 835             #print STDERR Data::Dumper->new([\%orgs],[qw(orgs)])->Indent(3)->Quotekeys(0)->Dump;
 836         } else {
 837             $self->{orgs} = {};
 838         }
 839     }
 840     return $self->{orgs};
 841 }
 842
 843 # Returns a reference to a hash of acpl objects, id as key.
 844 sub shelves {
 845     my $self = shift;
 846
 847     unless ($self->{shelves} && %{$self->{shelves}}) {
 848         my $fmClass = Fieldmapper::class_for_hint('acpl');
 849         my @classFields = $fmClass->real_fields();
 850         my $classTable = $fmClass->Table();
 851         my $query = 'select ' . join(',', @classFields);
 852         $query .= "\nfrom $classTable";
 853         #my $result = $self->{handle}->selectall_arrayref($query, {Slice=>{}});
 854         my $result = $self->{handle}->selectall_hashref($query, 'id');
 855         #Translate into fieldmapper objects
 856         my %shelves = map {$_ => $fmClass->from_bare_hash($$result{$_})} keys %{ $result };
 857         $self->{shelves} = \%shelves;
 858     }
 859
 860     return $self->{shelves};
 861 }
 862
 863 # Returns an reference to a hash of ccs objects.
 864 sub statuses {
 865     my $self = shift;
 866
 867     unless ($self->{statuses} && %{$self->{statuses}}) {
 868         my $fmClass = Fieldmapper::class_for_hint('ccs');
 869         my @classFields = $fmClass->real_fields();
 870         my $classTable = $fmClass->Table();
 871         my $query = 'select ' . join(',', @classFields);
 872         $query .= "\nfrom $classTable";
 873         my $result = $self->{handle}->selectall_hashref($query, 'id');
 874         my %statuses = map {$_ => $fmClass->from_bare_hash($$result{$_})} keys %{ $result };
 875         $self->{statuses} = \%statuses;
 876     }
 877
 878     return $self->{statuses};
 879 }
 880
 881 # Returns a reference to a hash of acnp objects, id as key.
 882 sub prefixes {
 883     my $self = shift;
 884
 885     unless ($self->{prefixes} && %{$self->{prefixes}}) {
 886         my $fmClass = Fieldmapper::class_for_hint('acnp');
 887         my @classFields = $fmClass->real_fields();
 888         my $classTable = $fmClass->Table();
 889         my $query = 'select ' . join(',', @classFields);
 890         $query .= "\nfrom $classTable";
 891         my $result = $self->{handle}->selectall_hashref($query, 'id');
 892         my %prefixes = map {$_ => $fmClass->from_bare_hash($$result{$_})} keys %{ $result };
 893         $self->{prefixes} = \%prefixes;
 894     }
 895
 896     return $self->{prefixes};
 897 }
 898
 899 # Returns a reference to a hash of acns objects, id as key
 900 sub suffixes {
 901     my $self = shift;
 902
 903     unless ($self->{suffixes} && %{$self->{suffixes}}) {
 904         my $fmClass = Fieldmapper::class_for_hint('acns');
 905         my @classFields = $fmClass->real_fields();
 906         my $classTable = $fmClass->Table();
 907         my $query = 'select ' . join(',', @classFields);
 908         $query .= "\nfrom $classTable";
 909         my $result = $self->{handle}->selectall_hashref($query, 'id');
 910         my %suffixes = map {$_ => $fmClass->from_bare_hash($$result{$_})} keys %{ $result };
 911         $self->{suffixes} = \%suffixes;
 912     }
 913
 914     return $self->{suffixes};
 915 }
 916
 917 # Return true if an in scope uri exists for the given bre object or id.
 918 # Purpose is prevent excluding a bib if it has no copies but it does have scoped uris
 919 # Assumptions - --uris is in use, --items is in use and --exclude-hidden is in use
 920 sub uris_exist_for_bre {
 921     my $self = shift;
 922     my $bre = shift;
 923     $bre = $bre->id() if (ref($bre));
 924
 925     unless ($self->{acnUriHandle}) {
 926         my $acnTable = $self->{acnClass}->Table();
 927         my $auricnmTable = $self->{auricnmClass}->Table();
 928
 929         my $query = "select 1";
 930         $query .= "\nfrom $acnTable";
 931         $query .= "\njoin $auricnmTable on $auricnmTable.call_number = $acnTable.id";
 932         $query .= "\nwhere";
 933         $query .= "\n$acnTable.record = ?";
 934         $query .= "\nand $acnTable.owning_lib in (select id from actor.org_unit where opac_visible)";
 935         if (@{$self->{libs}}) {
 936                 $query .= "\nand owning_lib in (";
 937                 $query .= join(',', @{$self->{libs}}) . ")";
 938         }
 939         $query .= "\nand deleted = 'f'" unless($Marque::config->option_value('since'));
 940         $query .= "\nlimit 1";
 941         $self->{acnUriHandle} = $self->{handle}->prepare($query);
 942     }
 943
 944     if ($self->{acnUriHandle}->execute($bre)) {
 945         (my $result) = $self->{acnUriHandle}->fetchrow_array();
 946         return 1 if $result;
 947     }
 948
 949     # If for some reason, we don't find anything.
 950     return undef;
 951
 952 }
 953 # Returns an array of acn objects for a given bre object or id.
 954 sub acns_for_bre {
 955     my $self = shift;
 956     my $bre = shift;
 957     $bre = $bre->id() if (ref($bre));
 958
 959     unless ($self->{acnHandle}) {
 960         my $query = "select " . join(',', $self->{acnClass}->real_fields());
 961         $query .= "\nfrom " . $self->{acnClass}->Table();
 962         $query .= "\nwhere record = ?";
 963         if (@{$self->{libs}}) {
 964             $query .= "\nand owning_lib in (";
 965             $query .= join(',', @{$self->{libs}}) . ")";
 966         } elsif ($Marque::config->option_value('exclude-hidden')) {
 967             $query .= "\nand owning_lib in (select id from actor.org_unit where opac_visible)";
 968         }
 969         $query .= "\nand deleted = 'f'" unless($Marque::config->option_value('since'));
 970         $self->{acnHandle} = $self->{handle}->prepare($query);
 971     }
 972
 973     if ($self->{acnHandle}->execute($bre)) {
 974         my $result = $self->{acnHandle}->fetchall_arrayref({});
 975         return map {$self->{acnClass}->from_bare_hash($_)} @{$result};
 976     }
 977
 978     # If for some reason, we don't find anything.
 979     return undef;
 980 }
 981
 982 # Returns an array of acp objects for a given bre object or id.
 983 sub acps_for_bre {
 984     my $self = shift;
 985     my $bre = shift;
 986     $bre = $bre->id() if (ref($bre));
 987
 988     my $orgs = $self->orgs();
 989     my $locations = $self->shelves();
 990     my $prefixes = $self->prefixes();
 991     my $suffixes = $self->suffixes();
 992     my $statuses = $self->statuses();
 993
 994     my @acns = $self->acns_for_bre($bre);
 995     if (@acns) {
 996
 997         #Setup a prepared statement for the first call
 998         unless ($self->{acpHandle}) {
 999             my $query = 'select ' . join(',', $self->{acpClass}->real_fields());
1000             $query .= "\nfrom " . $self->{acpClass}->Table();
1001             $query .= "\nwhere call_number = ANY(?::INT[])";
1002             #$query .= join(',', map {$_->id()} @acns);
1003             #$query .= ")";
1004             $query .= "\nand deleted = 'f'" unless ($Marque::config->option_value('since'));
1005             $query .= "\nand opac_visible" if ($Marque::config->option_value('exclude-hidden'));
1006             $self->{acpHandle} = $self->{handle}->prepare($query);
1007         }
1008
1009         #Use the prepared statement
1010         my $result;
1011         my @acnsa = map {$_->id()} @acns;
1012         if ($self->{acpHandle}->execute( \@acnsa )) {
1013             $result = $self->{acpHandle}->fetchall_arrayref( {} );
1014         }
1015
1016         if ($result && @{$result}) {
1017             my @acps = map {$self->{acpClass}->from_bare_hash($_)} @{$result};
1018             foreach (@acps) {
1019                 my $cn = $_->call_number();
1020                 my ($acn) = grep {$_->id() == $cn} @acns;
1021                 $acn->owning_lib($orgs->{$acn->owning_lib()});
1022                 $_->call_number($acn);
1023                 $_->circ_lib($orgs->{$_->circ_lib()});
1024                 $_->location($locations->{$_->location()});
1025                 $_->status($statuses->{$_->status()});
1026                 $_->call_number->prefix($prefixes->{$acn->prefix()});
1027                 $_->call_number->suffix($suffixes->{$acn->suffix()});
1028             }
1029             return @acps;
1030         }
1031     }
1032
1033     # If for some reason, we don't find anything.
1034     return undef;
1035 }
1036
1037 # Retreive an array for sre objects when the --mfhd option is used.
1038 sub sres_for_bre {
1039     my $self = shift;
1040     my $bre = shift;
1041     $bre = $bre->id() if (ref($bre));
1042     my @sres;
1043     # Build a query to retrieve SREs when the MFHD option is passed.
1044     if ($Marque::config->option_value('mfhd')) {
1045         # Create a persistent handle as needed.
1046         unless ($self->{sreSth}) {
1047             my $query = "select " . join(',', $self->{sreClass}->real_fields());
1048             $query .= "\nfrom " . $self->{sreClass}->Table();
1049             $query .= "\nwhere record = ?";
1050             $query .= "\nand deleted = 'f'" unless ($Marque::config->option_value('since'));
1051             $self->{sreSth} = $self->{handle}->prepare($query);
1052         }
1053         if ($self->{sreSth}->execute($bre)) {
1054             while (my $data = $self->{sreSth}->fetchrow_hashref) {
1055                 push @sres, $self->{sreClass}->from_bare_hash($data);
1056             }
1057             $self->{sreSth}->finish; # Sometimes DBI complains.
1058         }
1059     }
1060     # May be empty.
1061     return @sres;
1062 }
1063
1064 # Get authority records from the database.
1065 package Marque::Authority;
1066
1067 sub new {
1068     my $class = shift;
1069     my $idlist = shift;
1070     my $self = {idlist => $idlist};
1071     $self->{handle} = Marque::Connector::connect(
1072         $Marque::config->database_settings);
1073     $self->{fmClass} = Fieldmapper::class_for_hint('are');
1074     $self->{since_date} = Date::Manip::Date->new;
1075     $self->{since_date}->parse($Marque::config->option_value('since'));
1076     bless $self, $class;
1077     return $self;
1078 }
1079
1080 sub build_query {
1081     my $self = shift;
1082
1083     # Get the information for are object from the Fieldmapper:
1084     my @fields  = $self->{fmClass}->real_fields();
1085     my $table = $self->{fmClass}->Table();
1086
1087     # Build the actual query.
1088     my $select = "select " . join(',', @fields);
1089     my $from = "from $table";
1090     my $where = 'where ';
1091
1092     # If we have an idlist, we pretty much ignore anything else.
1093     if ($self->{idlist} && @{$self->{idlist}}) {
1094         $where .= 'id in (' . join(',', @{$self->{idlist}}) . ')';
1095     } elsif ($Marque::config->option_value('since')) {
1096         my $since_str = Marque::Connector::db_date($self->{since_date});
1097         $where .= "edit_date > '$since_str'";
1098         $where .= " or create_date > '$since_str'";
1099     } else {
1100         # We want all non-deleted records.
1101         $where .= "deleted = 'f'";
1102     }
1103
1104     $self->{query} = $select . "\n" . $from . "\n" . $where;
1105 }
1106
1107
1108 sub execute_query {
1109     my $self = shift;
1110     $self->build_query() unless ($self->{query});
1111     unless ($self->{cursor}) {
1112         $self->{cursor} = 'DECLARE auths CURSOR WITH HOLD FOR ' . $self->{query};
1113         $self->{handle}->do($self->{cursor});
1114         $self->{fetchcmd} = 'fetch ' . $Marque::config->option_value('batch-size') . ' from auths';
1115     }
1116     $self->{sth} = $self->{handle}->prepare($self->{fetchcmd});
1117     return $self->{sth}->execute;
1118 }
1119
1120 sub next {
1121     my $self = shift;
1122     my $output;
1123     my $data = $self->{sth}->fetchrow_hashref;
1124
1125     unless ($data) {
1126         # We ran out of data, so try fetching the next batch.
1127         if ($self->execute_query()) {
1128             $data = $self->{sth}->fetchrow_hashref();
1129         }
1130     }
1131
1132     if ($data) {
1133         my $format = $Marque::config->option_value('format');
1134         my $r = $self->{fmClass}->from_bare_hash($data);
1135         if ($format eq 'ARE') {
1136             $output = OpenSRF::Utils::JSON->perl2JSON($r);
1137         } else {
1138             my $marc;
1139             eval {
1140                 local $SIG{__WARN__} = sub {
1141                     my $message = "Warning from authority record " . $r->id() . ": "
1142                         . shift;
1143                     warn($message);
1144                 };
1145                 $marc = MARC::Record->new_from_xml($r->marc(),
1146                                                 $Marque::config->option_value('encoding'),
1147                                                 $Marque::config->option_value('format'));
1148             };
1149             if ($@) {
1150                 warn("Error in authority record " . $r->id() . ": $@");
1151                 import MARC::File::XML; # Reset SAX Parser.
1152                 return $self->next();
1153             }
1154             if ($Marque::config->option_value('replace_001')) {
1155                 my $tcn = $marc->field('001');
1156                 if ($tcn) {
1157                     $tcn->update($r->id());
1158                 } else {
1159                     $tcn = MARC::Field->new('001', $r->id());
1160                     $marc->insert_fields_ordered($tcn);
1161                 }
1162             }
1163
1164             my $strip_arg_ref = $Marque::config->option_value('strip');
1165             my @strip = @{$strip_arg_ref};
1166
1167             foreach my $strip_ref (@strip) {
1168                 my $tagRE = $strip_ref->{tag};
1169                 my $subfieldRE = $strip_ref->{subfield};
1170
1171                 if ( $subfieldRE eq "") {
1172                     # Case 1: Field only check, e.g. "--strip 5.[0,1]"
1173                     # If the supplied regexp matches the field, then
1174                     # delete that field.
1175                     foreach my $test_field ($marc->fields()) {
1176                         if ($test_field->tag() =~ /$tagRE/) {
1177                             # A hit!
1178                             $marc->delete_field($test_field);
1179                         }
1180                     }
1181                 } elsif ($subfieldRE ne "" && $tagRE ne "") {
1182                     # Case 2: Field & subfield supplied.
1183                     # Note a blank tag will be wildcarded to "*".
1184                     # Traverse fields, then traverse subfields if match
1185                     # is found.
1186                     foreach my $test_field ($marc->fields()) {
1187                         if ( !$test_field->is_control_field() &&
1188                              $test_field->tag() =~ /$tagRE/) {
1189                             # Traverse all subfields:
1190                             foreach my $test_subfield ($test_field->subfields()) {
1191                                 my $sfcode = @{$test_subfield}[0];
1192                                 if ($sfcode =~ /$subfieldRE/) {
1193                                     $test_field->delete_subfield($sfcode);
1194                                 }
1195                             }
1196                         }
1197                     }
1198                 }
1199             }
1200
1201             if ($Marque::config->option_value('since')) {
1202                 my $leader = $marc->leader();
1203                 if ($U->is_true($r->deleted())) {
1204                     substr($leader, 5, 1) = 'd';
1205                     $marc->leader($leader);
1206                 } else {
1207                     my $create_date = Date::Manip::Date->new;
1208                     $create_date->parse($r->create_date());
1209                     my $edit_date = Date::Manip::Date->new;
1210                     $edit_date->parse($r->edit_date());
1211                     if ($self->{since_date}->cmp($create_date) < 0) {
1212                         substr($leader, 5, 1) = 'n';
1213                         $marc->leader($leader);
1214                     } elsif ($self->{since_date}->cmp($edit_date) < 0) {
1215                         substr($leader, 5, 1) = 'c';
1216                         $marc->leader($leader);
1217                     }
1218                 }
1219             }
1220             if ($Marque::config->option_value('format') eq 'XML') {
1221                 eval {
1222                     local $SIG{__WARN__} = sub {
1223                         my $message = "Warning from authority record " . $r->id() . ": "
1224                             . shift;
1225                         warn($message);
1226                     };
1227                     $output = $marc->as_xml_record;
1228                     $output =~ s/^<\?.+?\?>$//mo;
1229                 };
1230                 if ($@) {
1231                     warn("Error in authority record " . $r->id() . ": $@");
1232                     return $self->next();
1233                 }
1234             } else {
1235                 eval {
1236                     local $SIG{__WARN__} = sub {
1237                         my $message = "Warning from authority record " . $r->id() . ": "
1238                             . shift;
1239                         warn($message);
1240                     };
1241                     $output = $marc->as_usmarc;
1242                 };
1243                 if ($@) {
1244                     warn("Error in authority record " . $r->id() . ": $@");
1245                     return $self->next();
1246                 }
1247             }
1248         }
1249     }
1250
1251     return $output;
1252 }
1253
1254 # ------------------------------------------------------------------
1255 # Since the ultimate output is largely independent of the type of the
1256 # records, we use a single subpackage to group our output routines.
1257 package Marque::Output;
1258
1259 sub output {
1260     my $extractor = shift;
1261     if ($extractor->execute_query) {
1262         if ($Marque::config->option_value('encoding') eq 'UTF-8') {
1263             binmode(STDOUT, ':utf8');
1264         } else {
1265             binmode(STDOUT, ':raw');
1266         }
1267
1268         &preamble;
1269         while (my $output = $extractor->next()) {
1270             print $output;
1271         }
1272         &postamble;
1273     } else {
1274         print STDERR $extractor->{query} if ($Marque::config->option_value('debug'));
1275         die "Database query failed!";
1276     }
1277 }
1278
1279 sub preamble {
1280     if ($Marque::config->option_value('format') eq 'XML') {
1281         my $encoding = $Marque::config->option_value('encoding');
1282         print <<PREAMBLE;
1283 <?xml version="1.0" encoding="$encoding"?>
1284 <collection xmlns='http://www.loc.gov/MARC21/slim'>
1285 PREAMBLE
1286     }
1287 }
1288
1289 sub postamble {
1290     if ($Marque::config->option_value('format') eq 'XML') {
1291         print "</collection>\n";
1292     }
1293 }
1294
1295 1;