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     # Exporter doesn't like you to call it's import() directly
  73     return $class->export_to_level(1, $class, @super_args);
  74 }
  75
  76 sub new_editor { return OpenILS::Utils::CStoreEditor->new(@_); }
  77
  78 sub new_rstore_editor {
  79     my $e = OpenILS::Utils::CStoreEditor->new(@_);
  80     $e->app('open-ils.reporter-store');
  81     return $e;
  82 }
  83
  84
  85 # -----------------------------------------------------------------------------
  86 # Log levels
  87 # -----------------------------------------------------------------------------
  88 use constant E => 'error';
  89 use constant W => 'warn';
  90 use constant I => 'info';
  91 use constant D => 'debug';
  92 use constant A => 'activity';
  93
  94
  95
  96 # -----------------------------------------------------------------------------
  97 # Params include:
  98 #   xact=><true> : creates a storage transaction
  99 #   authtoken=>$token : the login session key
 100 # -----------------------------------------------------------------------------
 101 sub new {
 102     my( $class, %params ) = @_;
 103     $class = ref($class) || $class;
 104     my $self = bless( \%params, $class );
 105     $self->{checked_perms} = {};
 106     return $self;
 107 }
 108
 109 sub DESTROY {
 110         my $self = shift;
 111         $self->reset;
 112         return undef;
 113 }
 114
 115 sub app {
 116     my( $self, $app ) = @_;
 117     $self->{app} = $app if $app;
 118     $self->{app} = $self->personality unless $self->{app};
 119     return $self->{app};
 120 }
 121
 122
 123 # -----------------------------------------------------------------------------
 124 # Log the editor metadata along with the log string
 125 # -----------------------------------------------------------------------------
 126 sub log {
 127     my( $self, $lev, $str ) = @_;
 128     my $s = "editor[";
 129     if ($always_xact) {
 130         $s .= "!|";
 131     } elsif ($self->{xact}) {
 132         $s .= "1|";
 133     } else {
 134         $s .= "0|";
 135     }
 136     $s .= "0" unless $self->requestor;
 137     $s .= $self->requestor->id if $self->requestor;
 138     $s .= "]";
 139     $logger->$lev("$s $str");
 140 }
 141
 142 # -----------------------------------------------------------------------------
 143 # Verifies the auth token and fetches the requestor object
 144 # -----------------------------------------------------------------------------
 145 sub checkauth {
 146     my $self = shift;
 147     $self->log(D, "checking auth token ".$self->authtoken);
 148
 149     my $content = $U->simplereq(
 150         'open-ils.auth',
 151         'open-ils.auth.session.retrieve', $self->authtoken, 1);
 152
 153     if(!$content or $U->event_code($content)) {
 154         $self->event( ($content) ? $content : OpenILS::Event->new('NO_SESSION'));
 155         return undef;
 156     }
 157
 158     $self->{authtime} = $content->{authtime};
 159     return $self->{requestor} = $content->{userobj};
 160 }
 161
 162 =head1 test
 163
 164 sub checkauth {
 165     my $self = shift;
 166     $cache = OpenSRF::Utils::Cache->new('global') unless $cache;
 167     $self->log(D, "checking cached auth token ".$self->authtoken);
 168     my $user = $cache->get_cache("oils_auth_".$self->authtoken);
 169     return $self->{requestor} = $user->{userobj} if $user;
 170     $self->event(OpenILS::Event->new('NO_SESSION'));
 171     return undef;
 172 }
 173
 174 =cut
 175
 176
 177 # -----------------------------------------------------------------------------
 178 # Returns the last generated event
 179 # -----------------------------------------------------------------------------
 180 sub event {
 181     my( $self, $evt ) = @_;
 182     $self->{event} = $evt if $evt;
 183     return $self->{event};
 184 }
 185
 186 # -----------------------------------------------------------------------------
 187 # Destroys the transaction and disconnects where necessary,
 188 # then returns the last event that occurred
 189 # -----------------------------------------------------------------------------
 190 sub die_event {
 191     my $self = shift;
 192     my $evt = shift;
 193     $self->rollback;
 194     $self->died(1);
 195     $self->event($evt);
 196     return $self->event;
 197 }
 198
 199
 200 # -----------------------------------------------------------------------------
 201 # Clears the last caught event
 202 # -----------------------------------------------------------------------------
 203 sub clear_event {
 204     my $self = shift;
 205     $self->{event} = undef;
 206 }
 207
 208 sub died {
 209     my($self, $died) = @_;
 210     $self->{died} = $died if defined $died;
 211     return $self->{died};
 212 }
 213
 214 sub authtoken {
 215     my( $self, $auth ) = @_;
 216     $self->{authtoken} = $auth if $auth;
 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, $hint, $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.$hint";
 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, if no authtoken is set, fall back to anonymous.
 831     unshift(@arg, ($self->authtoken || 'ANONYMOUS'))
 832         if ($self->personality eq 'open-ils.pcrud');
 833
 834     try {
 835         $obj = $self->request($method, @arg);
 836     } catch Error with { $err = shift; };
 837
 838
 839     if(!defined $obj) {
 840         $self->log(I, "request returned no data : $method");
 841
 842         if( $action eq 'retrieve' ) {
 843             $self->event(_mk_not_found($type, $arg));
 844
 845         } elsif( $action eq 'update' or
 846                 $action eq 'delete' or $action eq 'create' ) {
 847             my $evt = OpenILS::Event->new(
 848                 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
 849             $self->event($evt);
 850         }
 851
 852         if( $err ) {
 853             $self->event(
 854                 OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
 855                     payload => $arg, debug => "$err" ));
 856             return undef;
 857         }
 858
 859         return undef;
 860     }
 861
 862     if( $action eq 'create' and $obj == 0 ) {
 863         my $evt = OpenILS::Event->new(
 864             'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
 865         $self->event($evt);
 866         return undef;
 867     }
 868
 869     # If we havn't dealt with the error in a nice way, go ahead and throw it
 870     if( $err ) {
 871         $self->event(
 872             OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
 873                 payload => $arg, debug => "$err" ));
 874         return undef;
 875     }
 876
 877     if( $action eq 'search' ) {
 878         $self->log(I, "$method: returned ".scalar(@$obj). " result(s)");
 879         $self->event(_mk_not_found($type, $arg)) unless @$obj;
 880     }
 881
 882     if( $action eq 'create' ) {
 883         my $idf = $obj->Identity;
 884         $self->log(I, "created a new $type object with Identity " . $obj->$idf);
 885         $arg->$idf($obj->$idf);
 886     }
 887
 888     $self->data($obj); # cache the data for convenience
 889
 890     return ($obj) ? $obj : 1;
 891 }
 892
 893
 894 sub _mk_not_found {
 895     my( $type, $arg ) = @_;
 896     (my $t = $type) =~ s/\./_/og;
 897     $t = uc($t);
 898     return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
 899 }
 900
 901
 902
 903 # utility method for loading
 904 sub __fm2meth {
 905     my $str = shift;
 906     my $sep = shift;
 907     $str =~ s/Fieldmapper:://o;
 908     $str =~ s/::/$sep/g;
 909     return $str;
 910 }
 911
 912
 913 # -------------------------------------------------------------
 914 # Load up the methods from the FM classes
 915 # -------------------------------------------------------------
 916
 917 sub init {
 918     no warnings;    #  Here we potentially redefine subs via eval
 919     my $map = $Fieldmapper::fieldmap;
 920     for my $object (keys %$map) {
 921         my $obj  = __fm2meth($object, '_');
 922         my $type = __fm2meth($object, '.');
 923         my $hint = $object->json_hint;
 924         foreach my $command (qw/ update retrieve search create delete batch_retrieve retrieve_all /) {
 925             eval "sub ${command}_$obj {return shift()->runmethod('$command', '$type', '$hint', \@_);}\n";
 926         }
 927         # TODO: performance test against concatenating a big string of all the subs and eval'ing only ONCE.
 928     }
 929 }
 930
 931 init();  # Add very many subs to this namespace
 932
 933 sub json_query {
 934     my( $self, $arg, $options ) = @_;
 935
 936     if( $self->personality eq 'open-ils.pcrud' ) {
 937         $self->log(E, "json_query is not allowed when using the ".
 938             "open-ils.pcrud personality of CStoreEditor: " .Dumper($arg));
 939
 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