Project

General

Profile

1 1929 brooke
 #
2
 #  '$RCSfile$'
3
 #  Copyright: 2000 Regents of the University of California
4
 #
5
 #   '$Author$'
6
 #     '$Date$'
7
 # '$Revision$'
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 3421 walbridge
use HTTP::Request::Common qw(POST);
35 1929 brooke
use HTTP::Cookies;
36
37
our @ISA = qw(Exporter);
38
39
# Items to export into callers namespace by default. Note: do not export
40
# names by default without a very good reason. Use EXPORT_OK instead.
41
# Do not simply export all your public functions/methods/constants.
42
43
# This allows declaration	use Metacat ':all';
44
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
45
# will save memory.
46
our %EXPORT_TAGS = ( 'all' => [ qw(
47
48
) ] );
49
50
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
51
52
our @EXPORT = qw(
53
54
);
55
our $VERSION = '0.01';
56
57
58
# Preloaded methods go here.
59
60
#############################################################
61
# Constructor creates a new class instance and inits all
62
# of the instance variables to their proper default values,
63
# which can later be changed using "set_options"
64
#############################################################
65
sub new {
66 3421 walbridge
  my($type,$metacatUrl) = @_;
67 1929 brooke
  my $cookie_jar = HTTP::Cookies->new;
68
69 3421 walbridge
  my $self = {
70
    metacatUrl     => $metacatUrl,
71 1929 brooke
    message        => '',
72
    cookies        => \$cookie_jar
73
  };
74
75 3421 walbridge
  bless $self, $type;
76
  return $self;
77 1929 brooke
}
78
79
#############################################################
80
# subroutine to set options for the class, including the URL
81
# for the Metacat database to which we would connect
82
#############################################################
83
sub set_options {
84
  my $self = shift;
85
  my %newargs = ( @_ );
86
87
  my $arg;
88
  foreach $arg (keys %newargs) {
89
    $self->{$arg} = $newargs{$arg};
90
  }
91
}
92
93
#############################################################
94
# subroutine to send data to metacat and get the response
95
# return response from metacat
96
#############################################################
97
sub sendData {
98
  my $self = shift;
99
  my %postData = ( @_ );
100
101 1955 jones
  $self->{'message'} = '';
102 1929 brooke
  my $userAgent = new LWP::UserAgent;
103
  $userAgent->agent("MetacatClient/1.0");
104 3421 walbridge
105
  # determine encoding type
106
  my $contentType = 'application/x-www-form-urlencoded';
107
  if ($postData{'enctype'}) {
108
      $contentType = $postData{'enctype'};
109
      delete $postData{'enctype'};
110
  }
111
112
  my $request = POST("$self->{'metacatUrl'}",
113
                     Content_Type => $contentType,
114
                     Content => \%postData
115
                );
116
117
  # set cookies on UA object
118 1929 brooke
  my $cookie_jar = $self->{'cookies'};
119
  $$cookie_jar->add_cookie_header($request);
120 5029 daigle
  #print "Content_type:text/html\n\n";
121 3421 walbridge
  #print "request: " . $request->as_string();
122 1929 brooke
123
  my $response = $userAgent->request($request);
124 3421 walbridge
  #print "response: " . $response->as_string();
125
126 1929 brooke
  if ($response->is_success) {
127
    # save the cookies
128
    $$cookie_jar->extract_cookies($response);
129
    # save the metacat response message
130
    $self->{'message'} = $response->content;
131
  } else {
132
    #print "SendData content is: ", $response->content, "\n";
133
    return 0;
134
  }
135
  return $response;
136
}
137
138
#############################################################
139
# subroutine to log into Metacat and save the cookie if the
140 2684 sgarg
# login is valid.  If not valid, return 0. If valid then send
141
# following values to indicate user status
142
# 1 - user
143
# 2 - moderator
144
# 3 - administrator
145
# 4 - moderator and administrator
146 1929 brooke
#############################################################
147
sub login {
148
  my $self = shift;
149
  my $username = shift;
150
  my $password = shift;
151
152
  my $returnval = 0;
153
154
  my %postData = ( action => 'login',
155
                   qformat => 'xml',
156
                   username => $username,
157
                   password => $password
158
                 );
159
  my $response = $self->sendData(%postData);
160
  if (($response) && $response->content =~ /<login>/) {
161
    $returnval = 1;
162
  }
163
164 2684 sgarg
  if (($response) && $response->content =~ /<isAdministrator>/) {
165
	if (($response) && $response->content =~ /<isModerator>/) {
166
    		$returnval = 4;
167
	} else {
168
		$returnval = 3;
169
	}
170
  } elsif (($response) && $response->content =~ /<isModerator>/){
171
	$returnval = 2;
172
  }
173
174 1929 brooke
  return $returnval;
175
}
176
177
#############################################################
178
# subroutine to insert an XML document into Metacat
179
# If success, return 1, else return 0
180
#############################################################
181
sub insert {
182
  my $self = shift;
183
  my $docid = shift;
184
  my $xmldocument = shift;
185
  my $dtd = shift;
186
187
  my $returnval = 0;
188
189
  my %postData = ( action => 'insert',
190
                   docid => $docid,
191
                   doctext => $xmldocument
192
                 );
193
  if ($dtd) {
194
    $postData{'dtdtext'} = $dtd;
195
  }
196
197
  my $response = $self->sendData(%postData);
198
  if (($response) && $response->content =~ /<success>/) {
199
    $returnval = 1;
200
  } elsif (($response)) {
201
    $returnval = 0;
202
    #print "Error response from sendData!\n";
203
    #print $response->content, "\n";
204
  } else {
205
    $returnval = 0;
206
    #print "Invalid response from sendData!\n";
207
  }
208
209
  return $returnval;
210
}
211
212
#############################################################
213
# subroutine to update an XML document in Metacat
214
# If success, return 1, else return 0
215
#############################################################
216
sub update {
217
  my $self = shift;
218
  my $docid = shift;
219
  my $xmldocument = shift;
220
  my $dtd = shift;
221
222
  my $returnval = 0;
223
224
  my %postData = ( action => 'update',
225
                   docid => $docid,
226
                   doctext => $xmldocument
227
                 );
228
  if ($dtd) {
229
    $postData{'dtdtext'} = $dtd;
230
  }
231
232
  my $response = $self->sendData(%postData);
233
  if (($response) && $response->content =~ /<success>/) {
234
    $returnval = 1;
235
  }
236
237
  return $returnval;
238
}
239
240 3421 walbridge
############################################################
241
# subroutine to upload an XML document in Metacat
242
# If success, return 1, else return 0
243 1929 brooke
#############################################################
244 3421 walbridge
sub upload {
245
  my $self = shift;
246
  my $docid = shift;
247
  my $datafile = shift;
248
249
  my $returnval = 0;
250
251
  my %postData = ( action => 'upload',
252
                   docid => $docid,
253
                   datafile => [$datafile],
254
                   enctype => 'form-data'
255
                 );
256
257
  my $response = $self->sendData(%postData);
258
  #print "response is: $response";
259
  #
260
  if (($response) && $response->content =~ /<success>/) {
261
    $returnval = $response->content;
262
  }
263
264
  return $returnval;
265
}
266
267
268
#############################################################
269 1929 brooke
# subroutine to delete an XML document in Metacat
270
# If success, return 1, else return 0
271
#############################################################
272
sub delete {
273
  my $self = shift;
274
  my $docid = shift;
275
276
  my $returnval = 0;
277
278
  my %postData = ( action => 'delete',
279
                   docid => $docid
280
                 );
281
282
  my $response = $self->sendData(%postData);
283
  if (($response) && $response->content =~ /<success>/) {
284
    $returnval = 1;
285
  }
286
287
  return $returnval;
288
}
289
290
#############################################################
291 2846 sgarg
# subroutine to set access for an XML document in Metacat
292
# If success, return 1, else return 0
293
#############################################################
294
sub setaccess {
295
  my $self = shift;
296
  my $docid = shift;
297
  my $principal = shift;
298
  my $permission = shift;
299
  my $permType = shift;
300
  my $permOrder = shift;
301
302
  my $returnval = 0;
303
304
  my %postData = ( action => 'setaccess',
305
                   docid => $docid,
306
		   principal => $principal,
307
		   permission => $permission,
308
		   permType => $permType,
309
		   permOrder => $permOrder
310
                 );
311
312
  my $response = $self->sendData(%postData);
313
  if (($response) && $response->content =~ /<success>/) {
314
    $returnval = 1;
315
  }
316
317
  return $returnval;
318
}
319
320
321
#############################################################
322 1929 brooke
# subroutine to read an XML document from Metacat
323
# returns the XML from Metacat, which may be an error response
324
#############################################################
325
sub read {
326
  my $self = shift;
327
  my $docid = shift;
328
329
  my %postData = ( action => 'read',
330
                   qformat => 'xml',
331
                   docid => $docid
332
                 );
333
334
  my $response = $self->sendData(%postData);
335
336
  my $returnval = 0;
337
  if ($response) {
338
    $returnval = $response;
339
  }
340
341
  return $returnval;
342
}
343
344
#############################################################
345
# subroutine to query metacat using a structured path query
346
# returns the XML from Metacat, which may be an error response
347
#############################################################
348
sub squery {
349
  my $self = shift;
350
  my $query = shift;
351
352
  my %postData = ( action => 'squery',
353
                   qformat => 'xml',
354
                   query => $query
355
                 );
356
357
  my $response = $self->sendData(%postData);
358
359
  my $returnval = 0;
360
  if ($response) {
361
    $returnval = $response;
362
  }
363
364
  return $returnval;
365
}
366
367
#############################################################
368 1953 jones
# subroutine to get the maximimum id in a series
369
# If success, return max id, else return 0
370
#############################################################
371
sub getLastId {
372
  my $self = shift;
373
  my $scope = shift;
374
375
  my $returnval = 0;
376
377
  my %postData = ( action => 'getlastdocid',
378
                   scope => $scope
379
                 );
380
381
  my $response = $self->sendData(%postData);
382 5201 daigle
  if (($response) && $response->content =~  /<docid>(.*)<\/docid>/s) {
383 1953 jones
      $returnval = "$1";
384
  } elsif (($response)) {
385
    $returnval = 0;
386
    #print "Error response from sendData!\n";
387
    #print $response->content, "\n";
388
  } else {
389
    $returnval = 0;
390
    #print "Invalid response from sendData!\n";
391
  }
392
393
  return $returnval;
394
}
395 5201 daigle
396 1953 jones
#############################################################
397 5201 daigle
# subroutine to get the maximimum id in a series
398
# If success, return max id, else return 0
399
#############################################################
400
sub getLastRevision {
401
  my $self = shift;
402
  my $docid = shift;
403
404
  my $returnval = 0;
405
406
  my %postData = ( action => 'getrevisionanddoctype',
407
                   docid => $docid
408
                 );
409
410
  my $response = $self->sendData(%postData);
411
  if (($response) && $response->content =~ /(.*);(.*)/s)  {
412
      $returnval = "$1";
413
  } elsif (($response)) {
414
    $returnval = 0;
415
    #print "Error response from sendData!\n";
416
    #print $response->content, "\n";
417
  } else {
418
    $returnval = 0;
419
    #print "Invalid response from sendData!\n";
420
  }
421
422
  return $returnval;
423
}
424
425
#############################################################
426 1929 brooke
# subroutine to get the message returned from the last executed
427
# metacat action.  These are generally XML formatted messages.
428
#############################################################
429
sub getMessage {
430
  my $self = shift;
431
432
  return $self->{'message'};
433
}
434
435
#############################################################
436
# subroutine to get the cookies returned from the metacat
437
# server to establish (and pass on) session info (JSESSIONID).
438
#############################################################
439
sub getCookies {
440
  my $self = shift;
441
442
  return $self->{'cookies'};
443
}
444
445
# Autoload methods go after =cut, and are processed by the autosplit program.
446
447
1;
448
__END__
449
# Below is stub documentation for your module. You better edit it!
450
451
=head1 NAME
452
453
Metacat - Perl extension for communicating with the Metacat XML database
454
455
=head1 SYNOPSIS
456
457
  use Metacat;
