Project

General

Profile

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

1
 #
2
 #  '$RCSfile$'
3
 #  Copyright: 2000 Regents of the University of California 
4
 #
5
 #   '$Author: leinfelder $'
6
 #     '$Date: 2013-06-21 16:06:27 -0700 (Fri, 21 Jun 2013) $'
7
 # '$Revision: 7821 $' 
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::Request::Common qw(POST);
35
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
  my($type,$metacatUrl) = @_;
67
  my $cookie_jar = HTTP::Cookies->new;
68

    
69
  my $self = {
70
    metacatUrl     => $metacatUrl,
71
    message        => '',
72
    cookies        => \$cookie_jar
73
  };
74

    
75
  bless $self, $type; 
76
  return $self;
77
}
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
  $self->{'message'} = '';
102
  my $userAgent = new LWP::UserAgent;
103
  $userAgent->agent("MetacatClient/1.0");
104

    
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
  my $cookie_jar = $self->{'cookies'};
119
  $$cookie_jar->add_cookie_header($request);
120
  #print "Content_type:text/html\n\n";
121
  #print "request: " . $request->as_string();
122

    
123
  my $response = $userAgent->request($request);
124
  #print "response: " . $response->as_string();
125
   
126
  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
# 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
#############################################################
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
  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
  return $returnval;
