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