Project

General

Profile

1
 #
2
 #  '$RCSfile$'
3
 #  Copyright: 2000 Regents of the University of California 
4
 #
5
 #   '$Author: walbridge $'
6
 #     '$Date: 2007-09-11 15:48:00 -0700 (Tue, 11 Sep 2007) $'
7
 # '$Revision: 3421 $' 
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 "request: " . $request->as_string();
121

    
122
  my $response = $userAgent->request($request);
123
  #print "response: " . $response->as_string();
124
   
125
  if ($response->is_success) {
126
    # save the cookies
127
    $$cookie_jar->extract_cookies($response);
128
    # save the metacat response message
129
    $self->{'message'} = $response->content;
130
  } else {
131
    #print "SendData content is: ", $response->content, "\n";
132
    return 0;
133
  } 
134
  return $response;
135
}
136

    
137
#############################################################
138
# subroutine to log into Metacat and save the cookie if the
139
# login is valid.  If not valid, return 0. If valid then send 
140
# following values to indicate user status
141
# 1 - user
142
# 2 - moderator
143
# 3 - administrator
144
# 4 - moderator and administrator
145
#############################################################
146
sub login {
147
  my $self = shift;
148
  my $username = shift;
149
  my $password = shift;
150

    
151
  my $returnval = 0;
152

    
153
  my %postData = ( action => 'login',
154
                   qformat => 'xml',
155
                   username => $username,
156
                   password => $password
157
                 );
158
  my $response = $self->sendData(%postData);
159
  if (($response) && $response->content =~ /<login>/) {
160
    $returnval = 1;
161
  }
162

    
163
  if (($response) && $response->content =~ /<isAdministrator>/) {
164
	if (($response) && $response->content =~ /<isModerator>/) {
165
    		$returnval = 4;
166
	} else {
167
		$returnval = 3;
168
	}
169
  } elsif (($response) && $response->content =~ /<isModerator>/){
170
	$returnval = 2;
171
  }
172

    
173
  return $returnval;
174
}
175

    
176
#############################################################
177
# subroutine to insert an XML document into Metacat
178
# If success, return 1, else return 0
179
#############################################################
180
sub insert {
181
  my $self = shift;
182
  my $docid = shift;
183
  my $xmldocument = shift;
184
  my $dtd = shift;
185

    
186
  my $returnval = 0;
187

    
188
  my %postData = ( action => 'insert',
189
                   docid => $docid,
190
                   doctext => $xmldocument
191
                 );
192
  if ($dtd) {
193
    $postData{'dtdtext'} = $dtd;
194
  }
195

    
196
  my $response = $self->sendData(%postData);
197
  if (($response) && $response->content =~ /<success>/) {
198
    $returnval = 1;
199
  } elsif (($response)) {
200
    $returnval = 0;
201
    #print "Error response from sendData!\n";
202
    #print $response->content, "\n";
203
  } else {
204
    $returnval = 0;
205
    #print "Invalid response from sendData!\n";
206
  }
207

    
208
  return $returnval;
209
}
210

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

    
221
  my $returnval = 0;
222

    
223
  my %postData = ( action => 'update',
224
                   docid => $docid,
225
                   doctext => $xmldocument
226
                 );
227
  if ($dtd) {
228
    $postData{'dtdtext'} = $dtd;
229
  }
230

    
231
  my $response = $self->sendData(%postData);
232
  if (($response) && $response->content =~ /<success>/) {
233
    $returnval = 1;
234
  }
235

    
236
  return $returnval;
