LP#1714026 - Schema-qualify maintain_control_numbers function.
[working/Evergreen.git] / Open-ILS / src / sql / Pg / 002.functions.config.sql
1 /*
2  * Copyright (C) 2004-2008  Georgia Public Library Service
3  * Copyright (C) 2008-2014  Equinox Software, Inc.
4  * Mike Rylander <miker@esilibrary.com>
5  *
6  * This program is free software; you can redistribute it and/or
7  * modify it under the terms of the GNU General Public License
8  * as published by the Free Software Foundation; either version 2
9  * of the License, or (at your option) any later version.
10  *
11  * This program is distributed in the hope that it will be useful,
12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14  * GNU General Public License for more details.
15  *
16  */
17
18
19 BEGIN;
20
21 CREATE OR REPLACE FUNCTION evergreen.xml_famous5_to_text( TEXT ) RETURNS TEXT AS $f$
22  SELECT REPLACE(
23             REPLACE(
24                 REPLACE(
25                     REPLACE(
26                         REPLACE( $1, '&lt;', '<'),
27                         '&gt;',
28                         '>'
29                     ),
30                     '&apos;',
31                     $$'$$
32                 ), -- ' ... vim
33                 '&quot;',
34                 '"'
35             ),
36             '&amp;',
37             '&'
38         );
39 $f$ LANGUAGE SQL IMMUTABLE;
40
41 CREATE OR REPLACE FUNCTION evergreen.oils_xpath ( TEXT, TEXT, TEXT[] ) RETURNS TEXT[] AS $f$
42     SELECT  ARRAY_AGG(
43                 CASE WHEN strpos(x,'<') = 1 THEN -- It's an element node
44                     x
45                 ELSE -- it's text-ish
46                     evergreen.xml_famous5_to_text(x)
47                 END
48             )
49       FROM  UNNEST(XPATH( $1, $2::XML, $3 )::TEXT[]) x;
50 $f$ LANGUAGE SQL IMMUTABLE;
51
52 -- Trust me, it's just simpler to duplicate these...
53 CREATE OR REPLACE FUNCTION evergreen.oils_xpath ( TEXT, TEXT ) RETURNS TEXT[] AS $f$
54     SELECT  ARRAY_AGG(
55                 CASE WHEN strpos(x,'<') = 1 THEN -- It's an element node
56                     x
57                 ELSE -- it's text-ish
58                     evergreen.xml_famous5_to_text(x)
59                 END
60             )
61       FROM  UNNEST(XPATH( $1, $2::XML)::TEXT[]) x;
62 $f$ LANGUAGE SQL IMMUTABLE;
63
64 CREATE OR REPLACE FUNCTION evergreen.oils_xslt_process(TEXT, TEXT) RETURNS TEXT AS $func$
65   use strict;
66
67   use XML::LibXSLT;
68   use XML::LibXML;
69
70   my $doc = shift;
71   my $xslt = shift;
72
73   # The following approach uses the older XML::LibXML 1.69 / XML::LibXSLT 1.68
74   # methods of parsing XML documents and stylesheets, in the hopes of broader
75   # compatibility with distributions
76   my $parser = $_SHARED{'_xslt_process'}{parsers}{xml} || XML::LibXML->new();
77
78   # Cache the XML parser, if we do not already have one
79   $_SHARED{'_xslt_process'}{parsers}{xml} = $parser
80     unless ($_SHARED{'_xslt_process'}{parsers}{xml});
81
82   my $xslt_parser = $_SHARED{'_xslt_process'}{parsers}{xslt} || XML::LibXSLT->new();
83
84   # Cache the XSLT processor, if we do not already have one
85   $_SHARED{'_xslt_process'}{parsers}{xslt} = $xslt_parser
86     unless ($_SHARED{'_xslt_process'}{parsers}{xslt});
87
88   my $stylesheet = $_SHARED{'_xslt_process'}{stylesheets}{$xslt} ||
89     $xslt_parser->parse_stylesheet( $parser->parse_string($xslt) );
90
91   $_SHARED{'_xslt_process'}{stylesheets}{$xslt} = $stylesheet
92     unless ($_SHARED{'_xslt_process'}{stylesheets}{$xslt});
93
94   return $stylesheet->output_as_chars(
95     $stylesheet->transform(
96       $parser->parse_string($doc)
97     )
98   );
99
100 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
101
102 CREATE OR REPLACE FUNCTION oils_xpath_string ( TEXT, TEXT, TEXT, ANYARRAY ) RETURNS TEXT AS $func$
103     SELECT  ARRAY_TO_STRING(
104                 oils_xpath(
105                     $1 ||
106                         CASE WHEN $1 ~ $re$/[^/[]*@[^]]+$$re$ OR $1 ~ $re$text\(\)$$re$ THEN '' ELSE '//text()' END,
107                     $2,
108                     $4
109                 ),
110                 $3
111             );
112 $func$ LANGUAGE SQL IMMUTABLE;
113
114 CREATE OR REPLACE FUNCTION oils_xpath_string ( TEXT, TEXT, TEXT ) RETURNS TEXT AS $func$
115     SELECT oils_xpath_string( $1, $2, $3, '{}'::TEXT[] );
116 $func$ LANGUAGE SQL IMMUTABLE;
117
118 CREATE OR REPLACE FUNCTION oils_xpath_string ( TEXT, TEXT, ANYARRAY ) RETURNS TEXT AS $func$
119     SELECT oils_xpath_string( $1, $2, '', $3 );
120 $func$ LANGUAGE SQL IMMUTABLE;
121
122 CREATE OR REPLACE FUNCTION oils_xpath_string ( TEXT, TEXT ) RETURNS TEXT AS $func$
123     SELECT oils_xpath_string( $1, $2, '{}'::TEXT[] );
124 $func$ LANGUAGE SQL IMMUTABLE;
125
126
127 CREATE OR REPLACE FUNCTION oils_xpath_table ( key TEXT, document_field TEXT, relation_name TEXT, xpaths TEXT, criteria TEXT ) RETURNS SETOF RECORD AS $func$
128 DECLARE
129     xpath_list  TEXT[];
130     select_list TEXT[];
131     where_list  TEXT[];
132     q           TEXT;
133     out_record  RECORD;
134     empty_test  RECORD;
135 BEGIN
136     xpath_list := STRING_TO_ARRAY( xpaths, '|' );
137
138     select_list := ARRAY_APPEND( select_list, key || '::INT AS key' );
139
140     FOR i IN 1 .. ARRAY_UPPER(xpath_list,1) LOOP
141         IF xpath_list[i] = 'null()' THEN
142             select_list := ARRAY_APPEND( select_list, 'NULL::TEXT AS c_' || i );
143         ELSE
144             select_list := ARRAY_APPEND(
145                 select_list,
146                 $sel$
147                 unnest(
148                     COALESCE(
149                         NULLIF(
150                             oils_xpath(
151                                 $sel$ ||
152                                     quote_literal(
153                                         CASE
154                                             WHEN xpath_list[i] ~ $re$/[^/[]*@[^/]+$$re$ OR xpath_list[i] ~ $re$text\(\)$$re$ THEN xpath_list[i]
155                                             ELSE xpath_list[i] || '//text()'
156                                         END
157                                     ) ||
158                                 $sel$,
159                                 $sel$ || document_field || $sel$
160                             ),
161                            '{}'::TEXT[]
162                         ),
163                         '{NULL}'::TEXT[]
164                     )
165                 ) AS c_$sel$ || i
166             );
167             where_list := ARRAY_APPEND(
168                 where_list,
169                 'c_' || i || ' IS NOT NULL'
170             );
171         END IF;
172     END LOOP;
173
174     q := $q$
175 SELECT * FROM (
176     SELECT $q$ || ARRAY_TO_STRING( select_list, ', ' ) || $q$ FROM $q$ || relation_name || $q$ WHERE ($q$ || criteria || $q$)
177 )x WHERE $q$ || ARRAY_TO_STRING( where_list, ' OR ' );
178     -- RAISE NOTICE 'query: %', q;
179
180     FOR out_record IN EXECUTE q LOOP
181         RETURN NEXT out_record;
182     END LOOP;
183
184     RETURN;
185 END;
186 $func$ LANGUAGE PLPGSQL IMMUTABLE;
187
188 CREATE OR REPLACE FUNCTION oils_xpath_tag_to_table(marc text, tag text, xpaths text[]) RETURNS SETOF record AS $function$
189
190 -- This function currently populates columns with the FIRST matching value
191 -- of each XPATH.  It would be reasonable to add a 'return_arrays' option
192 -- where each column is an array of all matching values for each path, but
193 -- that remains as a TODO
194
195 DECLARE
196     field RECORD;
197     output RECORD;
198     select_list TEXT[];
199     from_list TEXT[];
200     q TEXT;
201 BEGIN
202     -- setup query select
203     FOR i IN 1 .. ARRAY_UPPER(xpaths,1) LOOP
204         IF xpaths[i] = 'null()' THEN
205             select_list := ARRAY_APPEND(select_list, 'NULL::TEXT AS c_' || i );
206         ELSE
207             select_list := ARRAY_APPEND(select_list, '(oils_xpath(' ||
208                 quote_literal(
209                     CASE
210                         WHEN xpaths[i] ~ $re$/[^/[]*@[^/]+$$re$ -- attribute
211                             OR xpaths[i] ~ $re$text\(\)$$re$
212                         THEN xpaths[i]
213                         ELSE xpaths[i] || '//text()'
214                     END
215                 ) || ', field_marc))[1] AS cl_' || i);
216                 -- hardcoded to first value for each path
217         END IF;
218     END LOOP;
219
220     -- run query over tag set
221     q := 'SELECT ' || ARRAY_TO_STRING(select_list, ',')
222         || ' FROM UNNEST(oils_xpath(' || quote_literal('//*[@tag="' || tag
223         || '"]') || ', ' || quote_literal(marc) || ')) AS field_marc;';
224     --RAISE NOTICE '%', q;
225
226     RETURN QUERY EXECUTE q;
227 END;
228
229 $function$ LANGUAGE PLPGSQL;
230
231 CREATE OR REPLACE FUNCTION extract_marc_field ( TEXT, BIGINT, TEXT, TEXT ) RETURNS TEXT AS $$
232 DECLARE
233     query TEXT;
234     output TEXT;
235 BEGIN
236     query := $q$
237         SELECT  regexp_replace(
238                     oils_xpath_string(
239                         $q$ || quote_literal($3) || $q$,
240                         marc,
241                         ' '
242                     ),
243                     $q$ || quote_literal($4) || $q$,
244                     '',
245                     'g')
246           FROM  $q$ || $1 || $q$
247           WHERE id = $q$ || $2;
248
249     EXECUTE query INTO output;
250
251     -- RAISE NOTICE 'query: %, output; %', query, output;
252
253     RETURN output;
254 END;
255 $$ LANGUAGE PLPGSQL IMMUTABLE;
256
257 CREATE OR REPLACE FUNCTION extract_marc_field_set
258         (TEXT, BIGINT, TEXT, TEXT) RETURNS SETOF TEXT AS $$
259 DECLARE
260     query TEXT;
261     output TEXT;
262 BEGIN
263     FOR output IN
264         SELECT x.t FROM (
265             SELECT id,t
266                 FROM  oils_xpath_table(
267                     'id', 'marc', $1, $3, 'id = ' || $2)
268                 AS t(id int, t text))x
269         LOOP
270         IF $4 IS NOT NULL THEN
271             SELECT INTO output (SELECT regexp_replace(output, $4, '', 'g'));
272         END IF;
273         RETURN NEXT output;
274     END LOOP;
275     RETURN;
276 END;
277 $$ LANGUAGE PLPGSQL IMMUTABLE;
278
279
280 CREATE OR REPLACE FUNCTION extract_marc_field ( TEXT, BIGINT, TEXT ) RETURNS TEXT AS $$
281     SELECT extract_marc_field($1,$2,$3,'');
282 $$ LANGUAGE SQL IMMUTABLE;
283
284
285
286 CREATE OR REPLACE FUNCTION oils_i18n_xlate ( keytable TEXT, keyclass TEXT, keycol TEXT, identcol TEXT, keyvalue TEXT, raw_locale TEXT ) RETURNS TEXT AS $func$
287 DECLARE
288     locale      TEXT := REGEXP_REPLACE( REGEXP_REPLACE( raw_locale, E'[;, ].+$', '' ), E'_', '-', 'g' );
289     language    TEXT := REGEXP_REPLACE( locale, E'-.+$', '' );
290     result      config.i18n_core%ROWTYPE;
291     fallback    TEXT;
292     keyfield    TEXT := keyclass || '.' || keycol;
293 BEGIN
294
295     -- Try the full locale
296     SELECT  * INTO result
297       FROM  config.i18n_core
298       WHERE fq_field = keyfield
299             AND identity_value = keyvalue
300             AND translation = locale;
301
302     -- Try just the language
303     IF NOT FOUND THEN
304         SELECT  * INTO result
305           FROM  config.i18n_core
306           WHERE fq_field = keyfield
307                 AND identity_value = keyvalue
308                 AND translation = language;
309     END IF;
310
311     -- Fall back to the string we passed in in the first place
312     IF NOT FOUND THEN
313         EXECUTE
314             'SELECT ' ||
315                 keycol ||
316             ' FROM ' || keytable ||
317             ' WHERE ' || identcol || ' = ' || quote_literal(keyvalue)
318                 INTO fallback;
319         RETURN fallback;
320     END IF;
321
322     RETURN result.string;
323 END;
324 $func$ LANGUAGE PLPGSQL STABLE;
325
326 -- Functions for marking translatable strings in SQL statements
327 -- Parameters are: primary key, string, class hint, property
328 CREATE OR REPLACE FUNCTION oils_i18n_gettext( INT, TEXT, TEXT, TEXT ) RETURNS TEXT AS $$
329     SELECT $2;
330 $$ LANGUAGE SQL;
331
332 CREATE OR REPLACE FUNCTION oils_i18n_gettext( TEXT, TEXT, TEXT, TEXT ) RETURNS TEXT AS $$
333     SELECT $2;
334 $$ LANGUAGE SQL;
335
336 CREATE OR REPLACE FUNCTION is_json( TEXT ) RETURNS BOOL AS $f$
337     use JSON::XS;
338     my $json = shift();
339     eval { JSON::XS->new->allow_nonref->decode( $json ) };
340     return $@ ? 0 : 1;
341 $f$ LANGUAGE PLPERLU;
342
343 -- turn a JSON scalar into an SQL TEXT value
344 CREATE OR REPLACE FUNCTION oils_json_to_text( TEXT ) RETURNS TEXT AS $f$
345     use JSON::XS;
346     my $json = shift();
347     my $txt;
348     eval { $txt = JSON::XS->new->allow_nonref->decode( $json ) };
349     return undef if ($@);
350     return $txt
351 $f$ LANGUAGE PLPERLU;
352
353 CREATE OR REPLACE FUNCTION evergreen.maintain_901 () RETURNS TRIGGER AS $func$
354 use strict;
355 use MARC::Record;
356 use MARC::File::XML (BinaryEncoding => 'UTF-8');
357 use MARC::Charset;
358 use Encode;
359 use Unicode::Normalize;
360
361 MARC::Charset->assume_unicode(1);
362
363 my $schema = $_TD->{table_schema};
364 my $marc = MARC::Record->new_from_xml($_TD->{new}{marc});
365
366 my @old901s = $marc->field('901');
367 $marc->delete_fields(@old901s);
368
369 if ($schema eq 'biblio') {
370     my $tcn_value = $_TD->{new}{tcn_value};
371
372     # Set TCN value to record ID?
373     my $id_as_tcn = spi_exec_query("
374         SELECT enabled
375         FROM config.global_flag
376         WHERE name = 'cat.bib.use_id_for_tcn'
377     ");
378     if (($id_as_tcn->{processed}) && $id_as_tcn->{rows}[0]->{enabled} eq 't') {
379         $tcn_value = $_TD->{new}{id}; 
380         $_TD->{new}{tcn_value} = $tcn_value;
381     }
382
383     my $new_901 = MARC::Field->new("901", " ", " ",
384         "a" => $tcn_value,
385         "b" => $_TD->{new}{tcn_source},
386         "c" => $_TD->{new}{id},
387         "t" => $schema
388     );
389
390     if ($_TD->{new}{owner}) {
391         $new_901->add_subfields("o" => $_TD->{new}{owner});
392     }
393
394     if ($_TD->{new}{share_depth}) {
395         $new_901->add_subfields("d" => $_TD->{new}{share_depth});
396     }
397
398     if ($_TD->{new}{source}) {
399         my $plan = spi_prepare('
400             SELECT source
401             FROM config.bib_source
402             WHERE id = $1
403         ', 'INTEGER');
404         my $source_name =
405             spi_exec_prepared($plan, {limit => 1}, $_TD->{new}{source})->{rows}[0]{source};
406         spi_freeplan($plan);
407         $new_901->add_subfields("s" => $source_name) if $source_name;
408     }
409
410     $marc->append_fields($new_901);
411 } elsif ($schema eq 'authority') {
412     my $new_901 = MARC::Field->new("901", " ", " ",
413         "c" => $_TD->{new}{id},
414         "t" => $schema,
415     );
416     $marc->append_fields($new_901);
417 } elsif ($schema eq 'serial') {
418     my $new_901 = MARC::Field->new("901", " ", " ",
419         "c" => $_TD->{new}{id},
420         "t" => $schema,
421         "o" => $_TD->{new}{owning_lib},
422     );
423
424     if ($_TD->{new}{record}) {
425         $new_901->add_subfields("r" => $_TD->{new}{record});
426     }
427
428     $marc->append_fields($new_901);
429 } else {
430     my $new_901 = MARC::Field->new("901", " ", " ",
431         "c" => $_TD->{new}{id},
432         "t" => $schema,
433     );
434     $marc->append_fields($new_901);
435 }
436
437 my $xml = $marc->as_xml_record();
438 $xml =~ s/\n//sgo;
439 $xml =~ s/^<\?xml.+\?\s*>//go;
440 $xml =~ s/>\s+</></go;
441 $xml =~ s/\p{Cc}//go;
442
443 # Embed a version of OpenILS::Application::AppUtils->entityize()
444 # to avoid having to set PERL5LIB for PostgreSQL as well
445
446 $xml = NFC($xml);
447
448 # Convert raw ampersands to entities
449 $xml =~ s/&(?!\S+;)/&amp;/gso;
450
451 # Convert Unicode characters to entities
452 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
453
454 $xml =~ s/[\x00-\x1f]//go;
455 $_TD->{new}{marc} = $xml;
456
457 return "MODIFY";
458 $func$ LANGUAGE PLPERLU;
459
460 CREATE OR REPLACE FUNCTION evergreen.force_unicode_normal_form(string TEXT, form TEXT) RETURNS TEXT AS $func$
461 use Unicode::Normalize 'normalize';
462 return normalize($_[1],$_[0]); # reverse the params
463 $func$ LANGUAGE PLPERLU;
464
465 CREATE OR REPLACE FUNCTION evergreen.maintain_control_numbers() RETURNS TRIGGER AS $func$
466 use strict;
467 use MARC::Record;
468 use MARC::File::XML (BinaryEncoding => 'UTF-8');
469 use MARC::Charset;
470 use Encode;
471 use Unicode::Normalize;
472
473 MARC::Charset->assume_unicode(1);
474
475 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
476 my $schema = $_TD->{table_schema};
477 my $rec_id = $_TD->{new}{id};
478
479 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
480 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
481 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
482     return;
483 }
484
485 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
486 my $ou_cni = 'EVRGRN';
487
488 my $owner;
489 if ($schema eq 'serial') {
490     $owner = $_TD->{new}{owning_lib};
491 } else {
492     # are.owner and bre.owner can be null, so fall back to the consortial setting
493     $owner = $_TD->{new}{owner} || 1;
494 }
495
496 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
497 if ($ous_rv->{processed}) {
498     $ou_cni = $ous_rv->{rows}[0]->{value};
499     $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
500 } else {
501     # Fall back to the shortname of the OU if there was no OU setting
502     $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
503     if ($ous_rv->{processed}) {
504         $ou_cni = $ous_rv->{rows}[0]->{shortname};
505     }
506 }
507
508 my ($create, $munge) = (0, 0);
509
510 my @scns = $record->field('035');
511
512 foreach my $id_field ('001', '003') {
513     my $spec_value;
514     my @controls = $record->field($id_field);
515
516     if ($id_field eq '001') {
517         $spec_value = $rec_id;
518     } else {
519         $spec_value = $ou_cni;
520     }
521
522     # Create the 001/003 if none exist
523     if (scalar(@controls) == 1) {
524         # Only one field; check to see if we need to munge it
525         unless (grep $_->data() eq $spec_value, @controls) {
526             $munge = 1;
527         }
528     } else {
529         # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
530         foreach my $control (@controls) {
531             $record->delete_field($control);
532         }
533         $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
534         $create = 1;
535     }
536 }
537
538 my $cn = $record->field('001')->data();
539 # Special handling of OCLC numbers, often found in records that lack 003
540 if ($cn =~ /^o(c[nm]|n)\d/) {
541     $cn =~ s/^o(c[nm]|n)0*(\d+)/$2/;
542     $record->field('003')->data('OCoLC');
543     $create = 0;
544 }
545
546 # Now, if we need to munge the 001, we will first push the existing 001/003
547 # into the 035; but if the record did not have one (and one only) 001 and 003
548 # to begin with, skip this process
549 if ($munge and not $create) {
550
551     my $scn = "(" . $record->field('003')->data() . ")" . $cn;
552
553     # Do not create duplicate 035 fields
554     unless (grep $_->subfield('a') eq $scn, @scns) {
555         $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
556     }
557 }
558
559 # Set the 001/003 and update the MARC
560 if ($create or $munge) {
561     $record->field('001')->data($rec_id);
562     $record->field('003')->data($ou_cni);
563
564     my $xml = $record->as_xml_record();
565     $xml =~ s/\n//sgo;
566     $xml =~ s/^<\?xml.+\?\s*>//go;
567     $xml =~ s/>\s+</></go;
568     $xml =~ s/\p{Cc}//go;
569
570     # Embed a version of OpenILS::Application::AppUtils->entityize()
571     # to avoid having to set PERL5LIB for PostgreSQL as well
572
573     $xml = NFC($xml);
574
575     # Convert raw ampersands to entities
576     $xml =~ s/&(?!\S+;)/&amp;/gso;
577
578     # Convert Unicode characters to entities
579     $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
580
581     $xml =~ s/[\x00-\x1f]//go;
582     $_TD->{new}{marc} = $xml;
583
584     return "MODIFY";
585 }
586
587 return;
588 $func$ LANGUAGE PLPERLU;
589
590 CREATE OR REPLACE FUNCTION oils_text_as_bytea (TEXT) RETURNS BYTEA AS $_$
591     SELECT CAST(REGEXP_REPLACE(UPPER($1), $$\\$$, $$\\\\$$, 'g') AS BYTEA);
592 $_$ LANGUAGE SQL IMMUTABLE;
593
594 CREATE OR REPLACE FUNCTION evergreen.lpad_number_substrings( TEXT, TEXT, INT ) RETURNS TEXT AS $$
595     my $string = shift;            # Source string
596     my $pad = shift;               # string to fill. Typically '0'. This should be a single character.
597     my $len = shift;               # length of resultant padded field
598
599     $string =~ s/([0-9]+)/$pad x ($len - length($1)) . $1/eg;
600
601     return $string;
602 $$ LANGUAGE PLPERLU;
603
604 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
605
606     use strict;
607     use Unicode::Normalize;
608     use Encode;
609
610     my $str = shift;
611     my $sf = shift;
612
613     # Apply NACO normalization to input string; based on
614     # https://www.loc.gov/aba/pcc/naco/documents/SCA_PccNormalization_Final_revised.pdf
615     #
616     # Note that unlike a strict reading of the NACO normalization rules,
617     # output is returned as lowercase instead of uppercase for compatibility
618     # with previous versions of the Evergreen naco_normalize routine.
619
620     # Convert to upper-case first; even though final output will be lowercase, doing this will
621     # ensure that the German eszett (ß) and certain ligatures (ff, fi, ffl, etc.) will be handled correctly.
622     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
623     $str = uc $str;
624
625     # remove non-filing strings
626     $str =~ s/\x{0098}.*?\x{009C}//g;
627
628     $str = NFKD($str);
629
630     # additional substitutions - 3.6.
631     $str =~ s/\x{00C6}/AE/g;
632     $str =~ s/\x{00DE}/TH/g;
633     $str =~ s/\x{0152}/OE/g;
634     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
635
636     # transformations based on Unicode category codes
637     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
638
639         if ($sf && $sf =~ /^a/o) {
640                 my $commapos = index($str, ',');
641                 if ($commapos > -1) {
642                         if ($commapos != length($str) - 1) {
643                 $str =~ s/,/\x07/; # preserve first comma
644                         }
645                 }
646         }
647
648     # since we've stripped out the control characters, we can now
649     # use a few as placeholders temporarily
650     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
651     $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;
652     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
653
654     # decimal digits
655     $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/;
656
657     # intentionally skipping step 8 of the NACO algorithm; if the string
658     # gets normalized away, that's fine.
659
660     # leading and trailing spaces
661     $str =~ s/\s+/ /g;
662     $str =~ s/^\s+//;
663     $str =~ s/\s+$//g;
664
665     return lc $str;
666 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
667
668 -- Currently, the only difference from naco_normalize is that search_normalize
669 -- turns apostrophes into spaces, while naco_normalize collapses them.
670 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
671
672     use strict;
673     use Unicode::Normalize;
674     use Encode;
675
676     my $str = shift;
677     my $sf = shift;
678
679     # Apply NACO normalization to input string; based on
680     # https://www.loc.gov/aba/pcc/naco/documents/SCA_PccNormalization_Final_revised.pdf
681     #
682     # Note that unlike a strict reading of the NACO normalization rules,
683     # output is returned as lowercase instead of uppercase for compatibility
684     # with previous versions of the Evergreen naco_normalize routine.
685
686     # Convert to upper-case first; even though final output will be lowercase, doing this will
687     # ensure that the German eszett (ß) and certain ligatures (ff, fi, ffl, etc.) will be handled correctly.
688     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
689     $str = uc $str;
690
691     # remove non-filing strings
692     $str =~ s/\x{0098}.*?\x{009C}//g;
693
694     $str = NFKD($str);
695
696     # additional substitutions - 3.6.
697     $str =~ s/\x{00C6}/AE/g;
698     $str =~ s/\x{00DE}/TH/g;
699     $str =~ s/\x{0152}/OE/g;
700     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}][/DDOLl/d;
701
702     # transformations based on Unicode category codes
703     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
704
705         if ($sf && $sf =~ /^a/o) {
706                 my $commapos = index($str, ',');
707                 if ($commapos > -1) {
708                         if ($commapos != length($str) - 1) {
709                 $str =~ s/,/\x07/; # preserve first comma
710                         }
711                 }
712         }
713
714     # since we've stripped out the control characters, we can now
715     # use a few as placeholders temporarily
716     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
717     $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;
718     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
719
720     # decimal digits
721     $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/;
722
723     # intentionally skipping step 8 of the NACO algorithm; if the string
724     # gets normalized away, that's fine.
725
726     # leading and trailing spaces
727     $str =~ s/\s+/ /g;
728     $str =~ s/^\s+//;
729     $str =~ s/\s+$//g;
730
731     return lc $str;
732 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
733
734 CREATE OR REPLACE FUNCTION public.naco_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
735         SELECT public.naco_normalize($1,'a');
736 $func$ LANGUAGE SQL STRICT IMMUTABLE;
737
738 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT ) RETURNS TEXT AS $func$
739         SELECT public.naco_normalize($1,'');
740 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
741
742 CREATE OR REPLACE FUNCTION public.search_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
743         SELECT public.search_normalize($1,'a');
744 $func$ LANGUAGE SQL STRICT IMMUTABLE;
745
746 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT ) RETURNS TEXT AS $func$
747         SELECT public.search_normalize($1,'');
748 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
749
750
751 COMMIT;
752