1 -- Correct a few thinkos in the functions that implement authority control
5 INSERT INTO config.upgrade_log (version) VALUES ('0331'); -- dbs
7 CREATE OR REPLACE FUNCTION vandelay.add_field ( target_xml TEXT, source_xml TEXT, field TEXT ) RETURNS TEXT AS $_$
13 my $target_xml = shift;
14 my $source_xml = shift;
15 my $field_spec = shift;
17 my $target_r = MARC::Record->new_from_xml( $target_xml );
18 my $source_r = MARC::Record->new_from_xml( $source_xml );
20 return $target_xml unless ($target_r && $source_r);
22 my @field_list = split(',', $field_spec);
25 for my $f (@field_list) {
26 $f =~ s/^\s*//; $f =~ s/\s*$//;
27 if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
33 $match =~ s/^\s*//; $match =~ s/\s*$//;
34 $fields{$field} = { sf => [ split('', $sf) ] };
36 my ($msf,$mre) = split('~', $match);
37 if (length($msf) > 0 and length($mre) > 0) {
38 $msf =~ s/^\s*//; $msf =~ s/\s*$//;
39 $mre =~ s/^\s*//; $mre =~ s/\s*$//;
40 $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
46 for my $f ( keys %fields) {
47 if ( @{$fields{$f}{sf}} ) {
48 for my $from_field ($source_r->field( $f )) {
49 for my $to_field ($target_r->field( $f )) {
50 if (exists($fields{$f}{match})) {
51 next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
53 my @new_sf = map { ($_ => $from_field->subfield($_)) } @{$fields{$f}{sf}};
54 $to_field->add_subfields( @new_sf );
58 my @new_fields = map { $_->clone } $source_r->field( $f );
59 $target_r->insert_fields_ordered( @new_fields );
63 $target_xml = $target_r->as_xml_record;
64 $target_xml =~ s/^<\?.+?\?>$//mo;
65 $target_xml =~ s/\n//sgo;
66 $target_xml =~ s/>\s+</></sgo;
72 CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS TEXT AS $_$
79 my $r = MARC::Record->new_from_xml( $xml );
81 return $xml unless ($r);
83 my $field_spec = shift;
84 my @field_list = split(',', $field_spec);
87 for my $f (@field_list) {
88 $f =~ s/^\s*//; $f =~ s/\s*$//;
89 if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
95 $match =~ s/^\s*//; $match =~ s/\s*$//;
96 $fields{$field} = { sf => [ split('', $sf) ] };
98 my ($msf,$mre) = split('~', $match);
99 if (length($msf) > 0 and length($mre) > 0) {
100 $msf =~ s/^\s*//; $msf =~ s/\s*$//;
101 $mre =~ s/^\s*//; $mre =~ s/\s*$//;
102 $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
108 for my $f ( keys %fields) {
109 for my $to_field ($r->field( $f )) {
110 if (exists($fields{$f}{match})) {
111 next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
114 if ( @{$fields{$f}{sf}} ) {
115 $to_field->delete_subfield(code => $fields{$f}{sf});
117 $r->delete_field( $to_field );
122 $xml = $r->as_xml_record;
123 $xml =~ s/^<\?.+?\?>$//mo;
125 $xml =~ s/>\s+</></sgo;
129 $_$ LANGUAGE PLPERLU;
131 CREATE OR REPLACE FUNCTION maintain_control_numbers() RETURNS TRIGGER AS $func$
136 use Unicode::Normalize;
138 my $record = MARC::Record->new_from_xml($_TD->{new}{marc});
139 my $schema = $_TD->{table_schema};
140 my $rec_id = $_TD->{new}{id};
142 # Short-circuit if maintaining control numbers per MARC21 spec is not enabled
143 my $enable = spi_exec_query("SELECT enabled FROM config.global_flag WHERE name = 'cat.maintain_control_numbers'");
144 if (!($enable->{processed}) or $enable->{rows}[0]->{enabled} eq 'f') {
148 # Get the control number identifier from an OU setting based on $_TD->{new}{owner}
149 my $ou_cni = 'EVRGRN';
151 # bre.owner can be null, so fall back to the consortial setting
152 my $owner = $_TD->{new}{owner} || 1;
154 my $ous_rv = spi_exec_query("SELECT value FROM actor.org_unit_ancestor_setting('cat.marc_control_number_identifier', $owner)");
155 if ($ous_rv->{processed}) {
156 $ou_cni = $ous_rv->{rows}[0]->{value};
157 $ou_cni =~ s/"//g; # Stupid VIM syntax highlighting"
159 # Fall back to the shortname of the OU if there was no OU setting
160 $ous_rv = spi_exec_query("SELECT shortname FROM actor.org_unit WHERE id = $owner");
161 if ($ous_rv->{processed}) {
162 $ou_cni = $ous_rv->{rows}[0]->{shortname};
166 my ($create, $munge) = (0, 0);
167 my ($orig_001, $orig_003) = ('', '');
169 # Incoming MARC records may have multiple 001s or 003s, despite the spec
170 my @control_ids = $record->field('003');
171 my @scns = $record->field('035');
173 foreach my $id_field ('001', '003') {
175 my @controls = $record->field($id_field);
177 if ($id_field eq '001') {
178 $spec_value = $rec_id;
180 $spec_value = $ou_cni;
183 # Create the 001/003 if none exist
184 if (scalar(@controls) == 0) {
185 $record->insert_fields_ordered(MARC::Field->new($id_field, $spec_value));
187 } elsif (scalar(@controls) > 1) {
188 # Do we already have the right 001/003 value in the existing set?
189 unless (grep $_->data() eq $spec_value, @controls) {
193 # Delete the other fields, as with more than 1 001/003 we do not know which 003/001 to match
194 foreach my $control (@controls) {
195 unless ($control->data() eq $spec_value) {
196 $record->delete_field($control);
200 # Only one field; check to see if we need to munge it
201 unless (grep $_->data() eq $spec_value, @controls) {
207 # Now, if we need to munge the 001, we will first push the existing 001/003 into the 035
209 my $scn = "(" . $record->field('003')->data() . ")" . $record->field('001')->data();
211 # Do not create duplicate 035 fields
212 unless (grep $_->subfield('a') eq $scn, @scns) {
213 $record->insert_fields_ordered(MARC::Field->new('035', '', '', 'a' => $scn));
217 # Set the 001/003 and update the MARC
218 if ($create or $munge) {
219 $record->field('001')->data($rec_id);
220 $record->field('003')->data($ou_cni);
222 my $xml = $record->as_xml_record();
224 $xml =~ s/^<\?xml.+\?\s*>//go;
225 $xml =~ s/>\s+</></go;
226 $xml =~ s/\p{Cc}//go;
228 # Embed a version of OpenILS::Application::AppUtils->entityize()
229 # to avoid having to set PERL5LIB for PostgreSQL as well
231 # If we are going to convert non-ASCII characters to XML entities,
232 # we had better be dealing with a UTF8 string to begin with
233 $xml = decode_utf8($xml);
237 # Convert raw ampersands to entities
238 $xml =~ s/&(?!\S+;)/&/gso;
240 # Convert Unicode characters to entities
241 $xml =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
243 $xml =~ s/[\x00-\x1f]//go;
244 $_TD->{new}{marc} = $xml;
250 $func$ LANGUAGE PLPERLU;