File Coverage

blib/lib/Ace.pm
Criterion Covered Total %
statement 343 498 68.9
branch 125 266 47.0
condition 42 100 42.0
subroutine 50 63 79.4
pod 26 39 66.7
total 586 966 60.7


line stmt bran cond sub pod time code
1             package Ace;
2              
3 4     4   58 use strict;
  4         115  
  4         55  
4 4     4   81 use Carp qw(croak carp cluck);
  4         35  
  4         69  
5 4     4   60 use Scalar::Util 'weaken';
  4         1158  
  4         106  
6              
7 4     4   143 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Error $DEBUG_LEVEL);
  4         67  
  4         61  
8              
9 4     4   260 use Data::Dumper;
  4         40  
  4         152  
10 4     4   126 use AutoLoader 'AUTOLOAD';
  4         37  
  4         69  
11             require Exporter;
12             use overload
13 4         66   '""' => 'asString',
14 4     4   89   'cmp' => 'cmp';
  4         35  
15              
16             @ISA = qw(Exporter);
17              
18             # Items to export into callers namespace by default.
19             @EXPORT = qw(STATUS_WAITING STATUS_PENDING STATUS_ERROR);
20              
21             # Optional exports
22             @EXPORT_OK = qw(rearrange ACE_PARSE);
23             $VERSION = '1.91';
24              
25 4     4   61 use constant STATUS_WAITING => 0;
  4         35  
  4         108  
26 4     4   105 use constant STATUS_PENDING => 1;
  4         37  
  4         48  
27 4     4   62 use constant STATUS_ERROR => -1;
  4         86  
  4         49  
28 4     4   58 use constant ACE_PARSE => 3;
  4         37  
  4         50  
29              
30 4     4   85 use constant DEFAULT_PORT => 200005; # rpc server
  4         2174  
  4         81  
31 4     4   95 use constant DEFAULT_SOCKET => 2005; # socket server
  4         36  
  4         49  
32              
33             require Ace::Iterator;
34             require Ace::Object;
35 4     4   97 eval qq{use Ace::Freesubs}; # XS file, may not be available
  0         0  
  0         0  
