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         $_TD->{new}{tcn_value} = $tcn_value;
 473     }
 474
 475     my $new_901 = MARC::Field->new("901", " ", " ",
 476         "a" => $tcn_value,
 477         "b" => $_TD->{new}{tcn_source},
 478         "c" => $_TD->{new}{id},
 479         "t" => $schema
 480     );
 481
 482     if ($_TD->{new}{owner}) {
 483         $new_901->add_subfields("o" => $_TD->{new}{owner});
 484     }
 485
 486     if ($_TD->{new}{share_depth}) {
 487         $new_901->add_subfields("d" => $_TD->{new}{share_depth});
 488     }
 489
 490     $marc->append_fields($new_901);
 491 } elsif ($schema eq 'authority') {
 492     my $new_901 = MARC::Field->new("901", " ", " ",
 493         "c" => $_TD->{new}{id},
 494         "t" => $schema,
 495     );
 496     $marc->append_fields($new_901);
 497 } elsif ($schema eq 'serial') {
 498     my $new_901 = MARC::Field->new("901", " ", " ",
 499         "c" => $_TD->{new}{id},
 500         "t" => $schema,
 501         "o" => $_TD->{new}{owning_lib},
 502     );
 503
 504     if ($_TD->{new}{record}) {
 505         $new_901->add_subfields("r" => $_TD->{new}{record});
 506     }
 507
 508     $marc->append_fields($new_901);
 509 } else {
 510     my $new_901 = MARC::Field->new("901", " ", " ",
 511         "c" => $_TD->{new}{id},
 512         "t" => $schema,
 513     );
 514     $marc->append_fields($new_901);
 515 }
 516
 517 my $xml = $marc->as_xml_record();
 518 $xml =~ s/\n//sgo;
 519 $xml =~ s/^<\?xml.+\?\s*>//go;
 520 $xml =~ s/>\s+</></go;
 521 $xml =~ s/\p{Cc}//go;
 522
 523 # Embed a version of OpenILS::Application::AppUtils->entityize()
 524 # to avoid having to set PERL5LIB for PostgreSQL as well
 525
 526 # If we are going to convert non-ASCII characters to XML entities,
 527 # we had better be dealing with a UTF8 string to begin with
 528 $xml = decode_utf8($xml);
 529
 530 $xml = NFC($xml);
 531
 532 # Convert raw ampersands to entities
 533 $xml =~ s/&(?!\S+;)/&amp;/gso;
 534
 535 # Convert Unicode characters to entities
 536 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 537
 538 $xml =~ s/[\x00-\x1f]//go;
 539 $_TD->{new}{marc} = $xml;
 540
 541 return "MODIFY";
 542 $func$ LANGUAGE PLPERLU;
 543
 544 CREATE OR REPLACE FUNCTION evergreen.force_unicode_normal_form(string TEXT, form TEXT) RETURNS TEXT AS $func$
 545 use Unicode::Normalize 'normalize';
 546 return normalize($_[1],$_[0]); # reverse the params
 547 $func$ LANGUAGE PLPERLU;
 548
 549 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
 550 use strict;
 551 use MARC::Record;
 552 use MARC::File::XML (BinaryEncoding => 'UTF-8');
 553 use MARC::Charset;
 554 use Encode;
 555 use Unicode::Normalize;
 556
 557 MARC::Charset->assume_unicode(1);
 558
 559 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
 560 my $schema = $_TD->{table_schema};
 561 my $rec_id = $_TD->{new}{id};
 562
 563 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
 564 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
 565 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
 566     return;
 567 }
 568
 569 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
 570 my $ou_cni = 'EVRGRN';
 571
 572 my $owner;
 573 if ($schema eq 'serial') {
 574     $owner = $_TD->{new}{owning_lib};
 575 } else {
 576     # are.owner and bre.owner can be null, so fall back to the consortial setting
 577     $owner = $_TD->{new}{owner} || 1;
 578 }
 579
 580 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
 581 if ($ous_rv->{processed}) {
 582     $ou_cni = $ous_rv->{rows}[0]->{value};
 583     $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
 584 } else {
 585     # Fall back to the shortname of the OU if there was no OU setting
 586     $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
 587     if ($ous_rv->{processed}) {
 588         $ou_cni = $ous_rv->{rows}[0]->{shortname};
 589     }
 590 }
 591
 592 my ($create, $munge) = (0, 0);
 593
 594 my @scns = $record->field('035');
 595
 596 foreach my $id_field ('001', '003') {
 597     my $spec_value;
 598     my @controls = $record->field($id_field);
 599
 600     if ($id_field eq '001') {
 601         $spec_value = $rec_id;
 602     } else {
 603         $spec_value = $ou_cni;
 604     }
 605
 606     # Create the 001/003 if none exist
 607     if (scalar(@controls) == 1) {
 608         # Only one field; check to see if we need to munge it
 609         unless (grep $_->data() eq $spec_value, @controls) {
 610             $munge = 1;
 611         }
 612     } else {
 613         # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
 614         foreach my $control (@controls) {
 615             $record->delete_field($control);
 616         }
 617         $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
 618         $create = 1;
 619     }
 620 }
 621
 622 my $cn = $record->field('001')->data();
 623 # Special handling of OCLC numbers, often found in records that lack 003
 624 if ($cn =~ /^o(c[nm]|n)\d/) {
 625     $cn =~ s/^o(c[nm]|n)0*(\d+)/$2/;
 626     $record->field('003')->data('OCoLC');
 627     $create = 0;
 628 }
 629
 630 # Now, if we need to munge the 001, we will first push the existing 001/003
 631 # into the 035; but if the record did not have one (and one only) 001 and 003
 632 # to begin with, skip this process
 633 if ($munge and not $create) {
 634
 635     my $scn = "(" . $record->field('003')->data() . ")" . $cn;
 636
 637     # Do not create duplicate 035 fields
 638     unless (grep $_->subfield('a') eq $scn, @scns) {
 639         $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
 640     }
 641 }
 642
 643 # Set the 001/003 and update the MARC
 644 if ($create or $munge) {
 645     $record->field('001')->data($rec_id);
 646     $record->field('003')->data($ou_cni);
 647
 648     my $xml = $record->as_xml_record();
 649     $xml =~ s/\n//sgo;
 650     $xml =~ s/^<\?xml.+\?\s*>//go;
 651     $xml =~ s/>\s+</></go;
 652     $xml =~ s/\p{Cc}//go;
 653
 654     # Embed a version of OpenILS::Application::AppUtils->entityize()
 655     # to avoid having to set PERL5LIB for PostgreSQL as well
 656
 657     # If we are going to convert non-ASCII characters to XML entities,
 658     # we had better be dealing with a UTF8 string to begin with
 659     $xml = decode_utf8($xml);
 660
 661     $xml = NFC($xml);
 662
 663     # Convert raw ampersands to entities
 664     $xml =~ s/&(?!\S+;)/&amp;/gso;
 665
 666     # Convert Unicode characters to entities
 667     $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 668
 669     $xml =~ s/[\x00-\x1f]//go;
 670     $_TD->{new}{marc} = $xml;
 671
 672     return "MODIFY";
 673 }
 674
 675 return;
 676 $func$ LANGUAGE PLPERLU;
 677
 678 CREATE OR REPLACE FUNCTION oils_text_as_bytea (TEXT) RETURNS BYTEA AS $_$
 679     SELECT CAST(REGEXP_REPLACE(UPPER($1), $$\\$$, $$\\\\$$, 'g') AS BYTEA);
 680 $_$ LANGUAGE SQL IMMUTABLE;
 681
 682 CREATE OR REPLACE FUNCTION evergreen.lpad_number_substrings( TEXT, TEXT, INT ) RETURNS TEXT AS $$
 683     my $string = shift;
 684     my $pad = shift;
 685     my $len = shift;
 686     my $find = $len - 1;
 687
 688     while ($string =~ /(?:^|\D)(\d{1,$find})(?:$|\D)/) {
 689         my $padded = $1;
 690         $padded = $pad x ($len - length($padded)) . $padded;
 691         $string =~ s/$1/$padded/sg;
 692     }
 693
 694     return $string;
 695 $$ LANGUAGE PLPERLU;
 696
 697 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
 698
 699     use strict;
 700     use Unicode::Normalize;
 701     use Encode;
 702
 703     my $str = decode_utf8(shift);
 704     my $sf = shift;
 705
 706     # Apply NACO normalization to input string; based on
 707     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
 708     #
 709     # Note that unlike a strict reading of the NACO normalization rules,
 710     # output is returned as lowercase instead of uppercase for compatibility
 711     # with previous versions of the Evergreen naco_normalize routine.
 712
 713     # Convert to upper-case first; even though final output will be lowercase, doing this will
 714     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
 715     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
 716     $str = uc $str;
 717
 718     # remove non-filing strings
 719     $str =~ s/\x{0098}.*?\x{009C}//g;
 720
 721     $str = NFKD($str);
 722
 723     # additional substitutions - 3.6.
 724     $str =~ s/\x{00C6}/AE/g;
 725     $str =~ s/\x{00DE}/TH/g;
 726     $str =~ s/\x{0152}/OE/g;
 727     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
 728
 729     # transformations based on Unicode category codes
 730     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
 731
 732         if ($sf && $sf =~ /^a/o) {
 733                 my $commapos = index($str, ',');
 734                 if ($commapos > -1) {
 735                         if ($commapos != length($str) - 1) {
 736                 $str =~ s/,/\x07/; # preserve first comma
 737                         }
 738                 }
 739         }
 740
 741     # since we've stripped out the control characters, we can now
 742     # use a few as placeholders temporarily
 743     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
 744     $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;
 745     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
 746
 747     # decimal digits
 748     $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
 750     # intentionally skipping step 8 of the NACO algorithm; if the string
 751     # gets normalized away, that's fine.
 752
 753     # leading and trailing spaces
 754     $str =~ s/\s+/ /g;
 755     $str =~ s/^\s+//;
 756     $str =~ s/\s+$//g;
 757
 758     return lc $str;
 759 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 760
 761 -- Currently, the only difference from naco_normalize is that search_normalize
 762 -- turns apostrophes into spaces, while naco_normalize collapses them.
 763 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
 764
 765     use strict;
 766     use Unicode::Normalize;
 767     use Encode;
 768
 769     my $str = decode_utf8(shift);
 770     my $sf = shift;
 771
 772     # Apply NACO normalization to input string; based on
 773     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
 774     #
 775     # Note that unlike a strict reading of the NACO normalization rules,
 776     # output is returned as lowercase instead of uppercase for compatibility
 777     # with previous versions of the Evergreen naco_normalize routine.
 778
 779     # Convert to upper-case first; even though final output will be lowercase, doing this will
 780     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
 781     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
 782     $str = uc $str;
 783
 784     # remove non-filing strings
 785     $str =~ s/\x{0098}.*?\x{009C}//g;
 786
 787     $str = NFKD($str);
 788
 789     # additional substitutions - 3.6.
 790     $str =~ s/\x{00C6}/AE/g;
 791     $str =~ s/\x{00DE}/TH/g;
 792     $str =~ s/\x{0152}/OE/g;
 793     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}][/DDOLl/d;
 794
 795     # transformations based on Unicode category codes
 796     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
 797
 798         if ($sf && $sf =~ /^a/o) {
 799                 my $commapos = index($str, ',');
 800                 if ($commapos > -1) {
 801                         if ($commapos != length($str) - 1) {
 802                 $str =~ s/,/\x07/; # preserve first comma
 803                         }
 804                 }
 805         }
 806
 807     # since we've stripped out the control characters, we can now
 808     # use a few as placeholders temporarily
 809     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
 810     $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;
 811     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
 812
 813     # decimal digits
 814     $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
 816     # intentionally skipping step 8 of the NACO algorithm; if the string
 817     # gets normalized away, that's fine.
 818
 819     # leading and trailing spaces
 820     $str =~ s/\s+/ /g;
 821     $str =~ s/^\s+//;
 822     $str =~ s/\s+$//g;
 823
 824     return lc $str;
 825 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 826
 827 CREATE OR REPLACE FUNCTION public.naco_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
 828         SELECT public.naco_normalize($1,'a');
 829 $func$ LANGUAGE SQL STRICT IMMUTABLE;
 830
 831 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT ) RETURNS TEXT AS $func$
 832         SELECT public.naco_normalize($1,'');
 833 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
 834
 835 CREATE OR REPLACE FUNCTION public.search_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
 836         SELECT public.search_normalize($1,'a');
 837 $func$ LANGUAGE SQL STRICT IMMUTABLE;
 838
 839 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT ) RETURNS TEXT AS $func$
 840         SELECT public.search_normalize($1,'');
 841 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
 842
 843
 844 COMMIT;
 845