fixed fix again ;)
[opensuse:sxkeeper.git] / perl / SXKeeper / Access.pm
1 # -----------------------------------------------------------
2 # SUSE Inttools Codebase
3 # (c)2005 SUSE LINUX Products GmbH, Nuernberg
4 # -----------------------------------------------------------
5 # Contributor(s):
6 # Christopher Hofmann <cwh@suse.de>
7 # Andreas Bauer <abauer@suse.de>
8 # Klaas Freitag <freitag@suse.de>
9 # -----------------------------------------------------------
10 package SXKeeper::Access;
11
12 use strict;
13 use URI;
14 use Carp;
15 use LWP::UserAgent;
16 use Encode qw( encode _utf8_off );
17 use Params::Validate qw( :all );
18 use Regexp::Common qw( URI );
19
20 use vars qw( $VERSION );
21
22 $VERSION = 0.94;
23
24 #----------------------------------------------------
25 # new()
26 #----------------------------------------------------
27 # constructor
28 #
29 # named parameters:
30 #       url:    location of keeper
31 #       logger: Log::Dispatch object to log output to
32 #       debug:  log also debug messages
33 #       agent:  Set user-agent string sent to server; default: "KeeperAccess/$VERSION"
34
35 sub new
36 {
37     my $class = shift;
38     my $self = {};
39     bless( $self, $class );
40     
41     my %params = validate( @_,
42                            { url => { type      => SCALAR,
43                                       optional => 0 },
44                              logger => { type => OBJECT,
45                                          optional => 1 },
46                              debug => { optional => 1 },
47                              agent => { default => "KeeperAccess/$VERSION" },
48                              charset => { default => 'UTF-8' },
49                              username => { optional => 1 },
50                              password => { optional => 1 },
51                              return_response_object => { type => SCALAR,
52                                                          default => 0 } } );
53     
54     $self->{ua} = LWP::UserAgent->new( agent => $params{'agent'},
55                                        timeout => 60,
56                                        env_proxy => 0 );
57
58     $self->{charset} = $params{'charset'};
59
60     $self->{ua_default_header} = { 'Accept' => 'text/*; charset='.$self->{charset} };
61
62     unless( $params{url} =~ /$RE{URI}{HTTP}/ )
63     {
64         croak( "Invalid URL: '$params{url}'" );
65     }
66
67     if( exists $params{logger} && $params{logger}->isa("Log::Dispatch") )
68     {
69         $self->{logger} = $params{logger};
70     }
71
72     foreach( 'url', 'debug', 'username', 'password', 'return_response_object' )
73     {
74         $self->{$_} = $params{$_};
75     }
76
77     $self->{url} .= '/' unless( $params{url} =~ /\/$/ );
78
79     $self->log("debug", "created object") if( $self->{debug} );
80     
81     return $self;
82 }
83
84 #----------------------------------------------------
85 # getStaticContent($path)
86 #----------------------------------------------------
87
88 sub getStaticContent
89 {
90     my ( $self, $path ) = validate_pos( @_,
91                                         { isa => __PACKAGE__ },              # $self
92                                         { type => SCALAR, optional => 0 } ); # path
93
94     my $uri = URI->new( $self->{url}.$path );
95
96     return $self->askKeeper( $uri );
97 }
98
99 #----------------------------------------------------
100 # getSingleDocument( $container, $xquery )
101 #----------------------------------------------------
102 # Parameters:
103 #    $container - name of the container, e.g. 'feature'
104 #    $id - optional - id of the wanted document or empty string for all documents
105 #
106 # Return Value:
107 #    string containing XML; root element depends on result's content (root element = name of container)
108 #
109 #
110
111 sub getSingleDocument
112 {
113     my ( $self, $container, $id, $rev ) = validate_pos( @_,
114                                                         { isa => __PACKAGE__ },              # $self
115                                                         { type => SCALAR, optional => 0 },   # Container
116                                                         { type => SCALAR, optional => 0 },   # ID
117                                                         { type => SCALAR, optional => 1 } ); # Revision
118     
119     my $url = $self->{url}."$container/$id";
120     $url .= "/$rev" if( defined $rev );
121
122     my $uri = URI->new( $url );
123
124     return $self->askKeeper( $uri );
125 }
126
127 #----------------------------------------------------
128 # getDocuments( $container [, $query ] )
129 #----------------------------------------------------
130 # Parameters:
131 #    $container - name of the container, e.g. 'feature'
132 #    $xquery - optional
133 #
134 # Return Value:
135 #    string containing XML; root element: <k:collection>...</k:collection>
136 #
137 #
138
139 sub getDocuments
140 {
141     my ( $self, $container, $query ) = validate_pos( @_,
142                                                      { isa => __PACKAGE__ },              # $self
143                                                      { type => SCALAR, optional => 0 },   # Container
144                                                      { type => SCALAR, optional => 1 } ); # XQuery-string
145
146     my $uri = URI->new( $self->{url}."$container/" );
147
148     if( $query )
149     {
150         $uri->query_form( 'query' => $query );
151     }
152
153     return $self->askKeeper( $uri );
154 }
155
156 #----------------------------------------------------
157 # updateDocument( %params )
158 #----------------------------------------------------
159
160 sub updateDocument
161 {
162     my $self = shift;
163
164     croak('Has to be called as a method.') if( ref( $self ) ne __PACKAGE__ );
165
166     my %params = validate( @_,
167                            { container => { type => SCALAR, optional => 0 },
168                              id => { type => SCALAR, optional => 0 },
169                              data => { type => SCALAR, optional => 0 },
170                              params => { type => HASHREF, optional => 1 },
171                              username => { type => SCALAR, optional => 1 },
172                              password => { type => SCALAR, optional => 1 } }  );
173
174     my ( $container, $id, $data, $query_params, $username, $password ) =
175         @params{ 'container', 'id', 'data', 'params', 'username', 'password' };
176
177     unless( $username && $password )
178     {
179         $username = $self->{username};
180         $password = $self->{password};
181     }
182    
183     #print STDERR "u:$username, p:$password\n";
184
185     my $uri = URI->new( $self->{url}."$container/$id" );
186
187     if( $query_params )
188     {
189         $uri->query_form( $query_params );
190     }
191
192     $self->log( 'debug', "PUT '$uri'" ) if( $self->{debug} );
193
194     my $request = HTTP::Request->new( "PUT", $uri );
195
196     my $header = $request->headers;
197     $header->authorization_basic( $username, $password );
198     $header->header( %{$self->{ua_default_header}} );
199     $header->header( 'Content_Type' => 'text/xml; charset='.$self->{charset} );
200
201     #print STDERR $header->as_string."\n";
202
203     # fill the data in the request to be sent to the keeper:
204
205     # There are problems with "wide characters in syswrite. To fix that I see 2
206     # possible solutions. However I'm not sure which one makes the correct encoding.
207
208     # 1:
209     # _utf8_off($data);
210     # $request->content( $data );
211     # --
212
213     # 2:
214     encode( $self->{charset}, $data);
215     # --
216
217     my $response = $self->{ua}->request( $request );
218
219     if( $self->{return_response_object} )
220     {
221         return $response;
222     }
223     else
224     {
225         if( $response->is_success )
226         {
227             $self->log( 'debug', $response->status_line ) if( $self->{debug} );
228             return $response->content();
229         }
230         else
231         {
232             if( $response->content_type() eq 'text/xml' )
233             {
234                 $self->log( 'debug', $response->status_line ) if( $self->{debug} );
235                 return $response->decoded_content();
236             }
237             else
238             {
239                 $self->log( 'error', $response->status_line );
240                 croak( $response->status_line );
241             }
242         }
243     }
244 }
245
246 #----------------------------------------------------
247 # newDocument( %params )
248 #----------------------------------------------------
249
250 sub newDocument
251 {
252     my $self = shift;
253
254     croak('Has to be called as a method.') if( ref( $self ) ne __PACKAGE__ );
255
256     my %params = validate( @_,
257                            { container => { type => SCALAR, optional => 0 },
258                              data => { type => SCALAR, optional => 0 },
259                              params => { type => HASHREF, optional => 1 },
260                              username => { type => SCALAR, optional => 1 },
261                              password => { type => SCALAR, optional => 1 } }  );
262
263     my ( $container, $id, $data, $query_params, $username, $password ) =
264         @params{ 'container', 'id', 'data', 'params', 'username', 'password' };
265
266     unless( $username && $password )
267     {
268         $username = $self->{username};
269         $password = $self->{password};
270     }
271
272     my $uri = URI->new( $self->{url}."$container/" );
273
274     if( $query_params )
275     {
276         $uri->query_form( $query_params );
277     }
278
279     $self->log( 'debug', "POST '$uri'" ) if( $self->{debug} );
280
281     my $request = HTTP::Request->new( "POST", $uri );
282
283     my $header = $request->headers;
284     $header->authorization_basic( $username, $password );
285     $header->header( %{$self->{ua_default_header}} );
286     $header->header( 'Content_Type' => 'text/xml; charset='.$self->{charset} );
287
288     # fill the data in the request to be sent to the keeper:
289     $request->content( encode( $self->{charset}, $data) );
290
291     my $response = $self->{ua}->request( $request );
292
293     if( $self->{return_response_object} )
294     {
295         return $response;
296     }
297     else
298     {
299         if( $response->is_success )
300         {
301             $self->log( 'debug', $response->status_line ) if( $self->{debug} );
302             return $response->content();
303         }
304         else
305         {
306             if( $response->content_type() eq 'text/xml' )
307             {
308                 $self->log( 'debug', $response->status_line ) if( $self->{debug} );
309                 return $response->decoded_content();
310             }
311             else
312             {
313                 $self->log( 'error', $response->status_line );
314                 croak( $response->status_line );
315             }
316         }
317     }
318 }
319
320 #----------------------------------------------------
321 # askKeeper( $url )
322 #----------------------------------------------------
323 # Internal method
324 #
325 # Parameters:
326 #    $url - url to send to the keeper
327 #
328 # Return Value:
329 #
330 #
331 #
332
333 sub askKeeper
334 {
335     my ( $self, $uri ) = validate_pos( @_, { isa => __PACKAGE__ }, 1 );
336
337     $self->log( 'debug', "GET '$uri'" ) if( $self->{debug} );
338
339     my $request = HTTP::Request->new( "GET", $uri );
340     $request->headers->header( %{$self->{ua_default_header}} );
341     $request->headers->authorization_basic( $self->{username},
342                                             $self->{password} ) if( $self->{username} && $self->{password} );
343
344     my $response = $self->{ua}->request( $request );
345     
346     if( $self->{return_response_object} )
347     {
348         return $response;
349     }
350     else
351     {
352         if( $response->is_success )
353         {
354             $self->log( 'debug', "Content-type: ".$response->content_type() ) if( $self->{debug} );
355             return $response->decoded_content();
356         }
357         else
358         {
359             $self->log( 'debug', "Getting $uri failed." ) if( $self->{debug} );
360
361             #print STDERR $response->decoded_content();
362
363             if( $response->content_type() eq 'text/xml' )
364             {
365                 return $response->decoded_content();
366             }
367             else
368             {
369                 croak( $response->status_line );
370             }
371         }
372     }
373 }
374
375 #############################
376 # helper functions
377 #############################
378
379 sub log
380 {
381     my ( $self, $level, $msg ) = validate_pos( @_,
382                                                { isa => __PACKAGE__ },
383                                                { type => SCALAR,
384                                                  optional => 0 },
385                                                { type => SCALAR,
386                                                  optional => 0 } );
387     
388     if( exists $self->{logger} )
389     {
390         $self->{logger}->log( $level, $msg );
391     }
392     else
393     {
394         print STDERR "[$level] KeeperAccess: $msg\n";
395     }
396 }