File Coverage

blib/lib/DiaColloDB/Client.pm
Criterion Covered Total %
statement 20 101 19.8
branch 0 60 0.0
condition 0 26 0.0
subroutine 8 30 26.6
pod 20 21 95.2
total 48 238 20.1


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ## File: DiaColloDB::Client.pm
3             ## Author: Bryan Jurish <moocow@cpan.org>
4             ## Description: collocation db, client
5              
6             package DiaColloDB::Client;
7 2     2   892 use DiaColloDB::Persistent;
  2         8  
  2         72  
8 2     2   1350 use DiaColloDB::Client::file;
  2         6  
  2         72  
9 2     2   1052 use DiaColloDB::Client::http;
  2         8  
  2         82  
10 2     2   1110 use DiaColloDB::Client::list;
  1         5  
  1         95  
11 1     1   14 use URI;
  1         2  
  1         28  
12 1     1   7 use strict;
  1         2  
  1         1548  
13              
14              
15             ##==============================================================================
16             ## Globals & Constants
17              
18             our @ISA = qw(DiaColloDB::Persistent);
19              
20             ##==============================================================================
21             ## Constructors etc.
22              
23             ## $cli = CLASS_OR_OBJECT->new(%args)
24             ## $cli = CLASS_OR_OBJECT->new($url, %args)
25             ## + %args, object structure:
26             ## (
27             ## ##-- DiaColloDB::Client: options
28             ## url => $url, ##-- db url
29             ## )
30             sub new {
31 0     0 1   my $that = shift;
32 0 0         my $url = (@_ % 2)==0 ? undef : shift;
33 0   0       my $cli = bless({
34             $that->defaults(),
35             url=>$url,
36             @_
37             }, ref($that)||$that);
38 0 0         return $cli->open($cli->{url},@_) if (defined($cli->{url}));
39 0           return $cli;
40             }
41              
42             ## %defaults = $CLASS_OR_OBJ->defaults()
43             ## + called by new() and promote()
44             sub defaults {
45 0     0 1   return qw();
46             }
47              
48             ## $cli_or_undef = $cli->promote($class,%opts)
49             ## + promotes $cli to (a subclass of) $class
50             ## + ensures $class->defaults() keys are set for $cli
51             ## + client options are clobbered with %opts
52             sub promote {
53 0     0 1   my ($cli,$class,%opts) = @_;
54 0 0         $cli = $cli->new() if (!ref($cli));
55 0 0         bless($cli,$class) if (!UNIVERSAL::isa($cli,$class));
56 0           @$cli{keys %opts} = values(%opts);
57 0           %$cli = ($class->defaults,%$cli);
58 0           return $cli;
59             }
60              
61             ## undef = $obj->DESTROY
62             ## + destructor calls close() if necessary
63             sub DESTROY {
64             #$_[0]->trace("DESTROY (tid=", (UNIVERSAL::can('threads','tid') ? threads->tid : '-undef-'), ')'); ##-- DEBUG:thrads
65 0 0 0 0     return if (UNIVERSAL::can('threads','tid') && threads->tid!=0); ##-- don't implicitly close if we're not in main thread
66 0 0         $_[0]->close() if ($_[0]->opened);
67             }
68              
69             ##==============================================================================
70             ## I/O: open/close
71              
72             ## $cli_or_undef = $cli->open($url,%opts)
73             ## $cli_or_undef = $cli->open()
74             ## + calls open_rcfile(), open_file(), open_http(), or open_list() as appropriate
75             sub open {
76 0     0 1   my ($cli,$url) = (shift,shift);
77 0   0       $url //= $cli->{url};
78 0 0 0       my $scheme = UNIVERSAL::isa($url,'ARRAY') ? 'list' : (URI->new($url)->scheme // 'file');
79 0 0         if ($scheme =~ /^rcfile|rc$/) {
    0          
    0          
    0          
80 0           return $cli->open_rcfile($url,@_);
81             }
82             elsif ($scheme eq 'file') {
83 0           return $cli->open_file($url,@_);
84             }
85             elsif ($scheme =~ /^https?$/) {
86 0           return $cli->open_http($url,@_);
87             }
88             elsif ($scheme eq 'list') {
89 0           return $cli->open_list($url,@_);
90             }
91 0 0         $cli->logconfess("open(): unsupported URL scheme ".($scheme ? "'$scheme'" : '(undef)')." for $url");
92 0           return undef;
93             }
94              
95             ## $cli_or_undef = $cli->open_rcfile($rcfile_url,%opts)
96             ## $cli_or_undef = $cli->open_rcfile()
97             ## + opens a local file url
98             ## + may re-bless() $cli into an appropriate package
99             ## + loads a JSON config file containing one or more of the following keys:
100             ## (
101             ## class => $CLASS, ##-- bless() client into class $CLASS
102             ## url => $url, ##-- open client url $url
103             ## $key => $val, ##-- ... other keys passed to $cli->open($url,%opts)
104             ## )
105             sub open_rcfile {
106 0     0 1   my ($cli,$rcurl,%opts) = @_;
107 0 0         $cli = $cli->new() if (!ref($cli));
108 0 0         $cli->close() if ($cli->opened);
109 0   0       $cli->{rcurl} = ($rcurl //= $cli->{url});
110 0           my $uri = URI->new($rcurl);
111 0   0       my $rcpath = ($uri->authority//'') . ($uri->path//'');
      0        
112 0           my %rcopts = $uri->query_form;
113              
114             ##-- load data from file
115 0 0         my $hdr = $cli->readHeaderFile($rcpath)
116             or $cli->logconfess("open_rcfile() failed to open config file '$rcpath' for URL '$rcurl': $!");
117 0 0         $cli->promote($hdr->{class}) if ($hdr->{class});
118 0           delete $hdr->{class};
119 0           @$cli{keys %$hdr} = values %$hdr;
120 0           @$cli{keys %rcopts} = values %rcopts;
121 0           @$cli{keys %opts} = values %opts;
122              
123             ##-- dispatch to lower-level open:// call
124 0 0 0       delete $cli->{url} if (($cli->{url}//'') eq $rcurl);
125 0 0 0       return $cli->opened || !$cli->{url} ? $cli : $cli->open($cli->{url},%opts);
126             }
127              
128             ## $cli_or_undef = $cli->open_file($file_url,%opts)
129             ## $cli_or_undef = $cli->open_file()
130             ## + opens a local file url
131             ## + may re-bless() $cli into an appropriate package
132             ## + OVERRIDE in subclasses supporting file urls
133             sub open_file {
134 0     0 1   my $cli = shift;
135 0 0         $cli = $cli->new() if (!ref($cli));
136 0 0         $cli->close() if ($cli->opened);
137 0           $cli->promote('DiaColloDB::Client::file');
138 0 0         $cli->logconfess("open_file(): not implemented") if ($cli->can('open_file') eq \&open_file);
139 0           return $cli->open_file(@_)
140             }
141              
142             ## $cli_or_undef = $cli->open_http($http_url,%opts)
143             ## $cli_or_undef = $cli->open_http()
144             ## + opens a http url
145             ## + may re-bless() $cli into an appropriate package
146             ## + OVERRIDE in subclasses supporting http urls
147             sub open_http {
148 0     0 1   my $cli = shift;
149 0 0         $cli = $cli->new() if (!ref($cli));
150 0 0         $cli->close() if ($cli->opened);
151 0           $cli->promote('DiaColloDB::Client::http');
152 0 0         $cli->logconfess("open_http(): not implemented") if ($cli->can('open_http') eq \&open_http);
153 0           return $cli->open_http(@_)
154             }
155              
156             ## $cli_or_undef = $cli->open_list($list_url,%opts)
157             ## $cli_or_undef = $cli->open_list(\@urls, %opts)
158             ## $cli_or_undef = $cli->open_list()
159             ## + opens a list url
160             ## + may re-bless() $cli into an appropriate package
161             ## + OVERRIDE in subclasses supporting list urls
162             sub open_list {
163 0     0 1   my $cli = shift;
164 0 0         $cli = $cli->new() if (!ref($cli));
165 0 0         $cli->close() if ($cli->opened);
166 0           $cli->promote('DiaColloDB::Client::list');
167 0 0         $cli->logconfess("open_list(): not implemented") if ($cli->can('open_list') eq \&open_list);
168 0           return $cli->open_list(@_)
169             }
170              
171             ## $cli_or_undef = $cli->close()
172             ## + default just returns $cli
173             sub close {
174 0     0 1   return $_[0];
175             }
176              
177             ## $bool = $cli->opened()
178             ## + default just checks for $cli->{url}
179             sub opened {
180 0   0 0 1   return ref($_[0]) && defined($_[0]{url});
181             }
182              
183             ## %opts = $cli->dbOptions()
184             ## + options to be passed down to bottom-level DB
185             ## + default is all log-related options
186             sub dbOptions {
187 0     0 0   my $cli = shift;
188 0 0         return ref($cli) ? (map {($_=>$cli->{$_})} grep {/^log/} keys %$cli) : qw();
  0            
  0            
189             }
190              
191             ##==============================================================================
192             ## db-info
193              
194             ## \%info = $cli->dbinfo()
195             sub dbinfo {
196 0     0 1   my $cli = shift;
197 0           $cli->logconfess("dbinfo(): not implemented");
198             }
199              
200             ##==============================================================================
201             ## Profiling
202              
203             ##--------------------------------------------------------------
204             ## Profiling: Wrappers
205              
206             ## $mprf = $cli->query($rel,%opts)
207             ## + get a generic DiaColloDB::Profile::Multi object for $rel
208             ## + calls $coldb->profile() or $coldb->compare() as appropriate
209             sub query {
210 0     0 1   my ($cli,$rel) = (shift,shift);
211 0 0         if ($rel =~ s{^(?:d(?!dc)(?:iff)?|co?mp(?:are)?)[\-\/\.\:]?}{}) {
    0          
212 0           return $cli->compare($rel,@_);
213             }
214             elsif ($rel =~ s{^ext(?:end)?[\-\/\.\:]?}{}) {
215 0           return $cli->extend($rel,@_);
216             }
217 0           return $cli->profile($rel,@_);
218             }
219              
220             ## $mprf = $cli->profile1(%opts)
221             ## + get unigram frequency profile for selected items as a DiaColloDB::Profile::Multi object
222             ## + really just wraps $cli->profile('xf', %opts)
223             ## + %opts: see profile() method
224             sub profile1 {
225 0     0 1   return $_[0]->profile('xf',@_[1..$#_]);
226             }
227              
228              
229             ## $mprf = $cli->profile2(%opts)
230             ## + get co-frequency profile for selected items as a DiaColloDB::Profile::Multi object
231             ## + really just wraps $cli->profile('cof', %opts)
232             ## + %opts: see profile() method
233             sub profile2 {
234 0     0 1   return $_[0]->profile('cof',@_[1..$#_]);
235             }
236              
237             ## $mprf = $cli->compare1(%opts)
238             ## + get unigram comparison profile for selected items as a DiaColloDB::Profile::MultiDiff object
239             ## + really just wraps $cli->compare('xf', %opts)
240             ## + %opts: see compare() method
241 1     1   80 BEGIN { *diff1 = \&compare1; }
242             sub compare1 {
243 0     0 1   return $_[0]->compare('xf',@_[1..$#_]);
244             }
245              
246             ## $mprf = $cli->compare2(%opts)
247             ## + get co-frequency comparison profile for selected items as a DiaColloDB::Profile::MultiDiff object
248             ## + really just wraps $cli->profile('cof', %opts)
249             ## + %opts: see compare() method
250 1     1   234 BEGIN { *diff2 = \&compare2; }
251             sub compare2 {
252 0     0 1   return $_[0]->compare('cof',@_[1..$#_]);
253             }
254              
255             ##--------------------------------------------------------------
256             ## Profiling: Generic
257              
258             ## $mprf = $cli->profile($relation, %opts)
259             ## + get a relation profile for selected items as a DiaColloDB::Profile::Multi object
260             ## + %opts: as for DiaColloDB::profile()
261             ## + sets $cli->{error} on error
262             sub profile {
263 0     0 1   my ($cli,$rel,%opts) = @_;
264 0           $cli->logconfess("profile(): not implemented");
265             }
266              
267             ##--------------------------------------------------------------
268             ## Profiling: extend (pass-2 for multi-clients)
269              
270             ## $mprf = $cli->extend($relation, %opts)
271             ## + get an extension-profile for selected items as a DiaColloDB::Profile::Multi object
272             ## + %opts: as for DiaColloDB::extend()
273             ## + sets $cli->{error} on error
274             sub extend {
275 0     0 1   my ($cli,$rel,%opts) = @_;
276 0           $cli->logconfess("extend(): not implemented");
277             }
278              
279             ##--------------------------------------------------------------
280             ## Profiling: Comparison (diff)
281              
282             ## $mprf = $cli->compare($relation, %opts)
283             ## + get a relation comparison profile for selected items as a DiaColloDB::Profile::MultiDiff object
284             ## + %opts: as for DiaColloDB::compare()
285             ## + sets $cli->{error} on error
286 0     0 1   sub diff { $_[0]->compare(@_[1..$#_]); }
287             sub compare {
288 0     0 1   my ($cli,$rel,%opts) = @_;
289 0           $cli->logconfess("compare(): not implemented");
290             }
291              
292             ##==============================================================================
293             ## Footer
294             1;
295              
296             __END__
297              
298              
299              
300