Project

General

Profile

metacat / src / perl / Metacat / Metacat.pm @ 1955

1
 #
2
 #  '$RCSfile$'
3
 #  Copyright: 2000 Regents of the University of California 
4
 #
5
 #   '$Author: jones $'
6
 #     '$Date: 2003-12-09 23:42:29 -0800 (Tue, 09 Dec 2003) $'
7
 # '$Revision: 1955 $' 
8
 # 
9
 # This program is free software; you can redistribute it and/or modify
10
 # it under the terms of the GNU General Public License as published by
11
 # the Free Software Foundation; either version 2 of the License, or
12
 # (at your option) any later version.
13
 #
14
 # This program is distributed in the hope that it will be useful,
15
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17
 # GNU General Public License for more details.
18
 #
19
 # You should have received a copy of the GNU General Public License
20
 # along with this program; if not, write to the Free Software
21
 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
22
 #
23

    
24
package Metacat;
25

    
26
require 5.005_62;
27
use strict;
28
use warnings;
29

    
30
require Exporter;
31
use AutoLoader qw(AUTOLOAD);
32

    
33
use LWP::UserAgent;
34
use HTTP::Cookies;
35

    
36
our @ISA = qw(Exporter);
37

    
38
# Items to export into callers namespace by default. Note: do not export
39
# names by default without a very good reason. Use EXPORT_OK instead.
40
# Do not simply export all your public functions/methods/constants.
41

    
42
# This allows declaration	use Metacat ':all';
43
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
44
# will save memory.
45
our %EXPORT_TAGS = ( 'all' => [ qw(
46
	
47
) ] );
48

    
49
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
50

    
51
our @EXPORT = qw(
52
	
53
);
54
our $VERSION = '0.01';
55

    
56

    
57
# Preloaded methods go here.
58

    
59
#############################################################
60
# Constructor creates a new class instance and inits all
61
# of the instance variables to their proper default values,
62
# which can later be changed using "set_options"
63
#############################################################
64
sub new {
65
  my $cookie_jar = HTTP::Cookies->new;
66

    
67
  my $type = {
68
    metacatUrl     => 'http://dev.nceas.ucsb.edu/jones/servlet/metacat',
69
    message        => '',
70
    cookies        => \$cookie_jar
71
  };
72

    
73
  bless $type, shift;
74
  return $type;
75
}
76

    
77
#############################################################
78
# subroutine to set options for the class, including the URL 
79
# for the Metacat database to which we would connect
80
#############################################################
81
sub set_options {
82
  my $self = shift;
83
  my %newargs = ( @_ );
84

    
85
  my $arg;
86
  foreach $arg (keys %newargs) {
87
    $self->{$arg} = $newargs{$arg};
88
  }
89
}
90

    
91
#############################################################
92
# subroutine to send data to metacat and get the response
93
# return response from metacat
94
#############################################################
95
sub sendData {
96
  my $self = shift;
97
  my %postData = ( @_ );
98

    
99
  $self->{'message'} = '';
100
  my $userAgent = new LWP::UserAgent;
101
  $userAgent->agent("MetacatClient/1.0");
102
  
103
  my $request = new HTTP::Request('POST' => "$self->{'metacatUrl'}");
104
  my $cookie_jar = $self->{'cookies'};
105
  $$cookie_jar->add_cookie_header($request);
106
  $request->content_type('application/x-www-form-urlencoded');
107
  foreach my $key (keys %postData) {
108
    $request->add_content("$key=$postData{$key}&")
109
  }
110

    
111
  my $response = $userAgent->request($request);
112
  
113
  if ($response->is_success) {
114
    # save the cookies
115
    $$cookie_jar->extract_cookies($response);
116
    # save the metacat response message
117
    $self->{'message'} = $response->content;
118
  } else {
119
    #print "SendData content is: ", $response->content, "\n";
120
    return 0;
121
  } 
122
  return $response;
123
}
124

    
125
#############################################################
126
# subroutine to log into Metacat and save the cookie if the
127
# login is valid.  If valid, return 1, else return 0
128
#############################################################
129
sub login {
130
  my $self = shift;
131
  my $username = shift;
132
  my $password = shift;
133

    
134
  my $returnval = 0;
135

    
136
  my %postData = ( action => 'login',
137
                   qformat => 'xml',
138
                   username => $username,
139
                   password => $password
140
                 );
141
  my $response = $self->sendData(%postData);
142
  if (($response) && $response->content =~ /<login>/) {
143
    $returnval = 1;
144
  }
145

    
146
  return $returnval;
147
}
148

    
149
#############################################################
150
# subroutine to insert an XML document into Metacat
151
# If success, return 1, else return 0
152
#############################################################
153
sub insert {
154
  my $self = shift;
155
  my $docid = shift;
156
  my $xmldocument = shift;
157
  my $dtd = shift;
158

    
159
  my $returnval = 0;
160

    
161
  my %postData = ( action => 'insert',
162
                   docid => $docid,
163
                   doctext => $xmldocument
164
                 );
165
  if ($dtd) {
166
    $postData{'dtdtext'} = $dtd;
167
  }
168

    
169
  my $response = $self->sendData(%postData);
170
  if (($response) && $response->content =~ /<success>/) {
171
    $returnval = 1;
172
  } elsif (($response)) {
173
    $returnval = 0;
174
    #print "Error response from sendData!\n";
175
    #print $response->content, "\n";
176
  } else {
177
    $returnval = 0;
178
    #print "Invalid response from sendData!\n";
179
  }
180

    
181
  return $returnval;
182
}
183

    
184
#############################################################
185
# subroutine to update an XML document in Metacat
186
# If success, return 1, else return 0
187
#############################################################
188
sub update {
189
  my $self = shift;
190
  my $docid = shift;
191
  my $xmldocument = shift;
192
  my $dtd = shift;
193

    
194
  my $returnval = 0;
195

    
196
  my %postData = ( action => 'update',
197
                   docid => $docid,
198
                   doctext => $xmldocument
199
                 );
200
  if ($dtd) {
201
    $postData{'dtdtext'} = $dtd;
202
  }
203

    
204
  my $response = $self->sendData(%postData);
205
  if (($response) && $response->content =~ /<success>/) {
206
    $returnval = 1;
207
  }
208

    
209
  return $returnval;
210
}
211

    
212
#############################################################
213
# subroutine to delete an XML document in Metacat
214
# If success, return 1, else return 0
215
#############################################################
216
sub delete {
217
  my $self = shift;
218
  my $docid = shift;
219

    
220
  my $returnval = 0;
221

    
222
  my %postData = ( action => 'delete',
223
                   docid => $docid
224
                 );
225

    
226
  my $response = $self->sendData(%postData);
227
  if (($response) && $response->content =~ /<success>/) {
228
    $returnval = 1;
229
  }
230

    
231
  return $returnval;
232
}
233

    
234
#############################################################
235
# subroutine to read an XML document from Metacat
236
# returns the XML from Metacat, which may be an error response
237
#############################################################
238
sub read {
239
  my $self = shift;
240
  my $docid = shift;
241

    
242
  my %postData = ( action => 'read',
243
                   qformat => 'xml',
244
                   docid => $docid
245
                 );
246

    
247
  my $response = $self->sendData(%postData);
248
  
249
  my $returnval = 0;
250
  if ($response) {
251
    $returnval = $response;
252
  } 
253
    
254
  return $returnval;
255
}
256

    
257
#############################################################
258
# subroutine to query metacat using a structured path query
259
# returns the XML from Metacat, which may be an error response
260
#############################################################
261
sub squery {
262
  my $self = shift;
263
  my $query = shift;
264

    
265
  my %postData = ( action => 'squery',
266
                   qformat => 'xml',
267
                   query => $query
268
                 );
269

    
270
  my $response = $self->sendData(%postData);
271

    
272
  my $returnval = 0;
273
  if ($response) {
274
    $returnval = $response;
275
  } 
276
    
277
  return $returnval;
278
}
279

    
280
#############################################################
281
# subroutine to get the maximimum id in a series
282
# If success, return max id, else return 0
283
#############################################################
284
sub getLastId {
285
  my $self = shift;
286
  my $scope = shift;
287

    
288
  my $returnval = 0;
289

    
290
  my %postData = ( action => 'getlastdocid',
291
                   scope => $scope
292
                 );
293

    
294
  my $response = $self->sendData(%postData);
295
  if (($response) && $response->content =~ /<docid>(.*)<\/docid>/s) {
296
      $returnval = "$1";
297
  } elsif (($response)) {
298
    $returnval = 0;
299
    #print "Error response from sendData!\n";
300
    #print $response->content, "\n";
301
  } else {
302
    $returnval = 0;
303
    #print "Invalid response from sendData!\n";
304
  }
305

    
306
  return $returnval;
307
}
308
#############################################################
309
# subroutine to get the message returned from the last executed
310
# metacat action.  These are generally XML formatted messages.
311
#############################################################
312
sub getMessage {
313
  my $self = shift;
314

    
315
  return $self->{'message'};
316
}
317

    
318
#############################################################
319
# subroutine to get the cookies returned from the metacat 
320
# server to establish (and pass on) session info (JSESSIONID).
321
#############################################################
322
sub getCookies {
323
  my $self = shift;
324

    
325
  return $self->{'cookies'};
326
}
327

    
328
# Autoload methods go after =cut, and are processed by the autosplit program.
329

    
330
1;
331
__END__
332
# Below is stub documentation for your module. You better edit it!
333

    
334
=head1 NAME
335

    
336
Metacat - Perl extension for communicating with the Metacat XML database
337

    
338
=head1 SYNOPSIS
339

    
340
  use Metacat;
