Open-ILS/src/sql/Pg/upgrade/0862.function.remove_extra_utf8_decodes.sql

   1 BEGIN;
   2
   3 -- this file is a duplicate of 0851, moved up for better backport clarity
   4
   5 -- check whether patch can be applied
   6 SELECT evergreen.upgrade_deps_block_check('0862', :eg_version);
   7
   8 CREATE OR REPLACE FUNCTION evergreen.maintain_901 () RETURNS TRIGGER AS $func$
   9 use strict;
  10 use MARC::Record;
  11 use MARC::File::XML (BinaryEncoding => 'UTF-8');
  12 use MARC::Charset;
  13 use Encode;
  14 use Unicode::Normalize;
  15
  16 MARC::Charset->assume_unicode(1);
  17
  18 my $schema = $_TD->{table_schema};
  19 my $marc = MARC::Record->new_from_xml($_TD->{new}{marc});
  20
  21 my @old901s = $marc->field('901');
  22 $marc->delete_fields(@old901s);
  23
  24 if ($schema eq 'biblio') {
  25     my $tcn_value = $_TD->{new}{tcn_value};
  26
  27     # Set TCN value to record ID?
  28     my $id_as_tcn = spi_exec_query("
  29         SELECT enabled
  30         FROM config.global_flag
  31         WHERE name = 'cat.bib.use_id_for_tcn'
  32     ");
  33     if (($id_as_tcn->{processed}) && $id_as_tcn->{rows}[0]->{enabled} eq 't') {
  34         $tcn_value = $_TD->{new}{id};
  35         $_TD->{new}{tcn_value} = $tcn_value;
  36     }
  37
  38     my $new_901 = MARC::Field->new("901", " ", " ",
  39         "a" => $tcn_value,
  40         "b" => $_TD->{new}{tcn_source},
  41         "c" => $_TD->{new}{id},
  42         "t" => $schema
  43     );
  44
  45     if ($_TD->{new}{owner}) {
  46         $new_901->add_subfields("o" => $_TD->{new}{owner});
  47     }
  48
  49     if ($_TD->{new}{share_depth}) {
  50         $new_901->add_subfields("d" => $_TD->{new}{share_depth});
  51     }
  52
  53     $marc->append_fields($new_901);
  54 } elsif ($schema eq 'authority') {
  55     my $new_901 = MARC::Field->new("901", " ", " ",
  56         "c" => $_TD->{new}{id},
  57         "t" => $schema,
  58     );
  59     $marc->append_fields($new_901);
  60 } elsif ($schema eq 'serial') {
  61     my $new_901 = MARC::Field->new("901", " ", " ",
  62         "c" => $_TD->{new}{id},
  63         "t" => $schema,
  64         "o" => $_TD->{new}{owning_lib},
  65     );
  66
  67     if ($_TD->{new}{record}) {
  68         $new_901->add_subfields("r" => $_TD->{new}{record});
  69     }
  70
  71     $marc->append_fields($new_901);
  72 } else {
  73     my $new_901 = MARC::Field->new("901", " ", " ",
  74         "c" => $_TD->{new}{id},
  75         "t" => $schema,
  76     );
  77     $marc->append_fields($new_901);
  78 }
  79
  80 my $xml = $marc->as_xml_record();
  81 $xml =~ s/\n//sgo;
  82 $xml =~ s/^<\?xml.+\?\s*>//go;
  83 $xml =~ s/>\s+</></go;
  84 $xml =~ s/\p{Cc}//go;
  85
  86 # Embed a version of OpenILS::Application::AppUtils->entityize()
  87 # to avoid having to set PERL5LIB for PostgreSQL as well
  88
  89 $xml = NFC($xml);
  90
  91 # Convert raw ampersands to entities
  92 $xml =~ s/&(?!\S+;)/&amp;/gso;
  93
  94 # Convert Unicode characters to entities
  95 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
  96
  97 $xml =~ s/[\x00-\x1f]//go;
  98 $_TD->{new}{marc} = $xml;
  99
 100 return "MODIFY";
 101 $func$ LANGUAGE PLPERLU;
 102
 103 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
 104 use strict;
 105 use MARC::Record;
 106 use MARC::File::XML (BinaryEncoding => 'UTF-8');
 107 use MARC::Charset;
 108 use Encode;
 109 use Unicode::Normalize;
 110
 111 MARC::Charset->assume_unicode(1);
 112
 113 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
 114 my $schema = $_TD->{table_schema};
 115 my $rec_id = $_TD->{new}{id};
 116
 117 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
 118 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
 119 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
 120     return;
 121 }
 122
 123 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
 124 my $ou_cni = 'EVRGRN';
 125
 126 my $owner;
 127 if ($schema eq 'serial') {
 128     $owner = $_TD->{new}{owning_lib};
 129 } else {
 130     # are.owner and bre.owner can be null, so fall back to the consortial setting
 131     $owner = $_TD->{new}{owner} || 1;
 132 }
 133
 134 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
 135 if ($ous_rv->{processed}) {
 136     $ou_cni = $ous_rv->{rows}[0]->{value};
 137     $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
 138 } else {
 139     # Fall back to the shortname of the OU if there was no OU setting
 140     $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
 141     if ($ous_rv->{processed}) {
 142         $ou_cni = $ous_rv->{rows}[0]->{shortname};
 143     }
 144 }
 145
 146 my ($create, $munge) = (0, 0);
 147
 148 my @scns = $record->field('035');
 149
 150 foreach my $id_field ('001', '003') {
 151     my $spec_value;
 152     my @controls = $record->field($id_field);
 153
 154     if ($id_field eq '001') {
 155         $spec_value = $rec_id;
 156     } else {
 157         $spec_value = $ou_cni;
 158     }
 159
 160     # Create the 001/003 if none exist
 161     if (scalar(@controls) == 1) {
 162         # Only one field; check to see if we need to munge it
 163         unless (grep $_->data() eq $spec_value, @controls) {
 164             $munge = 1;
 165         }
 166     } else {
 167         # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
 168         foreach my $control (@controls) {
 169             $record->delete_field($control);
 170         }
 171         $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
 172         $create = 1;
 173     }
 174 }
 175
 176 my $cn = $record->field('001')->data();
 177 # Special handling of OCLC numbers, often found in records that lack 003
 178 if ($cn =~ /^o(c[nm]|n)\d/) {
 179     $cn =~ s/^o(c[nm]|n)0*(\d+)/$2/;
 180     $record->field('003')->data('OCoLC');
 181     $create = 0;
 182 }
 183
 184 # Now, if we need to munge the 001, we will first push the existing 001/003
 185 # into the 035; but if the record did not have one (and one only) 001 and 003
 186 # to begin with, skip this process
 187 if ($munge and not $create) {
 188
 189     my $scn = "(" . $record->field('003')->data() . ")" . $cn;
 190
 191     # Do not create duplicate 035 fields
 192     unless (grep $_->subfield('a') eq $scn, @scns) {
 193         $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
 194     }
 195 }
 196
 197 # Set the 001/003 and update the MARC
 198 if ($create or $munge) {
 199     $record->field('001')->data($rec_id);
 200     $record->field('003')->data($ou_cni);
 201
 202     my $xml = $record->as_xml_record();
 203     $xml =~ s/\n//sgo;
 204     $xml =~ s/^<\?xml.+\?\s*>//go;
 205     $xml =~ s/>\s+</></go;
 206     $xml =~ s/\p{Cc}//go;
 207
 208     # Embed a version of OpenILS::Application::AppUtils->entityize()
 209     # to avoid having to set PERL5LIB for PostgreSQL as well
 210
 211     $xml = NFC($xml);
 212
 213     # Convert raw ampersands to entities
 214     $xml =~ s/&(?!\S+;)/&amp;/gso;
 215
 216     # Convert Unicode characters to entities
 217     $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 218
 219     $xml =~ s/[\x00-\x1f]//go;
 220     $_TD->{new}{marc} = $xml;
 221
 222     return "MODIFY";
 223 }
 224
 225 return;
 226 $func$ LANGUAGE PLPERLU;
 227
 228 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
 229
 230     use strict;
 231     use Unicode::Normalize;
 232     use Encode;
 233
 234     my $str = shift;
 235     my $sf = shift;
 236
 237     # Apply NACO normalization to input string; based on
 238     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
 239     #
 240     # Note that unlike a strict reading of the NACO normalization rules,
 241     # output is returned as lowercase instead of uppercase for compatibility
 242     # with previous versions of the Evergreen naco_normalize routine.
 243
 244     # Convert to upper-case first; even though final output will be lowercase, doing this will
 245     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
 246     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
 247     $str = uc $str;
 248
 249     # remove non-filing strings
 250     $str =~ s/\x{0098}.*?\x{009C}//g;
 251
 252     $str = NFKD($str);
 253
 254     # additional substitutions - 3.6.
 255     $str =~ s/\x{00C6}/AE/g;
 256     $str =~ s/\x{00DE}/TH/g;
 257     $str =~ s/\x{0152}/OE/g;
 258     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
 259
 260     # transformations based on Unicode category codes
 261     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
 262
 263         if ($sf && $sf =~ /^a/o) {
 264                 my $commapos = index($str, ',');
 265                 if ($commapos > -1) {
 266                         if ($commapos != length($str) - 1) {
 267                 $str =~ s/,/\x07/; # preserve first comma
 268                         }
 269                 }
 270         }
 271
 272     # since we've stripped out the control characters, we can now
 273     # use a few as placeholders temporarily
 274     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
 275     $str =~ s/[\p{Pc}\p{Pd}\p{Pe}\p{Pf}\p{Pi}\p{Po}\p{Ps}\p{Sk}\p{Sm}\p{So}\p{Zl}\p{Zp}\p{Zs}]/ /g;
 276     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
 277
 278     # decimal digits
 279     $str =~ tr/\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{07C0}-\x{07C9}\x{0966}-\x{096F}\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}\x{0BE6}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}\x{1040}-\x{1049}\x{1090}-\x{1099}\x{17E0}-\x{17E9}\x{1810}-\x{1819}\x{1946}-\x{194F}\x{19D0}-\x{19D9}\x{1A80}-\x{1A89}\x{1A90}-\x{1A99}\x{1B50}-\x{1B59}\x{1BB0}-\x{1BB9}\x{1C40}-\x{1C49}\x{1C50}-\x{1C59}\x{A620}-\x{A629}\x{A8D0}-\x{A8D9}\x{A900}-\x{A909}\x{A9D0}-\x{A9D9}\x{AA50}-\x{AA59}\x{ABF0}-\x{ABF9}\x{FF10}-\x{FF19}/0-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-9/;
 280
 281     # intentionally skipping step 8 of the NACO algorithm; if the string
 282     # gets normalized away, that's fine.
 283
 284     # leading and trailing spaces
 285     $str =~ s/\s+/ /g;
 286     $str =~ s/^\s+//;
 287     $str =~ s/\s+$//g;
 288
 289     return lc $str;
 290 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 291
 292 -- Currently, the only difference from naco_normalize is that search_normalize
 293 -- turns apostrophes into spaces, while naco_normalize collapses them.
 294 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
 295
 296     use strict;
 297     use Unicode::Normalize;
 298     use Encode;
 299
 300     my $str = shift;
 301     my $sf = shift;
 302
 303     # Apply NACO normalization to input string; based on
 304     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
 305     #
 306     # Note that unlike a strict reading of the NACO normalization rules,
 307     # output is returned as lowercase instead of uppercase for compatibility
 308     # with previous versions of the Evergreen naco_normalize routine.
 309
 310     # Convert to upper-case first; even though final output will be lowercase, doing this will
 311     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
 312     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
 313     $str = uc $str;
 314
 315     # remove non-filing strings
 316     $str =~ s/\x{0098}.*?\x{009C}//g;
 317
 318     $str = NFKD($str);
 319
 320     # additional substitutions - 3.6.
 321     $str =~ s/\x{00C6}/AE/g;
 322     $str =~ s/\x{00DE}/TH/g;
 323     $str =~ s/\x{0152}/OE/g;
 324     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}][/DDOLl/d;
 325
 326     # transformations based on Unicode category codes
 327     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
 328
 329         if ($sf && $sf =~ /^a/o) {
 330                 my $commapos = index($str, ',');
 331                 if ($commapos > -1) {
 332                         if ($commapos != length($str) - 1) {
 333                 $str =~ s/,/\x07/; # preserve first comma
 334                         }
 335                 }
 336         }
 337
 338     # since we've stripped out the control characters, we can now
 339     # use a few as placeholders temporarily
 340     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
 341     $str =~ s/[\p{Pc}\p{Pd}\p{Pe}\p{Pf}\p{Pi}\p{Po}\p{Ps}\p{Sk}\p{Sm}\p{So}\p{Zl}\p{Zp}\p{Zs}]/ /g;
 342     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
 343
 344     # decimal digits
 345     $str =~ tr/\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{07C0}-\x{07C9}\x{0966}-\x{096F}\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}\x{0BE6}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}\x{1040}-\x{1049}\x{1090}-\x{1099}\x{17E0}-\x{17E9}\x{1810}-\x{1819}\x{1946}-\x{194F}\x{19D0}-\x{19D9}\x{1A80}-\x{1A89}\x{1A90}-\x{1A99}\x{1B50}-\x{1B59}\x{1BB0}-\x{1BB9}\x{1C40}-\x{1C49}\x{1C50}-\x{1C59}\x{A620}-\x{A629}\x{A8D0}-\x{A8D9}\x{A900}-\x{A909}\x{A9D0}-\x{A9D9}\x{AA50}-\x{AA59}\x{ABF0}-\x{ABF9}\x{FF10}-\x{FF19}/0-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-9/;
 346
 347     # intentionally skipping step 8 of the NACO algorithm; if the string
 348     # gets normalized away, that's fine.
 349
 350     # leading and trailing spaces
 351     $str =~ s/\s+/ /g;
 352     $str =~ s/^\s+//;
 353     $str =~ s/\s+$//g;
 354
 355     return lc $str;
 356 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 357
 358 COMMIT;