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 9529 cjones
112
113
  my $request;
114
  if ( $self->{'auth_token_header'} ) {
115
      # if available, set the Authorization header from the auth_token_header instance variable
116
      $request = POST("$self->{'metacatUrl'}",
117
                      Content_Type => $contentType,
118
                      Authorization => $self->{'auth_token_header'},
119
                      Content => \%postData
120
                      );
121
122
  } else {
123
      $request = POST("$self->{'metacatUrl'}",
124
                      Content_Type => $contentType,
125
                      Content => \%postData
126
                      );
127
  }
128 3421 walbridge
129
  # set cookies on UA object
130 1929 brooke
  my $cookie_jar = $self->{'cookies'};
131
  $$cookie_jar->add_cookie_header($request);
132 5029 daigle
  #print "Content_type:text/html\n\n";
133 3421 walbridge
  #print "request: " . $request->as_string();
134 1929 brooke
135
  my $response = $userAgent->request($request);
136 3421 walbridge
  #print "response: " . $response->as_string();
137
138 1929 brooke
  if ($response->is_success) {
139
    # save the cookies
140
    $$cookie_jar->extract_cookies($response);
141
    # save the metacat response message
142
    $self->{'message'} = $response->content;
143
  } else {
144
    #print "SendData content is: ", $response->content, "\n";
145
    return 0;
146
  }
147
  return $response;
