Open-ILS/src/sql/Pg/upgrade/0353.schema.plperl.binaryencoding.sql

   1 BEGIN;
   2
   3 INSERT INTO config.upgrade_log (version) VALUES ('0353'); -- miker
   4
   5 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
   6 use strict;
   7 use MARC::Record;
   8 use MARC::File::XML (BinaryEncoding => 'UTF-8');
   9 use Encode;
  10 use Unicode::Normalize;
  11
  12 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
  13 my $schema = $_TD->{table_schema};
  14 my $rec_id = $_TD->{new}{id};
  15
  16 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
  17 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
  18 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
  19     return;
  20 }
  21
  22 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
  23 my $ou_cni = 'EVRGRN';
  24
  25 my $owner;
  26 if ($schema eq 'serial') {
  27     $owner = $_TD->{new}{owning_lib};
  28 } else {
  29     # are.owner and bre.owner can be null, so fall back to the consortial setting
  30     $owner = $_TD->{new}{owner} || 1;
  31 }
  32
  33 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
  34 if ($ous_rv->{processed}) {
  35     $ou_cni = $ous_rv->{rows}[0]->{value};
  36     $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
  37 } else {
  38     # Fall back to the shortname of the OU if there was no OU setting
  39     $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
  40     if ($ous_rv->{processed}) {
  41         $ou_cni = $ous_rv->{rows}[0]->{shortname};
  42     }
  43 }
  44
  45 my ($create, $munge) = (0, 0);
  46 my ($orig_001, $orig_003) = ('', '');
  47
  48 # Incoming MARC records may have multiple 001s or 003s, despite the spec
  49 my @control_ids = $record->field('003');
  50 my @scns = $record->field('035');
  51
  52 foreach my $id_field ('001', '003') {
  53     my $spec_value;
  54     my @controls = $record->field($id_field);
  55
  56     if ($id_field eq '001') {
  57         $spec_value = $rec_id;
  58     } else {
  59         $spec_value = $ou_cni;
  60     }
  61
  62     # Create the 001/003 if none exist
  63     if (scalar(@controls) == 0) {
  64         $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
  65         $create = 1;
  66     } elsif (scalar(@controls) > 1) {
  67         # Do we already have the right 001/003 value in the existing set?
  68         unless (grep $_->data() eq $spec_value, @controls) {
  69             $munge = 1;
  70         }
  71
  72         # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
  73         foreach my $control (@controls) {
  74             unless ($control->data() eq $spec_value) {
  75                 $record->delete_field($control);
  76             }
  77         }
  78     } else {
  79         # Only one field; check to see if we need to munge it
  80         unless (grep $_->data() eq $spec_value, @controls) {
  81             $munge = 1;
  82         }
  83     }
  84 }
  85
  86 # Now, if we need to munge the 001, we will first push the existing 001/003 into the 035
  87 if ($munge) {
  88     my $scn = "(" . $record->field('003')->data() . ")" . $record->field('001')->data();
  89
  90     # Do not create duplicate 035 fields
  91     unless (grep $_->subfield('a') eq $scn, @scns) {
  92         $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
  93     }
  94 }
  95
  96 # Set the 001/003 and update the MARC
  97 if ($create or $munge) {
  98     $record->field('001')->data($rec_id);
  99     $record->field('003')->data($ou_cni);
 100
 101     my $xml = $record->as_xml_record();
 102     $xml =~ s/\n//sgo;
 103     $xml =~ s/^<\?xml.+\?\s*>//go;
 104     $xml =~ s/>\s+</></go;
 105     $xml =~ s/\p{Cc}//go;
 106
 107     # Embed a version of OpenILS::Application::AppUtils->entityize()
 108     # to avoid having to set PERL5LIB for PostgreSQL as well
 109
 110     # If we are going to convert non-ASCII characters to XML entities,
 111     # we had better be dealing with a UTF8 string to begin with
 112     $xml = decode_utf8($xml);
 113
 114     $xml = NFC($xml);
 115
 116     # Convert raw ampersands to entities
 117     $xml =~ s/&(?!\S+;)/&amp;/gso;
 118
 119     # Convert Unicode characters to entities
 120     $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 121
 122     $xml =~ s/[\x00-\x1f]//go;
 123     $_TD->{new}{marc} = $xml;
 124
 125     return "MODIFY";
 126 }
 127
 128 return;
 129 $func$ LANGUAGE PLPERLU;
 130
 131 CREATE OR REPLACE FUNCTION authority.generate_overlay_template ( TEXT, BIGINT ) RETURNS TEXT AS $func$
 132
 133     use MARC::Record;
 134     use MARC::File::XML (BinaryEncoding => 'UTF-8');
 135
 136     my $xml = shift;
 137     my $r = MARC::Record->new_from_xml( $xml );
 138
 139     return undef unless ($r);
 140
 141     my $id = shift() || $r->subfield( '901' => 'c' );
 142     $id =~ s/^\s*(?:\([^)]+\))?\s*(.+)\s*?$/$1/;
 143     return undef unless ($id); # We need an ID!
 144
 145     my $tmpl = MARC::Record->new();
 146
 147     my @rule_fields;
 148     for my $field ( $r->field( '1..' ) ) { # Get main entry fields from the authority record
 149
 150         my $tag = $field->tag;
 151         my $i1 = $field->indicator(1);
 152         my $i2 = $field->indicator(2);
 153         my $sf = join '', map { $_->[0] } $field->subfields;
 154         my @data = map { @$_ } $field->subfields;
 155
 156         my @replace_them;
 157
 158         # Map the authority field to bib fields it can control.
 159         if ($tag >= 100 and $tag <= 111) {       # names
 160             @replace_them = map { $tag + $_ } (0, 300, 500, 600, 700);
 161         } elsif ($tag eq '130') {                # uniform title
 162             @replace_them = qw/130 240 440 730 830/;
 163         } elsif ($tag >= 150 and $tag <= 155) {  # subjects
 164             @replace_them = ($tag + 500);
 165         } elsif ($tag >= 180 and $tag <= 185) {  # floating subdivisions
 166             @replace_them = qw/100 400 600 700 800 110 410 610 710 810 111 411 611 711 811 130 240 440 730 830 650 651 655/;
 167         } else {
 168             next;
 169         }
 170
 171         # Dummy up the bib-side data
 172         $tmpl->append_fields(
 173             map {
 174                 MARC::Field->new( $_, $i1, $i2, @data )
 175             } @replace_them
 176         );
 177
 178         # Construct some 'replace' rules
 179         push @rule_fields, map { $_ . $sf . '[0~\)' .$id . '$]' } @replace_them;
 180     }
 181
 182     # Insert the replace rules into the template
 183     $tmpl->append_fields(
 184         MARC::Field->new( '905' => ' ' => ' ' => 'r' => join(',', @rule_fields ) )
 185     );
 186
 187     $xml = $tmpl->as_xml_record;
 188     $xml =~ s/^<\?.+?\?>$//mo;
 189     $xml =~ s/\n//sgo;
 190     $xml =~ s/>\s+</></sgo;
 191
 192     return $xml;
 193
 194 $func$ LANGUAGE PLPERLU;
 195
 196 CREATE OR REPLACE FUNCTION vandelay.add_field ( target_xml TEXT, source_xml TEXT, field TEXT ) RETURNS TEXT AS $_$
 197
 198     use MARC::Record;
 199     use MARC::File::XML (BinaryEncoding => 'UTF-8');
 200     use strict;
 201
 202     my $target_xml = shift;
 203     my $source_xml = shift;
 204     my $field_spec = shift;
 205
 206     my $target_r = MARC::Record->new_from_xml( $target_xml );
 207     my $source_r = MARC::Record->new_from_xml( $source_xml );
 208
 209     return $target_xml unless ($target_r && $source_r);
 210
 211     my @field_list = split(',', $field_spec);
 212
 213     my %fields;
 214     for my $f (@field_list) {
 215         $f =~ s/^\s*//; $f =~ s/\s*$//;
 216         if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
 217             my $field = $1;
 218             $field =~ s/\s+//;
 219             my $sf = $2;
 220             $sf =~ s/\s+//;
 221             my $match = $3;
 222             $match =~ s/^\s*//; $match =~ s/\s*$//;
 223             $fields{$field} = { sf => [ split('', $sf) ] };
 224             if ($match) {
 225                 my ($msf,$mre) = split('~', $match);
 226                 if (length($msf) > 0 and length($mre) > 0) {
 227                     $msf =~ s/^\s*//; $msf =~ s/\s*$//;
 228                     $mre =~ s/^\s*//; $mre =~ s/\s*$//;
 229                     $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
 230                 }
 231             }
 232         }
 233     }
 234
 235     for my $f ( keys %fields) {
 236         if ( @{$fields{$f}{sf}} ) {
 237             for my $from_field ($source_r->field( $f )) {
 238                 for my $to_field ($target_r->field( $f )) {
 239                     if (exists($fields{$f}{match})) {
 240                         next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
 241                     }
 242                     my @new_sf = map { ($_ => $from_field->subfield($_)) } @{$fields{$f}{sf}};
 243                     $to_field->add_subfields( @new_sf );
 244                 }
 245             }
 246         } else {
 247             my @new_fields = map { $_->clone } $source_r->field( $f );
 248             $target_r->insert_fields_ordered( @new_fields );
 249         }
 250     }
 251
 252     $target_xml = $target_r->as_xml_record;
 253     $target_xml =~ s/^<\?.+?\?>$//mo;
 254     $target_xml =~ s/\n//sgo;
 255     $target_xml =~ s/>\s+</></sgo;
 256
 257     return $target_xml;
 258
 259 $_$ LANGUAGE PLPERLU;
 260
 261 CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS TEXT AS $_$
 262
 263     use MARC::Record;
 264     use MARC::File::XML (BinaryEncoding => 'UTF-8');
 265     use strict;
 266
 267     my $xml = shift;
 268     my $r = MARC::Record->new_from_xml( $xml );
 269
 270     return $xml unless ($r);
 271
 272     my $field_spec = shift;
 273     my @field_list = split(',', $field_spec);
 274
 275     my %fields;
 276     for my $f (@field_list) {
 277         $f =~ s/^\s*//; $f =~ s/\s*$//;
 278         if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
 279             my $field = $1;
 280             $field =~ s/\s+//;
 281             my $sf = $2;
 282             $sf =~ s/\s+//;
 283             my $match = $3;
 284             $match =~ s/^\s*//; $match =~ s/\s*$//;
 285             $fields{$field} = { sf => [ split('', $sf) ] };
 286             if ($match) {
 287                 my ($msf,$mre) = split('~', $match);
 288                 if (length($msf) > 0 and length($mre) > 0) {
 289                     $msf =~ s/^\s*//; $msf =~ s/\s*$//;
 290                     $mre =~ s/^\s*//; $mre =~ s/\s*$//;
 291                     $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
 292                 }
 293             }
 294         }
 295     }
 296
 297     for my $f ( keys %fields) {
 298         for my $to_field ($r->field( $f )) {
 299             if (exists($fields{$f}{match})) {
 300                 next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
 301             }
 302
 303             if ( @{$fields{$f}{sf}} ) {
 304                 $to_field->delete_subfield(code => $fields{$f}{sf});
 305             } else {
 306                 $r->delete_field( $to_field );
 307             }
 308         }
 309     }
 310
 311     $xml = $r->as_xml_record;
 312     $xml =~ s/^<\?.+?\?>$//mo;
 313     $xml =~ s/\n//sgo;
 314     $xml =~ s/>\s+</></sgo;
 315
 316     return $xml;
 317
 318 $_$ LANGUAGE PLPERLU;
 319
 320 COMMIT;
 321