341
  my $metacat = Metacat->new();
342
  my $response = $metacat->login($username, $password); 
343
  print $metacat->getMessage();
344
  $response = $metacat->insert($docid, $xmldoc); 
345
  print $metacat->getMessage();
346
  $response = $metacat->insert($docid, $xmldoc, $dtd); 
347
  print $metacat->getMessage();
348
  $response = $metacat->update($docid, $xmldoc); 
349
  print $metacat->getMessage();
350
  $htmlResponse = $metacat->read($docid); 
351
  $xmldoc = $htmlResponse->content();
352
  print $xmldoc;
353
  $resultset = $metacat->squery($pathquery); 
354
  print $resultset;
355
  $response = $metacat->delete($docid); 
356
  my $lastid = $metacat->getLastId("obfs");
357
  print $metacat->getMessage();
358
  $response = $metacat->getCookies(); 
359
  print $metacat->getMessage();
360

    
361
=head1 DESCRIPTION
362

    
363
This is a client library for accessing the Metacat XML database.  Metacat
364
is a Java servlet that accepts commands over HTTP and returns XML and
365
HTML responses.  See http://knb.ecoinformatics.org for details about
366
Metacat and its interface.
367

    
368
=head2 EXPORT
369

    
370
None by default.
371

    
372

    
373
=head1 AUTHOR
374

    
375
Matthew B. Jones, jones@nceas.ucsb.edu
376

    
377
=head1 SEE ALSO
378

    
379
perl(1).
380

    
381
=cut