File Coverage

blib/lib/Net/OpenSRS/OMA.pm
Criterion Covered Total %
statement 61 77 79.2
branch 10 20 50.0
condition 5 18 27.7
subroutine 10 18 55.5
pod 4 4 100.0
total 90 137 65.6


line stmt bran cond sub pod time code
1             package Net::OpenSRS::OMA::Response; # internal package, defined below
2             1;
3             package Net::OpenSRS::OMA;
4              
5 1     1   18420 use strict;
  1         2  
  1         24  
6 1     1   3 use warnings;
  1         1  
  1         22  
7 1     1   532 use JSON;
  1         9763  
  1         4  
8 1     1   678 use LWP::UserAgent;
  1         36329  
  1         32  
9 1     1   8 use Carp;
  1         1  
  1         828  
10              
11             our $VERSION = "0.01_02";
12             $VERSION = eval $VERSION;
13              
14             =head1 NAME
15              
16             Net::OpenSRS::OMA - Client library for the OpenSRS Mail API
17              
18             =head1 SYNOPSIS
19              
20             use Data::Dumper;
21             use Net::OpenSRS::OMA;
22              
23             my $oma = new Net::OpenSRS::OMA(
24             uri => 'https://admin.a.hostedemail.com/api',
25             user => 'admin@domain.adm',
26             client => 'my client 0.1',
27             password => 'abc123',
28             );
29            
30              
31             my $response = $oma->get_user(
32             user => 'user@domain.com'
33             );
34              
35             if ($response->is_success)
36             {
37             print Dumper $response->content;
38             }
39             elsif ($response->error)
40             {
41             print "Request didn't work at OMA level: " . $response->error . "\n";
42             }
43             else
44             {
45             print "Request didn't work at HTTP level: " . $response->http_status;
46             }
47              
48             =head1 DEPENDENCIES
49              
50             This module requires these modules.
51              
52             =over
53              
54             =item LWP::UserAgent
55              
56             =item LWP::Protocol::https
57              
58             =item JSON
59              
60             =back
61              
62             =head1 CAVEAT
63              
64             This API is still under development and thus the
65             method calls, arguments and functions are subject to change.
66              
67             Consult the API documentation for up to date information.
68              
69             =head1 METHODS
70              
71             =cut
72              
73             =head2 new
74              
75             Create and return a new Net::OpenSRS::OMA object.
76              
77             Takes the following arguments (in a single hash argument)
78              
79             uri - base uri for the api: http://example.com/api/
80             user - username for authentication
81             password - password for authentication
82             token - token for authentication
83             client - client identification string
84              
85             uri, user and either password or token are required.
86              
87             =cut
88              
89             sub new($@)
90             {
91 1     1 1 15 my $proto = shift;
92 1   33     5 my $class = ref($proto) || $proto;
93 1         5 my %args = @_;
94 1         2 my $self = {};
95 1 0 33     7 unless ($args{uri} && $args{user} &&
      33        
      33        
96             ($args{password} || $args{token} ))
97             {
98 0         0 warn('Need uri, user and password or token');
99 0         0 return undef;
100             }
101 1         3 $self->{URI} = $args{uri};
102 1         1 my $client = $args{client};
103 1 50       3 $client = "Perl OMA Client\\$VERSION" unless $client;
104             $self->{CREDENTIALS} = {
105             user => $args{user},
106 1         3 client => $client
107             };
108            
109 1 50       2 if ($args{password}) {$self->{CREDENTIALS}->{password} = $args{password}}
  1         2  
110 0         0 else { $self->{CREDENTIALS}->{token} = $args{token}}
111              
112 1         8 $self->{UA} = LWP::UserAgent->new;
113 1         2903 $self->{UA}->agent($client);
114              
115 1         79 return bless($self, $class);
116             }
117              
118             =head2 uri
119              
120             Get the API address this object is using
121              
122             =head2 user
123              
124             Get the username this object is using
125              
126             =head2 client
127              
128             Get the client identifier string this object is using
129              
130             =cut
131              
132 0     0 1 0 sub uri($){return $_[0]->{URI}};
133 0     0 1 0 sub user($){return $_[0]->{CREDENTIALS}->{user}}
134 0     0 1 0 sub client($){return $_[0]->{CREDENTIALS}->{client}}
135              
136             =head2 API Methods
137              
138             API methods are called as object methods. All methods take a hash argument, that hash has
139             a credentials hashref added, is converted to JSON and sent to the API. Method calls return a
140             Net::OpenSRS::OMA::Response object containing the response from the server.
141              
142             Consult the API documentation for the arguments and response formats for each method.
143              
144             The callable methods are:
145              
146             =over
147              
148             =item add_role
149              
150             =item authenticate
151              
152             =item change_company
153              
154             =item change_company_bulletin
155              
156             =item change_domain
157              
158             =item change_domain_bulletin
159              
160             =item change_user
161              
162             =item change_brand
163              
164             =item create_workgroup
165              
166             =item delete_company
167              
168             =item delete_domain
169              
170             =item delete_user
171              
172             =item delete_workgroup
173              
174             =item echo
175              
176             =item generate_token
177              
178             =item get_company
179              
180             =item get_company_bulletin
181              
182             =item get_company_changes
183              
184             =item get_deleted_contacts
185              
186             =item get_deleted_messages
187              
188             =item get_domain
189              
190             =item get_domain_bulletin
191              
192             =item get_domain_changes
193              
194             =item get_user
195              
196             =item get_user_attribute_history
197              
198             =item get_user_changes
199              
200             =item get_user_folders
201              
202             =item get_user_messages
203              
204             =item get_valid_languages
205              
206             =item get_valid_timezones
207              
208             =item logout_user
209              
210             =item migration_add
211              
212             =item migration_jobs
213              
214             =item migration_status
215              
216             =item migration_threads
217              
218             =item migration_trace
219              
220             =item move_user_messages
221              
222             =item post_domain_bulletin
223              
224             =item post_company_bulletin
225              
226             =item remove_role
227              
228             =item rename_user
229              
230             =item restore_deleted_contacts
231              
232             =item restore_deleted_messages
233              
234             =item restore_domain
235              
236             =item restore_user
237              
238             =item search_brand_members
239              
240             =item search_brands
241              
242             =item search_companies
243              
244             =item search_domains
245              
246             =item search_users
247              
248             =item search_workgroups
249              
250             =item set_role
251              
252             =item stats_summary
253              
254             =item stats_list
255              
256             =item stats_snapshot
257              
258             =back
259              
260             =cut
261              
262             my @_methods = qw(
263             add_role
264             authenticate
265             change_company
266             change_company_bulletin
267             change_domain
268             change_domain_bulletin
269             change_user
270             change_brand
271             create_workgroup
272             delete_company
273             delete_domain
274             delete_user
275             delete_workgroup
276             echo
277             generate_token
278             get_company
279             get_company_bulletin
280             get_company_changes
281             get_deleted_contacts
282             get_deleted_messages
283             get_domain
284             get_domain_bulletin
285             get_domain_changes
286             get_user
287             get_user_attribute_history
288             get_user_changes
289             get_user_folders
290             get_user_messages
291             get_valid_languages
292             get_valid_timezones
293             logout_user
294             migration_add
295             migration_jobs
296             migration_status
297             migration_threads
298             migration_trace
299             move_user_messages
300             post_domain_bulletin
301             post_company_bulletin
302             remove_role
303             rename_user
304             restore_deleted_contacts
305             restore_deleted_messages
306             restore_domain
307             restore_user
308             search_brand_members
309             search_brands
310             search_companies
311             search_domains
312             search_users
313             search_workgroups
314             set_role
315             stats_summary
316             stats_list
317             stats_snapshot
318             );
319              
320             my @_deprecated_methods = qw(
321             _audit
322             _change_brand
323             _delete_brand
324             _get_brand
325             _get_brand_changes
326             _get_brand_trace
327             _get_company_trace
328             _get_domain_trace
329             _get_user_trace
330             _id_to_name
331             _list_brand_traces
332             _list_company_traces
333             _list_domain_traces
334             _list_user_traces
335             _name_to_id
336             );
337              
338             our $AUTOLOAD;
339             sub AUTOLOAD {
340 2 100   2   878 return if our $AUTOLOAD =~ /::DESTROY$/;
341 1         2 my $self = shift;
342 1         2 my $sub = $AUTOLOAD;
343 1         8 (my $method = $sub) =~ s/.*:://;
344 1 50       4 unless (grep {$_ eq $method} (@_methods, @_deprecated_methods))
  70         87  
345             {
346 0         0 croak("Undefined method $AUTOLOAD");
347             }
348 1         5 my %body = @_;
349 1         5 return $self->_do_method($method, \%body);
350             }
351              
352              
353             #
354             # don't call this
355             #
356             sub _do_method($$$)
357             {
358 1     1   2 my ($self, $method, $body) = @_;
359 1         8 my $muri = $self->{URI} . '/' . $method;
360              
361             # create request body (add credentials)
362 1         5 my %body_copy = %$body;
363 1         3 $body_copy{'credentials'} = $self->{'CREDENTIALS'};
364 1         6 my $body_text = to_json(\%body_copy);
365              
366             # create request
367 1         68 my $request = HTTP::Request->new(POST => $muri);
368 1         8710 $request->content_type('application/json');
369 1         45 $request->content($body_text);
370              
371             #send request
372 1         24 my $response = $self->{UA}->request($request);
373              
374             # deal with response
375 1 50       655848 if ($response->is_success)
376             {
377 1         10 my $j;
378 1         2 eval {$j = from_json($response->content)};
  1         7  
379 1 50       48 if ($@)
380             {
381 0         0 warn "Invalid JSON from API: -(" . $response->content . ")-";
382 0         0 $j = '';
383             }
384 1         4 return new Net::OpenSRS::OMA::Response(
385             status => $response->status_line,
386             raw_content => $response->content,
387             content => $j,
388             );
389             }
390             else
391             {
392 0         0 return new Net::OpenSRS::OMA::Response(
393             status => $response->status_line,
394             );
395             }
396             }
397              
398              
399             1;
400              
401             package Net::OpenSRS::OMA::Response;
402              
403              
404             =head1 RESPONSE OBJECT METHODS
405              
406             =cut
407              
408             sub new($@)
409             {
410 1     1   21 my $proto = shift;
411 1   33     6 my $class = ref($proto) || $proto;
412 1         4 my %args = @_;
413 1         2 my $self = {};
414 1 50       4 $self->{CONTENT} = $args{content} if $args{content};
415 1 50       3 $self->{RAW_CONTENT} = $args{raw_content} if $args{raw_content};
416 1 50       3 $self->{HTTP_STATUS} = $args{status} if $args{status};
417 1         29 return bless($self, $class);
418             }
419              
420             =head2 is_success
421              
422             Returns true if the HTTP status of the request was 200, the response had valid
423             JSON content, and the 'success' field of the response is true.
424              
425             =cut
426             sub is_success($)
427             {
428 0     0   0 my $self = shift;
429             return
430             $self->{HTTP_STATUS} =~ /^200/ &&
431             $self->{CONTENT} &&
432 0   0     0 $self->{CONTENT}->{success} ;
433             }
434              
435             =head2 content
436              
437             Returns a hashref, the decoded JSON content of the response, or undef if
438             there is no content.
439              
440             =cut
441              
442 0     0   0 sub content($) {return $_[0]->{CONTENT}};
443              
444             =head2 raw_content
445              
446             Returns a scalar, string, the raw response fromt he server, or undef if
447             there is no content
448              
449             =cut
450              
451 0     0   0 sub raw_content($) {return $_[0]->{RAW_CONTENT}};
452              
453             =head2 http_status
454              
455             Returns a scalar, the HTTP status of the request, from the LWP module.
456              
457             =cut
458              
459 1     1   323 sub http_status($) {return $_[0]->{HTTP_STATUS}};
460              
461             =head2 error_number
462              
463             Returns a scalar, the error number from the JSON content of the response,
464             or undef if no error number.
465              
466             =cut
467              
468 0     0     sub error_number($) {return $_[0]->{CONTENT}->{error_number}};
469              
470             =head2 error
471              
472             Returns a scalar, the error string from the JSON content of the response,
473             or undef if no error string.
474              
475             =cut
476              
477 0     0     sub error($) {return $_[0]->{CONTENT}->{error}};
478              
479             1;
480              
481             =head1 AUTHOR
482              
483             Richard Platel
484              
485             =head1 COPYRIGHT AND LICENSE
486              
487             Copyright 2012 Richard Platel
488              
489             This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.
490            
491             =cut