2 * Copyright (C) 2004-2008 Georgia Public Library Service
3 * Copyright (C) 2008 Equinox Software, Inc.
4 * Mike Rylander <miker@esilibrary.com>
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.
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.
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))
26 $_$ LANGUAGE SQL STRICT IMMUTABLE;
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);
32 CREATE OR REPLACE FUNCTION oils_xml_uncache (xml TEXT) RETURNS BOOL AS $func$
33 delete $_SHARED{'_xslt_process'}{docs}{shift()};
35 $func$ LANGUAGE PLPERLU;
37 CREATE OR REPLACE FUNCTION oils_xml_cache (xml TEXT) RETURNS BOOL AS $func$
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();
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});
52 # Parse and cache the doc
53 eval { $_SHARED{'_xslt_process'}{docs}{$doc} = $parser->parse_string($doc) };
57 $func$ LANGUAGE PLPERLU;
59 -- if we use these, we need to ...
60 drop function oils_xpath(text, text, anyarray);
62 CREATE OR REPLACE FUNCTION oils_xpath (xpath TEXT, xml TEXT, ns TEXT[][]) RETURNS TEXT[] AS $func$
68 my $ns_string = shift || '';
69 #elog(NOTICE,"ns_string: $ns_string");
71 my %ns_list = $ns_string =~ m/\{([^{,]+),([^}]+)\}/g;
72 #elog(NOTICE,"NS Prefix $_: $ns_list{$_}") for (keys %ns_list);
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() };
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});
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) };
90 # Cache the parsed XML doc, if already there
91 $_SHARED{'_xslt_process'}{docs}{$doc} = $dom
92 unless ($_SHARED{'_xslt_process'}{docs}{$doc});
94 # Register the requested namespaces
95 $dom->documentElement->setNamespace( $ns_list{$_} => $_ ) for ( keys %ns_list );
97 # Gather and return nodes
98 my @nodes = $dom->findnodes($xpath);
99 #elog(NOTICE,"nodes found by $xpath: ". scalar(@nodes));
101 return [ map { $_->toString } @nodes ];
102 $func$ LANGUAGE PLPERLU;
104 CREATE OR REPLACE FUNCTION oils_xpath ( TEXT, TEXT ) RETURNS TEXT[] AS $$SELECT oils_xpath( $1, $2, '{}'::TEXT[] );$$ LANGUAGE SQL IMMUTABLE;
108 CREATE FUNCTION version_specific_xpath () RETURNS TEXT AS $wrapper_function$
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+';
116 EXECUTE $create_82_funcs$
118 CREATE OR REPLACE FUNCTION oils_xpath ( xpath TEXT, xml TEXT, ns ANYARRAY ) RETURNS TEXT[] AS $func$
125 munged_xpath := xpath;
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(
131 E'(' || ns[namespace][1] || E'):(\\w+)',
132 E'*[local-name() = "\\2" and namespace-uri() = "' || ns[namespace][2] || E'"]',
137 munged_xpath := REGEXP_REPLACE( munged_xpath, E'\\]\\[(\\D)',E' and \\1', 'g');
140 -- RAISE NOTICE 'munged xpath: %', munged_xpath;
142 node_text := xpath_nodeset(xml, munged_xpath, 'XXX_OILS_NODESET');
143 -- RAISE NOTICE 'node_text: %', node_text;
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');
150 node_text := REGEXP_REPLACE(node_text,'^<XXX_OILS_NODESET>', '');
151 node_text := REGEXP_REPLACE(node_text,'</XXX_OILS_NODESET>$', '');
153 RETURN STRING_TO_ARRAY(node_text, '</XXX_OILS_NODESET><XXX_OILS_NODESET>');
155 $func$ LANGUAGE PLPGSQL IMMUTABLE;
157 CREATE OR REPLACE FUNCTION oils_xpath ( TEXT, TEXT ) RETURNS TEXT[] AS $$SELECT oils_xpath( $1, $2, '{}'::TEXT[] );$$ LANGUAGE SQL IMMUTABLE;
159 CREATE OR REPLACE FUNCTION oils_xslt_process(TEXT, TEXT) RETURNS TEXT AS $$
160 SELECT xslt_process( $1, $2 );
161 $$ LANGUAGE SQL IMMUTABLE;
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!';
167 EXECUTE $create_83_funcs$
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;
172 CREATE OR REPLACE FUNCTION oils_xslt_process(TEXT, TEXT) RETURNS TEXT AS $$
173 SELECT xslt_process( $1, $2 );
174 $$ LANGUAGE SQL IMMUTABLE;
179 out_text := 'Creating XPath wrapper functions around the native XPATH function in 8.4+, and plperlu-based xslt processor. No contrib/xml2 needed!';
181 EXECUTE $create_84_funcs$
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;
186 CREATE OR REPLACE FUNCTION oils_xslt_process(TEXT, TEXT) RETURNS TEXT AS $func$
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();
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});
204 my $xslt_parser = $_SHARED{'_xslt_process'}{parsers}{xslt} || XML::LibXSLT->new();
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});
210 my $stylesheet = $_SHARED{'_xslt_process'}{stylesheets}{$xslt} ||
211 $xslt_parser->parse_stylesheet( $parser->parse_string($xslt) );
213 $_SHARED{'_xslt_process'}{stylesheets}{$xslt} = $stylesheet
214 unless ($_SHARED{'_xslt_process'}{stylesheets}{$xslt});
216 return $stylesheet->output_string(
217 $stylesheet->transform(
218 $parser->parse_string($doc)
222 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
230 $wrapper_function$ LANGUAGE PLPGSQL;
232 SELECT version_specific_xpath();
233 DROP FUNCTION version_specific_xpath();
236 CREATE OR REPLACE FUNCTION oils_xpath_string ( TEXT, TEXT, TEXT, ANYARRAY ) RETURNS TEXT AS $func$
237 SELECT ARRAY_TO_STRING(
240 CASE WHEN $1 ~ $re$/[^/[]*@[^]]+$$re$ OR $1 ~ $re$text\(\)$$re$ THEN '' ELSE '//text()' END,
246 $func$ LANGUAGE SQL IMMUTABLE;
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;
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;
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;
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$
270 xpath_list := STRING_TO_ARRAY( xpaths, '|' );
272 select_list := ARRAY_APPEND( select_list, key || '::INT AS key' );
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 );
278 select_list := ARRAY_APPEND(
288 WHEN xpath_list[i] ~ $re$/[^/[]*@[^/]+$$re$ OR xpath_list[i] ~ $re$text\(\)$$re$ THEN xpath_list[i]
289 ELSE xpath_list[i] || '//text()'
293 $sel$ || document_field || $sel$
301 where_list := ARRAY_APPEND(
303 'c_' || i || ' IS NOT NULL'
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;
314 FOR out_record IN EXECUTE q LOOP
315 RETURN NEXT out_record;
320 $func$ LANGUAGE PLPGSQL IMMUTABLE;
323 CREATE OR REPLACE FUNCTION extract_marc_field ( TEXT, BIGINT, TEXT, TEXT ) RETURNS TEXT AS $$
329 SELECT regexp_replace(
331 $q$ || quote_literal($3) || $q$,
335 $q$ || quote_literal($4) || $q$,
338 FROM $q$ || $1 || $q$
339 WHERE id = $q$ || $2;
341 EXECUTE query INTO output;
343 -- RAISE NOTICE 'query: %, output; %', query, output;
347 $$ LANGUAGE PLPGSQL IMMUTABLE;
349 CREATE OR REPLACE FUNCTION extract_marc_field_set
350 (TEXT, BIGINT, TEXT, TEXT) RETURNS SETOF TEXT AS $$
358 FROM oils_xpath_table(
359 'id', 'marc', $1, $3, 'id = ' || $2)
360 AS t(id int, t text))x
362 IF $4 IS NOT NULL THEN
363 SELECT INTO output (SELECT regexp_replace(output, $4, '', 'g'));
369 $$ LANGUAGE PLPGSQL IMMUTABLE;
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;
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$
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;
384 keyfield TEXT := keyclass || '.' || keycol;
387 -- Try the full locale
389 FROM config.i18n_core
390 WHERE fq_field = keyfield
391 AND identity_value = keyvalue
392 AND translation = locale;
394 -- Try just the language
397 FROM config.i18n_core
398 WHERE fq_field = keyfield
399 AND identity_value = keyvalue
400 AND translation = language;
403 -- Fall back to the string we passed in in the first place
408 ' FROM ' || keytable ||
409 ' WHERE ' || identcol || ' = ' || quote_literal(keyvalue)
414 RETURN result.string;
416 $func$ LANGUAGE PLPGSQL STABLE;
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 $$
424 CREATE OR REPLACE FUNCTION oils_i18n_gettext( TEXT, TEXT, TEXT, TEXT ) RETURNS TEXT AS $$
428 CREATE OR REPLACE FUNCTION is_json( TEXT ) RETURNS BOOL AS $f$
431 eval { JSON::XS->new->allow_nonref->decode( $json ) };
433 $f$ LANGUAGE PLPERLU;
435 -- turn a JSON scalar into an SQL TEXT value
436 CREATE OR REPLACE FUNCTION oils_json_to_text( TEXT ) RETURNS TEXT AS $f$
440 eval { $txt = JSON::XS->new->allow_nonref->decode( $json ) };
441 return undef if ($@);
443 $f$ LANGUAGE PLPERLU;
445 CREATE OR REPLACE FUNCTION evergreen.maintain_901 () RETURNS TRIGGER AS $func$
448 use MARC::File::XML (BinaryEncoding => 'UTF-8');
451 use Unicode::Normalize;
453 MARC::Charset->assume_unicode(1);
455 my $schema = $_TD->{table_schema};
456 my $marc = MARC::Record->new_from_xml($_TD->{new}{marc});
458 my @old901s = $marc->field('901');
459 $marc->delete_fields(@old901s);
461 if ($schema eq 'biblio') {
462 my $tcn_value = $_TD->{new}{tcn_value};
464 # Set TCN value to record ID?
465 my $id_as_tcn = spi_exec_query("
467 FROM config.global_flag
468 WHERE name = 'cat.bib.use_id_for_tcn'
470 if (($id_as_tcn->{processed}) && $id_as_tcn->{rows}[0]->{enabled} eq 't') {
471 $tcn_value = $_TD->{new}{id};
474 my $new_901 = MARC::Field->new("901", " ", " ",
476 "b" => $_TD->{new}{tcn_source},
477 "c" => $_TD->{new}{id},
481 if ($_TD->{new}{owner}) {
482 $new_901->add_subfields("o" => $_TD->{new}{owner});
485 if ($_TD->{new}{share_depth}) {
486 $new_901->add_subfields("d" => $_TD->{new}{share_depth});
489 $marc->append_fields($new_901);
490 } elsif ($schema eq 'authority') {
491 my $new_901 = MARC::Field->new("901", " ", " ",
492 "c" => $_TD->{new}{id},
495 $marc->append_fields($new_901);
496 } elsif ($schema eq 'serial') {
497 my $new_901 = MARC::Field->new("901", " ", " ",
498 "c" => $_TD->{new}{id},
500 "o" => $_TD->{new}{owning_lib},
503 if ($_TD->{new}{record}) {
504 $new_901->add_subfields("r" => $_TD->{new}{record});
507 $marc->append_fields($new_901);
509 my $new_901 = MARC::Field->new("901", " ", " ",
510 "c" => $_TD->{new}{id},
513 $marc->append_fields($new_901);
516 my $xml = $marc->as_xml_record();
518 $xml =~ s/^<\?xml.+\?\s*>//go;
519 $xml =~ s/>\s+</></go;
520 $xml =~ s/\p{Cc}//go;
522 # Embed a version of OpenILS::Application::AppUtils->entityize()
523 # to avoid having to set PERL5LIB for PostgreSQL as well
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);
531 # Convert raw ampersands to entities
532 $xml =~ s/&(?!\S+;)/&/gso;
534 # Convert Unicode characters to entities
535 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
537 $xml =~ s/[\x00-\x1f]//go;
538 $_TD->{new}{marc} = $xml;
541 $func$ LANGUAGE PLPERLU;
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;
548 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
551 use MARC::File::XML (BinaryEncoding => 'UTF-8');
554 use Unicode::Normalize;
556 MARC::Charset->assume_unicode(1);
558 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
559 my $schema = $_TD->{table_schema};
560 my $rec_id = $_TD->{new}{id};
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') {
568 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
569 my $ou_cni = 'EVRGRN';
572 if ($schema eq 'serial') {
573 $owner = $_TD->{new}{owning_lib};
575 # are.owner and bre.owner can be null, so fall back to the consortial setting
576 $owner = $_TD->{new}{owner} || 1;
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"
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};
591 my ($create, $munge) = (0, 0);
593 my @scns = $record->field('035');
595 foreach my $id_field ('001', '003') {
597 my @controls = $record->field($id_field);
599 if ($id_field eq '001') {
600 $spec_value = $rec_id;
602 $spec_value = $ou_cni;
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) {
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);
616 $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
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');
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) {
634 my $scn = "(" . $record->field('003')->data() . ")" . $cn;
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));
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);
647 my $xml = $record->as_xml_record();
649 $xml =~ s/^<\?xml.+\?\s*>//go;
650 $xml =~ s/>\s+</></go;
651 $xml =~ s/\p{Cc}//go;
653 # Embed a version of OpenILS::Application::AppUtils->entityize()
654 # to avoid having to set PERL5LIB for PostgreSQL as well
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);
662 # Convert raw ampersands to entities
663 $xml =~ s/&(?!\S+;)/&/gso;
665 # Convert Unicode characters to entities
666 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
668 $xml =~ s/[\x00-\x1f]//go;
669 $_TD->{new}{marc} = $xml;
675 $func$ LANGUAGE PLPERLU;
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;
681 CREATE OR REPLACE FUNCTION evergreen.lpad_number_substrings( TEXT, TEXT, INT ) RETURNS TEXT AS $$
687 while ($string =~ /(?:^|\D)(\d{1,$find})(?:$|\D)/) {
689 $padded = $pad x ($len - length($padded)) . $padded;
690 $string =~ s/$1/$padded/sg;
696 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
699 use Unicode::Normalize;
702 my $str = decode_utf8(shift);
705 # Apply NACO normalization to input string; based on
706 # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
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.
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.
717 # remove non-filing strings
718 $str =~ s/\x{0098}.*?\x{009C}//g;
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;
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;
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
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}#,/;
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/;
749 # intentionally skipping step 8 of the NACO algorithm; if the string
750 # gets normalized away, that's fine.
752 # leading and trailing spaces
758 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
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$
765 use Unicode::Normalize;
768 my $str = decode_utf8(shift);
771 # Apply NACO normalization to input string; based on
772 # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
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.
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.
783 # remove non-filing strings
784 $str =~ s/\x{0098}.*?\x{009C}//g;
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;
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;
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
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}#,/;
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/;
815 # intentionally skipping step 8 of the NACO algorithm; if the string
816 # gets normalized away, that's fine.
818 # leading and trailing spaces
824 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
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;
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;
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;
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;