LP#1901597: Allow multi-subfield match in vandelay.strip_field

Now, when supplying a subfield match restriction for use with
vandelay.strip_field, you can separate multiple restrictions with '&&'
(no quotes).  For instance, to remove a Located URI 856 for for a
combination of a specific owner and a specific domain, you might say:

 856[u~oldservice.com && 9~MYLIB]

Signed-off-by: Mike Rylander <mrylander@gmail.com>
Signed-off-by: Chris Sharp <csharp@georgialibraries.org>

diff --git a/Open-ILS/src/sql/Pg/012.schema.vandelay.sql b/Open-ILS/src/sql/Pg/012.schema.vandelay.sql
index 2865b23..0e41c03 100644 (file)
--- a/Open-ILS/src/sql/Pg/012.schema.vandelay.sql
+++ b/Open-ILS/src/sql/Pg/012.schema.vandelay.sql
@@ -1203,7 +1203,8 @@ CREATE OR REPLACE FUNCTION vandelay.add_field ( target_xml TEXT, source_xml TEXT
     SELECT vandelay.add_field( $1, $2, $3, 0 );
 $_$ LANGUAGE SQL;
 
-CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS TEXT AS $_$
+
+CREATE OR REPLACE FUNCTION vandelay.strip_field(xml text, field text) RETURNS text AS $f$
 
     use MARC::Record;
     use MARC::File::XML (BinaryEncoding => 'UTF-8');
@@ -1228,15 +1229,18 @@ CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS
             $field =~ s/\s+//;
             my $sf = $2;
             $sf =~ s/\s+//;
-            my $match = $3;
-            $match =~ s/^\s*//; $match =~ s/\s*$//;
+            my $matches = $3;
+            $matches =~ s/^\s*//; $matches =~ s/\s*$//;
             $fields{$field} = { sf => [ split('', $sf) ] };
-            if ($match) {
-                my ($msf,$mre) = split('~', $match);
-                if (length($msf) > 0 and length($mre) > 0) {
-                    $msf =~ s/^\s*//; $msf =~ s/\s*$//;
-                    $mre =~ s/^\s*//; $mre =~ s/\s*$//;
-                    $fields{$field}{match} = { sf => $msf, re => qr/$mre/ };
+            if ($matches) {
+                for my $match (split('&&', $matches)) {
+                    $match =~ s/^\s*//; $match =~ s/\s*$//;
+                    my ($msf,$mre) = split('~', $match);
+                    if (length($msf) > 0 and length($mre) > 0) {
+                        $msf =~ s/^\s*//; $msf =~ s/\s*$//;
+                        $mre =~ s/^\s*//; $mre =~ s/\s*$//;
+                        $fields{$field}{match}{$msf} = qr/$mre/;
+                    }
                 }
             }
         }
@@ -1245,7 +1249,8 @@ CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS
     for my $f ( keys %fields) {
         for my $to_field ($r->field( $f )) {
             if (exists($fields{$f}{match})) {
-                next unless (grep { $_ =~ $fields{$f}{match}{re} } $to_field->subfield($fields{$f}{match}{sf}));
+                my @match_list = grep { $to_field->subfield($_) =~ $fields{$f}{match}{$_} } keys %{$fields{$f}{match}};
+                next unless (scalar(@match_list) == scalar(keys %{$fields{$f}{match}}));
             }
 
             if ( @{$fields{$f}{sf}} ) {
@@ -1263,7 +1268,7 @@ CREATE OR REPLACE FUNCTION vandelay.strip_field ( xml TEXT, field TEXT ) RETURNS
 
     return $xml;
 
-$_$ LANGUAGE PLPERLU;
+$f$ LANGUAGE plperlu;
 
 CREATE OR REPLACE FUNCTION vandelay.replace_field 
     (target_xml TEXT, source_xml TEXT, field TEXT) RETURNS TEXT AS $_$

diff --git a/Open-ILS/src/sql/Pg/upgrade/XXXX.function.strip_field_multimatch.sql b/Open-ILS/src/sql/Pg/upgrade/XXXX.function.strip_field_multimatch.sql
new file mode 100644 (file)
index 0000000..f61ecf2
--- /dev/null
+++ b/Open-ILS/src/sql/Pg/upgrade/XXXX.function.strip_field_multimatch.sql
@@ -0,0 +1,72 @@
+BEGIN;
+
+SELECT evergreen.upgrade_deps_block_check('XXXX', :eg_version);
+
+CREATE OR REPLACE FUNCTION vandelay.strip_field(xml text, field text) RETURNS text AS $f$
+
+    use MARC::Record;
+    use MARC::File::XML (BinaryEncoding => 'UTF-8');
+    use MARC::Charset;
+    use strict;
+
+    MARC::Charset->assume_unicode(1);
+
+    my $xml = shift;
+    my $r = MARC::Record->new_from_xml( $xml );
+
+    return $xml unless ($r);
+
+    my $field_spec = shift;
+    my @field_list = split(',', $field_spec);
+
+    my %fields;
+    for my $f (@field_list) {
+        $f =~ s/^\s*//; $f =~ s/\s*$//;
+        if ($f =~ /^(.{3})(\w*)(?:\[([^]]*)\])?$/) {
+            my $field = $1;
+            $field =~ s/\s+//;
+            my $sf = $2;
+            $sf =~ s/\s+//;
+            my $matches = $3;
+            $matches =~ s/^\s*//; $matches =~ s/\s*$//;
+            $fields{$field} = { sf => [ split('', $sf) ] };
+            if ($matches) {
+                for my $match (split('&&', $matches)) {
+                    $match =~ s/^\s*//; $match =~ s/\s*$//;
+                    my ($msf,$mre) = split('~', $match);
+                    if (length($msf) > 0 and length($mre) > 0) {
+                        $msf =~ s/^\s*//; $msf =~ s/\s*$//;
+                        $mre =~ s/^\s*//; $mre =~ s/\s*$//;
+                        $fields{$field}{match}{$msf} = qr/$mre/;
+                    }
+                }
+            }
+        }
+    }
+
+    for my $f ( keys %fields) {
+        for my $to_field ($r->field( $f )) {
+            if (exists($fields{$f}{match})) {
+                my @match_list = grep { $to_field->subfield($_) =~ $fields{$f}{match}{$_} } keys %{$fields{$f}{match}};
+                next unless (scalar(@match_list) == scalar(keys %{$fields{$f}{match}}));
+            }
+
+            if ( @{$fields{$f}{sf}} ) {
+                $to_field->delete_subfield(code => $fields{$f}{sf});
+            } else {
+                $r->delete_field( $to_field );
+            }
+        }
+    }
+
+    $xml = $r->as_xml_record;
+    $xml =~ s/^<\?.+?\?>$//mo;
+    $xml =~ s/\n//sgo;
+    $xml =~ s/>\s+</></sgo;
+
+    return $xml;
+
+$f$ LANGUAGE plperlu;
+
+COMMIT;
+