Project

General

Profile

1
 #
2
 #  '$RCSfile$'
3
 #  Copyright: 2000 Regents of the University of California 
4
 #
5
 #   '$Author: sgarg $'
6
 #     '$Date: 2005-12-15 09:59:42 -0800 (Thu, 15 Dec 2005) $'
7
 # '$Revision: 2846 $' 
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 not valid, return 0. If valid then send 
128
# following values to indicate user status
129
# 1 - user
130
# 2 - moderator
131
# 3 - administrator
132
# 4 - moderator and administrator
133
#############################################################
134
sub login {
135
  my $self = shift;
136
  my $username = shift;
137
  my $password = shift;
138

    
139
  my $returnval = 0;
140

    
141
  my %postData = ( action => 'login',
142
                   qformat => 'xml',
143
                   username => $username,
144
                   password => $password
145
                 );
146
  my $response = $self->sendData(%postData);
147
  if (($response) && $response->content =~ /<login>/) {
148
    $returnval = 1;
149
  }
150

    
151
  if (($response) && $response->content =~ /<isAdministrator>/) {
152
	if (($response) && $response->content =~ /<isModerator>/) {
153
    		$returnval = 4;
154
	} else {
155
		$returnval = 3;
156
	}
157
  } elsif (($response) && $response->content =~ /<isModerator>/){
158
	$returnval = 2;
159
  }
160

    
161
  return $returnval;
162
}
163

    
164
#############################################################
165
# subroutine to insert an XML document into Metacat
166
# If success, return 1, else return 0
167
#############################################################
168
sub insert {
169
  my $self = shift;
170
  my $docid = shift;
171
  my $xmldocument = shift;
172
  my $dtd = shift;
173

    
174
  my $returnval = 0;
175

    
176
  my %postData = ( action => 'insert',
177
                   docid => $docid,
178
                   doctext => $xmldocument
179
                 );
180
  if ($dtd) {
181
    $postData{'dtdtext'} = $dtd;
182
  }
183

    
184
  my $response = $self->sendData(%postData);
185
  if (($response) && $response->content =~ /<success>/) {
186
    $returnval = 1;
187
  } elsif (($response)) {
188
    $returnval = 0;
189
    #print "Error response from sendData!\n";
190
    #print $response->content, "\n";
191
  } else {
192
    $returnval = 0;
193
    #print "Invalid response from sendData!\n";
194
  }
195

    
196
  return $returnval;
197
}
198

    
199
#############################################################
200
# subroutine to update an XML document in Metacat
201
# If success, return 1, else return 0
202
#############################################################
203
sub update {
204
  my $self = shift;
205
  my $docid = shift;
206
  my $xmldocument = shift;
207
  my $dtd = shift;
208

    
209
  my $returnval = 0;
210

    
211
  my %postData = ( action => 'update',
212
                   docid => $docid,
213
                   doctext => $xmldocument
214
                 );
215
  if ($dtd) {
216
    $postData{'dtdtext'} = $dtd;
217
  }
218

    
219
  my $response = $self->sendData(%postData);
220
  if (($response) && $response->content =~ /<success>/) {
221
    $returnval = 1;
222
  }
223

    
224
  return $returnval;
225
}
226

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

    
235
  my $returnval = 0;
236

    
237
  my %postData = ( action => 'delete',
238
                   docid => $docid
239
                 );
240

    
241
  my $response = $self->sendData(%postData);
242
  if (($response) && $response->content =~ /<success>/) {
243
    $returnval = 1;
244
  }
245

    
246
  return $returnval;