36              
37             # Map database names to objects (to fix file-caching issue)
38             my %NAME2DB;
39              
40             # internal cache of objects
41             my %MEMORY_CACHE;
42              
43             my %DEFAULT_CACHE_PARAMETERS = (
44             default_expires_in  => '1 day',
45             auto_purge_interval => '12 hours',
46             );
47              
48             # Preloaded methods go here.
49             $Error = '';
50              
51             # Pseudonyms and deprecated methods.
52             *list      = \&fetch;
53             *Ace::ERR  = *Error;
54              
55             # now completely deprecated and gone
56             # *find_many = \&fetch_many;
57             # *models = \&classes;
58              
59             sub connect {
60 3     3 1 145   my $class = shift;
61 3         33   my ($host,$port,$user,$pass,$path,$program,
62                   $objclass,$timeout,$query_timeout,$database,
63                   $server_type,$url,$u,$p,$cache,$other);
64              
65             # one-argument single "URL" form
66 3 50       190   if (@_ == 1) {
67 0         0     return $class->connect(-url=>shift);
68               }
69              
70             # multi-argument (traditional) form
71 3         71   ($host,$port,$user,$pass,
72                $path,$objclass,$timeout,$query_timeout,$url,$cache,$other) =
73                  rearrange(['HOST','PORT','USER','PASS',
74             'PATH',['CLASS','CLASSMAPPER'],'TIMEOUT',
75             'QUERY_TIMEOUT','URL','CACHE'],@_);
76              
77 3 50 0     115   ($host,$port,$u,$pass,$p,$server_type) = $class->process_url($url)
78                 or croak "Usage: Ace->connect(-host=>\$host,-port=>\$port [,-path=>\$path]\n"
79                   if defined $url;
80              
81 3 50       39   if ($path) { # local database
82 0         0     $server_type = 'Ace::Local';
83               } else { # either RPC or socket server
84 3   50     37     $host ||= 'localhost';
85 3   50     60     $user ||= $u || '';
      33        
86 3   50     53     $path ||= $p || '';
      33        
87 3 0 33     37     $port ||= $server_type eq 'Ace::SocketServer' ? DEFAULT_SOCKET : DEFAULT_PORT;
88 3 50       40     $query_timeout = 120 unless defined $query_timeout;
89 3 50 50     84     $server_type ||= 'Ace::SocketServer' if $port < 100000;
90 3 50 0     39     $server_type ||= 'Ace::RPC' if $port >= 100000;
91               }
92              
93             # we've normalized parameters, so do the actual connect
94 3 50       294   eval "require $server_type" || croak "Module $server_type not loaded: $@";
95 3 50       53   if ($path) {
96 0         0     $database = $server_type->connect(-path=>$path,%$other);
97               } else {
98 3         74     $database = $server_type->connect($host,$port,$query_timeout,$user,$pass,%$other);
99               }
100              
101 3 50       37   unless ($database) {
102 0   0     0     $Ace::Error ||= "Couldn't open database";
103 0         0     return;
104               }
105              
106 3   50     150   my $contents = {
107             'database'=> $database,
108             'host'   => $host,
109             'port'   => $port,
110             'path'   => $path,
111             'class'  => $objclass || 'Ace::Object',
112             'timeout' => $query_timeout,
113             'user'    => $user,
114             'pass'    => $pass,
115             'other'  => $other,
116             'date_style' => 'java',
117             'auto_save' => 0,
118             };
119              
120 3   33     1056   my $self = bless $contents,ref($class)||$class;
121              
122 3 50       36   $self->_create_cache($cache) if $cache;
123 3         40   $self->name2db("$self",$self);
124 3         52   return $self;
125             }
126              
127             sub reopen {
128 0     0 1 0   my $self = shift;
129 0 0       0   return 1 if $self->ping;
130 0         0   my $class = ref($self->{database});
131 0         0   my $database;
132 0 0       0   if ($self->{path}) {
133 0         0     $database = $class->connect(-path=>$self->{path},%{$self->other});
  0         0  
134               } else {
135 0         0     $database = $class->connect($self->{host},$self->{port}, $self->{timeout},
136 0         0 $self->{user},$self->{pass},%{$self->{other}});
137               }
138 0 0       0   unless ($database) {
139 0         0     $Ace::Error = "Couldn't open database";
140 0         0     return;
141               }
142 0         0   $self->{database} = $database;
143 0         0   1;
144             }
145              
146             sub class {
147 346     346 0 5299   my $self = shift;
148 346         5878   my $d = $self->{class};
149 346 50       3310   $self->{class} = shift if @_;
150 346         5038   $d;
151             }
152              
153             sub class_for {
154 214     214 0 2039   my $self = shift;
155 214         5235   my ($class,$id) = @_;
156 214         2057   my $selected_class;
157              
158 214 50       2490   if (my $selector = $self->class) {
159 214 50       4538     if (ref $selector eq 'HASH') {
    50          
    50          
160 0   0     0       $selected_class = $selector->{$class} || $selector->{'_DEFAULT_'};
161                 }
162                 elsif ($selector->can('class_for')) {
163 0         0       $selected_class = $selector->class_for($class,$id,$self);
164                 }
165                 elsif (!ref $selector) {
166 214         2040       $selected_class = $selector;
167                 }
168                 else {
169 0         0       croak "$selector is neither a scalar, nor a HASH, nor an object that supports the class_for() method";
170                 }
171               }
172              
173 214   50     2730   $selected_class ||= 'Ace::Object';
174              
175 214 50 0     2930   eval "require $selected_class; 1;" || croak $@
176                 unless $selected_class->can('new');
177              
178 214         3329   $selected_class;
179             }
180              
181             sub process_url {
182 0     0 0 0   my $class = shift;
183 0         0   my $url = shift;
184 0         0   my ($host,$port,$user,$pass,$path,$server_type) = ('','','','','','');
185              
186 0 0       0   if ($url) { # look for host:port
187 0         0     local $_ = $url;
188 0 0       0     if (m!^rpcace://([^:]+):(\d+)$!) { # rpcace://localhost:200005
    0          
    0          
    0          
    0          
189 0         0       ($host,$port) = ($1,$2);
190 0         0       $server_type = 'Ace::RPC';
191                 } elsif (m!^sace://([\w:]+)\@([^:]+):(\d+)$!) { # sace://user@localhost:2005
192 0         0       ($user,$host,$port) = ($1,$2,$3);
193 0         0       $server_type = 'Ace::SocketServer';
194                 } elsif (m!^sace://([^:]+):(\d+)$!) { # sace://localhost:2005
195 0         0       ($host,$port) = ($1,$2);
196 0         0       $server_type = 'Ace::SocketServer';
197                 } elsif (m!^tace:(/.+)$!) { # tace:/path/to/database
198 0         0       $path = $1;
199 0         0       $server_type = 'Ace::Local';
200                 } elsif (m!^(/.+)$!) { # /path/to/database
201 0         0       $path = $1;
202 0         0       $server_type = 'Ace::Local';
203                 } else {
204 0         0       return;
205                 }
206               }
207              
208 0 0       0   if ($user =~ /:/) {
209 0         0     ($user,$pass) = split /:/,$user;
210               }
211              
212 0         0   return ($host,$port,$user,$pass,$path,$server_type);
213              
214             }
215              
216             # Return the low-level Ace::AceDB object
217             sub db {
218 4624     4624 0 80826   return $_[0]->{'database'};
219             }
220              
221             # Fetch a model from the database.
222             # Since there are limited numbers of models, we cache
223             # the results internally.
224             sub model {
225 23     23 1 206   my $self = shift;
226 23         378   require Ace::Model;
227 23         218   my $model = shift;
228 23         186   my $break_cycle = shift; # for breaking cycles when following #includes
229 23         237   my $key = join(':',$self,'MODEL',$model);
230 23   66     580   $self->{'models'}{$model} ||= eval{$self->cache->get($key)};
  4         48  
231 23 100       267   unless ($self->{models}{$model}) {
232 4         58     $self->{models}{$model} =
233                   Ace::Model->new($self->raw_query("model \"$model\""),$self,$break_cycle);
234 4         42     eval {$self->cache->set($key=>$self->{models}{$model})};
  4         47  
235               }
236 23         334   return $self->{'models'}{$model};
237             }
238              
239             # cached get
240             # pass "1" for fill to get a full fill
241             # pass any other true value to get a tag fill
242             sub get {
243 9     9 1 81   my $self = shift;
244 9         87   my ($class,$name,$fill) = @_;
245              
246             # look in caches first
247 9   66     3784   my $obj = $self->memory_cache_fetch($class=>$name)
248                 || $self->file_cache_fetch($class=>$name);
249 9 100       127   return $obj if $obj;
250              
251             # _acedb_get() does the caching
252 6 50       65   $obj = $self->_acedb_get($class,$name,$fill) or return;
253 6         111   $obj;
254             }
255              
256             sub _acedb_get {
257 6     6   53   my $self = shift;
258 6         61   my ($class,$name,$filltag) = @_;
259 6 50       65   return unless $self->count($class,$name) >= 1;
260              
261             #return $self->{class}->new($class,$name,$self,1) unless $filltag;
262 6 50       89   return ($self->_list)[0] unless $filltag;
263              
264 0 0 0     0   if (defined $filltag && $filltag eq '1') { # full fill
265 0         0     return $self->_fetch();
266               } else {
267 0         0     return $self->_fetch(undef,undef,$filltag);
268               }
269             }
270              
271              
272             #### CACHE AND CARRY CODE ####
273             # Be very careful here. The key used for the memory cache is in the format
274             # db:class:name, but the key used for the file cache is in the format class:name.
275             # The difference is that the filecache has a built-in namespace but the memory
276             # cache doesn't.
277             sub memory_cache_fetch {
278 323     323 1 3105   my $self = shift;
279 323         3555   my ($class,$name) = @_;
280 323         4002   my $key = join ":",$self,$class,$name;
281 323 100       4933   return unless defined $MEMORY_CACHE{$key};
282 123 50       1532   carp "memory_cache hit on $class:$name"
283                 if Ace->debug;
284 123         1372   return $MEMORY_CACHE{$key};
285             }
286              
287             sub memory_cache_store {
288 234     234 1 2146   my $self = shift;
289 234 50       2337   croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
290 234         2330   my $obj = shift;
291 234         2746   my $key = join ':',$obj->db,$obj->class,$obj->name;
292 234 100       4771   return if exists $MEMORY_CACHE{$key};
293 192 50       2335   carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
294 192         3728   weaken($MEMORY_CACHE{$key} = $obj);
295             }
296              
297             sub memory_cache_clear {
298 0     0 1 0     my $self = shift;
299 0         0     %MEMORY_CACHE = ();
300         <