237
}
238

    
239
############################################################
240
# subroutine to upload an XML document in Metacat
241
# If success, return 1, else return 0
242
#############################################################
243
sub upload {
244
  my $self = shift;
245
  my $docid = shift;
246
  my $datafile = shift;
247

    
248
  my $returnval = 0;
249

    
250
  my %postData = ( action => 'upload',
251
                   docid => $docid,
252
                   datafile => [$datafile],
253
                   enctype => 'form-data'
254
                 );
255

    
256
  my $response = $self->sendData(%postData);
257
  #print "response is: $response";
258
  # 
259
  if (($response) && $response->content =~ /<success>/) {
260
    $returnval = $response->content;
261
  }
262

    
263
  return $returnval;
264
}
265

    
266

    
267
#############################################################
268
# subroutine to delete an XML document in Metacat
269
# If success, return 1, else return 0
270
#############################################################
271
sub delete {
272
  my $self = shift;
273
  my $docid = shift;
274

    
275
  my $returnval = 0;
276

    
277
  my %postData = ( action => 'delete',
278
                   docid => $docid
279
                 );
280

    
281
  my $response = $self->sendData(%postData);
282
  if (($response) && $response->content =~ /<success>/) {
283
    $returnval = 1;
284
  }
285

    
286
  return $returnval;
287
}
288

    
289
#############################################################
290
# subroutine to set access for an XML document in Metacat
291
# If success, return 1, else return 0
292
#############################################################
293
sub setaccess {
294
  my $self = shift;
295
  my $docid = shift;
296
  my $principal = shift;
297
  my $permission = shift;
298
  my $permType = shift;
299
  my $permOrder = shift;
300

    
301
  my $returnval = 0;
302

    
303
  my %postData = ( action => 'setaccess',
304
                   docid => $docid,
305
		   principal => $principal,
306
		   permission => $permission,
307
		   permType => $permType,
308
		   permOrder => $permOrder
309
                 );
310

    
311
  my $response = $self->sendData(%postData);
312
  if (($response) && $response->content =~ /<success>/) {
313
    $returnval = 1;
314
  }
315

    
316
  return $returnval;
317
}
318

    
319

    
320
#############################################################
321
# subroutine to read an XML document from Metacat
322
# returns the XML from Metacat, which may be an error response
323
#############################################################
324
sub read {
325
  my $self = shift;
326
  my $docid = shift;
327

    
328
  my %postData = ( action => 'read',
329
                   qformat => 'xml',
330
                   docid => $docid
331
                 );
332

    
333
  my $response = $self->sendData(%postData);
334
  
335
  my $returnval = 0;
336
  if ($response) {
337
    $returnval = $response;
338
  } 
339
    
340
  return $returnval;
341
}
342

    
343
#############################################################
344
# subroutine to query metacat using a structured path query
345
# returns the XML from Metacat, which may be an error response
346
#############################################################
347
sub squery {
348
  my $self = shift;
349
  my $query = shift;
350

    
351
  my %postData = ( action => 'squery',
352
                   qformat => 'xml',
353
                   query => $query
354
                 );
355

    
356
  my $response = $self->sendData(%postData);
357

    
358
  my $returnval = 0;
359
  if ($response) {
360
    $returnval = $response;
361
  } 
362
    
363
  return $returnval;
364
}
365

    
366
#############################################################
367
# subroutine to get the maximimum id in a series
368
# If success, return max id, else return 0
369
#############################################################
370
sub getLastId {
371
  my $self = shift;
372
  my $scope = shift;
373

    
374
  my $returnval = 0;
375

    
376
  my %postData = ( action => 'getlastdocid',
377
                   scope => $scope
378
                 );
379

    
380
  my $response = $self->sendData(%postData);
381
  if (($response) && $response->content =~ /<docid>(.*)<\/docid>/s) {
382
      $returnval = "$1";
383
  } elsif (($response)) {
384
    $returnval = 0;
385
    #print "Error response from sendData!\n";
386
    #print $response->content, "\n";
387
  } else {
388
    $returnval = 0;
389
    #print "Invalid response from sendData!\n";
390
  }
391

    
392
  return $returnval;
393
}
394
#############################################################
395
# subroutine to get the message returned from the last executed
396
# metacat action.  These are generally XML formatted messages.
397
#############################################################
398
sub getMessage {
399
  my $self = shift;
400

    
401
  return $self->{'message'};
402
}
403

    
404
#############################################################
405
# subroutine to get the cookies returned from the metacat 
406
# server to establish (and pass on) session info (JSESSIONID).
407
#############################################################
408
sub getCookies {
409
  my $self = shift;
410

    
411
  return $self->{'cookies'};
412
}
413

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

    
416
1;
417
__END__
418
# Below is stub documentation for your module. You better edit it!
419

    
420
=head1 NAME
421

    
422
Metacat - Perl extension for communicating with the Metacat XML database
423

    
424
=head1 SYNOPSIS
425

    
426
  use Metacat;
427
  my $metacat = Metacat->new();
428
  my $response = $metacat->login($username, $password); 
429
  print $metacat->getMessage();
430
  $response = $metacat->insert($docid, $xmldoc); 
431
  print $metacat->getMessage();
432
  $response = $metacat->insert($docid, $xmldoc, $dtd); 
433
  print $metacat->getMessage();
434
  $response = $metacat->update($docid, $xmldoc); 
435
  print $metacat->getMessage();
436
  $htmlResponse = $metacat->read($docid); 
437
  $xmldoc = $htmlResponse->content();
438
  print $xmldoc;
439
  $resultset = $metacat->squery($pathquery); 
440
  print $resultset;
441
  $response = $metacat->delete($docid); 
442
  $response = $metacat->setaccess($docid,$principal,$permission,$permType,$permOrder); 
443
  my $lastid = $metacat->getLastId("obfs");
444
  print $metacat->getMessage();
445
  $response = $metacat->getCookies(); 
446
  print $metacat->getMessage();
447

    
448
=head1 DESCRIPTION
449

    
450
This is a client library for accessing the Metacat XML database.  Metacat
451
is a Java servlet that accepts commands over HTTP and returns XML and
452
HTML responses.  See http://knb.ecoinformatics.org for details about
453
Metacat and its interface.
454

    
455
=head2 EXPORT
456

    
457
None by default.
458

    
459

    
460
=head1 AUTHOR
461

    
462
Matthew B. Jones, jones@nceas.ucsb.edu
463

    
464
=head1 SEE ALSO
465

    
466
perl(1).
467

    
468
=cut
(5-5/7)