148
}
149
150
#############################################################
151
# subroutine to log into Metacat and save the cookie if the
152 2684 sgarg
# login is valid.  If not valid, return 0. If valid then send
153
# following values to indicate user status
154
# 1 - user
155
# 2 - moderator
156
# 3 - administrator
157
# 4 - moderator and administrator
158 1929 brooke
#############################################################
159
sub login {
160
  my $self = shift;
161
  my $username = shift;
162
  my $password = shift;
163
164
  my $returnval = 0;
165
166
  my %postData = ( action => 'login',
167
                   qformat => 'xml',
168
                   username => $username,
169
                   password => $password
170
                 );
171
  my $response = $self->sendData(%postData);
172
  if (($response) && $response->content =~ /<login>/) {
173
    $returnval = 1;
174
  }
175
176 2684 sgarg
  if (($response) && $response->content =~ /<isAdministrator>/) {
177
	if (($response) && $response->content =~ /<isModerator>/) {
178
    		$returnval = 4;
179
	} else {
180
		$returnval = 3;
181
	}
182
  } elsif (($response) && $response->content =~ /<isModerator>/){
183
	$returnval = 2;
184
  }
185
186 1929 brooke
  return $returnval;
187
}
188
189
#############################################################
190 9228 leinfelder
# subroutine to logout of Metacat
191
#############################################################
192
sub logout {
193
    my $self = shift;
194
195
    my %postData = (action => 'logout');
196
197
    my $response = $self->sendData(%postData);
198
199 9234 leinfelder
    my $returnval = 1;
200
    if (($response) && $response->content =~ /<logout>/) {
201
    	$returnval = 0;
202
  	}
203
204 9228 leinfelder
    # clear the cookie
205
    my $cookie_jar = $self->{'cookies'};
206
    $$cookie_jar->clear();
207
208 9234 leinfelder
    return $returnval;
209 9228 leinfelder
}
210
211
#############################################################
212 5311 daigle
# subroutine to log into Metacat and get usr info xml for
213
# a logged in user
214
#############################################################
215
sub getUserInfo {
216
	my $self = shift;
217
218
	my %postData = (action => 'getloggedinuserinfo');
219
220
	my $response = $self->sendData(%postData);
221
222
	return $response->content;
223
}
224
225
#############################################################
226 1929 brooke
# subroutine to insert an XML document into Metacat
227
# If success, return 1, else return 0
228
#############################################################
229
sub insert {
230
  my $self = shift;
231
  my $docid = shift;
232
  my $xmldocument = shift;
233
  my $dtd = shift;
234
235
  my $returnval = 0;
236
237
  my %postData = ( action => 'insert',
238
                   docid => $docid,
239
                   doctext => $xmldocument
240
                 );
241
  if ($dtd) {
242
    $postData{'dtdtext'} = $dtd;
243
  }
244
245
  my $response = $self->sendData(%postData);
246
  if (($response) && $response->content =~ /<success>/) {
247
    $returnval = 1;
248
  } elsif (($response)) {
249
    $returnval = 0;
250
    #print "Error response from sendData!\n";
251
    #print $response->content, "\n";
252
  } else {
253
    $returnval = 0;
254
    #print "Invalid response from sendData!\n";
255
  }
256
257
  return $returnval;
258
}
259
260
#############################################################
261
# subroutine to update an XML document in Metacat
262
# If success, return 1, else return 0
263
#############################################################
264
sub update {
265
  my $self = shift;
266
  my $docid = shift;
267
  my $xmldocument = shift;
268
  my $dtd = shift;
269
270
  my $returnval = 0;
271
272
  my %postData = ( action => 'update',
273
                   docid => $docid,
274
                   doctext => $xmldocument
275
                 );
276
  if ($dtd) {
277
    $postData{'dtdtext'} = $dtd;
278
  }
279
280
  my $response = $self->sendData(%postData);
281
  if (($response) && $response->content =~ /<success>/) {
282
    $returnval = 1;
283
  }
284
285
  return $returnval;
286
}
287
288 3421 walbridge
############################################################
289
# subroutine to upload an XML document in Metacat
290
# If success, return 1, else return 0
291 1929 brooke
#############################################################
292 3421 walbridge
sub upload {
293
  my $self = shift;
294
  my $docid = shift;
295
  my $datafile = shift;
296 7820 leinfelder
  my $filename = shift;
297 3421 walbridge
298
  my $returnval = 0;
299
300
  my %postData = ( action => 'upload',
301
                   docid => $docid,
302 7821 leinfelder
                   datafile => [$datafile, $filename],
303 9535 cjones
                   enctype => 'multipart/form-data'
304 3421 walbridge
                 );
305
306
  my $response = $self->sendData(%postData);
307
  #print "response is: $response";
308
  #
309
  if (($response) && $response->content =~ /<success>/) {
310
    $returnval = $response->content;
311
  }
312
313
  return $returnval;
314
}
315
316
317
#############################################################
318 1929 brooke
# subroutine to delete an XML document in Metacat
319
# If success, return 1, else return 0
320
#############################################################
321
sub delete {
322
  my $self = shift;
323
  my $docid = shift;
324
325
  my $returnval = 0;
326
327
  my %postData = ( action => 'delete',
328
                   docid => $docid
329
                 );
330
331
  my $response = $self->sendData(%postData);
332
  if (($response) && $response->content =~ /<success>/) {
333
    $returnval = 1;
334
  }
335
336
  return $returnval;
337
}
338
339
#############################################################
340 2846 sgarg
# subroutine to set access for an XML document in Metacat
341
# If success, return 1, else return 0
342
#############################################################
343
sub setaccess {
344
  my $self = shift;
345
  my $docid = shift;
346
  my $principal = shift;
347
  my $permission = shift;
348
  my $permType = shift;
349
  my $permOrder = shift;
350
351
  my $returnval = 0;
352
353
  my %postData = ( action => 'setaccess',
354
                   docid => $docid,
355
		   principal => $principal,
356
		   permission => $permission,
357
		   permType => $permType,
358
		   permOrder => $permOrder
359
                 );
360
361
  my $response = $self->sendData(%postData);
362
  if (($response) && $response->content =~ /<success>/) {
363
    $returnval = 1;
364
  }
365
366
  return $returnval;
367
}
368
369 9645 leinfelder
#############################################################
370
# subroutine to get access info from Metacat
371
# returns access XML block from Metacat
372
#############################################################
373
sub getaccess {
374
    my $self = shift;
375
    my $docid = shift;
376
377
    my %postData = ( action => 'getaccess',
378
    docid => $docid
379
    );
380
381
    my $response = $self->sendData(%postData);
382
383
    my $returnval = 0;
384
    if ($response) {
385
        $returnval = $response;
386
    }
387
388
    return $returnval;
389
}
390 2846 sgarg
391
#############################################################
392 1929 brooke
# subroutine to read an XML document from Metacat
393
# returns the XML from Metacat, which may be an error response
394
#############################################################
395
sub read {
396
  my $self = shift;
397
  my $docid = shift;
398
399
  my %postData = ( action => 'read',
400
                   qformat => 'xml',
401
                   docid => $docid
402
                 );
403
404
  my $response = $self->sendData(%postData);
405
406
  my $returnval = 0;
407
  if ($response) {
408
    $returnval = $response;
409
  }
410
411
  return $returnval;
412
}
413
414
#############################################################
415
# subroutine to query metacat using a structured path query
416
# returns the XML from Metacat, which may be an error response
417
#############################################################
418
sub squery {
419
  my $self = shift;
420
  my $query = shift;
421
422
  my %postData = ( action => 'squery',
423
                   qformat => 'xml',
424
                   query => $query
425
                 );
426
427
  my $response = $self->sendData(%postData);
428
429
  my $returnval = 0;
430
  if ($response) {
431
    $returnval = $response;
432
  }
433
434
  return $returnval;
435
}
436
437
#############################################################
438 1953 jones
# subroutine to get the maximimum id in a series
439
# If success, return max id, else return 0
440
#############################################################
441
sub getLastId {
442
  my $self = shift;
443
  my $scope = shift;
444
445
  my $returnval = 0;
446
447
  my %postData = ( action => 'getlastdocid',
448
                   scope => $scope
449
                 );
450
451
  my $response = $self->sendData(%postData);
452 5201 daigle
  if (($response) && $response->content =~  /<docid>(.*)<\/docid>/s) {
453 1953 jones
      $returnval = "$1";
454
  } elsif (($response)) {
455
    $returnval = 0;
456
    #print "Error response from sendData!\n";
457
    #print $response->content, "\n";
458
  } else {
459
    $returnval = 0;
460
    #print "Invalid response from sendData!\n";
461
  }
462
463
  return $returnval;
464
}
465 5201 daigle
466 1953 jones
#############################################################
467 5201 daigle
# subroutine to get the maximimum id in a series
468
# If success, return max id, else return 0
469
#############################################################
470
sub getLastRevision {
471
  my $self = shift;
472
  my $docid = shift;
473
474
  my $returnval = 0;
475
476
  my %postData = ( action => 'getrevisionanddoctype',
477
                   docid => $docid
478
                 );
479
480
  my $response = $self->sendData(%postData);
481
  if (($response) && $response->content =~ /(.*);(.*)/s)  {
482
      $returnval = "$1";
483
  } elsif (($response)) {
484
    $returnval = 0;
485
    #print "Error response from sendData!\n";
486
    #print $response->content, "\n";
487
  } else {
488
    $returnval = 0;
489
    #print "Invalid response from sendData!\n";
490
  }
491
492
  return $returnval;
493
}
494
495
#############################################################
496 7695 leinfelder
# subroutine to get the docid for a given PID
497
# If success, return docid, else return -1
498
#############################################################
499
sub getDocid {
500
  my $self = shift;
501
  my $pid = shift;
502
503
  my $returnval = 0;
504
505
  my %postData = ( action => 'getdocid',
506
                   pid => $pid
507
                 );
508
509
  my $response = $self->sendData(%postData);
510
  if (($response) && $response->content =~  /<docid>(.*)<\/docid>/s) {
511
      $returnval = "$1";
512
  } elsif (($response)) {
513
    $returnval = -1;
514
    #print "Error response from sendData!\n";
515
    #print $response->content, "\n";
516
  } else {
517
    $returnval = -1;
518
    #print "Invalid response from sendData!\n";
519
  }
520
521
  return $returnval;
522
}
523
524
#############################################################
525 1929 brooke
# subroutine to get the message returned from the last executed
526
# metacat action.  These are generally XML formatted messages.
527
#############################################################
528
sub getMessage {
529
  my $self = shift;
530
531
  return $self->{'message'};
532
}
533
534
#############################################################
535
# subroutine to get the cookies returned from the metacat
536
# server to establish (and pass on) session info (JSESSIONID).
537
#############################################################
538
sub getCookies {
539
  my $self = shift;
540
541
  return $self->{'cookies'};
542
}
543
544
# Autoload methods go after =cut, and are processed by the autosplit program.
545
546
1;
547
__END__
548
# Below is stub documentation for your module. You better edit it!
549
550
=head1 NAME
551
552
Metacat - Perl extension for communicating with the Metacat XML database
553
554
=head1 SYNOPSIS
555
556
  use Metacat;
