Open-ILS/src/sql/Pg/020.schema.functions.sql

   1 /*
   2  * Copyright (C) 2004-2008  Georgia Public Library Service
   3  * Copyright (C) 2007-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 CREATE OR REPLACE FUNCTION public.non_filing_normalize ( TEXT, "char" ) RETURNS TEXT AS $$
  19         SELECT  SUBSTRING(
  20                         REGEXP_REPLACE(
  21                                 REGEXP_REPLACE(
  22                                         $1,
  23                                         E'\W*$',
  24                                         ''
  25                                 ),
  26                                 '  ',
  27                                 ' '
  28                         ),
  29                         CASE
  30                                 WHEN $2::INT NOT BETWEEN 48 AND 57 THEN 1
  31                                 ELSE $2::TEXT::INT + 1
  32                         END
  33                 );
  34 $$ LANGUAGE SQL STRICT IMMUTABLE;
  35
  36 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
  37
  38     use strict;
  39     use Unicode::Normalize;
  40
  41     my $str = shift;
  42     my $sf = shift;
  43
  44     # Apply NACO normalization to input string; based on
  45     # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
  46     #
  47     # Note that unlike a strict reading of the NACO normalization rules,
  48     # output is returned as lowercase instead of uppercase for compatibility
  49     # with previous versions of the Evergreen naco_normalize routine.
  50
  51     # Convert to upper-case first; even though final output will be lowercase, doing this will
  52     # ensure that the German eszett (ß) and certain ligatures (ﬀ, ﬁ, ﬄ, etc.) will be handled correctly.
  53     # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
  54     $str = uc $str;
  55
  56     # remove non-filing strings
  57     $str =~ s/\x{0098}.*?\x{009C}//g;
  58
  59     $str = NFKD($str);
  60
  61     # additional substitutions - 3.6.
  62     $str =~ s/\x{00C6}/AE/g;
  63     $str =~ s/\x{00DE}/TH/g;
  64     $str =~ s/\x{0152}/OE/g;
  65     $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
  66
  67     # transformations based on Unicode category codes
  68     $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
  69
  70         if ($sf && $sf =~ /^a/o) {
  71                 my $commapos = index($str, ',');
  72                 if ($commapos > -1) {
  73                         if ($commapos != length($str) - 1) {
  74                 $str =~ s/,/\x07/; # preserve first comma
  75                         }
  76                 }
  77         }
  78
  79     # since we've stripped out the control characters, we can now
  80     # use a few as placeholders temporarily
  81     $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
  82     $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;
  83     $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
  84
  85     # decimal digits
  86     $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/;
  87
  88     # intentionally skipping step 8 of the NACO algorithm; if the string
  89     # gets normalized away, that's fine.
  90
  91     # leading and trailing spaces
  92     $str =~ s/\s+/ /g;
  93     $str =~ s/^\s+//;
  94     $str =~ s/\s+$//g;
  95
  96     return lc $str;
  97 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
  98
  99 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT ) RETURNS TEXT AS $func$
 100         SELECT public.naco_normalize($1,'');
 101 $func$ LANGUAGE 'sql' STRICT IMMUTABLE;
 102
 103 CREATE OR REPLACE FUNCTION public.first_word ( TEXT ) RETURNS TEXT AS $$
 104         SELECT COALESCE(SUBSTRING( $1 FROM $_$^\S+$_$), '');
 105 $$ LANGUAGE SQL STRICT IMMUTABLE;
 106
 107 CREATE OR REPLACE FUNCTION public.naco_normalize_keep_comma( TEXT ) RETURNS TEXT AS $func$
 108         SELECT public.naco_normalize($1,'a');
 109 $func$ LANGUAGE SQL STRICT IMMUTABLE;
 110
 111 CREATE OR REPLACE FUNCTION public.normalize_space( TEXT ) RETURNS TEXT AS $$
 112     SELECT regexp_replace(regexp_replace(regexp_replace($1, E'\\n', ' ', 'g'), E'(?:^\\s+)|(\\s+$)', '', 'g'), E'\\s+', ' ', 'g');
 113 $$ LANGUAGE SQL STRICT IMMUTABLE;
 114
 115 CREATE OR REPLACE FUNCTION public.remove_commas( TEXT ) RETURNS TEXT AS $$
 116     SELECT regexp_replace($1, ',', '', 'g');
 117 $$ LANGUAGE SQL STRICT IMMUTABLE;
 118
 119 CREATE OR REPLACE FUNCTION public.remove_paren_substring( TEXT ) RETURNS TEXT AS $func$
 120     SELECT regexp_replace($1, $$\([^)]+\)$$, '', 'g');
 121 $func$ LANGUAGE SQL STRICT IMMUTABLE;
 122
 123 CREATE OR REPLACE FUNCTION public.remove_whitespace( TEXT ) RETURNS TEXT AS $$
 124     SELECT regexp_replace(normalize_space($1), E'\\s+', '', 'g');
 125 $$ LANGUAGE SQL STRICT IMMUTABLE;
 126
 127 CREATE OR REPLACE FUNCTION public.lowercase( TEXT ) RETURNS TEXT AS $$
 128     return lc(shift);
 129 $$ LANGUAGE PLPERLU STRICT IMMUTABLE;
 130
 131 CREATE OR REPLACE FUNCTION public.uppercase( TEXT ) RETURNS TEXT AS $$
 132     return uc(shift);
 133 $$ LANGUAGE PLPERLU STRICT IMMUTABLE;
 134
 135 CREATE OR REPLACE FUNCTION public.remove_diacritics( TEXT ) RETURNS TEXT AS $$
 136     use Unicode::Normalize;
 137
 138     my $x = NFD(shift);
 139     $x =~ s/\pM+//go;
 140     return $x;
 141
 142 $$ LANGUAGE PLPERLU STRICT IMMUTABLE;
 143
 144 CREATE OR REPLACE FUNCTION public.entityize( TEXT ) RETURNS TEXT AS $$
 145     use Unicode::Normalize;
 146
 147     my $x = NFC(shift);
 148     $x =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
 149     return $x;
 150
 151 $$ LANGUAGE PLPERLU STRICT IMMUTABLE;
 152
 153 CREATE OR REPLACE FUNCTION public.call_number_dewey( TEXT ) RETURNS TEXT AS $$
 154         my $txt = shift;
 155         $txt =~ s/^\s+//o;
 156         $txt =~ s/[\[\]\{\}\(\)`'"#<>\*\?\-\+\$\\]+//og;
 157         $txt =~ s/\s+$//o;
 158         if ($txt =~ /(\d{3}(?:\.\d+)?)/o) {
 159                 return $1;
 160         } else {
 161                 return (split /\s+/, $txt)[0];
 162         }
 163 $$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
 164
 165 CREATE OR REPLACE FUNCTION public.call_number_dewey( TEXT, INT ) RETURNS TEXT AS $$
 166         SELECT SUBSTRING(call_number_dewey($1) FROM 1 FOR $2);
 167 $$ LANGUAGE SQL STRICT IMMUTABLE;
 168
 169 CREATE OR REPLACE FUNCTION tableoid2name ( oid ) RETURNS TEXT AS $$
 170         BEGIN
 171                 RETURN $1::regclass;
 172         END;
 173 $$ language 'plpgsql';
 174
 175 CREATE OR REPLACE FUNCTION actor.org_unit_descendants( INT, INT ) RETURNS SETOF actor.org_unit AS $$
 176     WITH RECURSIVE descendant_depth AS (
 177         SELECT  ou.id,
 178                 ou.parent_ou,
 179                 out.depth
 180           FROM  actor.org_unit ou
 181                 JOIN actor.org_unit_type out ON (out.id = ou.ou_type)
 182                 JOIN anscestor_depth ad ON (ad.id = ou.id)
 183           WHERE ad.depth = $2
 184             UNION ALL
 185         SELECT  ou.id,
 186                 ou.parent_ou,
 187                 out.depth
 188           FROM  actor.org_unit ou
 189                 JOIN actor.org_unit_type out ON (out.id = ou.ou_type)
 190                 JOIN descendant_depth ot ON (ot.id = ou.parent_ou)
 191     ), anscestor_depth AS (
 192         SELECT  ou.id,
 193                 ou.parent_ou,
 194                 out.depth
 195           FROM  actor.org_unit ou
 196                 JOIN actor.org_unit_type out ON (out.id = ou.ou_type)
 197           WHERE ou.id = $1
 198             UNION ALL
 199         SELECT  ou.id,
 200                 ou.parent_ou,
 201                 out.depth
 202           FROM  actor.org_unit ou
 203                 JOIN actor.org_unit_type out ON (out.id = ou.ou_type)
 204                 JOIN anscestor_depth ot ON (ot.parent_ou = ou.id)
 205     ) SELECT ou.* FROM actor.org_unit ou JOIN descendant_depth USING (id);
 206 $$ LANGUAGE SQL;
 207
 208 CREATE OR REPLACE FUNCTION actor.org_unit_descendants( INT ) RETURNS SETOF actor.org_unit AS $$
 209     WITH RECURSIVE descendant_depth AS (
 210         SELECT  ou.id,
 211                 ou.parent_ou,
 212                 out.depth
 213           FROM  actor.org_unit ou
 214                 JOIN actor.org_unit_type out ON (out.id = ou.ou_type)
 215           WHERE ou.id = $1
 216             UNION ALL
 217         SELECT  ou.id,
 218                 ou.parent_ou,
 219                 out.depth
 220           FROM  actor.org_unit ou
 221                 JOIN actor.org_unit_type out ON (out.id = ou.ou_type)
 222                 JOIN descendant_depth ot ON (ot.id = ou.parent_ou)
 223     ) SELECT ou.* FROM actor.org_unit ou JOIN descendant_depth USING (id);
 224 $$ LANGUAGE SQL;
 225
 226 CREATE OR REPLACE FUNCTION actor.org_unit_ancestors( INT ) RETURNS SETOF actor.org_unit AS $$
 227     WITH RECURSIVE anscestor_depth AS (
 228         SELECT  ou.id,
 229                 ou.parent_ou
 230           FROM  actor.org_unit ou
 231           WHERE ou.id = $1
 232             UNION ALL
 233         SELECT  ou.id,
 234                 ou.parent_ou
 235           FROM  actor.org_unit ou
 236                 JOIN anscestor_depth ot ON (ot.parent_ou = ou.id)
 237     ) SELECT ou.* FROM actor.org_unit ou JOIN anscestor_depth USING (id);
 238 $$ LANGUAGE SQL;
 239
 240 CREATE OR REPLACE FUNCTION actor.org_unit_ancestor_at_depth ( INT,INT ) RETURNS actor.org_unit AS $$
 241         SELECT  a.*
 242           FROM  actor.org_unit a
 243           WHERE id = ( SELECT FIRST(x.id)
 244                          FROM   actor.org_unit_ancestors($1) x
 245                                 JOIN actor.org_unit_type y
 246                                         ON x.ou_type = y.id AND y.depth = $2);
 247 $$ LANGUAGE SQL STABLE;
 248
 249 CREATE OR REPLACE FUNCTION actor.org_unit_full_path ( INT ) RETURNS SETOF actor.org_unit AS $$
 250         SELECT  *
 251           FROM  actor.org_unit_ancestors($1)
 252                         UNION
 253         SELECT  *
 254           FROM  actor.org_unit_descendants($1);
 255 $$ LANGUAGE SQL STABLE;
 256
 257 CREATE OR REPLACE FUNCTION actor.org_unit_full_path ( INT, INT ) RETURNS SETOF actor.org_unit AS $$
 258         SELECT  * FROM actor.org_unit_full_path((actor.org_unit_ancestor_at_depth($1, $2)).id)
 259 $$ LANGUAGE SQL STABLE;
 260
 261 CREATE OR REPLACE FUNCTION actor.org_unit_combined_ancestors ( INT, INT ) RETURNS SETOF actor.org_unit AS $$
 262         SELECT  *
 263           FROM  actor.org_unit_ancestors($1)
 264                         UNION
 265         SELECT  *
 266           FROM  actor.org_unit_ancestors($2);
 267 $$ LANGUAGE SQL STABLE;
 268
 269 CREATE OR REPLACE FUNCTION actor.org_unit_common_ancestors ( INT, INT ) RETURNS SETOF actor.org_unit AS $$
 270         SELECT  *
 271           FROM  actor.org_unit_ancestors($1)
 272                         INTERSECT
 273         SELECT  *
 274           FROM  actor.org_unit_ancestors($2);
 275 $$ LANGUAGE SQL STABLE;
 276
 277 CREATE OR REPLACE FUNCTION actor.org_unit_proximity ( INT, INT ) RETURNS INT AS $$
 278         SELECT COUNT(id)::INT FROM (
 279                 SELECT id FROM actor.org_unit_combined_ancestors($1, $2)
 280                         EXCEPT
 281                 SELECT id FROM actor.org_unit_common_ancestors($1, $2)
 282         ) z;
 283 $$ LANGUAGE SQL STABLE;
 284
 285 CREATE OR REPLACE FUNCTION actor.org_unit_ancestor_setting( setting_name TEXT, org_id INT ) RETURNS SETOF actor.org_unit_setting AS $$
 286 DECLARE
 287     setting RECORD;
 288     cur_org INT;
 289 BEGIN
 290     cur_org := org_id;
 291     LOOP
 292         SELECT INTO setting * FROM actor.org_unit_setting WHERE org_unit = cur_org AND name = setting_name;
 293         IF FOUND THEN
 294             RETURN NEXT setting;
 295         END IF;
 296         SELECT INTO cur_org parent_ou FROM actor.org_unit WHERE id = cur_org;
 297         EXIT WHEN cur_org IS NULL;
 298     END LOOP;
 299     RETURN;
 300 END;
 301 $$ LANGUAGE plpgsql STABLE;
 302
 303 COMMENT ON FUNCTION actor.org_unit_ancestor_setting( TEXT, INT) IS $$
 304 /**
 305 * Search "up" the org_unit tree until we find the first occurrence of an
 306 * org_unit_setting with the given name.
 307 */
 308 $$;
 309
 310 -- Intended to be used in a unique index on authority.record_entry like so:
 311 -- CREATE UNIQUE INDEX unique_by_heading_and_thesaurus
 312 --   ON authority.record_entry (authority.normalize_heading(marc))
 313 --   WHERE deleted IS FALSE or deleted = FALSE;
 314 CREATE OR REPLACE FUNCTION authority.normalize_heading( TEXT ) RETURNS TEXT AS $func$
 315     use strict;
 316     use warnings;
 317
 318     use utf8;
 319     use MARC::Record;
 320     use MARC::File::XML (BinaryEncoding => 'UTF8');
 321     use UUID::Tiny ':std';
 322
 323     my $xml = shift() or return undef;
 324
 325     my $r;
 326
 327     # Prevent errors in XML parsing from blowing out ungracefully
 328     eval {
 329         $r = MARC::Record->new_from_xml( $xml );
 330         1;
 331     } or do {
 332        return 'BAD_MARCXML_' . create_uuid_as_string(UUID_MD5, $xml);
 333     };
 334
 335     if (!$r) {
 336        return 'BAD_MARCXML_' . create_uuid_as_string(UUID_MD5, $xml);
 337     }
 338
 339     # From http://www.loc.gov/standards/sourcelist/subject.html
 340     my $thes_code_map = {
 341         a => 'lcsh',
 342         b => 'lcshac',
 343         c => 'mesh',
 344         d => 'nal',
 345         k => 'cash',
 346         n => 'notapplicable',
 347         r => 'aat',
 348         s => 'sears',
 349         v => 'rvm',
 350     };
 351
 352     # Default to "No attempt to code" if the leader is horribly broken
 353     my $fixed_field = $r->field('008');
 354     my $thes_char = '|';
 355     if ($fixed_field) {
 356         $thes_char = substr($fixed_field->data(), 11, 1) || '|';
 357     }
 358
 359     my $thes_code = 'UNDEFINED';
 360
 361     if ($thes_char eq 'z') {
 362         # Grab the 040 $f per http://www.loc.gov/marc/authority/ad040.html
 363         $thes_code = $r->subfield('040', 'f') || 'UNDEFINED';
 364     } elsif ($thes_code_map->{$thes_char}) {
 365         $thes_code = $thes_code_map->{$thes_char};
 366     }
 367
 368     my $auth_txt = '';
 369     my $head = $r->field('1..');
 370     if ($head) {
 371         # Concatenate all of these subfields together, prefixed by their code
 372         # to prevent collisions along the lines of "Fiction, North Carolina"
 373         foreach my $sf ($head->subfields()) {
 374             $auth_txt .= '‡' . $sf->[0] . ' ' . $sf->[1];
 375         }
 376     }
 377
 378     # Perhaps better to parameterize the spi and pass as a parameter
 379     $auth_txt =~ s/'//go;
 380
 381     if ($auth_txt) {
 382         my $result = spi_exec_query("SELECT public.naco_normalize('$auth_txt') AS norm_text");
 383         my $norm_txt = $result->{rows}[0]->{norm_text};
 384         return $head->tag() . "_" . $thes_code . " " . $norm_txt;
 385     }
 386
 387     return 'NOHEADING_' . $thes_code . ' ' . create_uuid_as_string(UUID_MD5, $xml);
 388 $func$ LANGUAGE 'plperlu' IMMUTABLE;
 389
 390 COMMENT ON FUNCTION authority.normalize_heading( TEXT ) IS $$
 391 /**
 392 * Extract the authority heading, thesaurus, and NACO-normalized values
 393 * from an authority record. The primary purpose is to build a unique
 394 * index to defend against duplicated authority records from the same
 395 * thesaurus.
 396 */
 397 $$;