edit biblio records in koha using WWW::Mechanize

diff --git a/koha-mech.pl b/koha-mech.pl
new file mode 100755 (executable)
index 0000000..1fc6f0e
--- /dev/null
+++ b/koha-mech.pl
@@ -0,0 +1,79 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use WWW::Mechanize;
+use Data::Dump qw(dump);
+use XML::Simple;
+
+my $intranet = 'http://ffzg.koha-dev.rot13.org:8080/';
+# we will use %d and %s to insert values
+my $url_template = $intranet . '/cgi-bin/koha/cataloguing/addbiblio.pl?biblionumber=%d';
+
+my $koha_conf = XMLin('/etc/koha/sites/ffzg/koha-conf.xml');
+
+my $user = $koha_conf->{config}->{user};
+my $passwd = $koha_conf->{config}->{pass};
+
+my $mech = WWW::Mechanize->new( autocheck => 1 );
+
+
+warn "# login $intranet\n";
+$mech->get( $intranet );
+
+$mech->submit_form(
+       fields => {
+               userid => $user,
+               password => $passwd,
+       },
+);
+
+sub modify_field; # declare later
+
+while( <> ) {
+       chomp;
+       my @v = split(/\s+/,$_);
+       warn "<< ",dump(@v),$/;
+
+       my $url = sprintf $url_template, @v;
+       warn "# url $url\n";
+       $mech->get( $url );
+
+#      my $form = $mech->form_number( 1 ); # XXX 1st form
+       my $form = $mech->form_name( 'f' );
+
+       # tag_856_subfield_u_276192_219337 - add url
+       modify_field $form => 'tag_856_subfield_u' => sub { return "http://10.60.0.82/snz/$v[1]/" };
+
+       $mech->submit;
+
+}
+
+exit;
+
+# magic to find field name by partial match from beginning
+sub modify_field {
+       my ( $form, $field, $coderef ) = @_;
+
+       my @inputs = $form->inputs;
+       my ( $name, $value ) = map { $_->name, $_->value } grep { defined $_->name && $_->name =~ /^\Q$field\E/ } @inputs;
+       die "can't find $field in ", $mech->dump_forms unless $name;
+
+       if ( $value && $value !~ m{/snz/} ) {
+               warn "SKIP: $name has [$value]\n";
+               return;
+       }
+
+       my $new = $coderef->($value);
+
+       if ( $value eq $new ) {
+               warn "WARNING: $name not changed [$value]\n" if $value eq $new;
+               return;
+       }
+
+       warn "$name\n\tOLD: $value\n\tNEW: $new\n";
+
+       $mech->field( $name, $new );
+}
+