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;
  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    => $ENV{DEBUG},
  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     debug    => 0,
  89   );
  90
  91 URL must point to Koha's B<intranet> address and port.
  92
  93 Specified user must have C<editcatalogue> permission.
  94
  95 =cut
  96
  97 sub new {
  98     my $class = shift;
  99     my $self = {@_};
 100     bless $self, $class;
 101
 102     my $url = $self->{url} || die "no url found";
 103     my $user = $self->{user} || die "no user specified";
 104     my $password = $self->{password} || die "no password";
 105
 106     my $ua = LWP::UserAgent->new();
 107     $ua->cookie_jar({});
 108     my $resp = $ua->post( "$url/authentication", {userid =>$user, password => $password} );
 109     die $resp->status_line unless $resp->is_success;
 110
 111     warn "# $user $url = ", $resp->decoded_content, "\n" if $self->{debug};
 112
 113     $self->{ua} = $ua;
 114
 115     return $self;
 116 }
 117
 118 =head2 get
 119
 120   my $marcxml = $svc->get( $biblionumber );
 121
 122 =cut
 123
 124 sub get {
 125     my ($self,$biblionumber) = @_;
 126
 127     my $url = $self->{url};
 128     warn "# get $url/bib/$biblionumber\n" if $self->{debug};
 129     my $resp = $self->{ua}->get( "$url/bib/$biblionumber" );
 130     die $resp->status_line unless $resp->is_success;
 131     return $resp->decoded_content;
 132 }
 133
 134 =head2 post
 135
 136   my $marcxml = $svc->post( $biblionumber, $marcxml );
 137
 138 =cut
 139
 140 sub post {
 141     my ($self,$biblionumber,$marcxml) = @_;
 142     my $url = $self->{url};
 143     warn "# post $url/bib/$biblionumber\n" if $self->{debug};
 144     my $resp = $self->{ua}->post( "$url/bib/$biblionumber", 'Content_type' => 'text/xml', Content => $marcxml );
 145     die $resp->status_line unless $resp->is_success;
 146     return $resp->decoded_content;
 147 }
 148
 149 1;