marc_export_custom/marc_export_custom

   1 #!/usr/bin/perl
   2 # vim:et:sw=4:ts=4:
   3 use strict;
   4 use warnings;
   5 use bytes;
   6
   7 use OpenSRF::System;
   8 use OpenSRF::EX qw/:try/;
   9 use OpenSRF::AppSession;
  10 use OpenSRF::Utils::JSON;
  11 use OpenSRF::Utils::SettingsClient;
  12 use OpenILS::Application::AppUtils;
  13 use OpenILS::Utils::Fieldmapper;
  14 use OpenILS::Utils::CStoreEditor;
  15
  16 use MARC::Record;
  17 use MARC::File::XML;
  18 use UNIVERSAL::require;
  19
  20 use Time::HiRes qw/time/;
  21 use Getopt::Long;
  22
  23 use Config::Simple;
  24 use Data::Dumper;
  25
  26 my @formats = qw/USMARC UNIMARC XML BRE ARE/;
  27
  28 my ($config,$format,$encoding,$location,$dollarsign,$idl,$help,$holdings,$timeout,$export_mfhd,$type,$all_records,$quiet) = ('/openils/conf/opensrf_core.xml','USMARC','MARC8','','$',0,undef,undef,0,undef,'biblio',undef,0);
  29 my ($exclusion_ini,$collapse_to_depth, $output_file);
  30 my $cfg;
  31 my $force901;
  32 my $onlyholdings;
  33 my $with_ebooks;
  34 my $field852_4b_type = 'collapsed';
  35
  36 GetOptions(
  37         'help'       => \$help,
  38         'items'      => \$holdings,
  39         'mfhd'       => \$export_mfhd,
  40         'all'        => \$all_records,
  41         'location=s' => \$location,
  42         'money=s'    => \$dollarsign,
  43         'config=s'   => \$config,
  44         'format=s'   => \$format,
  45         'type=s'     => \$type,
  46         'xml-idl=s'  => \$idl,
  47         'encoding=s' => \$encoding,
  48         'timeout=i'  => \$timeout,
  49         'force901'  => \$force901,
  50         'exclusion_ini=s' => \$exclusion_ini,
  51         'collapse_to_depth=i' => \$collapse_to_depth,
  52         'onlyholdings' => \$onlyholdings,
  53         'with-ebooks' => \$with_ebooks,
  54         'output-file=s' => \$output_file,
  55         'quiet' => \$quiet,
  56         'field-852-4b-type=s' => \$field852_4b_type,
  57 );
  58
  59 if ($exclusion_ini) {
  60         die "exclusion ini file does not exist" unless (-r $exclusion_ini and -s $exclusion_ini);
  61         $cfg = new Config::Simple($exclusion_ini)
  62 }
  63 unless($field852_4b_type =~ /^(collapsed?|circ|owning)/) {
  64     die sprintf("Invalid argument '%s' to --field-852-4b-type", $field852_4b_type);
  65 }
  66
  67 if ($help) {
  68 print <<"HELP";
  69 This script exports MARC authority, bibliographic, and serial holdings
  70 records from an Evergreen database.
  71
  72 Input to this script can consist of a list of record IDs, with one record ID
  73 per line, corresponding to the record ID in the Evergreen database table of
  74 your requested record type.
  75
  76 Alternately, passing the --all option will attempt to export all records of
  77 the specified type from the Evergreen database. The --all option starts at
  78 record ID 1 and increments the ID by 1 until the largest ID in the database
  79 is retrieved. This may not be very efficient for databases with large gaps
  80 in their ID sequences.
  81
  82 Usage: $0 [options]
  83  --help or -h       This screen.
  84  --config or -c     Configuration file [/openils/conf/opensrf_core.xml]
  85  --format or -f     Output format (USMARC, UNIMARC, XML, BRE, ARE) [USMARC]
  86  --encoding or -e   Output encoding (UTF-8, ISO-8859-?, MARC8) [MARC8]
  87  --xml-idl or -x    Location of the IDL XML
  88  --timeout          Timeout for exporting a single record; increase if you
  89                     are using --holdings and are exporting records that
  90                     have a lot of items attached to them.
  91  --type or -t       Record type (BIBLIO, AUTHORITY) [BIBLIO]
  92  --all or -a        Export all records; ignores input list
  93
  94  Additional options for type = 'BIBLIO':
  95  --items or -i      Include items (holdings) in the output
  96  --money            Currency symbol to use in item price field [\$]
  97  --mfhd             Export serial MFHD records for associated bib records
  98                     Not compatible with --format=BRE
  99  --location or -l   MARC Location Code for holdings from
 100                     http://www.loc.gov/marc/organizations/orgshome.html
 101
 102  Options added by Sitka:
 103  --force901                 Force-add 901 fields
 104  --exclusion_ini FILENAME   Config::Simple based INI file for excluding holdings from the export
 105  --collapse_to_depth 2      Depth to collapse holdings.  Any holdings at a depth below
 106                             will be collapsed up to the parent org unit at the set depth
 107  --onlyholdings             Clean out 852s before adding new ones, and only export items that
 108                             successfully recieved an 852 field
 109  --with-ebooks              Include records with 856 fields, even if they have no holdings
 110  --field-852-4b-type TYPE   TYPE IN 'circ', 'owning', 'collapsed' (default)
 111                             What library should be displayed in field 852 4\$b?
 112
 113 Examples:
 114
 115 To export a set of USMARC records in a file named "output_file" based on the
 116 IDs contained in a file named "list_of_ids":
 117   cat list_of_ids | $0 > output_file
 118
 119 To export a set of MARC21XML authority records in a file named "output.xml"
 120 for all authority records in the database:
 121   $0 --format XML --type AUTHORITY --all > output.xml
 122
 123 HELP
 124     exit;
 125 }
 126
 127 $type = lc($type);
 128 $format = uc($format);
 129 $encoding = uc($encoding);
 130
 131 my $outfh;
 132 my $real_stdout;
 133 open($real_stdout, ">&STDOUT") or die "Can't dup STDOUT: $!";
 134 if($output_file) {
 135     open($outfh, '>', $output_file) or die "Can't open file for output $output_file: $!";
 136 } else {
 137     $outfh = $real_stdout;
 138 }
 139
 140 binmode($outfh, ':raw') if ($encoding ne 'UTF-8');
 141 binmode($outfh, ':utf8') if ($encoding eq 'UTF-8');
 142
 143 if (!grep { $format eq $_ } @formats) {
 144     die "Please select a supported format.  ".
 145         "Right now that means one of [".
 146         join('|',@formats). "]\n";
 147 }
 148
 149 if ($format ne 'XML') {
 150     my $type = 'MARC::File::' . $format;
 151     $type->require;
 152 }
 153
 154 if ($timeout <= 0) {
 155     # set default timeout and/or correct silly user who
 156     # supplied a negative timeout; default timeout of
 157     # 300 seconds if exporting items determined empirically.
 158     $timeout = $holdings ? 300 : 1;
 159 }
 160
 161 OpenSRF::System->bootstrap_client( config_file => $config );
 162
 163 if (!$idl) {
 164     $idl = OpenSRF::Utils::SettingsClient->new->config_value("IDL");
 165 }
 166
 167 Fieldmapper->import(IDL => $idl);
 168
 169 my $ses = OpenSRF::AppSession->create('open-ils.cstore');
 170 OpenILS::Utils::CStoreEditor::init();
 171 my $editor = OpenILS::Utils::CStoreEditor->new();
 172
 173 print $outfh <<HEADER if ($format eq 'XML');
 174 <?xml version="1.0" encoding="$encoding"?>
 175 <collection xmlns='http://www.loc.gov/MARC21/slim'>
 176 HEADER
 177
 178 my %orgs;
 179 my %shelves;
 180 my %statuses;
 181 my %outypes;
 182
 183 my $flesh = {};
 184
 185 if ($holdings) {
 186     get_bib_locations();
 187 }
 188
 189 my $start = time;
 190 my $last_time = time;
 191 my %count = ('bib' => 0, 'did' => 0);
 192 my $speed = 0;
 193
 194 if ($all_records) {
 195     my $top_record = 0;
 196     if ($type eq 'biblio') {
 197         $top_record = $editor->search_biblio_record_entry([
 198             {deleted => 'f'},
 199             {order_by => { 'bre' => 'id DESC' }, limit => 1}
 200         ])->[0]->id;
 201     } elsif ($type eq 'authority') {
 202         $top_record = $editor->search_authority_record_entry([
 203             {deleted => 'f'},
 204             {order_by => { 'are' => 'id DESC' }, limit => 1}
 205         ])->[0]->id;
 206     }
 207     for (my $i = 0; $i++ < $top_record;) {
 208         export_record($i);
 209     }
 210 } else {
 211     while ( my $i = <> ) {
 212         export_record($i);
 213     }
 214 }
 215
 216 print $outfh "</collection>\n" if ($format eq 'XML');
 217
 218 $speed = $count{did} / (time - $start);
 219 my $time = time - $start;
 220 print STDERR <<DONE;
 221
 222 Exports Attempted : $count{bib}
 223 Exports Completed : $count{did}
 224 Overall Speed     : $speed
 225 Total Time Elapsed: $time seconds
 226
 227 DONE
 228
 229 sub export_record {
 230     my $id = shift;
 231
 232     my $bib;
 233
 234     my $r = $ses->request( "open-ils.cstore.direct.$type.record_entry.retrieve", $id, $flesh );
 235     my $s = $r->recv(timeout => $timeout);
 236     if (!$s) {
 237         warn "\n!!!!! Failed trying to read record $id\n";
 238         return;
 239     }
 240     if ($r->failed) {
 241         warn "\n!!!!!! Failed trying to read record $id: " . $r->failed->stringify . "\n";
 242         return;
 243     }
 244     if ($r->timed_out) {
 245         warn "\n!!!!!! Timed out trying to read record $id\n";
 246         return;
 247     }
 248     $bib = $s->content;
 249     $r->finish;
 250
 251     $count{bib}++;
 252     return unless $bib;
 253     # Return if the bib is deleted
 254     return if ( $bib->deleted eq 't' );
 255
 256     if ($format eq 'ARE' or $format eq 'BRE') {
 257         print $outfh OpenSRF::Utils::JSON->perl2JSON($bib);
 258         stats() unless $quiet;
 259         $count{did}++;
 260         return;
 261     }
 262
 263     try {
 264
 265         my $r = MARC::Record->new_from_xml( $bib->marc, $encoding, $format );
 266         if ($type eq 'biblio') {
 267
 268             if($onlyholdings){
 269                 # Remove old 852 fields
 270                 my @f = $r->field('852');
 271                 $r->delete_fields(@f) if @f;
 272                 # Add new 852 fields
 273                 add_bib_holdings($bib, $r);
 274                 # Check that at least one 852 was added
 275                 @marc852 = $r->field('852');
 276                 @marc856 = $r->field('856');
 277                 # If not, we should NOT add this item to the export
 278                 # ... but we may still want the record if it has an 856
 279                 return unless ( @marc852 || ($with_ebooks && @marc856) );
 280             } else {
 281                 add_bib_holdings($bib, $r);
 282             }
 283         }
 284
 285         if($force901){
 286             $r->delete_field( $r->field('901') );
 287             $r->append_fields(
 288                 MARC::Field->new(
 289                     '901', ' ', ' ',
 290                     a => $bib->tcn_value,
 291                     b => $bib->tcn_source,
 292                     c => $bib->id
 293                 )
 294             );
 295         }
 296
 297         my $recordstr = undef;
 298
 299         if ($format eq 'XML') {
 300             my $xml = $r->as_xml_record;
 301             $xml =~ s/^<\?.+?\?>$//mo;
 302             $recordstr = $xml;
 303         } elsif ($format eq 'UNIMARC') {
 304             $recordstr = $r->as_usmarc;
 305         } elsif ($format eq 'USMARC') {
 306             $recordstr = $r->as_usmarc;
 307         }
 308         eval {
 309             if($format eq  'UNIMARC' or $format eq 'USMARC') {
 310                 my $rec = MARC::File::USMARC->decode($recordstr);
 311                 #throw Error::Simple('Reparsed MARC is not identical') if($recordstr ne $rec->as_usmarc);
 312             } elsif($format eq 'XML') {
 313                 my $rec = MARC::Record->new_from_xml($recordstr, 'utf8', 'UNIMARC');
 314                 #my $tmp = $rec->as_xml_record;
 315                 #$tmp =~ s/^<\?.+?\?>$//mo;
 316                 #throw Error::Simple('Reparsed XML is not identical') if($tmp ne $recordstr);
 317             }
 318         } or throw Error::Simple("Failed to parse MARC record back: $!");
 319         print $outfh $recordstr;
 320
 321         $count{did}++;
 322
 323     } otherwise {
 324         my $e = shift;
 325         my $errorid = $id;
 326         chomp($errorid);
 327         chomp($e);
 328         warn "\nERROR ON RECORD $errorid: $e\n";
 329         import MARC::File::XML; # reset SAX parser so that one bad record doesn't kill the entire export
 330     };
 331
 332     if ($export_mfhd and $type eq 'biblio') {
 333         my $mfhds = $editor->search_serial_record_entry({record => $id, deleted => 'f'});
 334         foreach my $mfhd (@$mfhds) {
 335             try {
 336                 my $r = MARC::Record->new_from_xml( $mfhd->marc, $encoding, $format );
 337
 338                 if($force901){
 339                     $r->delete_field( $r->field('901') );
 340                     $r->append_fields(
 341                         MARC::Field->new(
 342                             '901', ' ', ' ',
 343                             a => $bib->tcn_value,
 344                             b => $bib->tcn_source,
 345                             c => $bib->id
 346                         )
 347                     );
 348                 }
 349
 350                 if ($format eq 'XML') {
 351                     my $xml = $r->as_xml_record;
 352                     $xml =~ s/^<\?.+?\?>$//mo;
 353                     print $outfh $xml;
 354                 } elsif ($format eq 'UNIMARC') {
 355                     print $outfh $r->as_usmarc;
 356                 } elsif ($format eq 'USMARC') {
 357                     print $outfh $r->as_usmarc;
 358                 }
 359             } otherwise {
 360                 my $e = shift;
 361                 my $errorid = chomp($id);
 362                 chomp($e);
 363                 warn "\nERROR ON MFHD RECORD $errorid: $e\n";
 364                 import MARC::File::XML; # reset SAX parser so that one bad record doesn't kill the entire export
 365             };
 366         }
 367     }
 368
 369     stats() if (!$quiet && ! ($count{bib} % 50 ));
 370 }
 371
 372 sub stats {
 373     try {
 374         no warnings;
 375
 376         $speed = $count{did} / (time - $start);
 377
 378         my $speed_now = ($count{did} - $count{did_last}) / (time - $count{time_last});
 379         my $cn_speed = $count{cn} / (time - $start);
 380         my $cp_speed = $count{cp} / (time - $start);
 381
 382         printf STDERR "\r  $count{did} of $count{bib} @  \%0.4f/s ttl / \%0.4f/s rt ".
 383                 "($count{cn} CNs @ \%0.4f/s :: $count{cp} CPs @ \%0.4f/s)\r",
 384                 $speed,
 385                 $speed_now,
 386                 $cn_speed,
 387                 $cp_speed;
 388     } otherwise {};
 389     $count{did_last} = $count{did};
 390     $count{time_last} = time;
 391 }
 392
 393 sub get_bib_locations {
 394     print STDERR "Retrieving Org Units ... " unless $quiet;
 395     my $r = $ses->request( 'open-ils.cstore.direct.actor.org_unit.search', { id => { '!=' => undef } } );
 396
 397     while (my $o = $r->recv) {
 398         die $r->failed->stringify if ($r->failed);
 399         $o = $o->content;
 400         last unless ($o);
 401         $orgs{$o->id} = $o;
 402     }
 403     $r->finish;
 404     print STDERR "OK\n";
 405
 406     print STDERR "Retrieving Copy statuses ... " unless $quiet;
 407     $r = $ses->request( 'open-ils.cstore.direct.config.copy_status.search', { id => { '!=' => undef } } );
 408
 409     while (my $sta = $r->recv) {
 410         die $r->failed->stringify if ($r->failed);
 411         $sta = $sta->content;
 412         last unless ($sta);
 413         $statuses{$sta->id} = $sta;
 414     }
 415     $r->finish;
 416     print STDERR "OK\n";
 417
 418     print STDERR "Retrieving OU types ... " unless $quiet;
 419     $r = $ses->request( 'open-ils.cstore.direct.actor.org_unit_type.search', { id => { '!=' => undef } } );
 420
 421     while (my $outy = $r->recv) {
 422         die $r->failed->stringify if ($r->failed);
 423         $outy = $outy->content;
 424         last unless ($outy);
 425         $outypes{$outy->id} = $outy;
 426     }
 427     $r->finish;
 428     print STDERR "OK\n";
 429
 430     print STDERR "Retrieving Shelving locations ... " unless $quiet;
 431     $r = $ses->request( 'open-ils.cstore.direct.asset.copy_location.search', { id => { '!=' => undef } } );
 432
 433     while (my $s = $r->recv) {
 434         die $r->failed->stringify if ($r->failed);
 435         $s = $s->content;
 436         last unless ($s);
 437         $shelves{$s->id} = $s;
 438     }
 439     $r->finish;
 440     print STDERR "OK\n";
 441
 442     $flesh = { flesh => 2, flesh_fields => { bre => [ 'call_numbers' ], acn => [ 'copies' ] } };
 443 }
 444
 445 sub add_bib_holdings {
 446     my $bib = shift;
 447     my $r = shift;
 448
 449     my $cn_list = $bib->call_numbers;
 450     if ($cn_list && @$cn_list) {
 451
 452         $count{cn} += @$cn_list;
 453
 454         my $cp_list = [ map { @{ $_->copies } } @$cn_list ];
 455         if ($cp_list && @$cp_list) {
 456
 457             my %cn_map;
 458             push @{$cn_map{$_->call_number}}, $_ for (@$cp_list);
 459
 460             CALLNUMMAP: for my $cn ( @$cn_list ) {
 461                 my $cn_map_list = $cn_map{$cn->id};
 462
 463                 # Ignore deleted copies
 464                 next CALLNUMMAP if ( $cn->deleted eq 't' );
 465
 466                 COPYMAP: for my $cp ( @$cn_map_list ) {
 467                     $count{cp}++;
 468
 469
 470                     my $owninglib = $cn->owning_lib;
 471                     my $circlib = $cp->circ_lib;
 472                     my $printlib = $cp->circ_lib;
 473
 474                     # Ignore deleted copies
 475                     next COPYMAP if ( $cp->deleted eq 't');
 476
 477                     if($cfg){
 478                         my $thisorg = $orgs{$circlib};
 479
 480                         if($collapse_to_depth){
 481                             while ( $outypes{ $thisorg->ou_type }->depth > $collapse_to_depth ){
 482                                 my $localcfg = $cfg->param(-block=> $thisorg->shortname);
 483                                 if( $localcfg->{'DontCollapse'} ){
 484                                     last;
 485                                 }
 486                                 if($thisorg->parent_ou){
 487                                     $thisorg = $orgs{$thisorg->parent_ou};
 488                                     $printlib = $thisorg->id;
 489                                 }
 490                             }
 491                         }
 492
 493                         $thisorg = $orgs{$circlib};
 494
 495
 496                         while( $thisorg ){
 497                             # load the local config from the .ini file for exclusions
 498                             my $localcfg = $cfg->param(-block=> $thisorg->shortname);
 499                             my $cfgparam;
 500
 501                             # if we see this setting, just skip that org
 502
 503                             $cfgparam = 'ExcludeEntireOrg';
 504                             if( $localcfg->{$cfgparam} )
 505                             { skipnote($bib->id, $cfgparam); next COPYMAP; }
 506
 507                             # what follows are exclusion rules
 508
 509                             # Excluded Flags
 510                             $cfgparam = 'Flags';
 511                             if($localcfg->{$cfgparam}){
 512                                 # this little line is just forcing scalars into an array so we can 'use strict' with Config::Simple
 513                                 my @flags = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}));
 514                                 if(grep( { $_ eq 'reference' } @flags) && ($cp->ref eq 't'))
 515                                 { skipnote($bib->id,"Flags: reference"); next COPYMAP; }
 516                                 if(grep( { $_ eq 'unholdable' } @flags) && ($cp->holdable eq 'f'))
 517                                 { skipnote($bib->id,"Flags: unholdable"); next COPYMAP; }
 518                                 if(grep( { $_ eq 'circulate' } @flags) && ($cp->circulate eq 'f'))
 519                                 { skipnote($bib->id,"Flags: circulate"); next COPYMAP; }
 520                                 if(grep( { $_ eq 'hidden' } @flags) && ($cp->opac_visible eq 'f'))
 521                                 { skipnote($bib->id,"Flags: hidden"); next COPYMAP; }
 522                             }
 523
 524                             # Excluded Circ Modifiers
 525                             $cfgparam = 'CircMods';
 526                             if($localcfg->{$cfgparam}){
 527                                 my $circmod = $cp->circ_modifier || "";
 528                                 my @circmods = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 529                                 if(grep( { $_ eq $circmod } @circmods) && @circmods)
 530                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 531                             }
 532                             # Inverse rule -- only include specified Circ Mods
 533                             $cfgparam = 'OnlyIncludeCircMods';
 534                             if($localcfg->{$cfgparam}){
 535                                 my $circmod = $cp->circ_modifier || "";
 536                                 my @circmods = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 537                                 unless(grep( { $_ and $_ eq $circmod } @circmods) && @circmods)
 538                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 539                             }
 540                             # Excluded Copy Statuses
 541                             $cfgparam = 'Statuses';
 542                             if($localcfg->{$cfgparam}){
 543                                 my @statuses = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 544                                 if(grep( { $_ eq $statuses{$cp->status}->name } @statuses) && @statuses)
 545                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 546                             }
 547                             # Excluded Locations
 548                             $cfgparam = 'Locations';
 549                             if($localcfg->{$cfgparam}){
 550                                 my @locations = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 551                                 if(grep( { $_ eq $shelves{$cp->location}->name } @locations) && @locations)
 552                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 553                             }
 554                             # Inverse rule - Only use the specified locations
 555                             $cfgparam = 'OnlyIncludeLocations';
 556                             if($localcfg->{$cfgparam}){
 557                                 my @locations = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{'Locations'}) );
 558                                 unless(grep( { $_ eq $shelves{$cp->location}->name } @locations) && @locations)
 559                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 560                             }
 561                             # exclude based on a regex match to location names
 562                             $cfgparam = 'LocationRegex';
 563                             if($localcfg->{$cfgparam}){
 564                                 my @locregex = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 565                                 my $reg = $localcfg->{$cfgparam};
 566                                 if(grep( { $shelves{$cp->location}->name =~ m/($reg)/ } @locregex) && @locregex)
 567                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 568                             }
 569                             # include based on a regex match to location names
 570                             $cfgparam = 'OnlyIncludeLocationRegex';
 571                             if($localcfg->{$cfgparam}){
 572                                 my @locregex = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 573                                 my $reg = $localcfg->{$cfgparam};
 574                                 unless(grep( { $shelves{$cp->location}->name =~ m/($reg)/ } @locregex) && @locregex)
 575                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 576                             }
 577                             # Exclude based on a callno regex
 578                             $cfgparam = 'CallNoRegex';
 579                             if($localcfg->{$cfgparam}){
 580                                 my @callnoregex = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 581                                 my $reg = $localcfg->{$cfgparam};
 582                                 if(grep( { $cn->label =~ m/($reg)/ } @callnoregex) && @callnoregex)
 583                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 584                             }
 585                             # Include based on a callno regex
 586                             $cfgparam = 'OnlyIncludeCallNoRegex';
 587                             if($localcfg->{$cfgparam}){
 588                                 my @callnoregex = ( (ref($localcfg->{$cfgparam}) eq "ARRAY") ? @{$localcfg->{$cfgparam}} : ($localcfg->{$cfgparam}) );
 589                                 my $reg = $localcfg->{$cfgparam};
 590                                 unless(grep( { $cn->label =~ m/($reg)/ } @callnoregex) && @callnoregex)
 591                                 { skipnote($bib->id,$cfgparam); next COPYMAP; }
 592                             }
 593
 594                             # Trim call number to a float and exclude based on Dewey Range
 595                             if($localcfg->{'DeweyGT'} || $localcfg->{'DeweyLT'}){
 596                                 my $gt = $localcfg->{'DeweyGT'};
 597                                 my $lt = $localcfg->{'DeweyLT'};
 598
 599                                 # FIXME if either config has an array just ditch for now
 600                                 if (ref($gt) eq "ARRAY" or ref($lt) eq "ARRAY")
 601                                 { skipnote($bib->id,""); next COPYMAP; }
 602                                 $gt =~ s/[^0-9\.]//g if $gt; #trim off anything not deweyish
 603                                 $lt =~ s/[^0-9\.]//g if $lt; #trim off anything not deweyish
 604
 605                                 my $callno = $cn->label;
 606                                 $callno =~ s/[^0-9\.]//g; #trim off anything not deweyish
 607                                 print STDERR $callno;
 608                                 #note that we are making big assumptions about the call numbers in the db
 609
 610                                 # we have a range, exclude what's inbetween
 611                                 if($lt && $gt){
 612                                     if($callno > $gt and $callno < $lt)
 613                                     { skipnote($bib->id,"Dewey LTGT"); next COPYMAP; }
 614                                 # we only have a top threshold, exclude everything below it
 615                                 } elsif ($lt){
 616                                     if($callno < $lt)
 617                                     { skipnote($bib->id,"Dewey LT"); next COPYMAP; }
 618                                 # we only have a bottom threshold, exclude everything above it
 619                                 } elsif ($gt){
 620                                     if($callno > $gt)
 621                                     { skipnote($bib->id,"Dewey GT"); next COPYMAP; }
 622                                 }
 623                             }
 624
 625                             if($thisorg->parent_ou){
 626                                  $thisorg = $orgs{$thisorg->parent_ou}
 627                             } else {
 628                                 $thisorg = ();
 629                             }
 630
 631                         }
 632                     }
 633
 634                     my $field_852_4b = undef;
 635                     if($field852_4b_type =~ /collapsed?/) {
 636                         $field_852_4b = $orgs{$printlib}->shortname;
 637                     } elsif($field852_4b_type == 'circ') {
 638                         $field_852_4b = $orgs{$circlib}->shortname;
 639                     } elsif($field852_4b_type == 'owning') {
 640                         $field_852_4b = $orgs{$owninglib}->shortname;
 641                     } else {
 642                         die "Should not have reached here, invalid \$field852_4b_type=${field852_4b_type}";
 643                     }
 644
 645                     $r->append_fields(
 646                         MARC::Field->new(
 647                             852, '4', '',
 648                             a => $location,
 649                             b => $field_852_4b,
 650                             c => $shelves{$cp->location}->name,
 651                             j => $cn->label,
 652                             ($cp->circ_modifier ? ( g => $cp->circ_modifier ) : ()),
 653                             p => $cp->barcode,
 654                             ($cp->price ? ( y => $dollarsign.$cp->price ) : ()),
 655                             ($cp->copy_number ? ( t => $cp->copy_number ) : ()),
 656                             ($cp->ref eq 't' ? ( x => 'reference' ) : ()),
 657                             ($cp->holdable eq 'f' ? ( x => 'unholdable' ) : ()),
 658                             ($cp->circulate eq 'f' ? ( x => 'noncirculating' ) : ()),
 659                             ($cp->opac_visible eq 'f' ? ( x => 'hidden' ) : ()),
 660                             z => $statuses{$cp->status}->name,
 661                         )
 662                     );
 663
 664
 665
 666                     stats() if (!$quiet && ! ($count{cp} % 100 ));
 667                 } # COPYMAP: for my $cp ( @$cn_map_list )
 668             } # for my $cn ( @$cn_list )
 669         } # if ($cp_list && @$cp_list)
 670     } # if ($cn_list && @$cn_list)
 671 } # sub
 672
 673 sub skipnote {
 674         my $id = shift;
 675         my $note = shift;
 676         my $outf = *STDERR;
 677         $outf = *STDOUT if($output_file) ;
 678         printf($outf "Skipped %s due to config: %s\n",$id,$note) unless $quiet;
 679 }