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_string(
  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
 189 CREATE OR REPLACE FUNCTION extract_marc_field ( TEXT, BIGINT, TEXT, TEXT ) RETURNS TEXT AS $$
 190 DECLARE
 191     query TEXT;
 192     output TEXT;
 193 BEGIN
 194     query := $q$
 195         SELECT  regexp_replace(
 196                     oils_xpath_string(
 197                         $q$ || quote_literal($3) || $q$,
 198                         marc,
 199                         ' '
 200                     ),
 201                     $q$ || quote_literal($4) || $q$,
 202                     '',
 203                     'g')
 204           FROM  $q$ || $1 || $q$
 205           WHERE id = $q$ || $2;
 206
 207     EXECUTE query INTO output;
 208
 209     -- RAISE NOTICE 'query: %, output; %', query, output;
 210
 211     RETURN output;
 212 END;
 213 $$ LANGUAGE PLPGSQL IMMUTABLE;
 214
 215 CREATE OR REPLACE FUNCTION extract_marc_field_set
 216         (TEXT, BIGINT, TEXT, TEXT) RETURNS SETOF TEXT AS $$
 217 DECLARE
 218     query TEXT;
 219     output TEXT;
 220 BEGIN
 221     FOR output IN
 222         SELECT x.t FROM (
 223             SELECT id,t
 224                 FROM  oils_xpath_table(
 225                     'id', 'marc', $1, $3, 'id = ' || $2)
 226                 AS t(id int, t text))x
 227         LOOP
 228         IF $4 IS NOT NULL THEN
 229             SELECT INTO output (SELECT regexp_replace(output, $4, '', 'g'));
 230         END IF;
 231         RETURN NEXT output;
 232     END LOOP;
 233     RETURN;
 234 END;
 235 $$ LANGUAGE PLPGSQL IMMUTABLE;
 236
 237
 238 CREATE OR REPLACE FUNCTION extract_marc_field ( TEXT, BIGINT, TEXT ) RETURNS TEXT AS $$
 239     SELECT extract_marc_field($1,$2,$3,'');
 240 $$ LANGUAGE SQL IMMUTABLE;
 241
 242
 243
 244 CREATE OR REPLACE FUNCTION oils_i18n_xlate ( keytable TEXT, keyclass TEXT, keycol TEXT, identcol TEXT, keyvalue TEXT, raw_locale TEXT ) RETURNS TEXT AS $func$
 245 DECLARE
 246     locale      TEXT := REGEXP_REPLACE( REGEXP_REPLACE( raw_locale, E'[;, ].+$', '' ), E'_', '-', 'g' );
 247     language    TEXT := REGEXP_REPLACE( locale, E'-.+$', '' );
 248     result      config.i18n_core%ROWTYPE;
 249     fallback    TEXT;
 250     keyfield    TEXT := keyclass || '.' || keycol;
 251 BEGIN
 252
 253     -- Try the full locale
 254     SELECT  * INTO result
 255       FROM  config.i18n_core
 256       WHERE fq_field = keyfield
 257             AND identity_value = keyvalue
 258             AND translation = locale;
 259
 260     -- Try just the language
 261     IF NOT FOUND THEN
 262         SELECT  * INTO result
 263           FROM  config.i18n_core
 264           WHERE fq_field = keyfield
 265                 AND identity_value = keyvalue
 266                 AND translation = language;
 267     END IF;
 268
 269     -- Fall back to the string we passed in in the first place
 270     IF NOT FOUND THEN
 271         EXECUTE
 272             'SELECT ' ||
 273                 keycol ||
 274             ' FROM ' || keytable ||
 275             ' WHERE ' || identcol || ' = ' || quote_literal(keyvalue)
 276                 INTO fallback;
 277         RETURN fallback;
 278     END IF;
 279
 280     RETURN result.string;
 281 END;
 282 $func$ LANGUAGE PLPGSQL STABLE;
 283
 284 -- Functions for marking translatable strings in SQL statements
 285 -- Parameters are: primary key, string, class hint, property
 286 CREATE OR REPLACE FUNCTION oils_i18n_gettext( INT, TEXT, TEXT, TEXT ) RETURNS TEXT AS $$
 287     SELECT $2;
 288 $$ LANGUAGE SQL;
 289
 290 CREATE OR REPLACE FUNCTION oils_i18n_gettext( TEXT, TEXT, TEXT, TEXT ) RETURNS TEXT AS $$
 291     SELECT $2;
 292 $$ LANGUAGE SQL;
 293
 294 CREATE OR REPLACE FUNCTION is_json( TEXT ) RETURNS BOOL AS $f$
 295     use JSON::XS;
 296     my $json = shift();
 297     eval { JSON::XS->new->allow_nonref->decode( $json ) };
 298     return $@ ? 0 : 1;
 299 $f$ LANGUAGE PLPERLU;
 300
 301 -- turn a JSON scalar into an SQL TEXT value
 302 CREATE OR REPLACE FUNCTION oils_json_to_text( TEXT ) RETURNS TEXT AS $f$
 303     use JSON::XS;
 304     my $json = shift();
 305     my $txt;
 306     eval { $txt = JSON::XS->new->allow_nonref->decode( $json ) };
 307     return undef if ($@);
 308     return $txt
 309 $f$ LANGUAGE PLPERLU;
 310
 311 CREATE OR REPLACE FUNCTION evergreen.maintain_901 () RETURNS TRIGGER AS $func$
 312 use strict;
 313 use MARC::Record;
 314 use MARC::File::XML (BinaryEncoding => 'UTF-8');
 315 use MARC::Charset;
 316 use Encode;
 317 use Unicode::Normalize;
 318
 319 MARC::Charset->assume_unicode(1);
 320
 321 my $schema = $_TD->{table_schema};
 322 my $marc = MARC::Record->new_from_xml($_TD->{new}{marc});
 323
 324 my @old901s = $marc->field('901');
 325 $marc->delete_fields(@old901s);
 326
 327 if ($schema eq 'biblio') {
 328     my $tcn_value = $_TD->{new}{tcn_value};
 329
 330     # Set TCN value to record ID?
 331     my $id_as_tcn = spi_exec_query("
 332         SELECT enabled
 333         FROM config.global_flag
 334         WHERE name = 'cat.bib.use_id_for_tcn'
 335     ");
 336     if (($id_as_tcn->{processed}) && $id_as_tcn->{rows}[0]->{enabled} eq 't') {
 337         $tcn_value = $_TD->{new}{id};
 338         $_TD->{new}{tcn_value} = $tcn_value;
 339     }
 340
 341     my $new_901 = MARC::Field->new("901", " ", " ",
 342         "a" => $tcn_value,
 343         "b" => $_TD->{new}{tcn_source},
 344         "c" => $_TD->{new}{id},
 345         "t" => $schema
 346     );
 347
 348     if ($_TD->{new}{owner}) {
 349         $new_901->add_subfields("o" => $_TD->{new}{owner});
 350     }
 351
 352     if ($_TD->{new}{share_depth}) {
 353         $new_901->add_subfields("d" => $_TD->{new}{share_depth});
 354     }
 355
 356     $marc->append_fields($new_901);
 357 } elsif ($schema eq 'authority') {
 358     my $new_901 = MARC::Field->new("901", " ", " ",
 359         "c" => $_TD->{new}{id},
 360         "t" => $schema,
 361     );
 362     $marc->append_fields($new_901);
 363 } elsif ($schema eq 'serial') {
 364     my $new_901 = MARC::Field->new("901", " ", " ",
 365         "c" => $_TD->{new}{id},
 366         "t" => $schema,
 367         "o" => $_TD->{new}{owning_lib},
 368     );
 369
 370     if ($_TD->{new}{record}) {
 371         $new_901->add_subfields("r" => $_TD->{new}{record});
 372     }
 373
 374     $marc->append_fields($new_901);
 375 } else {
 376     my $new_901 = MARC::Field->new("901", " ", " ",
 377         "c" => $_TD->{new}{id},
 378         "t" => $schema,
 379     );
 380     $marc->append_fields($new_901);
 381 }
 382
 383 my $xml = $marc->as_xml_record();
 384 $xml =~ s/\n//sgo;
 385 $xml =~ s/^<\?xml.+\?\s*>//go;
 386 $xml =~ s/>\s+</></go;
 387 $xml =~ s/\p{Cc}//go;
 388
 389 # Embed a version of OpenILS::Application::AppUtils->entityize()
 390 # to avoid having to set PERL5LIB for PostgreSQL as well
 391
 392 $xml = NFC($xml);
 393
 394 # Convert raw ampersands to entities
 395 $xml =~ s/&(?!\S+;)/&amp;/gso;
 396
 397 # Convert Unicode characters to entities
 398 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 399
 400 $xml =~ s/[\x00-\x1f]//go;
 401 $_TD->{new}{marc} = $xml;
 402
 403 return "MODIFY";
 404 $func$ LANGUAGE PLPERLU;
 405
 406 CREATE OR REPLACE FUNCTION evergreen.force_unicode_normal_form(string TEXT, form TEXT) RETURNS TEXT AS $func$
 407 use Unicode::Normalize 'normalize';
 408 return normalize($_[1],$_[0]); # reverse the params
 409 $func$ LANGUAGE PLPERLU;
 410
 411 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
 412 use strict;
 413 use MARC::Record;
 414 use MARC::File::XML (BinaryEncoding => 'UTF-8');
 415 use MARC::Charset;
 416 use Encode;
 417 use Unicode::Normalize;
 418
 419 MARC::Charset->assume_unicode(1);
 420
 421 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
 422 my $schema = $_TD->{table_schema};
 423 my $rec_id = $_TD->{new}{id};
 424
 425 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
 426 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
 427 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
 428     return;
 429 }
 430
 431 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
 432 my $ou_cni = 'EVRGRN';
 433
 434 my $owner;
 435 if ($schema eq 'serial') {
 436     $owner = $_TD->{new}{owning_lib};
 437 } else {
 438     # are.owner and bre.owner can be null, so fall back to the consortial setting
 439     $owner = $_TD->{new}{owner} || 1;
 440 }
 441
 442 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
 443 if ($ous_rv->{processed}) {
 444     $ou_cni = $ous_rv->{rows}[0]->{value};
 445     $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
 446 } else {
 447     # Fall back to the shortname of the OU if there was no OU setting
 448     $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
 449     if ($ous_rv->{processed}) {
 450         $ou_cni = $ous_rv->{rows}[0]->{shortname};
 451     }
 452 }
 453
 454 my ($create, $munge) = (0, 0);
 455
 456 my @scns = $record->field('035');
 457
 458 foreach my $id_field ('001', '003') {
 459     my $spec_value;
 460     my @controls = $record->field($id_field);
 461
 462     if ($id_field eq '001') {
 463         $spec_value = $rec_id;
 464     } else {
 465         $spec_value = $ou_cni;
 466     }
 467
 468     # Create the 001/003 if none exist
 469     if (scalar(@controls) == 1) {
 470         # Only one field; check to see if we need to munge it
 471         unless (grep $_->data() eq $spec_value, @controls) {
 472             $munge = 1;
 473         }
 474     } else {
 475         # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
 476         foreach my $control (@controls) {
 477             $record->delete_field($control);
 478         }
 479         $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
 480         $create = 1;
 481     }
 482 }
 483
 484 my $cn = $record->field('001')->data();
 485 # Special handling of OCLC numbers, often found in records that lack 003
 486 if ($cn =~ /^o(c[nm]|n)\d/) {
 487     $cn =~ s/^o(c[nm]|n)0*(\d+)/$2/;
 488     $record->field('003')->data('OCoLC');
 489     $create = 0;
 490 }
 491
 492 # Now, if we need to munge the 001, we will first push the existing 001/003
 493 # into the 035; but if the record did not have one (and one only) 001 and 003
 494 # to begin with, skip this process
 495 if ($munge and not $create) {
 496
 497     my $scn = "(" . $record->field('003')->data() . ")" . $cn;
 498
 499     # Do not create duplicate 035 fields
 500     unless (grep $_->subfield('a') eq $scn, @scns) {
 501         $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
 502     }
 503 }
 504
 505 # Set the 001/003 and update the MARC
 506 if ($create or $munge) {
 507     $record->field('001')->data($rec_id);
 508     $record->field('003')->data($ou_cni);
 509
 510     my $xml = $record->as_xml_record();
 511     $xml =~ s/\n//sgo;
 512     $xml =~ s/^<\?xml.+\?\s*>//go;
 513     $xml =~ s/>\s+</></go;
 514     $xml =~ s/\p{Cc}//go;
 515
 516     # Embed a version of OpenILS::Application::AppUtils->entityize()
 517     # to avoid having to set PERL5LIB for PostgreSQL as well
 518
 519     $xml = NFC($xml);
 520
 521     # Convert raw ampersands to entities
 522     $xml =~ s/&(?!\S+;)/&amp;/gso;
 523
 524     # Convert Unicode characters to entities
 525     $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 526
 527     $xml =~ s/[\x00-\x1f]//go;
 528     $_TD->{new}{marc} = $xml;
 529
 530     return "MODIFY";
 531 }
 532
 533 return;
 534 $func$ LANGUAGE PLPERLU;
 535
 536 CREATE OR REPLACE FUNCTION oils_text_as_bytea (TEXT) RETURNS BYTEA AS $_$
 537     SELECT CAST(REGEXP_REPLACE(UPPER($1), $$\\$$, $$\\\\$$, 'g') AS BYTEA);
 538 $_$ LANGUAGE SQL IMMUTABLE;
 539
 540 CREATE OR REPLACE FUNCTION evergreen.lpad_number_substrings( TEXT, TEXT, INT ) RETURNS TEXT AS $$
 541     my $string = shift;            # Source string
 542     my $pad = shift;               # string to fill. Typically '0'. This should be a single character.
 543     my $len = shift;               # length of resultant padded field
 544     my $find = $len - 1;
 545
 546     while ($string =~ /(^|\D)(\d{1,$find})($|\D)/) {
 547         my $padded = $2;
 548         $padded = $pad x ($len - length($padded)) . $padded;
 549         $string = $` . $1 . $padded . $3 . $';
 550     }
 551
 552     return $string;
 553 $$ LANGUAGE PLPERLU;
 554
 555 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
 556
 557     use strict;
 558     use Unicode::Normalize;
 559     use Encode;
 560
 561     my $str = shift;
 562     my $sf = shift;
 563
 564     # Apply NACO normalization to input string; based on
 565     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
 566     #
 567     # Note that unlike a strict reading of the NACO normalization rules,
 568     # output is returned as lowercase instead of uppercase for compatibility
 569     # with previous versions of the Evergreen naco_normalize routine.
 570
 571     # Convert to upper-case first; even though final output will be lowercase, doing this will
 572     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
 573     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
 574     $str = uc $str;
 575
 576     # remove non-filing strings
 577     $str =~ s/\x{0098}.*?\x{009C}//g;
 578
 579     $str = NFKD($str);
 580
 581     # additional substitutions - 3.6.
 582     $str =~ s/\x{00C6}/AE/g;
 583     $str =~ s/\x{00DE}/TH/g;
 584     $str =~ s/\x{0152}/OE/g;
 585     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
 586
 587     # transformations based on Unicode category codes
 588     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
 589
 590         if ($sf && $sf =~ /^a/o) {
 591                 my $commapos = index($str, ',');
 592                 if ($commapos > -1) {
 593                         if ($commapos != length($str) - 1) {
 594                 $str =~ s/,/\x07/; # preserve first comma
 595                         }
 596                 }
 597         }
 598
 599     # since we've stripped out the control characters, we can now
 600     # use a few as placeholders temporarily
 601     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
 602     $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;
 603     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
 604
 605     # decimal digits
 606     $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/;
 607
 608     # intentionally skipping step 8 of the NACO algorithm; if the string
 609     # gets normalized away, that's fine.
 610
 611     # leading and trailing spaces
 612     $str =~ s/\s+/ /g;
 613     $str =~ s/^\s+//;
 614     $str =~ s/\s+$//g;
 615
 616     return lc $str;
 617 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 618
 619 -- Currently, the only difference from naco_normalize is that search_normalize
 620 -- turns apostrophes into spaces, while naco_normalize collapses them.
 621 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
 622
 623     use strict;
 624     use Unicode::Normalize;
 625     use Encode;
 626
 627     my $str = shift;
 628     my $sf = shift;
 629
 630     # Apply NACO normalization to input string; based on
 631     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
 632     #
 633     # Note that unlike a strict reading of the NACO normalization rules,
 634     # output is returned as lowercase instead of uppercase for compatibility
 635     # with previous versions of the Evergreen naco_normalize routine.
 636
 637     # Convert to upper-case first; even though final output will be lowercase, doing this will
 638     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
 639     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
 640     $str = uc $str;
 641
 642     # remove non-filing strings
 643     $str =~ s/\x{0098}.*?\x{009C}//g;
 644
 645     $str = NFKD($str);
 646
 647     # additional substitutions - 3.6.
 648     $str =~ s/\x{00C6}/AE/g;
 649     $str =~ s/\x{00DE}/TH/g;
 650     $str =~ s/\x{0152}/OE/g;
 651     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}][/DDOLl/d;
 652
 653     # transformations based on Unicode category codes
 654     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
 655
 656         if ($sf && $sf =~ /^a/o) {
 657                 my $commapos = index($str, ',');
 658                 if ($commapos > -1) {
 659                         if ($commapos != length($str) - 1) {
 660                 $str =~ s/,/\x07/; # preserve first comma
 661                         }
 662                 }
 663         }
 664
 665     # since we've stripped out the control characters, we can now
 666     # use a few as placeholders temporarily
 667     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
 668     $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;
 669     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
 670
 671     # decimal digits
 672     $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/;
 673
 674     # intentionally skipping step 8 of the NACO algorithm; if the string
 675     # gets normalized away, that's fine.
 676
 677     # leading and trailing spaces
 678     $str =~ s/\s+/ /g;
 679     $str =~ s/^\s+//;
 680     $str =~ s/\s+$//g;
 681
 682     return lc $str;
 683 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 684
 685 CREATE OR REPLACE FUNCTION public.naco_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
 686         SELECT public.naco_normalize($1,'a');
 687 $func$ LANGUAGE SQL STRICT IMMUTABLE;
 688
 689 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT ) RETURNS TEXT AS $func$
 690         SELECT public.naco_normalize($1,'');
 691 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
 692
 693 CREATE OR REPLACE FUNCTION public.search_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
 694         SELECT public.search_normalize($1,'a');
 695 $func$ LANGUAGE SQL STRICT IMMUTABLE;
 696
 697 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT ) RETURNS TEXT AS $func$
 698         SELECT public.search_normalize($1,'');
 699 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
 700
 701
 702 COMMIT;
 703