misc/migration_tools/koha-svc.pl

   1 #!/usr/bin/perl
   2
   3 # Copyright 2011 - Dobrica Pavlinusic
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use warnings;
  21 use strict;
  22
  23 use LWP::UserAgent;
  24 use File::Slurp qw( read_file write_file );
  25
  26 if ( $#ARGV >= 3 && ! caller ) { # process command-line params only if not called as module!
  27     my ( $url, $user, $password, $biblionumber, $file ) = @ARGV;
  28
  29     my $svc = Koha::SVC->new(
  30         url      => $url,
  31         user     => $user,
  32         password => $password,
  33         debug    => 0,
  34     );
  35
  36     if ( ! $file ) {
  37         my $marcxml = $svc->get( $biblionumber );
  38         my $file = "bib-$biblionumber.xml";
  39         write_file $file , $marcxml;
  40         print "saved $file ", -s $file, " bytes\n";
  41         print $marcxml;
  42     } else {
  43         print "update $biblionumber from $file\n";
  44         $svc->post( $biblionumber, scalar read_file($file) );
  45     }
  46
  47     exit 0;
  48 }
  49
  50 package Koha::SVC;
  51 use warnings;
  52 use strict;
  53
  54 =head1 NAME
  55
  56 Koha::SVC
  57
  58 =head1 DESCRIPTION
  59
  60 Call Koha's C</svc/> API to fetch/update records
  61
  62 This script can be used from other scripts as C<Koha::SVC> module or run
  63 directly using syntax:
  64
  65   koha-svc.pl http://koha-dev:8080/cgi-bin/koha/svc svc-user svc-password $biblionumber [bib-42.xml]
  66
  67 If called without last argument (MARCXML filename) it will fetch C<$biblionumber> from Koha and create
  68 C<bib-$biblionumber.xml> file from it. When called with xml filename, it will update record in Koha.
  69
  70 This script is intentionally separate from Koha itself and dependencies which Koha has under
  71 assumption that you might want to run it on another machine (or create custom script which mungles
  72 Koha's records from other machine without bringing all Koha dependencies with it).
  73
  74 =head1 USAGE
  75
  76 This same script can be used as module (as it defines T<Koha::SVC> package) using
  77
  78   require "koha-svc.pl"
  79
  80 at beginning of script. Rest of API is described below. Example of its usage is at beginning of this script.
  81
  82 =head2 new
  83
  84   my $svc = Koha::SVC->new(
  85     url      => 'http://koha-dev:8080/cgi-bin/koha/svc',
  86     user     => 'svc-user',
  87     password => 'svc-password',
  88   );
  89
  90 URL must point to Koha's B<intranet> address and port.
  91
  92 Specified user must have C<editcatalogue> permission.
  93
  94 =cut
  95
  96 sub new {
  97     my $class = shift;
  98     my $self = {@_};
  99     bless $self, $class;
 100
 101     my $url = $self->{url} || die "no url found";
 102     my $user = $self->{user} || die "no user specified";
 103     my $password = $self->{password} || die "no password";
 104
 105     my $ua = LWP::UserAgent->new();
 106     $ua->cookie_jar({});
 107     my $resp = $ua->post( "$url/authentication", {userid =>$user, password => $password} );
 108     die $resp->status_line unless $resp->is_success;
 109
 110     warn "# $user $url = ", $resp->decoded_content, "\n" if $self->{debug};
 111
 112     $self->{ua} = $ua;
 113
 114     return $self;
 115 }
 116
 117 =head2 get
 118
 119   my $marcxml = $svc->get( $biblionumber );
 120
 121 =cut
 122
 123 sub get {
 124     my ($self,$biblionumber) = @_;
 125
 126     my $url = $self->{url};
 127     warn "# get $url/bib/$biblionumber\n" if $self->{debug};
 128     my $resp = $self->{ua}->get( "$url/bib/$biblionumber" );
 129     die $resp->status_line unless $resp->is_success;
 130     return $resp->decoded_content;
 131 }
 132
 133 =head2 post
 134
 135   my $marcxml = $svc->post( $biblionumber, $marcxml );
 136
 137 =cut
 138
 139 sub post {
 140     my ($self,$biblionumber,$marcxml) = @_;
 141     my $url = $self->{url};
 142     warn "# post $url/bib/$biblionumber\n" if $self->{debug};
 143     my $resp = $self->{ua}->post( "$url/bib/$biblionumber", 'Content_type' => 'text/xml', Content => $marcxml );
 144     die $resp->status_line unless $resp->is_success;
 145     return $resp->decoded_content;
 146 }
 147
 148 1;