175
}
176

    
177
#############################################################
178
# subroutine to log into Metacat and get usr info xml for
179
# a logged in user
180
#############################################################
181
sub getUserInfo {
182
	my $self = shift;
183

    
184
	my %postData = (action => 'getloggedinuserinfo');
185
  
186
	my $response = $self->sendData(%postData);
187

    
188
	return $response->content;
189
}
190

    
191
#############################################################
192
# subroutine to insert an XML document into Metacat
193
# If success, return 1, else return 0
194
#############################################################
195
sub insert {
196
  my $self = shift;
197
  my $docid = shift;
198
  my $xmldocument = shift;
199
  my $dtd = shift;
200

    
201
  my $returnval = 0;
202

    
203
  my %postData = ( action => 'insert',
204
                   docid => $docid,
205
                   doctext => $xmldocument
206
                 );
207
  if ($dtd) {
208
    $postData{'dtdtext'} = $dtd;
209
  }
210

    
211
  my $response = $self->sendData(%postData);
212
  if (($response) && $response->content =~ /<success>/) {
213
    $returnval = 1;
214
  } elsif (($response)) {
215
    $returnval = 0;
216
    #print "Error response from sendData!\n";
217
    #print $response->content, "\n";
218
  } else {
219
    $returnval = 0;
220
    #print "Invalid response from sendData!\n";
221
  }
222

    
223
  return $returnval;
224
}
225

    
226
#############################################################
227
# subroutine to update an XML document in Metacat
228
# If success, return 1, else return 0
229
#############################################################
230
sub update {
231
  my $self = shift;
232
  my $docid = shift;
233
  my $xmldocument = shift;
234
  my $dtd = shift;
235

    
236
  my $returnval = 0;
237

    
238
  my %postData = ( action => 'update',
239
                   docid => $docid,
240
                   doctext => $xmldocument
241
                 );
242
  if ($dtd) {
243
    $postData{'dtdtext'} = $dtd;
244
  }
245

    
246
  my $response = $self->sendData(%postData);
247
  if (($response) && $response->content =~ /<success>/) {
248
    $returnval = 1;
249
  }
250

    
251
  return $returnval;
252
}
253

    
254
############################################################
255
# subroutine to upload an XML document in Metacat
256
# If success, return 1, else return 0
257
#############################################################
258
sub upload {
259
  my $self = shift;
260
  my $docid = shift;
261
  my $datafile = shift;
262
  my $filename = shift;
263

    
264
  my $returnval = 0;
265

    
266
  my %postData = ( action => 'upload',
267
                   docid => $docid,
268
                   datafile => [$datafile, $filename],
269
                   enctype => 'form-data'
270
                 );
271

    
272
  my $response = $self->sendData(%postData);
273
  #print "response is: $response";
274
  # 
275
  if (($response) && $response->content =~ /<success>/) {
276
    $returnval = $response->content;
277
  }
278

    
279
  return $returnval;
280
}
281

    
282

    
283
#############################################################
284
# subroutine to delete an XML document in Metacat
285
# If success, return 1, else return 0
286
#############################################################
287
sub delete {
288
  my $self = shift;
289
  my $docid = shift;
290

    
291
  my $returnval = 0;
292

    
293
  my %postData = ( action => 'delete',
294
                   docid => $docid
295
                 );
296

    
297
  my $response = $self->sendData(%postData);
298
  if (($response) && $response->content =~ /<success>/) {
299
    $returnval = 1;
300
  }
301

    
302
  return $returnval;
303
}
304

    
305
#############################################################
306
# subroutine to set access for an XML document in Metacat
307
# If success, return 1, else return 0
308
#############################################################
309
sub setaccess {
310
  my $self = shift;
311
  my $docid = shift;
312
  my $principal = shift;
313
  my $permission = shift;
314
  my $permType = shift;
315
  my $permOrder = shift;
316

    
317
  my $returnval = 0;
318

    
319
  my %postData = ( action => 'setaccess',
320
                   docid => $docid,
321
		   principal => $principal,
322
		   permission => $permission,
323
		   permType => $permType,
324
		   permOrder => $permOrder
325
                 );
326

    
327
  my $response = $self->sendData(%postData);
328
  if (($response) && $response->content =~ /<success>/) {
329
    $returnval = 1;
330
  }
331

    
332
  return $returnval;
333
}
334

    
335

    
336
#############################################################
337
# subroutine to read an XML document from Metacat
338
# returns the XML from Metacat, which may be an error response
339
#############################################################
340
sub read {
341
  my $self = shift;
342
  my $docid = shift;
343

    
344
  my %postData = ( action => 'read',
345
                   qformat => 'xml',
346
                   docid => $docid
347
                 );
348

    
349
  my $response = $self->sendData(%postData);
350
  
351
  my $returnval = 0;
352
  if ($response) {
353
    $returnval = $response;
354
  } 
355
    
356
  return $returnval;
357
}
358

    
359
#############################################################
360
# subroutine to query metacat using a structured path query
361
# returns the XML from Metacat, which may be an error response
362
#############################################################
363
sub squery {
364
  my $self = shift;
365
  my $query = shift;
366

    
367
  my %postData = ( action => 'squery',
368
                   qformat => 'xml',
369
                   query => $query
370
                 );
371

    
372
  my $response = $self->sendData(%postData);
373

    
374
  my $returnval = 0;
375
  if ($response) {
376
    $returnval = $response;
377
  } 
378
    
379
  return $returnval;
380
}
381

    
382
#############################################################
383
# subroutine to get the maximimum id in a series
384
# If success, return max id, else return 0
385
#############################################################
386
sub getLastId {
387
  my $self = shift;
388
  my $scope = shift;
389

    
390
  my $returnval = 0;
391

    
392
  my %postData = ( action => 'getlastdocid',
393
                   scope => $scope
394
                 );
395

    
396
  my $response = $self->sendData(%postData);
397
  if (($response) && $response->content =~  /<docid>(.*)<\/docid>/s) {
398
      $returnval = "$1";
399
  } elsif (($response)) {
400
    $returnval = 0;
401
    #print "Error response from sendData!\n";
402
    #print $response->content, "\n";
403
  } else {
404
    $returnval = 0;
405
    #print "Invalid response from sendData!\n";
406
  }
407

    
408
  return $returnval;
409
}
410

    
411
#############################################################
412
# subroutine to get the maximimum id in a series
413
# If success, return max id, else return 0
414
#############################################################
415
sub getLastRevision {
416
  my $self = shift;
417
  my $docid = shift;
418

    
419
  my $returnval = 0;
420

    
421
  my %postData = ( action => 'getrevisionanddoctype',
422
                   docid => $docid
423
                 );
424

    
425
  my $response = $self->sendData(%postData);
426
  if (($response) && $response->content =~ /(.*);(.*)/s)  {
427
      $returnval = "$1";
428
  } elsif (($response)) {
429
    $returnval = 0;
430
    #print "Error response from sendData!\n";
431
    #print $response->content, "\n";
432
  } else {
433
    $returnval = 0;
434
    #print "Invalid response from sendData!\n";
435
  }
436

    
437
  return $returnval;
438
}
439

    
440
#############################################################
441
# subroutine to get the docid for a given PID
442
# If success, return docid, else return -1
443
#############################################################
444
sub getDocid {
445
  my $self = shift;
446
  my $pid = shift;
447

    
448
  my $returnval = 0;
449

    
450
  my %postData = ( action => 'getdocid',
451
                   pid => $pid
452
                 );
453

    
454
  my $response = $self->sendData(%postData);
455
  if (($response) && $response->content =~  /<docid>(.*)<\/docid>/s) {
456
      $returnval = "$1";
457
  } elsif (($response)) {
458
    $returnval = -1;
459
    #print "Error response from sendData!\n";
460
    #print $response->content, "\n";
461
  } else {
462
    $returnval = -1;
463
    #print "Invalid response from sendData!\n";
464
  }
465

    
466
  return $returnval;
467
}
468

    
469
#############################################################
470
# subroutine to get the message returned from the last executed
471
# metacat action.  These are generally XML formatted messages.
472
#############################################################
473
sub getMessage {
474
  my $self = shift;
475

    
476
  return $self->{'message'};
477
}
478

    
479
#############################################################
480
# subroutine to get the cookies returned from the metacat 
481
# server to establish (and pass on) session info (JSESSIONID).
482
#############################################################
483
sub getCookies {
484
  my $self = shift;
485

    
486
  return $self->{'cookies'};
487
}
488

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

    
491
1;
492
__END__
493
# Below is stub documentation for your module. You better edit it!
494

    
495
=head1 NAME
496

    
497
Metacat - Perl extension for communicating with the Metacat XML database
498

    
499
=head1 SYNOPSIS
500

    
501
  use Metacat;
