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