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