458
  my $metacat = Metacat->new();
459
  my $response = $metacat->login($username, $password);
460
  print $metacat->getMessage();
461
  $response = $metacat->insert($docid, $xmldoc);
462
  print $metacat->getMessage();
463
  $response = $metacat->insert($docid, $xmldoc, $dtd);
464
  print $metacat->getMessage();
465
  $response = $metacat->update($docid, $xmldoc);
466
  print $metacat->getMessage();
467 3724 jones
  $response = $metacat->upload($docid, $data);
468
  print $metacat->getMessage();
469 1929 brooke
  $htmlResponse = $metacat->read($docid);
470
  $xmldoc = $htmlResponse->content();
471
  print $xmldoc;
472
  $resultset = $metacat->squery($pathquery);
473
  print $resultset;
474
  $response = $metacat->delete($docid);
475 2846 sgarg
  $response = $metacat->setaccess($docid,$principal,$permission,$permType,$permOrder);
476 1953 jones
  my $lastid = $metacat->getLastId("obfs");
477 1929 brooke
  print $metacat->getMessage();
478
  $response = $metacat->getCookies();
479
  print $metacat->getMessage();
480
481
=head1 DESCRIPTION
482
483
This is a client library for accessing the Metacat XML database.  Metacat
484
is a Java servlet that accepts commands over HTTP and returns XML and
485
HTML responses.  See http://knb.ecoinformatics.org for details about
486
Metacat and its interface.
487
488
=head2 EXPORT
489
490
None by default.
491
492
493
=head1 AUTHOR
494
495
Matthew B. Jones, jones@nceas.ucsb.edu
496
497
=head1 SEE ALSO
498
499
perl(1).
500
501
=cut