502
  my $metacat = Metacat->new();
503
  my $response = $metacat->login($username, $password); 
504
  print $metacat->getMessage();
505
  $response = $metacat->insert($docid, $xmldoc); 
506
  print $metacat->getMessage();
507
  $response = $metacat->insert($docid, $xmldoc, $dtd); 
508
  print $metacat->getMessage();
509
  $response = $metacat->update($docid, $xmldoc); 
510
  print $metacat->getMessage();
511
  $response = $metacat->upload($docid, $data); 
512
  print $metacat->getMessage();
513
  $htmlResponse = $metacat->read($docid); 
514
  $xmldoc = $htmlResponse->content();
515
  print $xmldoc;
516
  $resultset = $metacat->squery($pathquery); 
517
  print $resultset;
518
  $response = $metacat->delete($docid); 
519
  $response = $metacat->setaccess($docid,$principal,$permission,$permType,$permOrder); 
520
  my $lastid = $metacat->getLastId("obfs");
521
  print $metacat->getMessage();
522
  $response = $metacat->getCookies(); 
523
  print $metacat->getMessage();
524

    
525
=head1 DESCRIPTION
526

    
527
This is a client library for accessing the Metacat XML database.  Metacat
528
is a Java servlet that accepts commands over HTTP and returns XML and
529
HTML responses.  See http://knb.ecoinformatics.org for details about
530
Metacat and its interface.
531

    
532
=head2 EXPORT
533

    
534
None by default.
535

    
536

    
537
=head1 AUTHOR
538

    
539
Matthew B. Jones, jones@nceas.ucsb.edu
540

    
541
=head1 SEE ALSO
542

    
543
perl(1).
544

    
545
=cut