LP#1347774 Anonymous PCRUD mode
[working/Evergreen.git] / Open-ILS / src / perlmods / lib / OpenILS / Utils / CStoreEditor.pm
1 use strict; use warnings;
2 package OpenILS::Utils::CStoreEditor;
3 use OpenILS::Application::AppUtils;
4 use OpenSRF::Application;
5 use OpenSRF::AppSession;
6 use OpenSRF::EX qw(:try);
7 use OpenILS::Utils::Fieldmapper;
8 use OpenILS::Event;
9 use Data::Dumper;
10 use OpenSRF::Utils::JSON;
11 use OpenSRF::Utils::Logger qw($logger);
12 my $U = "OpenILS::Application::AppUtils";
13 my %PERMS;
14 my $cache;
15 my %xact_ed_cache;
16
17 # if set, we will use this locale for all new sessions
18 # if unset, we rely on the existing opensrf locale propagation
19 our $default_locale;
20
21 our $always_xact = 0;
22 our $_loaded = 1;
23
24 #my %PERMS = (
25 #   'biblio.record_entry'   => { update => 'UPDATE_MARC' },
26 #   'asset.copy'                => { update => 'UPDATE_COPY'},
27 #   'asset.call_number'     => { update => 'UPDATE_VOLUME'},
28 #   'action.circulation'        => { retrieve => 'VIEW_CIRCULATIONS'},
29 #);
30
31 sub flush_forced_xacts {
32     for my $k ( keys %xact_ed_cache ) {
33         try {
34             $xact_ed_cache{$k}->rollback;
35         } catch Error with {
36             # rollback failed
37         };
38         delete $xact_ed_cache{$k};
39     }
40 }
41
42 # -----------------------------------------------------------------------------
43 # Export some useful functions
44 # -----------------------------------------------------------------------------
45 use vars qw(@EXPORT_OK %EXPORT_TAGS);
46 use Exporter;
47 use base qw/Exporter/;
48 push @EXPORT_OK, ( 'new_editor', 'new_rstore_editor' );
49 %EXPORT_TAGS = ( funcs => [ qw/ new_editor new_rstore_editor / ] );
50
51 our $personality = 'open-ils.cstore';
52
53 sub personality { 
54     my( $self, $app ) = @_;
55     $personality = $app if $app;
56     init() if $app; # rewrite if we changed personalities
57     return $personality;
58 }
59
60 sub import {
61     my $class = shift;
62
63     my @super_args = ();
64     while ( my $a = shift ) {
65         if ($a eq 'personality') {
66             $class->personality( shift );
67         } else {
68             push @super_args, $a;
69         }
70     }
71
72     return $class->SUPER::import( @super_args );
73 }
74
75 sub new_editor { return OpenILS::Utils::CStoreEditor->new(@_); }
76
77 sub new_rstore_editor { 
78     my $e = OpenILS::Utils::CStoreEditor->new(@_); 
79     $e->app('open-ils.reporter-store');
80     return $e;
81 }
82
83
84 # -----------------------------------------------------------------------------
85 # Log levels
86 # -----------------------------------------------------------------------------
87 use constant E => 'error';
88 use constant W => 'warn';
89 use constant I => 'info';
90 use constant D => 'debug';
91 use constant A => 'activity';
92
93
94
95 # -----------------------------------------------------------------------------
96 # Params include:
97 #   xact=><true> : creates a storage transaction
98 #   authtoken=>$token : the login session key
99 # -----------------------------------------------------------------------------
100 sub new {
101     my( $class, %params ) = @_;
102     $class = ref($class) || $class;
103     my $self = bless( \%params, $class );
104     $self->{checked_perms} = {};
105     return $self;
106 }
107
108 sub DESTROY {
109         my $self = shift;
110         $self->reset;
111         return undef;
112 }
113
114 sub app {
115     my( $self, $app ) = @_;
116     $self->{app} = $app if $app;
117     $self->{app} = $self->personality unless $self->{app};
118     return $self->{app};
119 }
120
121
122 # -----------------------------------------------------------------------------
123 # Log the editor metadata along with the log string
124 # -----------------------------------------------------------------------------
125 sub log {
126     my( $self, $lev, $str ) = @_;
127     my $s = "editor[";
128     if ($always_xact) {
129         $s .= "!|";
130     } elsif ($self->{xact}) {
131         $s .= "1|";
132     } else {
133         $s .= "0|";
134     }
135     $s .= "0" unless $self->requestor;
136     $s .= $self->requestor->id if $self->requestor;
137     $s .= "]";
138     $logger->$lev("$s $str");
139 }
140
141 # -----------------------------------------------------------------------------
142 # Verifies the auth token and fetches the requestor object
143 # -----------------------------------------------------------------------------
144 sub checkauth {
145     my $self = shift;
146     $self->log(D, "checking auth token ".$self->authtoken);
147
148     my $content = $U->simplereq( 
149         'open-ils.auth', 
150         'open-ils.auth.session.retrieve', $self->authtoken, 1);
151
152     if(!$content or $U->event_code($content)) {
153         $self->event( ($content) ? $content : OpenILS::Event->new('NO_SESSION'));
154         return undef;
155     }
156
157     $self->{authtime} = $content->{authtime};
158     return $self->{requestor} = $content->{userobj};
159 }
160
161 =head1 test
162
163 sub checkauth {
164     my $self = shift;
165     $cache = OpenSRF::Utils::Cache->new('global') unless $cache;
166     $self->log(D, "checking cached auth token ".$self->authtoken);
167     my $user = $cache->get_cache("oils_auth_".$self->authtoken);
168     return $self->{requestor} = $user->{userobj} if $user;
169     $self->event(OpenILS::Event->new('NO_SESSION'));
170     return undef;
171 }
172
173 =cut
174
175
176 # -----------------------------------------------------------------------------
177 # Returns the last generated event
178 # -----------------------------------------------------------------------------
179 sub event {
180     my( $self, $evt ) = @_;
181     $self->{event} = $evt if $evt;
182     return $self->{event};
183 }
184
185 # -----------------------------------------------------------------------------
186 # Destroys the transaction and disconnects where necessary,
187 # then returns the last event that occurred
188 # -----------------------------------------------------------------------------
189 sub die_event {
190     my $self = shift;
191     my $evt = shift;
192     $self->rollback;
193     $self->died(1);
194     $self->event($evt);
195     return $self->event;
196 }
197
198
199 # -----------------------------------------------------------------------------
200 # Clears the last caught event
201 # -----------------------------------------------------------------------------
202 sub clear_event {
203     my $self = shift;
204     $self->{event} = undef;
205 }
206
207 sub died {
208     my($self, $died) = @_;
209     $self->{died} = $died if defined $died;
210     return $self->{died};
211 }
212
213 sub authtoken {
214     my( $self, $auth ) = @_;
215     $self->{authtoken} = $auth if $auth;
216     return 'ANONYMOUS' if ($self->personality eq 'open-ils.pcrud' and !defined($self->{authtoken}));
217     return $self->{authtoken};
218 }
219
220 sub authtime {
221     my( $self, $auth ) = @_;
222     $self->{authtime} = $auth if $auth;
223     return $self->{authtime};
224 }
225
226 sub timeout {
227     my($self, $to) = @_;
228     $self->{timeout} = $to if defined $to;
229     return defined($self->{timeout}) ? $self->{timeout} : 60;
230 }
231
232 # -----------------------------------------------------------------------------
233 # fetches the session, creating if necessary.  If 'xact' is true on this
234 # object, a db session is created
235 # -----------------------------------------------------------------------------
236 sub session {
237     my( $self, $session ) = @_;
238     $self->{session} = $session if $session;
239
240     # sessions can stick around longer than a single request/transaction.
241     # kill it if our default locale was altered since the last request
242     # and it does not match the locale of the existing session.
243     delete $self->{session} if
244         $default_locale and
245         $self->{session} and
246         $self->{session}->session_locale ne $default_locale;
247
248     if(!$self->{session}) {
249         $self->{session} = OpenSRF::AppSession->create($self->app);
250         $self->{session}->session_locale($default_locale) if $default_locale;
251
252         if( ! $self->{session} ) {
253             my $str = "Error creating cstore session with OpenSRF::AppSession->create()!";
254             $self->log(E, $str);
255             throw OpenSRF::EX::ERROR ($str);
256         }
257
258         $self->{session}->connect if $self->{xact} or $self->{connect} or $always_xact;
259         $self->xact_begin if $self->{xact} or $always_xact;
260     }
261
262     $xact_ed_cache{$self->{xact_id}} = $self if $always_xact and $self->{xact_id};
263     return $self->{session};
264 }
265
266
267 # -----------------------------------------------------------------------------
268 # Starts a storage transaction
269 # -----------------------------------------------------------------------------
270 sub xact_begin {
271     my $self = shift;
272     return $self->{xact_id} if $self->{xact_id};
273     $self->session->connect unless $self->session->state == OpenSRF::AppSession::CONNECTED();
274     $self->log(D, "starting new database transaction");
275     unless($self->{xact_id}) {
276         my $stat = $self->request($self->app . '.transaction.begin');
277         $self->log(E, "error starting database transaction") unless $stat;
278         $self->{xact_id} = $stat;
279         if($self->authtoken) {
280             if(!$self->requestor) {
281                 $self->checkauth;
282             }
283             my $user_id = undef;
284             my $ws_id = undef;
285             if($self->requestor) {
286                 $user_id = $self->requestor->id;
287                 $ws_id = $self->requestor->wsid;
288             }
289             $self->request($self->app . '.set_audit_info', $self->authtoken, $user_id, $ws_id);
290         }
291     }
292     $self->{xact} = 1;
293     return $self->{xact_id};
294 }
295
296 # -----------------------------------------------------------------------------
297 # Commits a storage transaction
298 # -----------------------------------------------------------------------------
299 sub xact_commit {
300     my $self = shift;
301     return unless $self->{xact_id};
302     $self->log(D, "comitting db session");
303     my $stat = $self->request($self->app.'.transaction.commit');
304     $self->log(E, "error comitting database transaction") unless $stat;
305     delete $self->{xact_id};
306     delete $self->{xact};
307     return $stat;
308 }
309
310 # -----------------------------------------------------------------------------
311 # Rolls back a storage stransaction
312 # -----------------------------------------------------------------------------
313 sub xact_rollback {
314     my $self = shift;
315     return unless $self->{session} and $self->{xact_id};
316     $self->log(I, "rolling back db session");
317     my $stat = $self->request($self->app.".transaction.rollback");
318     $self->log(E, "error rolling back database transaction") unless $stat;
319     delete $self->{xact_id};
320     delete $self->{xact};
321     return $stat;
322 }
323
324
325 # -----------------------------------------------------------------------------
326 # Savepoint functions.  If no savepoint name is provided, the same name is used 
327 # for each successive savepoint, in which case only the last savepoint set can 
328 # be released or rolled back.
329 # -----------------------------------------------------------------------------
330 sub set_savepoint {
331     my $self = shift;
332     my $name = shift || 'savepoint';
333     return unless $self->{session} and $self->{xact_id};
334     $self->log(I, "setting savepoint '$name'");
335     my $stat = $self->request($self->app.".savepoint.set", $name)
336         or $self->log(E, "error setting savepoint '$name'");
337     return $stat;
338 }
339
340 sub release_savepoint {
341     my $self = shift;
342     my $name = shift || 'savepoint';
343     return unless $self->{session} and $self->{xact_id};
344     $self->log(I, "releasing savepoint '$name'");
345     my $stat = $self->request($self->app.".savepoint.release", $name)
346         or $self->log(E, "error releasing savepoint '$name'");
347     return $stat;
348 }
349
350 sub rollback_savepoint {
351     my $self = shift;
352     my $name = shift || 'savepoint';
353     return unless $self->{session} and $self->{xact_id};
354     $self->log(I, "rollback savepoint '$name'");
355     my $stat = $self->request($self->app.".savepoint.rollback", $name)
356         or $self->log(E, "error rolling back savepoint '$name'");
357     return $stat;
358 }
359
360
361 # -----------------------------------------------------------------------------
362 # Rolls back the transaction and disconnects
363 # -----------------------------------------------------------------------------
364 sub rollback {
365     my $self = shift;
366     my $err;
367     my $ret;
368     try {
369         $self->xact_rollback;
370     } catch Error with  {
371         $err = shift
372     } finally {
373         $ret = $self->disconnect
374     };
375     throw $err if ($err);
376     return $ret;
377 }
378
379 sub disconnect {
380     my $self = shift;
381     $self->session->disconnect if 
382         $self->{session} and 
383         $self->{session}->state == OpenSRF::AppSession::CONNECTED();
384     delete $self->{session};
385 }
386
387
388 # -----------------------------------------------------------------------------
389 # commits the db session and destroys the session
390 # returns the status of the commit call
391 # -----------------------------------------------------------------------------
392 sub commit {
393     my $self = shift;
394     return unless $self->{xact_id};
395     my $stat = $self->xact_commit;
396     $self->disconnect;
397     return $stat;
398 }
399
400 # -----------------------------------------------------------------------------
401 # clears all object data. Does not commit the db transaction.
402 # -----------------------------------------------------------------------------
403 sub reset {
404     my $self = shift;
405     $self->disconnect;
406     $$self{$_} = undef for (keys %$self);
407 }
408
409
410 # -----------------------------------------------------------------------------
411 # commits and resets
412 # -----------------------------------------------------------------------------
413 sub finish {
414     my $self = shift;
415     my $err;
416     my $ret;
417     try {
418         $self->commit;
419     } catch Error with  {
420         $err = shift
421     } finally {
422         $ret = $self->reset
423     };
424     throw $err if ($err);
425     return $ret;
426 }
427
428
429
430 # -----------------------------------------------------------------------------
431 # Does a simple storage request
432 # -----------------------------------------------------------------------------
433 sub request {
434     my( $self, $method, @params ) = @_;
435
436     my $val;
437     my $err;
438     my $argstr = __arg_to_string( (scalar(@params)) == 1 ? $params[0] : \@params);
439     my $locale = $self->session->session_locale;
440
441     $self->log(I, "request $locale $method $argstr");
442
443     if( ($self->{xact} or $always_xact) and 
444             $self->session->state != OpenSRF::AppSession::CONNECTED() ) {
445         #$logger->error("CStoreEditor lost it's connection!!");
446         throw OpenSRF::EX::ERROR ($self->app." connection timed out - transaction cannot continue");
447     }
448
449
450     try {
451
452         my $req = $self->session->request($method, @params);
453
454         if($self->substream) {
455             $self->log(D,"running in substream mode");
456             $val = [];
457             while( my $resp = $req->recv(timeout => $self->timeout) ) {
458                 push(@$val, $resp->content) if $resp->content and not $self->discard;
459             }
460
461         } else {
462             my $resp = $req->recv(timeout => $self->timeout);
463             if($req->failed) {
464                 $err = $resp;
465                 $self->log(E, "request error $method : $argstr : $err");
466             } else {
467                 $val = $resp->content if $resp;
468             }
469         }
470
471         $req->finish;
472
473     } catch Error with {
474         $err = shift;
475         $self->log(E, "request error $method : $argstr : $err");
476     };
477
478     throw $err if $err;
479     return $val;
480 }
481
482 sub substream {
483    my( $self, $bool ) = @_;
484    $self->{substream} = $bool if defined $bool;
485    return $self->{substream};
486 }
487
488 # -----------------------------------------------------------------------------
489 # discard response data instead of returning it to the caller.  currently only 
490 # works in conjunction with substream mode.  
491 # -----------------------------------------------------------------------------
492 sub discard {
493    my( $self, $bool ) = @_;
494    $self->{discard} = $bool if defined $bool;
495    return $self->{discard};
496 }
497
498
499 # -----------------------------------------------------------------------------
500 # Sets / Returns the requestor object.  This is set when checkauth succeeds.
501 # -----------------------------------------------------------------------------
502 sub requestor {
503     my($self, $requestor) = @_;
504     $self->{requestor} = $requestor if $requestor;
505     return $self->{requestor};
506 }
507
508
509
510 # -----------------------------------------------------------------------------
511 # Holds the last data received from a storage call
512 # -----------------------------------------------------------------------------
513 sub data {
514     my( $self, $data ) = @_;
515     $self->{data} = $data if defined $data;
516     return $self->{data};
517 }
518
519
520 # -----------------------------------------------------------------------------
521 # True if this perm has already been checked at this org
522 # -----------------------------------------------------------------------------
523 sub perm_checked {
524     my( $self, $perm, $org ) = @_;
525     $self->{checked_perms}->{$org} = {}
526         unless $self->{checked_perms}->{$org};
527     my $checked = $self->{checked_perms}->{$org}->{$perm};
528     if(!$checked) {
529         $self->{checked_perms}->{$org}->{$perm} = 1;
530         return 0;
531     }
532     return 1;
533 }
534
535
536
537 # -----------------------------------------------------------------------------
538 # Returns true if the requested perm is allowed.  If the perm check fails,
539 # $e->event is set and undef is returned
540 # The perm user is $e->requestor->id and perm org defaults to the requestor's
541 # ws_ou
542 # if perm is an array of perms, method will return true at the first allowed
543 # permission.  If none of the perms are allowed, the perm_failure event
544 # is created with the last perm to fail
545 # -----------------------------------------------------------------------------
546 my $PERM_QUERY = {
547     select => {
548         au => [ {
549             transform => 'permission.usr_has_perm',
550             alias => 'has_perm',
551             column => 'id',
552             params => []
553         } ]
554     },
555     from => 'au',
556     where => {},
557 };
558
559 my $OBJECT_PERM_QUERY = {
560     select => {
561         au => [ {
562             transform => 'permission.usr_has_object_perm',
563             alias => 'has_perm',
564             column => 'id',
565             params => []
566         } ]
567     },
568     from => 'au',
569     where => {},
570 };
571
572 sub allowed {
573     my( $self, $perm, $org, $object, $hint ) = @_;
574     my $uid = $self->requestor->id;
575     $org ||= $self->requestor->ws_ou;
576
577     my $perms = (ref($perm) eq 'ARRAY') ? $perm : [$perm];
578
579     for $perm (@$perms) {
580         $self->log(I, "checking perms user=$uid, org=$org, perm=$perm");
581     
582         if($object) {
583             my $params;
584             if(ref $object) {
585                 # determine the ID field and json_hint from the object
586                 my $id_field = $object->Identity;
587                 $params = [$perm, $object->json_hint, $object->$id_field];
588             } else {
589                 # we were passed an object-id and json_hint
590                 $params = [$perm, $hint, $object];
591             }
592             push(@$params, $org) if $org;
593             $OBJECT_PERM_QUERY->{select}->{au}->[0]->{params} = $params;
594             $OBJECT_PERM_QUERY->{where}->{id} = $uid;
595             return 1 if $U->is_true($self->json_query($OBJECT_PERM_QUERY)->[0]->{has_perm});
596
597         } else {
598             $PERM_QUERY->{select}->{au}->[0]->{params} = [$perm, $org];
599             $PERM_QUERY->{where}->{id} = $uid;
600             return 1 if $U->is_true($self->json_query($PERM_QUERY)->[0]->{has_perm});
601         }
602     }
603
604     # set the perm failure event if the permission check returned false
605     my $e = OpenILS::Event->new('PERM_FAILURE', ilsperm => $perm, ilspermloc => $org);
606     $self->event($e);
607     return undef;
608 }
609
610
611 # -----------------------------------------------------------------------------
612 # Returns the list of object IDs this user has object-specific permissions for
613 # -----------------------------------------------------------------------------
614 sub objects_allowed {
615     my($self, $perm, $obj_type) = @_;
616
617     my $perms = (ref($perm) eq 'ARRAY') ? $perm : [$perm];
618     my @ids;
619
620     for $perm (@$perms) {
621         my $query = {
622             select => {puopm => ['object_id']},
623             from => {
624                 puopm => {
625                     ppl => {field => 'id',fkey => 'perm'}
626                 }
627             },
628             where => {
629                 '+puopm' => {usr => $self->requestor->id, object_type => $obj_type},
630                 '+ppl' => {code => $perm}
631             }
632         };
633     
634         my $list = $self->json_query($query);
635         push(@ids, 0+$_->{object_id}) for @$list;
636     }
637
638    my %trim;
639    $trim{$_} = 1 for @ids;
640    return [ keys %trim ];
641 }
642
643
644 # -----------------------------------------------------------------------------
645 # checks the appropriate perm for the operation
646 # -----------------------------------------------------------------------------
647 sub _checkperm {
648     my( $self, $ptype, $action, $org ) = @_;
649     $org ||= $self->requestor->ws_ou;
650     my $perm = $PERMS{$ptype}{$action};
651     if( $perm ) {
652         return undef if $self->perm_checked($perm, $org);
653         return $self->event unless $self->allowed($perm, $org);
654     } else {
655         $self->log(I, "no perm provided for $ptype.$action");
656     }
657     return undef;
658 }
659
660
661
662 # -----------------------------------------------------------------------------
663 # Logs update actions to the activity log
664 # -----------------------------------------------------------------------------
665 sub log_activity {
666     my( $self, $method, $type, $action, $arg ) = @_;
667     my $str = "$type.$action";
668
669     if ($arg) {
670         
671         my $redact;
672
673         if ($OpenSRF::Application::shared_conf and
674             $OpenSRF::Application::shared_conf->shared and
675             $redact = $OpenSRF::Application::shared_conf->shared->log_protect and
676             ref($redact) eq 'ARRAY' and
677             grep { $method =~ /^$_/ } @{$redact}) {
678
679                 # when API calls are marked as log-protect, avoid
680                 # dumping the param object to the activity log.
681                 $str .= " **DETAILS REDACTED**";
682         } else {
683
684             $str .= _prop_string($arg);
685         }
686     }
687
688
689     $self->log(A, $str);
690 }
691
692
693
694 sub _prop_string {
695     my $obj = shift;
696     my @props = $obj->properties;
697     my $str = "";
698     for(@props) {
699         my $prop = $obj->$_() || "";
700         $prop = substr($prop, 0, 128) . "..." if length $prop > 131;
701         $str .= " $_=$prop";
702     }
703     return $str;
704 }
705
706
707 sub __arg_to_string {
708     my $arg = shift;
709     return "" unless defined $arg;
710     if( UNIVERSAL::isa($arg, "Fieldmapper") ) {
711         my $idf = $arg->Identity;
712         return (defined $arg->$idf) ? $arg->$idf : '<new object>';
713     }
714     return OpenSRF::Utils::JSON->perl2JSON($arg);
715     return "";
716 }
717
718
719 # -----------------------------------------------------------------------------
720 # This does the actual storage query.
721 #
722 # 'search' calls become search_where calls and $arg can be a search hash or
723 # an array-ref of storage search options.  
724 #
725 # 'retrieve' expects an id
726 # 'update' expects an object
727 # 'create' expects an object
728 # 'delete' expects an object
729 #
730 # All methods return true on success and undef on failure.  On failure, 
731 # $e->event is set to the generated event.  
732 # Note: this method assumes that updating a non-changed object and 
733 # thereby receiving a 0 from storage, is a successful update.  
734 #
735 # The method will therefore return true so the caller can just do 
736 # $e->update_blah($x) or return $e->event;
737 # The true value returned from storage for all methods will be stored in 
738 # $e->data, until the next method is called.
739 #
740 # not-found events are generated on retrieve and serach methods.
741 # action=search methods will return [] (==true) if no data is found.  If the
742 # caller is interested in the not found event, they can do:  
743 # return $e->event unless @$results; 
744 # -----------------------------------------------------------------------------
745 sub runmethod {
746     my( $self, $action, $type, $arg, $options ) = @_;
747
748    $options ||= {};
749
750     if( $action eq 'retrieve' ) {
751         if(! defined($arg) ) {
752             $self->log(W,"$action $type called with no ID...");
753             $self->event(_mk_not_found($type, $arg));
754             return undef;
755         } elsif( ref($arg) =~ /Fieldmapper/ ) {
756             $self->log(D,"$action $type called with an object.. attempting Identity retrieval..");
757             my $idf = $arg->Identity;
758             $arg = $arg->$idf;
759         }
760     }
761
762     my @arg = ( ref($arg) eq 'ARRAY' ) ? @$arg : ($arg);
763     my $method = '';
764     if ($self->personality eq 'open-ils.pcrud') {
765         $method = $self->app.".$action.$type";
766     } else {
767         $method = $self->app.".direct.$type.$action";
768     }
769
770     if( $action eq 'search' ) {
771         $method .= '.atomic';
772
773     } elsif( $action eq 'batch_retrieve' ) {
774         $action = 'search';
775         $method =~ s/batch_retrieve/search/o;
776         $method .= '.atomic';
777         my $tt = $type;
778         $tt =~ s/\./::/og;
779         my $fmobj = "Fieldmapper::$tt";
780         my $ident_field = $fmobj->Identity;
781
782         if (ref $arg[0] eq 'ARRAY') {
783             # $arg looks like: ([1, 2, 3], {search_args})
784             @arg = ( { $ident_field => $arg[0] }, @arg[1 .. $#arg] );
785         } else {
786             # $arg looks like: [1, 2, 3]
787             @arg = ( { $ident_field => $arg } );
788         }
789
790     } elsif( $action eq 'retrieve_all' ) {
791         $action = 'search';
792         $method =~ s/retrieve_all/search/o;
793         my $tt = $type;
794         $tt =~ s/\./::/og;
795         my $fmobj = "Fieldmapper::$tt";
796         @arg = ( { $fmobj->Identity => { '!=' => undef } } );
797         $method .= '.atomic';
798     }
799
800     $method =~ s/search/id_list/o if $options->{idlist};
801
802     $method =~ s/\.atomic$//o if $self->substream($$options{substream} || 0);
803     $self->timeout($$options{timeout});
804     $self->discard($$options{discard});
805
806     # remove any stale events
807     $self->clear_event;
808
809     if( $action eq 'update' or $action eq 'delete' or $action eq 'create' ) {
810         if(!($self->{xact} or $always_xact)) {
811             $logger->error("Attempt to update DB while not in a transaction : $method");
812             throw OpenSRF::EX::ERROR ("Attempt to update DB while not in a transaction : $method");
813         }
814         $self->log_activity($method, $type, $action, $arg);
815     }
816
817     # only check perms this way in non-pcrud mode
818     if($self->personality ne 'open-ils.pcrud' and $$options{checkperm}) {
819         my $a = ($action eq 'search') ? 'retrieve' : $action;
820         my $e = $self->_checkperm($type, $a, $$options{permorg});
821         if($e) {
822             $self->event($e);
823             return undef;
824         }
825     }
826
827     my $obj; 
828     my $err = '';
829
830     # In pcrud mode, sub authtoken returns 'ANONYMOUS' if one is not yet set
831     unshift(@$arg, $self->authtoken) if ($self->personality eq 'open-ils.pcrud');
832
833     try {
834         $obj = $self->request($method, @arg);
835     } catch Error with { $err = shift; };
836     
837
838     if(!defined $obj) {
839         $self->log(I, "request returned no data : $method");
840
841         if( $action eq 'retrieve' ) {
842             $self->event(_mk_not_found($type, $arg));
843
844         } elsif( $action eq 'update' or 
845                 $action eq 'delete' or $action eq 'create' ) {
846             my $evt = OpenILS::Event->new(
847                 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
848             $self->event($evt);
849         }
850
851         if( $err ) {
852             $self->event( 
853                 OpenILS::Event->new( 'DATABASE_QUERY_FAILED', 
854                     payload => $arg, debug => "$err" ));
855             return undef;
856         }
857
858         return undef;
859     }
860
861     if( $action eq 'create' and $obj == 0 ) {
862         my $evt = OpenILS::Event->new(
863             'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
864         $self->event($evt);
865         return undef;
866     }
867
868     # If we havn't dealt with the error in a nice way, go ahead and throw it
869     if( $err ) {
870         $self->event( 
871             OpenILS::Event->new( 'DATABASE_QUERY_FAILED', 
872                 payload => $arg, debug => "$err" ));
873         return undef;
874     }
875
876     if( $action eq 'search' ) {
877         $self->log(I, "$method: returned ".scalar(@$obj). " result(s)");
878         $self->event(_mk_not_found($type, $arg)) unless @$obj;
879     }
880
881     if( $action eq 'create' ) {
882         my $idf = $obj->Identity;
883         $self->log(I, "created a new $type object with Identity " . $obj->$idf);
884         $arg->$idf($obj->$idf);
885     }
886
887     $self->data($obj); # cache the data for convenience
888
889     return ($obj) ? $obj : 1;
890 }
891
892
893 sub _mk_not_found {
894     my( $type, $arg ) = @_;
895     (my $t = $type) =~ s/\./_/og;
896     $t = uc($t);
897     return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
898 }
899
900
901
902 # utility method for loading
903 sub __fm2meth { 
904     my $str = shift;
905     my $sep = shift;
906     $str =~ s/Fieldmapper:://o;
907     $str =~ s/::/$sep/g;
908     return $str;
909 }
910
911
912 # -------------------------------------------------------------
913 # Load up the methods from the FM classes
914 # -------------------------------------------------------------
915
916 sub init {
917     no warnings;    #  Here we potentially redefine subs via eval
918     my $map = $Fieldmapper::fieldmap;
919     for my $object (keys %$map) {
920         my $obj  = __fm2meth($object, '_');
921         my $type;
922         if (__PACKAGE__->personality eq 'open-ils.pcrud') {
923             $type = $object->json_hint;
924         } else {
925             $type = __fm2meth($object, '.');
926         }
927         foreach my $command (qw/ update retrieve search create delete batch_retrieve retrieve_all /) {
928             eval "sub ${command}_$obj {return shift()->runmethod('$command', '$type', \@_);}\n";
929         }
930         # TODO: performance test against concatenating a big string of all the subs and eval'ing only ONCE.
931     }
932 }
933
934 init();  # Add very many subs to this namespace
935
936 sub json_query {
937     my( $self, $arg, $options ) = @_;
938
939     if( $self->personality eq 'open-ils.pcrud' ) {
940         $self->event(
941             OpenILS::Event->new(
942                 'JSON_QUERY_NOT_ALLOWED',
943                 attempted_query => $arg,
944                 debug => "json_query is not allowed when using the open-ils.pcrud personality of CStoreEditor" 
945             )
946         );
947         return undef;
948     }
949
950     $options ||= {};
951     my @arg = ( ref($arg) eq 'ARRAY' ) ? @$arg : ($arg);
952     my $method = $self->app.'.json_query.atomic';
953     $method =~ s/\.atomic$//o if $self->substream($$options{substream} || 0);
954
955     $self->timeout($$options{timeout});
956     $self->discard($$options{discard});
957     $self->clear_event;
958     my $obj;
959     my $err;
960     
961     try {
962         $obj = $self->request($method, @arg);
963     } catch Error with { $err = shift; };
964
965     if( $err ) {
966         $self->event(
967             OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
968             payload => $arg, debug => "$err" ));
969         return undef;
970     }
971
972     $self->log(I, "json_query : returned ".scalar(@$obj). " result(s)") if (ref($obj));
973     return $obj;
974 }
975
976
977
978 1;
979
980