Open-ILS/src/sql/Pg/upgrade/0331.schema.bib-trigger-fixes.sql

   1 -- Correct a few thinkos in the functions that implement authority control
   2 -- and control numbers
   3 BEGIN;
   4
   5 INSERT INTO config.upgrade_log (version) VALUES ('0331'); -- dbs
   6
   7 CREATE OR REPLACE FUNCTION vandelay.add_field ( target_xml TEXT, source_xml TEXT, field TEXT ) RETURNS TEXT AS $_$
   8
   9     use MARC::Record;
  10     use MARC::File::XML;
  11     use strict;
  12
  13     my $target_xml = shift;
  14     my $source_xml = shift;
  15     my $field_spec = shift;
  16
  17     my $target_r = MARC::Record->new_from_xml( $target_xml );
  18     my $source_r = MARC::Record->new_from_xml( $source_xml );
  19
  20     return $target_xml unless ($target_r && $source_r);
  21
  22     my @field_list = split(',', $field_spec);
  23
  24     my %fields;
  25     for my $f (@field_list) {
  26         $f =~ s/^\s*//; $f =~ s/\s*$//;
  27         if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
  28             my $field = $1;
  29             $field =~ s/\s+//;
  30             my $sf = $2;
  31             $sf =~ s/\s+//;
  32             my $match = $3;
  33             $match =~ s/^\s*//; $match =~ s/\s*$//;
  34             $fields{$field} = { sf => [ split('', $sf) ] };
  35             if ($match) {
  36                 my ($msf,$mre) = split('~', $match);
  37                 if (length($msf) > 0 and length($mre) > 0) {
  38                     $msf =~ s/^\s*//; $msf =~ s/\s*$//;
  39                     $mre =~ s/^\s*//; $mre =~ s/\s*$//;
  40                     $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
  41                 }
  42             }
  43         }
  44     }
  45
  46     for my $f ( keys %fields) {
  47         if ( @{$fields{$f}{sf}} ) {
  48             for my $from_field ($source_r->field( $f )) {
  49                 for my $to_field ($target_r->field( $f )) {
  50                     if (exists($fields{$f}{match})) {
  51                         next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
  52                     }
  53                     my @new_sf = map { ($_ => $from_field->subfield($_)) } @{$fields{$f}{sf}};
  54                     $to_field->add_subfields( @new_sf );
  55                 }
  56             }
  57         } else {
  58             my @new_fields = map { $_->clone } $source_r->field( $f );
  59             $target_r->insert_fields_ordered( @new_fields );
  60         }
  61     }
  62
  63     $target_xml = $target_r->as_xml_record;
  64     $target_xml =~ s/^<\?.+?\?>$//mo;
  65     $target_xml =~ s/\n//sgo;
  66     $target_xml =~ s/>\s+</></sgo;
  67
  68     return $target_xml;
  69
  70 $_$ LANGUAGE PLPERLU;
  71
  72 CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS TEXT AS $_$
  73
  74     use MARC::Record;
  75     use MARC::File::XML;
  76     use strict;
  77
  78     my $xml = shift;
  79     my $r = MARC::Record->new_from_xml( $xml );
  80
  81     return $xml unless ($r);
  82
  83     my $field_spec = shift;
  84     my @field_list = split(',', $field_spec);
  85
  86     my %fields;
  87     for my $f (@field_list) {
  88         $f =~ s/^\s*//; $f =~ s/\s*$//;
  89         if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
  90             my $field = $1;
  91             $field =~ s/\s+//;
  92             my $sf = $2;
  93             $sf =~ s/\s+//;
  94             my $match = $3;
  95             $match =~ s/^\s*//; $match =~ s/\s*$//;
  96             $fields{$field} = { sf => [ split('', $sf) ] };
  97             if ($match) {
  98                 my ($msf,$mre) = split('~', $match);
  99                 if (length($msf) > 0 and length($mre) > 0) {
 100                     $msf =~ s/^\s*//; $msf =~ s/\s*$//;
 101                     $mre =~ s/^\s*//; $mre =~ s/\s*$//;
 102                     $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
 103                 }
 104             }
 105         }
 106     }
 107
 108     for my $f ( keys %fields) {
 109         for my $to_field ($r->field( $f )) {
 110             if (exists($fields{$f}{match})) {
 111                 next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
 112             }
 113
 114             if ( @{$fields{$f}{sf}} ) {
 115                 $to_field->delete_subfield(code => $fields{$f}{sf});
 116             } else {
 117                 $r->delete_field( $to_field );
 118             }
 119         }
 120     }
 121
 122     $xml = $r->as_xml_record;
 123     $xml =~ s/^<\?.+?\?>$//mo;
 124     $xml =~ s/\n//sgo;
 125     $xml =~ s/>\s+</></sgo;
 126
 127     return $xml;
 128
 129 $_$ LANGUAGE PLPERLU;
 130
 131 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
 132 use strict;
 133 use MARC::Record;
 134 use MARC::File::XML;
 135 use Encode;
 136 use Unicode::Normalize;
 137
 138 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
 139 my $schema = $_TD->{table_schema};
 140 my $rec_id = $_TD->{new}{id};
 141
 142 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
 143 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
 144 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
 145     return;
 146 }
 147
 148 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
 149 my $ou_cni = 'EVRGRN';
 150
 151 # bre.owner can be null, so fall back to the consortial setting
 152 my $owner = $_TD->{new}{owner} || 1;
 153
 154 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
 155 if ($ous_rv->{processed}) {
 156     $ou_cni = $ous_rv->{rows}[0]->{value};
 157     $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
 158 } else {
 159     # Fall back to the shortname of the OU if there was no OU setting
 160     $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
 161     if ($ous_rv->{processed}) {
 162         $ou_cni = $ous_rv->{rows}[0]->{shortname};
 163     }
 164 }
 165
 166 my ($create, $munge) = (0, 0);
 167 my ($orig_001, $orig_003) = ('', '');
 168
 169 # Incoming MARC records may have multiple 001s or 003s, despite the spec
 170 my @control_ids = $record->field('003');
 171 my @scns = $record->field('035');
 172
 173 foreach my $id_field ('001', '003') {
 174     my $spec_value;
 175     my @controls = $record->field($id_field);
 176
 177     if ($id_field eq '001') {
 178         $spec_value = $rec_id;
 179     } else {
 180         $spec_value = $ou_cni;
 181     }
 182
 183     # Create the 001/003 if none exist
 184     if (scalar(@controls) == 0) {
 185         $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
 186         $create = 1;
 187     } elsif (scalar(@controls) > 1) {
 188         # Do we already have the right 001/003 value in the existing set?
 189         unless (grep $_->data() eq $spec_value, @controls) {
 190             $munge = 1;
 191         }
 192
 193         # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
 194         foreach my $control (@controls) {
 195             unless ($control->data() eq $spec_value) {
 196                 $record->delete_field($control);
 197             }
 198         }
 199     } else {
 200         # Only one field; check to see if we need to munge it
 201         unless (grep $_->data() eq $spec_value, @controls) {
 202             $munge = 1;
 203         }
 204     }
 205 }
 206
 207 # Now, if we need to munge the 001, we will first push the existing 001/003 into the 035
 208 if ($munge) {
 209     my $scn = "(" . $record->field('003')->data() . ")" . $record->field('001')->data();
 210
 211     # Do not create duplicate 035 fields
 212     unless (grep $_->subfield('a') eq $scn, @scns) {
 213         $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
 214     }
 215 }
 216
 217 # Set the 001/003 and update the MARC
 218 if ($create or $munge) {
 219     $record->field('001')->data($rec_id);
 220     $record->field('003')->data($ou_cni);
 221
 222     my $xml = $record->as_xml_record();
 223     $xml =~ s/\n//sgo;
 224     $xml =~ s/^<\?xml.+\?\s*>//go;
 225     $xml =~ s/>\s+</></go;
 226     $xml =~ s/\p{Cc}//go;
 227
 228     # Embed a version of OpenILS::Application::AppUtils->entityize()
 229     # to avoid having to set PERL5LIB for PostgreSQL as well
 230
 231     # If we are going to convert non-ASCII characters to XML entities,
 232     # we had better be dealing with a UTF8 string to begin with
 233     $xml = decode_utf8($xml);
 234
 235     $xml = NFC($xml);
 236
 237     # Convert raw ampersands to entities
 238     $xml =~ s/&(?!\S+;)/&amp;/gso;
 239
 240     # Convert Unicode characters to entities
 241     $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 242
 243     $xml =~ s/[\x00-\x1f]//go;
 244     $_TD->{new}{marc} = $xml;
 245
 246     return "MODIFY";
 247 }
 248
 249 return;
 250 $func$ LANGUAGE PLPERLU;
 251
 252 COMMIT;