557
  my $metacat = Metacat->new();
558
  my $response = $metacat->login($username, $password);
559
  print $metacat->getMessage();
560
  $response = $metacat->insert($docid, $xmldoc);
561
  print $metacat->getMessage();
562
  $response = $metacat->insert($docid, $xmldoc, $dtd);
563
  print $metacat->getMessage();
564
  $response = $metacat->update($docid, $xmldoc);
565
  print $metacat->getMessage();
566 3724 jones
  $response = $metacat->upload($docid, $data);
567
  print $metacat->getMessage();
568 1929 brooke
  $htmlResponse = $metacat->read($docid);
569
  $xmldoc = $htmlResponse->content();
570
  print $xmldoc;
571
  $resultset = $metacat->squery($pathquery);
572
  print $resultset;
573
  $response = $metacat->delete($docid);
574 2846 sgarg
  $response = $metacat->setaccess($docid,$principal,$permission,$permType,$permOrder);
575 1953 jones
  my $lastid = $metacat->getLastId("obfs");
576 1929 brooke
  print $metacat->getMessage();
577
  $response = $metacat->getCookies();
578
  print $metacat->getMessage();
579
580
=head1 DESCRIPTION
581
582
This is a client library for accessing the Metacat XML database.  Metacat
583
is a Java servlet that accepts commands over HTTP and returns XML and
584
HTML responses.  See http://knb.ecoinformatics.org for details about
585
Metacat and its interface.
586
587
=head2 EXPORT
588
589
None by default.
590
591
592
=head1 AUTHOR
593
594
Matthew B. Jones, jones@nceas.ucsb.edu
595
596
=head1 SEE ALSO
597
598
perl(1).
599
600
=cut