3 -- this file is a duplicate of 0851, moved up for better backport clarity
5 -- check whether patch can be applied
6 SELECT evergreen.upgrade_deps_block_check('0862', :eg_version);
8 CREATE OR REPLACE FUNCTION evergreen.maintain_901 () RETURNS TRIGGER AS $func$
11 use MARC::File::XML (BinaryEncoding => 'UTF-8');
14 use Unicode::Normalize;
16 MARC::Charset->assume_unicode(1);
18 my $schema = $_TD->{table_schema};
19 my $marc = MARC::Record->new_from_xml($_TD->{new}{marc});
21 my @old901s = $marc->field('901');
22 $marc->delete_fields(@old901s);
24 if ($schema eq 'biblio') {
25 my $tcn_value = $_TD->{new}{tcn_value};
27 # Set TCN value to record ID?
28 my $id_as_tcn = spi_exec_query("
30 FROM config.global_flag
31 WHERE name = 'cat.bib.use_id_for_tcn'
33 if (($id_as_tcn->{processed}) && $id_as_tcn->{rows}[0]->{enabled} eq 't') {
34 $tcn_value = $_TD->{new}{id};
35 $_TD->{new}{tcn_value} = $tcn_value;
38 my $new_901 = MARC::Field->new("901", " ", " ",
40 "b" => $_TD->{new}{tcn_source},
41 "c" => $_TD->{new}{id},
45 if ($_TD->{new}{owner}) {
46 $new_901->add_subfields("o" => $_TD->{new}{owner});
49 if ($_TD->{new}{share_depth}) {
50 $new_901->add_subfields("d" => $_TD->{new}{share_depth});
53 $marc->append_fields($new_901);
54 } elsif ($schema eq 'authority') {
55 my $new_901 = MARC::Field->new("901", " ", " ",
56 "c" => $_TD->{new}{id},
59 $marc->append_fields($new_901);
60 } elsif ($schema eq 'serial') {
61 my $new_901 = MARC::Field->new("901", " ", " ",
62 "c" => $_TD->{new}{id},
64 "o" => $_TD->{new}{owning_lib},
67 if ($_TD->{new}{record}) {
68 $new_901->add_subfields("r" => $_TD->{new}{record});
71 $marc->append_fields($new_901);
73 my $new_901 = MARC::Field->new("901", " ", " ",
74 "c" => $_TD->{new}{id},
77 $marc->append_fields($new_901);
80 my $xml = $marc->as_xml_record();
82 $xml =~ s/^<\?xml.+\?\s*>//go;
83 $xml =~ s/>\s+</></go;
86 # Embed a version of OpenILS::Application::AppUtils->entityize()
87 # to avoid having to set PERL5LIB for PostgreSQL as well
91 # Convert raw ampersands to entities
92 $xml =~ s/&(?!\S+;)/&/gso;
94 # Convert Unicode characters to entities
95 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
97 $xml =~ s/[\x00-\x1f]//go;
98 $_TD->{new}{marc} = $xml;
101 $func$ LANGUAGE PLPERLU;
103 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
106 use MARC::File::XML (BinaryEncoding => 'UTF-8');
109 use Unicode::Normalize;
111 MARC::Charset->assume_unicode(1);
113 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
114 my $schema = $_TD->{table_schema};
115 my $rec_id = $_TD->{new}{id};
117 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
118 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
119 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
123 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
124 my $ou_cni = 'EVRGRN';
127 if ($schema eq 'serial') {
128 $owner = $_TD->{new}{owning_lib};
130 # are.owner and bre.owner can be null, so fall back to the consortial setting
131 $owner = $_TD->{new}{owner} || 1;
134 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
135 if ($ous_rv->{processed}) {
136 $ou_cni = $ous_rv->{rows}[0]->{value};
137 $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
139 # Fall back to the shortname of the OU if there was no OU setting
140 $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
141 if ($ous_rv->{processed}) {
142 $ou_cni = $ous_rv->{rows}[0]->{shortname};
146 my ($create, $munge) = (0, 0);
148 my @scns = $record->field('035');
150 foreach my $id_field ('001', '003') {
152 my @controls = $record->field($id_field);
154 if ($id_field eq '001') {
155 $spec_value = $rec_id;
157 $spec_value = $ou_cni;
160 # Create the 001/003 if none exist
161 if (scalar(@controls) == 1) {
162 # Only one field; check to see if we need to munge it
163 unless (grep $_->data() eq $spec_value, @controls) {
167 # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
168 foreach my $control (@controls) {
169 $record->delete_field($control);
171 $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
176 my $cn = $record->field('001')->data();
177 # Special handling of OCLC numbers, often found in records that lack 003
178 if ($cn =~ /^o(c[nm]|n)\d/) {
179 $cn =~ s/^o(c[nm]|n)0*(\d+)/$2/;
180 $record->field('003')->data('OCoLC');
184 # Now, if we need to munge the 001, we will first push the existing 001/003
185 # into the 035; but if the record did not have one (and one only) 001 and 003
186 # to begin with, skip this process
187 if ($munge and not $create) {
189 my $scn = "(" . $record->field('003')->data() . ")" . $cn;
191 # Do not create duplicate 035 fields
192 unless (grep $_->subfield('a') eq $scn, @scns) {
193 $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
197 # Set the 001/003 and update the MARC
198 if ($create or $munge) {
199 $record->field('001')->data($rec_id);
200 $record->field('003')->data($ou_cni);
202 my $xml = $record->as_xml_record();
204 $xml =~ s/^<\?xml.+\?\s*>//go;
205 $xml =~ s/>\s+</></go;
206 $xml =~ s/\p{Cc}//go;
208 # Embed a version of OpenILS::Application::AppUtils->entityize()
209 # to avoid having to set PERL5LIB for PostgreSQL as well
213 # Convert raw ampersands to entities
214 $xml =~ s/&(?!\S+;)/&/gso;
216 # Convert Unicode characters to entities
217 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
219 $xml =~ s/[\x00-\x1f]//go;
220 $_TD->{new}{marc} = $xml;
226 $func$ LANGUAGE PLPERLU;
228 CREATE OR REPLACE FUNCTION public.naco_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
231 use Unicode::Normalize;
237 # Apply NACO normalization to input string; based on
238 # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
240 # Note that unlike a strict reading of the NACO normalization rules,
241 # output is returned as lowercase instead of uppercase for compatibility
242 # with previous versions of the Evergreen naco_normalize routine.
244 # Convert to upper-case first; even though final output will be lowercase, doing this will
245 # ensure that the German eszett (ß) and certain ligatures (ff, fi, ffl, etc.) will be handled correctly.
246 # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
249 # remove non-filing strings
250 $str =~ s/\x{0098}.*?\x{009C}//g;
254 # additional substitutions - 3.6.
255 $str =~ s/\x{00C6}/AE/g;
256 $str =~ s/\x{00DE}/TH/g;
257 $str =~ s/\x{0152}/OE/g;
258 $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
260 # transformations based on Unicode category codes
261 $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
263 if ($sf && $sf =~ /^a/o) {
264 my $commapos = index($str, ',');
265 if ($commapos > -1) {
266 if ($commapos != length($str) - 1) {
267 $str =~ s/,/\x07/; # preserve first comma
272 # since we've stripped out the control characters, we can now
273 # use a few as placeholders temporarily
274 $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
275 $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;
276 $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
279 $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/;
281 # intentionally skipping step 8 of the NACO algorithm; if the string
282 # gets normalized away, that's fine.
284 # leading and trailing spaces
290 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;
292 -- Currently, the only difference from naco_normalize is that search_normalize
293 -- turns apostrophes into spaces, while naco_normalize collapses them.
294 CREATE OR REPLACE FUNCTION public.search_normalize( TEXT, TEXT ) RETURNS TEXT AS $func$
297 use Unicode::Normalize;
303 # Apply NACO normalization to input string; based on
304 # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
306 # Note that unlike a strict reading of the NACO normalization rules,
307 # output is returned as lowercase instead of uppercase for compatibility
308 # with previous versions of the Evergreen naco_normalize routine.
310 # Convert to upper-case first; even though final output will be lowercase, doing this will
311 # ensure that the German eszett (ß) and certain ligatures (ff, fi, ffl, etc.) will be handled correctly.
312 # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
315 # remove non-filing strings
316 $str =~ s/\x{0098}.*?\x{009C}//g;
320 # additional substitutions - 3.6.
321 $str =~ s/\x{00C6}/AE/g;
322 $str =~ s/\x{00DE}/TH/g;
323 $str =~ s/\x{0152}/OE/g;
324 $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}][/DDOLl/d;
326 # transformations based on Unicode category codes
327 $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
329 if ($sf && $sf =~ /^a/o) {
330 my $commapos = index($str, ',');
331 if ($commapos > -1) {
332 if ($commapos != length($str) - 1) {
333 $str =~ s/,/\x07/; # preserve first comma
338 # since we've stripped out the control characters, we can now
339 # use a few as placeholders temporarily
340 $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
341 $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;
342 $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
345 $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/;
347 # intentionally skipping step 8 of the NACO algorithm; if the string
348 # gets normalized away, that's fine.
350 # leading and trailing spaces
356 $func$ LANGUAGE 'plperlu' STRICT IMMUTABLE;