247
}
248

    
249
#############################################################
250
# subroutine to set access for an XML document in Metacat
251
# If success, return 1, else return 0
252
#############################################################
253
sub setaccess {
254
  my $self = shift;
255
  my $docid = shift;
256
  my $principal = shift;
257
  my $permission = shift;
258
  my $permType = shift;
259
  my $permOrder = shift;
260

    
261
  my $returnval = 0;
262

    
263
  my %postData = ( action => 'setaccess',
264
                   docid => $docid,
265
		   principal => $principal,
266
		   permission => $permission,
267
		   permType => $permType,
268
		   permOrder => $permOrder
269
                 );
270

    
271
  my $response = $self->sendData(%postData);
272
  if (($response) && $response->content =~ /<success>/) {
273
    $returnval = 1;
274
  }
275

    
276
  return $returnval;
277
}
278

    
279

    
280
#############################################################
281
# subroutine to read an XML document from Metacat
282
# returns the XML from Metacat, which may be an error response
283
#############################################################
284
sub read {
285
  my $self = shift;
286
  my $docid = shift;
287

    
288
  my %postData = ( action => 'read',
289
                   qformat => 'xml',
290
                   docid => $docid
291
                 );
292

    
293
  my $response = $self->sendData(%postData);
294
  
295
  my $returnval = 0;
296
  if ($response) {
297
    $returnval = $response;
298
  } 
299
    
300
  return $returnval;
301
}
302

    
303
#############################################################
304
# subroutine to query metacat using a structured path query
305
# returns the XML from Metacat, which may be an error response
306
#############################################################
307
sub squery {
308
  my $self = shift;
309
  my $query = shift;
310

    
311
  my %postData = ( action => 'squery',
312
                   qformat => 'xml',
313
                   query => $query
314
                 );
315

    
316
  my $response = $self->sendData(%postData);
317

    
318
  my $returnval = 0;
319
  if ($response) {
320
    $returnval = $response;
321
  } 
322
    
323
  return $returnval;
324
}
325

    
326
#############################################################
327
# subroutine to get the maximimum id in a series
328
# If success, return max id, else return 0
329
#############################################################
330
sub getLastId {
331
  my $self = shift;
332
  my $scope = shift;
333

    
334
  my $returnval = 0;
335

    
336
  my %postData = ( action => 'getlastdocid',
337
                   scope => $scope
338
                 );
339

    
340
  my $response = $self->sendData(%postData);
341
  if (($response) && $response->content =~ /<docid>(.*)<\/docid>/s) {
342
      $returnval = "$1";
343
  } elsif (($response)) {
344
    $returnval = 0;
345
    #print "Error response from sendData!\n";
346
    #print $response->content, "\n";
347
  } else {
348
    $returnval = 0;
349
    #print "Invalid response from sendData!\n";
350
  }
351

    
352
  return $returnval;
353
}
354
#############################################################
355
# subroutine to get the message returned from the last executed
356
# metacat action.  These are generally XML formatted messages.
357
#############################################################
358
sub getMessage {
359
  my $self = shift;
360

    
361
  return $self->{'message'};
362
}
363

    
364
#############################################################
365
# subroutine to get the cookies returned from the metacat 
366
# server to establish (and pass on) session info (JSESSIONID).
367
#############################################################
368
sub getCookies {
369
  my $self = shift;
370

    
371
  return $self->{'cookies'};
372
}
373

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

    
376
1;
377
__END__
378
# Below is stub documentation for your module. You better edit it!
379

    
380
=head1 NAME
381

    
382
Metacat - Perl extension for communicating with the Metacat XML database
383

    
384
=head1 SYNOPSIS
385

    
386
  use Metacat;
387
  my $metacat = Metacat->new();
388
  my $response = $metacat->login($username, $password); 
389
  print $metacat->getMessage();
390
  $response = $metacat->insert($docid, $xmldoc); 
391
  print $metacat->getMessage();
392
  $response = $metacat->insert($docid, $xmldoc, $dtd); 
393
  print $metacat->getMessage();
394
  $response = $metacat->update($docid, $xmldoc); 
395
  print $metacat->getMessage();
396
  $htmlResponse = $metacat->read($docid); 
397
  $xmldoc = $htmlResponse->content();
398
  print $xmldoc;
399
  $resultset = $metacat->squery($pathquery); 
400
  print $resultset;
401
  $response = $metacat->delete($docid); 
402
  $response = $metacat->setaccess($docid,$principal,$permission,$permType,$permOrder); 
403
  my $lastid = $metacat->getLastId("obfs");
404
  print $metacat->getMessage();
405
  $response = $metacat->getCookies(); 
406
  print $metacat->getMessage();
407

    
408
=head1 DESCRIPTION
409

    
410
This is a client library for accessing the Metacat XML database.  Metacat
411
is a Java servlet that accepts commands over HTTP and returns XML and
412
HTML responses.  See http://knb.ecoinformatics.org for details about
413
Metacat and its interface.
414

    
415
=head2 EXPORT
416

    
417
None by default.
418

    
419

    
420
=head1 AUTHOR
421

    
422
Matthew B. Jones, jones@nceas.ucsb.edu
423

    
424
=head1 SEE ALSO
425

    
426
perl(1).
427

    
428
=cut
(5-5/7)