#!/usr/bin/perl -w
use strict;
-use lib '../src/perlmods/';
-use lib '../../OpenSRF/src/perlmods/';
-use lib '../src/perlmods/OpenILS/Utils/';
+use lib '../src/perlmods/lib/';
+use lib '../src/perlmods/lib/OpenILS/Utils/';
use OpenSRF::Utils::JSON;
use OpenSRF::System;
if BUILDILSCORE
#Add directories to build
-OILSCORE_DIRS = c-apps extras
+OILSCORE_DIRS = c-apps extras perlmods
#Add manual (non-automake) install targets for simplicity of installing.
OILSCORE_INST = ilscore-install
install-data-hook: $(OILSCORE_INST) $(OILSWEB_INST) $(OILSUPDATES_INST) $(OILSREP_INST)
uninstall-hook:
- rm -R $(perldir)
rm -R $(TEMPLATEDIR)
rm -R $(XSLDIR)
rm -R $(CGIDIR)
#perl-install and string-templates-install
ilscore-install:
@echo $@
- @echo "Installing Perl modules"
- $(MKDIR_P) $(perldir)
$(MKDIR_P) $(TEMPLATEDIR)
- cp -r @srcdir@/perlmods/* $(perldir)
cp -r @srcdir@/templates/marc $(TEMPLATEDIR)
cp -r @srcdir@/templates/password-reset $(TEMPLATEDIR)
- sed -i 's|SYSCONFDIR|@sysconfdir@|g' '$(DESTDIR)@libdir@/perl5/OpenILS/WWW/Web.pm'
- sed -i 's|SYSCONFDIR|@sysconfdir@|g' '$(DESTDIR)@libdir@/perl5/OpenILS/WWW/Method.pm'
@echo "Installing string templates to $(TEMPLATEDIR)"
$(MKDIR_P) $(TEMPLATEDIR)
$(MKDIR_P) $(datadir)/overdue/
--- /dev/null
+#!/usr/bin/perl
+
+use Module::Build;
+use strict;
+use warnings;
+
+my $build = Module::Build->new(
+ module_name => 'OpenILS',
+ license => 'gpl',
+ requires => {
+ 'Apache2::Const' => '0',
+ 'Apache2::Log' => '0',
+ 'Apache2::RequestIO' => '0',
+ 'Apache2::RequestRec' => '0',
+ 'Apache2::RequestUtil' => '0',
+ 'APR::Const' => '0',
+ 'APR::Table' => '0',
+ 'Business::CreditCard' => '0',
+ 'Business::EDI' => '0',
+ 'Business::ISBN' => '0',
+ 'Business::OnlinePayment' => '0',
+ 'Carp' => '0',
+ 'CGI' => '0',
+ 'Class::DBI' => '0',
+ 'Class::DBI::AbstractSearch' => '0',
+ 'Data::Dumper' => '0',
+ 'DateTime' => '0',
+ 'DateTime::Format::ISO8601' => '0',
+ 'DateTime::Format::Mail' => '0',
+ 'DateTime::Format::Strptime' => '0',
+ 'DateTime::Set' => '0',
+ 'DateTime::SpanSet' => '0',
+ 'DBI' => '0',
+ 'Digest::MD5' => '0',
+ 'Email::Send' => '0',
+ 'Encode' => '0',
+ 'Error' => '0',
+ 'Exporter' => '0',
+ 'File::Basename' => '0',
+ 'File::Spec' => '0',
+ 'File::stat' => '0',
+ 'File::Temp' => '0',
+ 'Getopt::Long' => '0',
+ 'IO::Scalar' => '0',
+ 'JavaScript::SpiderMonkey' => '0',
+ 'List::Util' => '0',
+ 'Locale::Country' => '0',
+ 'LWP::UserAgent' => '0',
+ 'MARC::Batch' => '0',
+ 'MARC::Field' => '0',
+ 'MARC::File::XML' => '0',
+ 'MARC::Record' => '0',
+ 'MIME::Base64' => '0',
+ 'Net::FTP' => '0',
+ 'Net::SSH2' => '0',
+ 'OpenSRF::Application' => '0',
+ 'OpenSRF::AppSession' => '0',
+ 'OpenSRF::EX' => '0',
+ 'OpenSRF::MultiSession' => '0',
+ 'OpenSRF::System' => '0',
+ 'OpenSRF::Utils' => '0',
+ 'OpenSRF::Utils::Cache' => '0',
+ 'OpenSRF::Utils::Config' => '0',
+ 'OpenSRF::Utils::JSON' => '0',
+ 'OpenSRF::Utils::Logger' => '0',
+ 'OpenSRF::Utils::SettingsClient' => '0',
+ 'OpenSRF::Utils::SettingsParser' => '0',
+ 'Parse::RecDescent' => '0',
+ 'POSIX' => '0',
+ 'RPC::XML' => '0',
+ 'RPC::XML::Client' => '0',
+ 'RPC::XML::Function' => '0',
+ 'RPC::XML::Method' => '0',
+ 'RPC::XML::Parser' => '0',
+ 'RPC::XML::Procedure' => '0',
+ 'Safe' => '0',
+ 'Scalar::Util' => '0',
+ 'Socket' => '0',
+ 'SRU::Request' => '0',
+ 'SRU::Response' => '0',
+ 'Sys::Syslog' => '0',
+ 'Template' => '0',
+ 'Template::Plugin' => '0',
+ 'Test::More' => '0',
+ 'Text::Aspell' => '0',
+ 'Text::CSV' => '0',
+ 'Text::Glob' => '0',
+ 'Time::HiRes' => '0',
+ 'Time::Local' => '0',
+ 'Unicode::Normalize' => '0',
+ 'UNIVERSAL::require' => '0',
+ 'UUID::Tiny' => '0',
+ 'XML::LibXML' => '0',
+ 'XML::LibXML::XPathContext' => '0',
+ 'XML::LibXSLT' => '0',
+ 'XML::Simple' => '0',
+ }
+);
+
+$build->create_build_script;
+
+# vim:et:ts=4:sw=4:
--- /dev/null
+Build.PL
+lib/OpenILS.pm
+lib/OpenILS/Application.pm
+lib/OpenILS/Application/Acq.pm
+lib/OpenILS/Application/Acq/Claims.pm
+lib/OpenILS/Application/Acq/EDI.pm
+lib/OpenILS/Application/Acq/EDI/Translator.pm
+lib/OpenILS/Application/Acq/Financials.pm
+lib/OpenILS/Application/Acq/Invoice.pm
+lib/OpenILS/Application/Acq/Lineitem.pm
+lib/OpenILS/Application/Acq/Order.pm
+lib/OpenILS/Application/Acq/Picklist.pm
+lib/OpenILS/Application/Acq/Provider.pm
+lib/OpenILS/Application/Acq/Search.pm
+lib/OpenILS/Application/Actor.pm
+lib/OpenILS/Application/Actor/ClosedDates.pm
+lib/OpenILS/Application/Actor/Container.pm
+lib/OpenILS/Application/Actor/Friends.pm
+lib/OpenILS/Application/Actor/Stage.pm
+lib/OpenILS/Application/Actor/UserGroups.pm
+lib/OpenILS/Application/AppUtils.pm
+lib/OpenILS/Application/Booking.pm
+lib/OpenILS/Application/Cat.pm
+lib/OpenILS/Application/Cat/AssetCommon.pm
+lib/OpenILS/Application/Cat/AuthCommon.pm
+lib/OpenILS/Application/Cat/Authority.pm
+lib/OpenILS/Application/Cat/BibCommon.pm
+lib/OpenILS/Application/Cat/Merge.pm
+lib/OpenILS/Application/Circ.pm
+lib/OpenILS/Application/Circ/CircCommon.pm
+lib/OpenILS/Application/Circ/Circulate.pm
+lib/OpenILS/Application/Circ/CopyLocations.pm
+lib/OpenILS/Application/Circ/CreditCard.pm
+lib/OpenILS/Application/Circ/HoldNotify.pm
+lib/OpenILS/Application/Circ/Holds.pm
+lib/OpenILS/Application/Circ/Money.pm
+lib/OpenILS/Application/Circ/NonCat.pm
+lib/OpenILS/Application/Circ/ScriptBuilder.pm
+lib/OpenILS/Application/Circ/StatCat.pm
+lib/OpenILS/Application/Circ/Survey.pm
+lib/OpenILS/Application/Circ/Transit.pm
+lib/OpenILS/Application/Collections.pm
+lib/OpenILS/Application/Fielder.pm
+lib/OpenILS/Application/Ingest.pm
+lib/OpenILS/Application/Penalty.pm
+lib/OpenILS/Application/PermaCrud.pm
+lib/OpenILS/Application/Proxy.pm
+lib/OpenILS/Application/Reporter.pm
+lib/OpenILS/Application/ResolverResolver.pm
+lib/OpenILS/Application/Search.pm
+lib/OpenILS/Application/Search/AddedContent.pm
+lib/OpenILS/Application/Search/Authority.pm
+lib/OpenILS/Application/Search/Biblio.pm
+lib/OpenILS/Application/Search/CNBrowse.pm
+lib/OpenILS/Application/Search/Serial.pm
+lib/OpenILS/Application/Search/Z3950.pm
+lib/OpenILS/Application/Search/Zips.pm
+lib/OpenILS/Application/Serial.pm
+lib/OpenILS/Application/Storage.pm
+lib/OpenILS/Application/Storage/CDBI.pm
+lib/OpenILS/Application/Storage/CDBI/action.pm
+lib/OpenILS/Application/Storage/CDBI/actor.pm
+lib/OpenILS/Application/Storage/CDBI/asset.pm
+lib/OpenILS/Application/Storage/CDBI/authority.pm
+lib/OpenILS/Application/Storage/CDBI/biblio.pm
+lib/OpenILS/Application/Storage/CDBI/booking.pm
+lib/OpenILS/Application/Storage/CDBI/config.pm
+lib/OpenILS/Application/Storage/CDBI/container.pm
+lib/OpenILS/Application/Storage/CDBI/metabib.pm
+lib/OpenILS/Application/Storage/CDBI/money.pm
+lib/OpenILS/Application/Storage/CDBI/permission.pm
+lib/OpenILS/Application/Storage/CDBI/serial.pm
+lib/OpenILS/Application/Storage/Driver/Pg.pm
+lib/OpenILS/Application/Storage/Driver/Pg/cdbi.pm
+lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+lib/OpenILS/Application/Storage/Driver/Pg/fts.pm
+lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+lib/OpenILS/Application/Storage/Driver/Pg/storage.pm
+lib/OpenILS/Application/Storage/FTS.pm
+lib/OpenILS/Application/Storage/Publisher.pm
+lib/OpenILS/Application/Storage/Publisher/action.pm
+lib/OpenILS/Application/Storage/Publisher/actor.pm
+lib/OpenILS/Application/Storage/Publisher/asset.pm
+lib/OpenILS/Application/Storage/Publisher/authority.pm
+lib/OpenILS/Application/Storage/Publisher/biblio.pm
+lib/OpenILS/Application/Storage/Publisher/config.pm
+lib/OpenILS/Application/Storage/Publisher/container.pm
+lib/OpenILS/Application/Storage/Publisher/metabib.pm
+lib/OpenILS/Application/Storage/Publisher/money.pm
+lib/OpenILS/Application/Storage/Publisher/permission.pm
+lib/OpenILS/Application/Storage/QueryParser.pm
+lib/OpenILS/Application/SuperCat.pm
+lib/OpenILS/Application/Trigger.pm
+lib/OpenILS/Application/Trigger/Cleanup.pm
+lib/OpenILS/Application/Trigger/Collector.pm
+lib/OpenILS/Application/Trigger/Event.pm
+lib/OpenILS/Application/Trigger/EventGroup.pm
+lib/OpenILS/Application/Trigger/ModRunner.pm
+lib/OpenILS/Application/Trigger/Reactor.pm
+lib/OpenILS/Application/Trigger/Reactor/ApplyCircFee.pm
+lib/OpenILS/Application/Trigger/Reactor/ApplyPatronPenalty.pm
+lib/OpenILS/Application/Trigger/Reactor/AstCall.pm
+lib/OpenILS/Application/Trigger/Reactor/GeneratePurchaseOrderJEDI.pm
+lib/OpenILS/Application/Trigger/Reactor/MarkItemLost.pm
+lib/OpenILS/Application/Trigger/Reactor/ProcessTemplate.pm
+lib/OpenILS/Application/Trigger/Reactor/SendEmail.pm
+lib/OpenILS/Application/Trigger/Reactor/SendFile.pm
+lib/OpenILS/Application/Trigger/Reactor/StaticEmail.pm
+lib/OpenILS/Application/Trigger/Validator.pm
+lib/OpenILS/Application/Trigger/Validator/Acq.pm
+lib/OpenILS/Application/Trigger/Validator/Acq/PurchaseOrderEDIRequired.pm
+lib/OpenILS/Application/Trigger/Validator/Acq/UserRequestCancelled.pm
+lib/OpenILS/Application/Trigger/Validator/Acq/UserRequestOrdered.pm
+lib/OpenILS/Application/Trigger/Validator/Acq/UserRequestReceived.pm
+lib/OpenILS/Application/Vandelay.pm
+lib/OpenILS/Const.pm
+lib/OpenILS/Event.pm
+lib/OpenILS/Perm.pm
+lib/OpenILS/Reporter/Proxy.pm
+lib/OpenILS/Reporter/SQLBuilder.pm
+lib/OpenILS/SIP.pm
+lib/OpenILS/SIP/Item.pm
+lib/OpenILS/SIP/Msg.pm
+lib/OpenILS/SIP/Patron.pm
+lib/OpenILS/SIP/Transaction.pm
+lib/OpenILS/SIP/Transaction/Checkin.pm
+lib/OpenILS/SIP/Transaction/Checkout.pm
+lib/OpenILS/SIP/Transaction/Renew.pm
+lib/OpenILS/Template/Plugin/Unicode.pm
+lib/OpenILS/Template/Plugin/WebSession.pm
+lib/OpenILS/Template/Plugin/WebUtils.pm
+lib/OpenILS/Utils/Cronscript.pm
+lib/OpenILS/Utils/Cronscript.pm.in
+lib/OpenILS/Utils/CStoreEditor.pm
+lib/OpenILS/Utils/Editor.pm
+lib/OpenILS/Utils/Fieldmapper.pm
+lib/OpenILS/Utils/ISBN.pm
+lib/OpenILS/Utils/Lockfile.pm
+lib/OpenILS/Utils/MFHD.pm
+lib/OpenILS/Utils/MFHD/Caption.pm
+lib/OpenILS/Utils/MFHD/Date.pm
+lib/OpenILS/Utils/MFHD/Holding.pm
+lib/OpenILS/Utils/MFHD/test/mfhd.t
+lib/OpenILS/Utils/MFHD/test/mfhddata.txt
+lib/OpenILS/Utils/MFHD/test/testlib.pm
+lib/OpenILS/Utils/MFHDParser.pm
+lib/OpenILS/Utils/ModsParser.pm
+lib/OpenILS/Utils/Normalize.pm
+lib/OpenILS/Utils/OfflineStore.pm
+lib/OpenILS/Utils/Penalty.pm
+lib/OpenILS/Utils/PermitHold.pm
+lib/OpenILS/Utils/RemoteAccount.pm
+lib/OpenILS/Utils/ScriptRunner.pm
+lib/OpenILS/Utils/SpiderMonkey.pm
+lib/OpenILS/Utils/ZClient.pm
+lib/OpenILS/WWW/AddedContent.pm
+lib/OpenILS/WWW/AddedContent/Amazon.pm
+lib/OpenILS/WWW/AddedContent/ContentCafe.pm
+lib/OpenILS/WWW/AddedContent/OpenLibrary.pm
+lib/OpenILS/WWW/AddedContent/Syndetic.pm
+lib/OpenILS/WWW/BadDebt.pm
+lib/OpenILS/WWW/EGWeb.pm
+lib/OpenILS/WWW/Exporter.pm
+lib/OpenILS/WWW/IDL2js.pm
+lib/OpenILS/WWW/Method.pm
+lib/OpenILS/WWW/PasswordReset.pm
+lib/OpenILS/WWW/Proxy.pm
+lib/OpenILS/WWW/Redirect.pm
+lib/OpenILS/WWW/Reporter.pm
+lib/OpenILS/WWW/Reporter/transforms.pm
+lib/OpenILS/WWW/SuperCat.pm
+lib/OpenILS/WWW/SuperCat/Feed.pm
+lib/OpenILS/WWW/TemplateBatchBibUpdate.pm
+lib/OpenILS/WWW/Vandelay.pm
+lib/OpenILS/WWW/Web.pm
+lib/OpenILS/WWW/XMLRPCGateway.pm
+MANIFEST This list of files
--- /dev/null
+
+#!start included /usr/share/perl5/ExtUtils/MANIFEST.SKIP
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\B\.git\b
+\B\.gitignore\b
+\b_darcs\b
+\B\.cvsignore$
+
+# Avoid VMS specific MakeMaker generated files
+\bDescrip.MMS$
+\bDESCRIP.MMS$
+\bdescrip.mms$
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$ # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+\bBuild.bat$
+\bBuild.COM$
+\bBUILD.COM$
+\bbuild.com$
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+\.tmp$
+\.#
+\.rej$
+\.swp$
+
+# Avoid OS-specific files/dirs
+# Mac OSX metadata
+\B\.DS_Store
+# Mac OSX SMB mount metadata files
+\B\._
+
+# Avoid Devel::Cover files.
+\bcover_db\b
+#!end included /usr/share/perl5/ExtUtils/MANIFEST.SKIP
+
+# Avoid configuration metadata file
+^MYMETA\.
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\bBuild.bat$
+\b_build
+\bBuild.COM$
+\bBUILD.COM$
+\bbuild.com$
+^MANIFEST\.SKIP
+
+# Avoid archives of this distribution
+\bOpenILS-[\d\.\_]+
--- /dev/null
+---
+abstract: ~
+author: []
+configure_requires:
+ Module::Build: 0.36
+dynamic_config: 0
+generated_by: 'Module::Build version 0.3603'
+license: gpl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: OpenILS
+provides:
+ CQL::BooleanNode:
+ file: lib/OpenILS/WWW/SuperCat.pm
+ CQL::TermNode:
+ file: lib/OpenILS/WWW/SuperCat.pm
+ Class::DBI:
+ file: lib/OpenILS/Application/Storage/FTS.pm
+ Fieldmapper:
+ file: lib/OpenILS/Utils/Fieldmapper.pm
+ MFHD:
+ file: lib/OpenILS/Utils/MFHD.pm
+ MFHD::Caption:
+ file: lib/OpenILS/Utils/MFHD/Caption.pm
+ MFHD::Date:
+ file: lib/OpenILS/Utils/MFHD/Date.pm
+ MFHD::Holding:
+ file: lib/OpenILS/Utils/MFHD/Holding.pm
+ OpenILS:
+ file: lib/OpenILS.pm
+ version: 2.00
+ OpenILS::Application:
+ file: lib/OpenILS/Application.pm
+ OpenILS::Application::Acq:
+ file: lib/OpenILS/Application/Acq.pm
+ OpenILS::Application::Acq::BatchManager:
+ file: lib/OpenILS/Application/Acq/Order.pm
+ OpenILS::Application::Acq::Claims:
+ file: lib/OpenILS/Application/Acq/Claims.pm
+ OpenILS::Application::Acq::EDI:
+ file: lib/OpenILS/Application/Acq/EDI.pm
+ OpenILS::Application::Acq::EDI::Translator:
+ file: lib/OpenILS/Application/Acq/EDI/Translator.pm
+ OpenILS::Application::Acq::Financials:
+ file: lib/OpenILS/Application/Acq/Financials.pm
+ OpenILS::Application::Acq::Invoice:
+ file: lib/OpenILS/Application/Acq/Invoice.pm
+ OpenILS::Application::Acq::Lineitem:
+ file: lib/OpenILS/Application/Acq/Lineitem.pm
+ OpenILS::Application::Acq::Order:
+ file: lib/OpenILS/Application/Acq/Order.pm
+ OpenILS::Application::Acq::Picklist:
+ file: lib/OpenILS/Application/Acq/Picklist.pm
+ OpenILS::Application::Acq::Provider:
+ file: lib/OpenILS/Application/Acq/Provider.pm
+ OpenILS::Application::Acq::Search:
+ file: lib/OpenILS/Application/Acq/Search.pm
+ OpenILS::Application::Actor:
+ file: lib/OpenILS/Application/Actor.pm
+ OpenILS::Application::Actor::ClosedDates:
+ file: lib/OpenILS/Application/Actor/ClosedDates.pm
+ OpenILS::Application::Actor::Container:
+ file: lib/OpenILS/Application/Actor/Container.pm
+ OpenILS::Application::Actor::Friends:
+ file: lib/OpenILS/Application/Actor/Friends.pm
+ OpenILS::Application::Actor::Stage:
+ file: lib/OpenILS/Application/Actor/Stage.pm
+ OpenILS::Application::Actor::UserGroups:
+ file: lib/OpenILS/Application/Actor/UserGroups.pm
+ OpenILS::Application::AppUtils:
+ file: lib/OpenILS/Application/AppUtils.pm
+ OpenILS::Application::Booking:
+ file: lib/OpenILS/Application/Booking.pm
+ OpenILS::Application::Cat:
+ file: lib/OpenILS/Application/Cat.pm
+ OpenILS::Application::Cat::AssetCommon:
+ file: lib/OpenILS/Application/Cat/AssetCommon.pm
+ OpenILS::Application::Cat::AuthCommon:
+ file: lib/OpenILS/Application/Cat/AuthCommon.pm
+ OpenILS::Application::Cat::Authority:
+ file: lib/OpenILS/Application/Cat/Authority.pm
+ OpenILS::Application::Cat::BibCommon:
+ file: lib/OpenILS/Application/Cat/BibCommon.pm
+ OpenILS::Application::Cat::Merge:
+ file: lib/OpenILS/Application/Cat/Merge.pm
+ OpenILS::Application::Circ:
+ file: lib/OpenILS/Application/Circ.pm
+ OpenILS::Application::Circ::CircCommon:
+ file: lib/OpenILS/Application/Circ/CircCommon.pm
+ OpenILS::Application::Circ::Circulate:
+ file: lib/OpenILS/Application/Circ/Circulate.pm
+ OpenILS::Application::Circ::Circulator:
+ file: lib/OpenILS/Application/Circ/Circulate.pm
+ OpenILS::Application::Circ::CopyLocations:
+ file: lib/OpenILS/Application/Circ/CopyLocations.pm
+ OpenILS::Application::Circ::CreditCard:
+ file: lib/OpenILS/Application/Circ/CreditCard.pm
+ OpenILS::Application::Circ::HoldNotify:
+ file: lib/OpenILS/Application/Circ/HoldNotify.pm
+ OpenILS::Application::Circ::Holds:
+ file: lib/OpenILS/Application/Circ/Holds.pm
+ OpenILS::Application::Circ::Money:
+ file: lib/OpenILS/Application/Circ/Money.pm
+ OpenILS::Application::Circ::NonCat:
+ file: lib/OpenILS/Application/Circ/NonCat.pm
+ OpenILS::Application::Circ::ScriptBuilder:
+ file: lib/OpenILS/Application/Circ/ScriptBuilder.pm
+ OpenILS::Application::Circ::StatCat:
+ file: lib/OpenILS/Application/Circ/StatCat.pm
+ OpenILS::Application::Circ::Survey:
+ file: lib/OpenILS/Application/Circ/Survey.pm
+ OpenILS::Application::Circ::Transit:
+ file: lib/OpenILS/Application/Circ/Transit.pm
+ OpenILS::Application::Collections:
+ file: lib/OpenILS/Application/Collections.pm
+ OpenILS::Application::Fielder:
+ file: lib/OpenILS/Application/Fielder.pm
+ OpenILS::Application::Ingest:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Ingest::Authority:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Ingest::Biblio:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Ingest::Biblio::Fingerprint:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Ingest::Biblio::URI:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Ingest::FlatMARC:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Ingest::XPATH:
+ file: lib/OpenILS/Application/Ingest.pm
+ OpenILS::Application::Penalty:
+ file: lib/OpenILS/Application/Penalty.pm
+ OpenILS::Application::PermaCrud:
+ file: lib/OpenILS/Application/PermaCrud.pm
+ OpenILS::Application::Proxy:
+ file: lib/OpenILS/Application/Proxy.pm
+ OpenILS::Application::Reporter:
+ file: lib/OpenILS/Application/Reporter.pm
+ OpenILS::Application::ResolverResolver:
+ file: lib/OpenILS/Application/ResolverResolver.pm
+ OpenILS::Application::Search:
+ file: lib/OpenILS/Application/Search.pm
+ OpenILS::Application::Search::AddedContent:
+ file: lib/OpenILS/Application/Search/AddedContent.pm
+ OpenILS::Application::Search::Authority:
+ file: lib/OpenILS/Application/Search/Authority.pm
+ OpenILS::Application::Search::Biblio:
+ file: lib/OpenILS/Application/Search/Biblio.pm
+ OpenILS::Application::Search::CNBrowse:
+ file: lib/OpenILS/Application/Search/CNBrowse.pm
+ OpenILS::Application::Search::Serial:
+ file: lib/OpenILS/Application/Search/Serial.pm
+ OpenILS::Application::Search::Z3950:
+ file: lib/OpenILS/Application/Search/Z3950.pm
+ OpenILS::Application::Search::Zips:
+ file: lib/OpenILS/Application/Search/Zips.pm
+ OpenILS::Application::Serial:
+ file: lib/OpenILS/Application/Serial.pm
+ OpenILS::Application::Storage:
+ file: lib/OpenILS/Application/Storage.pm
+ OpenILS::Application::Storage::CDBI:
+ file: lib/OpenILS/Application/Storage/CDBI.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::action:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::actor:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::asset:
+ file: lib/OpenILS/Application/Storage/CDBI/asset.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::authority:
+ file: lib/OpenILS/Application/Storage/CDBI/authority.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::biblio:
+ file: lib/OpenILS/Application/Storage/CDBI/biblio.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::booking:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::config:
+ file: lib/OpenILS/Application/Storage/CDBI/config.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::container:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::metabib:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::money:
+ file: lib/OpenILS/Application/Storage/CDBI/money.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::permission:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ version: 1
+ OpenILS::Application::Storage::CDBI::serial:
+ file: lib/OpenILS/Application/Storage/CDBI/serial.pm
+ version: 1
+ OpenILS::Application::Storage::Driver::Pg:
+ file: lib/OpenILS/Application/Storage/Driver/Pg.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::facet:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::filter:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::modifier:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::node:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::node::atom:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/QueryParser.pm
+ OpenILS::Application::Storage::FTS:
+ file: lib/OpenILS/Application/Storage/FTS.pm
+ OpenILS::Application::Storage::Publisher:
+ file: lib/OpenILS/Application/Storage/Publisher.pm
+ version: 1
+ OpenILS::Application::Storage::Publisher::action:
+ file: lib/OpenILS/Application/Storage/Publisher/action.pm
+ OpenILS::Application::Storage::Publisher::actor:
+ file: lib/OpenILS/Application/Storage/Publisher/actor.pm
+ OpenILS::Application::Storage::Publisher::asset:
+ file: lib/OpenILS/Application/Storage/Publisher/asset.pm
+ OpenILS::Application::Storage::Publisher::authority:
+ file: lib/OpenILS/Application/Storage/Publisher/authority.pm
+ version: 1
+ OpenILS::Application::Storage::Publisher::biblio:
+ file: lib/OpenILS/Application/Storage/Publisher/biblio.pm
+ version: 1
+ OpenILS::Application::Storage::Publisher::config:
+ file: lib/OpenILS/Application/Storage/Publisher/config.pm
+ OpenILS::Application::Storage::Publisher::container:
+ file: lib/OpenILS/Application/Storage/Publisher/container.pm
+ OpenILS::Application::Storage::Publisher::metabib:
+ file: lib/OpenILS/Application/Storage/Publisher/metabib.pm
+ version: 1
+ OpenILS::Application::Storage::Publisher::money:
+ file: lib/OpenILS/Application/Storage/Publisher/money.pm
+ OpenILS::Application::Storage::Publisher::permission:
+ file: lib/OpenILS/Application/Storage/Publisher/permission.pm
+ OpenILS::Application::SuperCat:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::acn:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::acp:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::auri:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sbsum:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::scap:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sdist:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::siss:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sisum:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sitem:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sssum:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sstr:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::ssub:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::ssum_base:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::SuperCat::unAPI::sunit:
+ file: lib/OpenILS/Application/SuperCat.pm
+ OpenILS::Application::Trigger:
+ file: lib/OpenILS/Application/Trigger.pm
+ OpenILS::Application::Trigger::Cleanup:
+ file: lib/OpenILS/Application/Trigger/Cleanup.pm
+ OpenILS::Application::Trigger::Collector:
+ file: lib/OpenILS/Application/Trigger/Collector.pm
+ OpenILS::Application::Trigger::Event:
+ file: lib/OpenILS/Application/Trigger/Event.pm
+ OpenILS::Application::Trigger::EventGroup:
+ file: lib/OpenILS/Application/Trigger/EventGroup.pm
+ OpenILS::Application::Trigger::ModLoader:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::ModRunner:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::ModRunner::Cleanup:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::ModRunner::Collector:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::ModRunner::Reactor:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::ModRunner::Validator:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::ModStackRunner:
+ file: lib/OpenILS/Application/Trigger/ModRunner.pm
+ OpenILS::Application::Trigger::Reactor:
+ file: lib/OpenILS/Application/Trigger/Reactor.pm
+ OpenILS::Application::Trigger::Reactor::ApplyCircFee:
+ file: lib/OpenILS/Application/Trigger/Reactor/ApplyCircFee.pm
+ OpenILS::Application::Trigger::Reactor::ApplyPatronPenalty:
+ file: lib/OpenILS/Application/Trigger/Reactor/ApplyPatronPenalty.pm
+ OpenILS::Application::Trigger::Reactor::AstCall:
+ file: lib/OpenILS/Application/Trigger/Reactor/AstCall.pm
+ OpenILS::Application::Trigger::Reactor::GeneratePurchaseOrderJEDI:
+ file: lib/OpenILS/Application/Trigger/Reactor/GeneratePurchaseOrderJEDI.pm
+ OpenILS::Application::Trigger::Reactor::MarkItemLost:
+ file: lib/OpenILS/Application/Trigger/Reactor/MarkItemLost.pm
+ OpenILS::Application::Trigger::Reactor::ProcessTemplate:
+ file: lib/OpenILS/Application/Trigger/Reactor/ProcessTemplate.pm
+ OpenILS::Application::Trigger::Reactor::SendEmail:
+ file: lib/OpenILS/Application/Trigger/Reactor/SendEmail.pm
+ OpenILS::Application::Trigger::Reactor::SendFile:
+ file: lib/OpenILS/Application/Trigger/Reactor/SendFile.pm
+ OpenILS::Application::Trigger::Reactor::StaticEmail:
+ file: lib/OpenILS/Application/Trigger/Reactor/StaticEmail.pm
+ OpenILS::Application::Trigger::Validator:
+ file: lib/OpenILS/Application/Trigger/Validator.pm
+ OpenILS::Application::Trigger::Validator::Acq:
+ file: lib/OpenILS/Application/Trigger/Validator/Acq.pm
+ OpenILS::Application::Trigger::Validator::Acq::PurchaseOrderEDIRequired:
+ file: lib/OpenILS/Application/Trigger/Validator/Acq/PurchaseOrderEDIRequired.pm
+ OpenILS::Application::Trigger::Validator::Acq::UserRequestCancelled:
+ file: lib/OpenILS/Application/Trigger/Validator/Acq/UserRequestCancelled.pm
+ OpenILS::Application::Trigger::Validator::Acq::UserRequestOrdered:
+ file: lib/OpenILS/Application/Trigger/Validator/Acq/UserRequestOrdered.pm
+ OpenILS::Application::Trigger::Validator::Acq::UserRequestReceived:
+ file: lib/OpenILS/Application/Trigger/Validator/Acq/UserRequestReceived.pm
+ OpenILS::Application::Vandelay:
+ file: lib/OpenILS/Application/Vandelay.pm
+ OpenILS::Const:
+ file: lib/OpenILS/Const.pm
+ OpenILS::Event:
+ file: lib/OpenILS/Event.pm
+ OpenILS::Perm:
+ file: lib/OpenILS/Perm.pm
+ OpenILS::Reporter::Proxy:
+ file: lib/OpenILS/Reporter/Proxy.pm
+ OpenILS::Reporter::SQLBuilder:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Having:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::OrderBy:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Select:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::Bare:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::GenericTransform:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::age:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::average:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::count:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::count_distinct:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::date_trunc:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::day_name:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::dom:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::dow:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::doy:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::first:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::hod:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::hour_trunc:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::last:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::lower:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::max:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::min:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::month_name:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::month_trunc:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::months_ago:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::moy:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::qoy:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::quarter:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::quarters_ago:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::substring:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::sum:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::upper:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::woy:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Transform::year_trunc:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Column::Where:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::Bare:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::GenericTransform:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::NULL:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::age:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::relative_date:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::relative_month:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::relative_week:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Input::Transform::relative_year:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Join:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Join::cross:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Join::inner:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Join::left:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Join::right:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::Relation:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::Reporter::SQLBuilder::ResultSet:
+ file: lib/OpenILS/Reporter/SQLBuilder.pm
+ OpenILS::SIP:
+ file: lib/OpenILS/SIP.pm
+ OpenILS::SIP::Item:
+ file: lib/OpenILS/SIP/Item.pm
+ OpenILS::SIP::Msg:
+ file: lib/OpenILS/SIP/Msg.pm
+ OpenILS::SIP::Patron:
+ file: lib/OpenILS/SIP/Patron.pm
+ OpenILS::SIP::Transaction:
+ file: lib/OpenILS/SIP/Transaction.pm
+ OpenILS::SIP::Transaction::Checkin:
+ file: lib/OpenILS/SIP/Transaction/Checkin.pm
+ OpenILS::SIP::Transaction::Checkout:
+ file: lib/OpenILS/SIP/Transaction/Checkout.pm
+ OpenILS::SIP::Transaction::Renew:
+ file: lib/OpenILS/SIP/Transaction/Renew.pm
+ OpenILS::Template::Plugin::Unicode:
+ file: lib/OpenILS/Template/Plugin/Unicode.pm
+ OpenILS::Template::Plugin::WebSession:
+ file: lib/OpenILS/Template/Plugin/WebSession.pm
+ OpenILS::Template::Plugin::WebUtils:
+ file: lib/OpenILS/Template/Plugin/WebUtils.pm
+ OpenILS::Utils::CStoreEditor:
+ file: lib/OpenILS/Utils/CStoreEditor.pm
+ OpenILS::Utils::Cronscript:
+ file: lib/OpenILS/Utils/Cronscript.pm
+ OpenILS::Utils::Editor:
+ file: lib/OpenILS/Utils/Editor.pm
+ OpenILS::Utils::ISBN:
+ file: lib/OpenILS/Utils/ISBN.pm
+ version: 0.01
+ OpenILS::Utils::Lockfile:
+ file: lib/OpenILS/Utils/Lockfile.pm
+ OpenILS::Utils::MFHDParser:
+ file: lib/OpenILS/Utils/MFHDParser.pm
+ OpenILS::Utils::ModsParser:
+ file: lib/OpenILS/Utils/ModsParser.pm
+ OpenILS::Utils::Normalize:
+ file: lib/OpenILS/Utils/Normalize.pm
+ OpenILS::Utils::OfflineStore:
+ file: lib/OpenILS/Utils/OfflineStore.pm
+ OpenILS::Utils::OfflineStore::Script:
+ file: lib/OpenILS/Utils/OfflineStore.pm
+ OpenILS::Utils::OfflineStore::Session:
+ file: lib/OpenILS/Utils/OfflineStore.pm
+ OpenILS::Utils::Penalty:
+ file: lib/OpenILS/Utils/Penalty.pm
+ OpenILS::Utils::PermitHold:
+ file: lib/OpenILS/Utils/PermitHold.pm
+ OpenILS::Utils::RemoteAccount:
+ file: lib/OpenILS/Utils/RemoteAccount.pm
+ OpenILS::Utils::ScriptRunner:
+ file: lib/OpenILS/Utils/ScriptRunner.pm
+ OpenILS::Utils::SpiderMonkey:
+ file: lib/OpenILS/Utils/SpiderMonkey.pm
+ OpenILS::Utils::ZClient:
+ file: lib/OpenILS/Utils/ZClient.pm
+ OpenILS::Utils::ZClient::Record:
+ file: lib/OpenILS/Utils/ZClient.pm
+ OpenILS::Utils::ZClient::ResultSet:
+ file: lib/OpenILS/Utils/ZClient.pm
+ OpenILS::WWW::AddedContent:
+ file: lib/OpenILS/WWW/AddedContent.pm
+ OpenILS::WWW::AddedContent::Amazon:
+ file: lib/OpenILS/WWW/AddedContent/Amazon.pm
+ OpenILS::WWW::AddedContent::ContentCafe:
+ file: lib/OpenILS/WWW/AddedContent/ContentCafe.pm
+ OpenILS::WWW::AddedContent::OpenLibrary:
+ file: lib/OpenILS/WWW/AddedContent/OpenLibrary.pm
+ OpenILS::WWW::AddedContent::Syndetic:
+ file: lib/OpenILS/WWW/AddedContent/Syndetic.pm
+ OpenILS::WWW::BadDebt:
+ file: lib/OpenILS/WWW/BadDebt.pm
+ OpenILS::WWW::EGWeb:
+ file: lib/OpenILS/WWW/EGWeb.pm
+ OpenILS::WWW::Exporter:
+ file: lib/OpenILS/WWW/Exporter.pm
+ OpenILS::WWW::IDL2js:
+ file: lib/OpenILS/WWW/IDL2js.pm
+ OpenILS::WWW::Method:
+ file: lib/OpenILS/WWW/Method.pm
+ OpenILS::WWW::PasswordReset:
+ file: lib/OpenILS/WWW/PasswordReset.pm
+ OpenILS::WWW::Proxy:
+ file: lib/OpenILS/WWW/Proxy.pm
+ OpenILS::WWW::Redirect:
+ file: lib/OpenILS/WWW/Redirect.pm
+ OpenILS::WWW::Reporter:
+ file: lib/OpenILS/WWW/Reporter.pm
+ OpenILS::WWW::SuperCat:
+ file: lib/OpenILS/WWW/SuperCat.pm
+ OpenILS::WWW::SuperCat::Feed:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::atom:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::atom::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::html:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::html::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::htmlcard:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::htmlcard::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::htmlholdings:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::htmlholdings::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::marctxt:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::marctxt::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::marcxml:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::marcxml::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods3:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods32:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods32::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods33:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods33::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods3::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::mods::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::ris:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::ris::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::rss2:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::SuperCat::Feed::rss2::item:
+ file: lib/OpenILS/WWW/SuperCat/Feed.pm
+ OpenILS::WWW::TemplateBatchBibUpdate:
+ file: lib/OpenILS/WWW/TemplateBatchBibUpdate.pm
+ OpenILS::WWW::Vandelay:
+ file: lib/OpenILS/WWW/Vandelay.pm
+ OpenILS::WWW::Web:
+ file: lib/OpenILS/WWW/Web.pm
+ OpenILS::WWW::XMLRPCGateway:
+ file: lib/OpenILS/WWW/XMLRPCGateway.pm
+ PathConfig:
+ file: lib/OpenILS/WWW/EGWeb.pm
+ QueryParser:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ QueryParser::query_plan:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ QueryParser::query_plan::facet:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ QueryParser::query_plan::filter:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ QueryParser::query_plan::modifier:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ QueryParser::query_plan::node:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ QueryParser::query_plan::node::atom:
+ file: lib/OpenILS/Application/Storage/QueryParser.pm
+ action:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::circulation:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::hold_copy_map:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::hold_notification:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::hold_request:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::hold_transit_copy:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::in_house_use:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::non_cat_in_house_use:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::non_cataloged_circulation:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::open_circulation:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::reservation_transit_copy:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::survey:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::survey_answer:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::survey_question:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::survey_response:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::transit_copy:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ action::unfulfilled_hold_list:
+ file: lib/OpenILS/Application/Storage/CDBI/action.pm
+ actor:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ actor::card:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_address:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_unit:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_unit::closed_date:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_unit::hours_of_operation:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_unit_proximity:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_unit_setting:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::org_unit_type:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::perm_group:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ actor::perm_group_permission_map:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ actor::perm_group_user_map:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ actor::permission:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ actor::stat_cat:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::stat_cat_entry:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::stat_cat_entry_user_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::user:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::user_access_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/actor.pm
+ actor::user_address:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::user_setting:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::user_standing_penalty:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::usr_note:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::usr_org_unit_opt_in:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ actor::workstation:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset:
+ file: lib/OpenILS/Application/Storage/CDBI/asset.pm
+ asset::call_number:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::call_number_class:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::call_number_note:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::copy:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::copy_location:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::copy_location_order:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::copy_note:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::stat_cat:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::stat_cat_entry:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ asset::stat_cat_entry_copy_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ authority:
+ file: lib/OpenILS/Application/Storage/CDBI/authority.pm
+ authority::full_rec:
+ file: lib/OpenILS/Application/Storage/CDBI/authority.pm
+ authority::record_descriptor:
+ file: lib/OpenILS/Application/Storage/CDBI/authority.pm
+ authority::record_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/authority.pm
+ authority::record_note:
+ file: lib/OpenILS/Application/Storage/CDBI/authority.pm
+ biblio:
+ file: lib/OpenILS/Application/Storage/CDBI/biblio.pm
+ biblio::record_entry:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ biblio::record_note:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ booking:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ booking::reservation:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ booking::reservation_attr_value_map:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ booking::resource:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ booking::resource_attr_map:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ booking::resource_type:
+ file: lib/OpenILS/Application/Storage/CDBI/booking.pm
+ config:
+ file: lib/OpenILS/Application/Storage/CDBI/config.pm
+ config::audience_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::bib_source:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::copy_status:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::i18n_core:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::i18n_locale:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::identification_type:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::item_form_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::item_type_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::language_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::lit_form_map:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::metabib_field:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::net_access_level:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::non_cataloged_type:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::rules::age_hold_protect:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::rules::circ_duration:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::rules::max_fine:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::rules::recurring_fine:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ config::standing:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ container:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::biblio_record_entry_bucket:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::biblio_record_entry_bucket_item:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::call_number_bucket:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::call_number_bucket_item:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::copy_bucket:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::copy_bucket_item:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::user_bucket:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ container::user_bucket_item:
+ file: lib/OpenILS/Application/Storage/CDBI/container.pm
+ metabib:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::author_field_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::full_rec:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::identifier_field_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::keyword_field_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::metarecord:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::metarecord_source_map:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::record_descriptor:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::series_field_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::subject_field_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ metabib::title_field_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/metabib.pm
+ money:
+ file: lib/OpenILS/Application/Storage/CDBI/money.pm
+ money::billable_transaction:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::billable_transaction_summary:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::billing:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::cash_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::check_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::collections_tracker:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::credit_card_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::credit_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::desk_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::forgive_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::goods_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::grocery:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::open_billable_transaction_summary:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::open_user_circulation_summary:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::open_user_summary:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::user_circulation_summary:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::user_summary:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ money::work_payment:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ permission:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ permission::grp_perm_map:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ permission::grp_tree:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ permission::perm_list:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ permission::usr_grp_map:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ permission::usr_perm_map:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ permission::usr_work_ou_map:
+ file: lib/OpenILS/Application/Storage/CDBI/permission.pm
+ serial:
+ file: lib/OpenILS/Application/Storage/CDBI/serial.pm
+ serial::issuance:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ serial::item:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ serial::record_entry:
+ file: lib/OpenILS/Application/Storage/CDBI/serial.pm
+ serial::subscription:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ serial::unit:
+ file: lib/OpenILS/Application/Storage/Driver/Pg/dbi.pm
+ testlib:
+ file: lib/OpenILS/Utils/MFHD/test/testlib.pm
+requires:
+ APR::Const: 0
+ APR::Table: 0
+ Apache2::Const: 0
+ Apache2::Log: 0
+ Apache2::RequestIO: 0
+ Apache2::RequestRec: 0
+ Apache2::RequestUtil: 0
+ Business::CreditCard: 0
+ Business::EDI: 0
+ Business::ISBN: 0
+ Business::OnlinePayment: 0
+ CGI: 0
+ Carp: 0
+ Class::DBI: 0
+ Class::DBI::AbstractSearch: 0
+ DBI: 0
+ Data::Dumper: 0
+ DateTime: 0
+ DateTime::Format::ISO8601: 0
+ DateTime::Format::Mail: 0
+ DateTime::Format::Strptime: 0
+ DateTime::Set: 0
+ DateTime::SpanSet: 0
+ Digest::MD5: 0
+ Email::Send: 0
+ Encode: 0
+ Error: 0
+ Exporter: 0
+ File::Basename: 0
+ File::Spec: 0
+ File::Temp: 0
+ File::stat: 0
+ Getopt::Long: 0
+ IO::Scalar: 0
+ JavaScript::SpiderMonkey: 0
+ LWP::UserAgent: 0
+ List::Util: 0
+ Locale::Country: 0
+ MARC::Batch: 0
+ MARC::Field: 0
+ MARC::File::XML: 0
+ MARC::Record: 0
+ MIME::Base64: 0
+ Net::FTP: 0
+ Net::SSH2: 0
+ OpenSRF::AppSession: 0
+ OpenSRF::Application: 0
+ OpenSRF::EX: 0
+ OpenSRF::MultiSession: 0
+ OpenSRF::System: 0
+ OpenSRF::Utils: 0
+ OpenSRF::Utils::Cache: 0
+ OpenSRF::Utils::Config: 0
+ OpenSRF::Utils::JSON: 0
+ OpenSRF::Utils::Logger: 0
+ OpenSRF::Utils::SettingsClient: 0
+ OpenSRF::Utils::SettingsParser: 0
+ POSIX: 0
+ Parse::RecDescent: 0
+ RPC::XML: 0
+ RPC::XML::Client: 0
+ RPC::XML::Function: 0
+ RPC::XML::Method: 0
+ RPC::XML::Parser: 0
+ RPC::XML::Procedure: 0
+ SRU::Request: 0
+ SRU::Response: 0
+ Safe: 0
+ Scalar::Util: 0
+ Socket: 0
+ Sys::Syslog: 0
+ Template: 0
+ Template::Plugin: 0
+ Test::More: 0
+ Text::Aspell: 0
+ Text::CSV: 0
+ Text::Glob: 0
+ Time::HiRes: 0
+ Time::Local: 0
+ UNIVERSAL::require: 0
+ UUID::Tiny: 0
+ Unicode::Normalize: 0
+ XML::LibXML: 0
+ XML::LibXML::XPathContext: 0
+ XML::LibXSLT: 0
+ XML::Simple: 0
+resources:
+ license: http://opensource.org/licenses/gpl-license.php
+version: 2.00
--- /dev/null
+# Copyright (C) 2009 Equinox Software, Inc.
+# Shawn Boyette <sboyette@esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+CLEANFILES = Build
+DISTCLEANFILES = Makefile.in Makefile
+
+all:
+ perl Build.PL || make -s build-perl-fail
+ ./Build || make -s build-perl-fail
+
+check:
+ ./Build test || make -s build-perl-fail
+
+install:
+ ./Build install
+
+build-perl-fail:
+ echo
+ echo ">>> Build/test of Perl modules has failed. The most likely"
+ echo ">>> possibility is that a dependency is not pre-installed"
+ echo ">>> or that a test has failed."
+ echo ">>> See the messages above this one for more information."
+ echo
+ exit 1
+
+install-perl-fail:
+ echo
+ echo ">>> Install of Perl modules has failed."
+ echo ">>> Are you root?"
+ echo ">>> See the message above this one for more information."
+ echo
+
+distclean-local:
+ rm -rf ./_build
+ rm -rf ./blib
\ No newline at end of file
+++ /dev/null
-package OpenILS::Application;
-use OpenSRF::Application;
-use UNIVERSAL::require;
-use base qw/OpenSRF::Application/;
-
-sub ils_version {
- # version format is "x-y-z", for example "2-0-0" for Evergreen 2.0.0
- # For branches, format is "x-y"
- return "HEAD";
-}
-
-__PACKAGE__->register_method(
- api_name => 'opensrf.open-ils.system.ils_version',
- api_level => 1,
- method => 'ils_version',
-);
-
-__PACKAGE__->register_method(
- api_name => 'opensrf.open-ils.fetch_idl.file',
- api_level => 1,
- method => 'get_idl_file',
-);
-sub get_idl_file {
- use OpenSRF::Utils::SettingsClient;
- return OpenSRF::Utils::SettingsClient->new->config_value('IDL');
-}
-
-sub register_method {
- my $class = shift;
- my %args = @_;
- my %dup_args = %args;
-
- $class = ref($class) || $class;
-
- $args{package} ||= $class;
- __PACKAGE__->SUPER::register_method( %args );
-
- if (exists($dup_args{authoritative}) and $dup_args{authoritative}) {
- (my $name = $dup_args{api_name}) =~ s/$/.authoritative/o;
- if ($name ne $dup_args{api_name}) {
- $dup_args{real_api_name} = $dup_args{api_name};
- $dup_args{method} = 'authoritative_wrapper';
- $dup_args{api_name} = $name;
- $dup_args{package} = __PACKAGE__;
- __PACKAGE__->SUPER::register_method( %dup_args );
- }
- }
-}
-
-sub authoritative_wrapper {
-
- if (!$OpenILS::Utils::CStoreEditor::_loaded) {
- die "Couldn't load OpenILS::Utils::CStoreEditor!" unless 'OpenILS::Utils::CStoreEditor'->use;
- }
-
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my $method = $self->method_lookup($self->{real_api_name});
- die unless $method;
-
- local $OpenILS::Utils::CStoreEditor::always_xact = 1;
-
- $client->respond( $_ ) for ( $method->run(@args) );
-
- OpenILS::Utils::CStoreEditor->flush_forced_xacts();
-
- return undef;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Acq;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenILS::Application::Acq::Picklist;
-use OpenILS::Application::Acq::Financials;
-use OpenILS::Application::Acq::Provider;
-use OpenILS::Application::Acq::Lineitem;
-use OpenILS::Application::Acq::Order;
-use OpenILS::Application::Acq::EDI;
-use OpenILS::Application::Acq::Search;
-use OpenILS::Application::Acq::Claims;
-use OpenILS::Application::Acq::Invoice;
-
-1;
+++ /dev/null
-package OpenILS::Application::Acq::Claims;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Event;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-__PACKAGE__->register_method(
- method => 'claim_ready_items',
- api_name => 'open-ils.acq.claim.eligible.lineitem_detail',
- stream => 1,
- signature => {
- desc => q/Locates lineitem_details that are eligible for claiming/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- { desc => q/
- Filter object. Filter keys include
- purchase_order
- lineitem
- lineitem_detail
- claim_policy_action
- ordering_agency
- /,
- type => 'object'
- },
- { desc => q/
- Flesh fields. Which fields to flesh on the response object.
- For valid options, see the filter object
- q/,
- type => 'array'
- }
- ],
- return => {desc => 'Claim ready data', type => 'object', class => 'acrlid'}
- }
-);
-
-sub claim_ready_items {
- my($self, $conn, $auth, $filters, $flesh_fields, $limit, $offset) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- $filters ||= {};
- $flesh_fields ||= [];
- $limit ||= 50;
- $offset ||= 0;
-
- if(defined $filters->{ordering_agency}) {
- return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $filters->{ordering_agency});
- } else {
- $filters->{ordering_agency} = $U->user_has_work_perm_at($e, 'VIEW_PURCHASE_ORDER', {descendants => 1});
- }
-
- my $items = $e->search_acq_claim_ready_lineitem_detail([$filters, {limit => $limit, offset => $offset}]);
-
- my %cache;
- for my $item (@$items) {
-
- # flesh from the flesh fields, using the cache when we can
- foreach (@$flesh_fields) {
- my $retrieve = "retrieve_acq_${_}";
- $cache{$_} = {} unless $cache{$_};
- $item->$_(
- $cache{$_}{$item->$_} ||
- ($cache{$_}{$item->$_} = $e->$retrieve($item->$_))
- );
- }
-
- $conn->respond($item);
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "claim_item",
- api_name => "open-ils.acq.claim.lineitem",
- stream => 1,
- signature => {
- desc => q/Initiates a claim for a lineitem/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Lineitem ID", type => "number"},
- {desc => q/Claim (acqcl) ID. If defined, attach new claim
- events to this existing claim object/, type => "number"},
- {desc => q/Claim Type (acqclt) ID. If defined (and no claim is
- defined), create a new claim with this type/, type => "number"},
- {desc => "Note for the claim event", type => "string"},
- {desc => q/Optional: Claim Policy Actions. If not present,
- claim events for all eligible claim policy actions will be
- created. This is an array of acqclpa IDs./,
- type => "array"},
- ],
- return => {
- desc => "The claim voucher events on success, Event on error",
- type => "object", class => "acrlid"
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'claim_item',
- api_name => 'open-ils.acq.claim.lineitem_detail',
- stream => 1,
- signature => {
- desc => q/Initiates a claim for an individual lineitem_detail/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Lineitem Detail ID', type => 'number'},
- {desc => 'Claim (acqcl) ID. If defined, attach new claim events to this existing claim object', type => 'number'},
- {desc => 'Claim Type (acqclt) ID. If defined (and no claim is defined), create a new claim with this type', type => 'number'},
- {desc => "Note for the claim event", type => "string"},
- { desc => q/
-
- Optional: Claim Policy Actions. If not present, claim events
- for all eligible claim policy actions will be created. This is
- an array of acqclpa ID's.
- /,
- type => 'array'
- },
- { desc => q/
- Optional: Claim Event Types. If present, we bypass any policy configuration
- and use the specified event types. This is useful for manual claiming against
- items that have no claim policy.
- /,
- type => 'array'
- }
- ],
- return => {
- desc => "The claim voucher events on success, Event on error",
- type => "object", class => "acrlid"
- }
- }
-);
-
-sub claim_item {
- my $self = shift;
- my $conn = shift;
- my $auth = shift;
- my $object_id = shift;
- my $claim_id = shift;
- my $claim_type_id = shift;
- my $note = shift;
- my $policy_actions = shift;
-
- # if this claim occurs outside of a policy, allow the caller to specificy the event type
- my $claim_event_types = shift;
-
- my $e = new_editor(xact => 1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- my $evt;
- my $claim;
- my $claim_type;
- my $claim_events = {
- events => [],
- trigger_stuff => []
- };
-
- my $lid_flesh = {
- "flesh" => 2,
- "flesh_fields" => {
- "acqlid" => ["lineitem"], "jub" => ["purchase_order"],
- }
- };
-
- if($claim_id) {
- $claim = $e->retrieve_acq_claim($claim_id) or return $e->die_event;
- } elsif($claim_type_id) {
- $claim_type = $e->retrieve_acq_claim_type($claim_type_id) or return $e->die_event;
- } else {
- $e->rollback;
- return OpenILS::Event->new('BAD_PARAMS');
- }
-
-
- my $lids;
- if($self->api_name =~ /claim.lineitem_detail/) {
-
- $lids = $e->search_acq_lineitem_detail([
- {"id" => $object_id, "cancel_reason" => undef},
- $lid_flesh
- ]) or return $e->die_event;
-
- } elsif($self->api_name =~ /claim.lineitem/) {
- $lids = $e->search_acq_lineitem_detail([
- {"lineitem" => $object_id, "cancel_reason" => undef},
- $lid_flesh
- ]) or return $e->die_event;
- }
-
- foreach my $lid (@$lids) {
- return $evt if
- $evt = claim_lineitem_detail(
- $e, $lid, $claim, $claim_type, $policy_actions,
- $note, $claim_events, $claim_event_types
- );
- }
-
- $e->commit;
-
- # create related A/T events
- $U->create_events_for_hook('claim_event.created', $_->[0], $_->[1]) for @{$claim_events->{trigger_stuff}};
-
- # do voucher rendering and return result
- $conn->respond($U->fire_object_event(
- undef, "format.acqcle.html", $_->[0], $_->[1], "print-on-demand"
- )) foreach @{$claim_events->{trigger_stuff}};
- return undef;
-}
-
-sub claim_lineitem_detail {
- my($e, $lid, $claim, $claim_type, $policy_actions, $note, $claim_events, $claim_event_types) = @_;
-
- # Create the claim object
- unless($claim) {
- $claim = Fieldmapper::acq::claim->new;
- $claim->lineitem_detail($lid->id);
- $claim->type($claim_type->id);
- $e->create_acq_claim($claim) or return $e->die_event;
- }
-
- unless($claim_event_types) {
- # user did not specify explicit event types
-
- unless($policy_actions) {
- # user did not specifcy policy actions. find all eligible.
-
- my $list = $e->json_query({
- select => {acrlid => ['claim_policy_action']},
- from => 'acrlid',
- where => {lineitem_detail => $lid->id}
- });
-
- $policy_actions = [map { $_->{claim_policy_action} } @$list];
- }
-
- # from the set of policy_action's, locate the related event types
- # IOW, the policy action's action
- $claim_event_types = [];
- for my $act_id (@$policy_actions) {
- my $action = $e->retrieve_acq_claim_policy_action($act_id) or return $e->die_event;
- push(@$claim_event_types, $action->action);
- }
- }
-
- # for each eligible (or chosen) policy actions, create a claim_event
- for my $event_type (@$claim_event_types) {
- my $event = Fieldmapper::acq::claim_event->new;
- $event->claim($claim->id);
- $event->type($event_type);
- $event->creator($e->requestor->id);
- $event->note($note);
- $e->create_acq_claim_event($event) or return $e->die_event;
- push(@{$claim_events->{events}}, $event);
- push(@{$claim_events->{trigger_stuff}}, [$event, $lid->lineitem->purchase_order->ordering_agency]);
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "get_claim_voucher_by_lid",
- api_name => "open-ils.acq.claim.voucher.by_lineitem_detail",
- stream => 1,
- signature => {
- desc => q/Retrieve existing claim vouchers by lineitem detail ID/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Lineitem detail ID", type => "number"}
- ],
- return => {
- desc => "Claim ready data", type => "object", class => "atev"
- }
- }
-);
-
-sub get_claim_voucher_by_lid {
- my ($self, $conn, $auth, $lid_id) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $lid = $e->retrieve_acq_lineitem_detail([
- $lid_id, {
- "flesh" => 2,
- "flesh_fields" => {
- "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
- }
- }
- ]);
-
- return $e->die_event unless $e->allowed(
- "VIEW_PURCHASE_ORDER", $lid->lineitem->purchase_order->ordering_agency
- );
-
- my $id_list = $e->json_query({
- "select" => {"atev" => ["id"]},
- "from" => {
- "atev" => {
- "atevdef" => {"field" => "id", "fkey" => "event_def"},
- "acqcle" => {
- "field" => "id", "fkey" => "target",
- "join" => {
- "acqcl" => {
- "field" => "id", "fkey" => "claim",
- "join" => {
- "acqlid" => {
- "fkey" => "lineitem_detail",
- "field" => "id"
- }
- }
- }
- }
- }
- }
- },
- "where" => {
- "-and" => {
- "+atevdef" => {"hook" => "format.acqcle.html"},
- "+acqlid" => {"id" => $lid_id}
- }
- }
- }) or return $e->die_event;
-
- if ($id_list && @$id_list) {
- foreach (@$id_list) {
- $conn->respond(
- $e->retrieve_action_trigger_event([
- $_->{"id"}, {
- "flesh" => 1,
- "flesh_fields" => {"atev" => ["template_output"]}
- }
- ])
- );
- }
- }
-
- $e->disconnect;
- undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Acq::EDI;
-use base qw/OpenILS::Application/;
-
-use strict; use warnings;
-
-use IO::Scalar;
-
-use OpenSRF::AppSession;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenSRF::Utils::JSON;
-
-use OpenILS::Application::Acq::Lineitem;
-use OpenILS::Utils::RemoteAccount;
-use OpenILS::Utils::CStoreEditor q/new_editor/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Application::Acq::EDI::Translator;
-
-use Business::EDI;
-
-use Data::Dumper;
-our $verbose = 0;
-
-sub new {
- my($class, %args) = @_;
- my $self = bless(\%args, $class);
- # $self->{args} = {};
- return $self;
-}
-
-# our $reasons = {}; # cache for acq.cancel_reason rows ?
-
-our $translator;
-
-sub translator {
- return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
-}
-
-my %map = (
- host => 'remote_host',
- username => 'remote_user',
- password => 'remote_password',
- account => 'remote_account',
- # in_dir => 'remote_path', # field_map overrides path with in_dir
- path => 'remote_path',
-);
-
-
-## Just for debugging stuff:
-sub add_a_msg {
- my ($self, $conn) = @_;
- my $e = new_editor(xact=>1);
- my $incoming = Fieldmapper::acq::edi_message->new;
- $incoming->edi("This is content");
- $incoming->account(1);
- $incoming->remote_file('in/some_file.edi');
- $e->create_acq_edi_message($incoming);;
- $e->commit;
-}
-# __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg'); # debugging
-
-__PACKAGE__->register_method(
- method => 'retrieve',
- api_name => 'open-ils.acq.edi.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Fetch incoming message(s) from EDI accounts. ' .
- 'Optional arguments to restrict to one vendor and/or a max number of messages. ' .
- 'Note that messages are not parsed or processed here, just fetched and translated.',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Vendor ID (undef for "all")', type => 'number'},
- {desc => 'Date Inactive Since', type => 'string'},
- {desc => 'Max Messages Retrieved', type => 'number'}
- ],
- return => {
- desc => 'List of new message IDs (empty if none)',
- type => 'array'
- }
- }
-);
-
-sub retrieve_core {
- my ($self, $set, $max, $e, $test) = @_; # $e is a working editor
-
- $e ||= new_editor();
- $set ||= __PACKAGE__->retrieve_vendors($e);
-
- my @return = ();
- my $vcount = 0;
- foreach my $account (@$set) {
- my $count = 0;
- my $server;
- $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host);
- unless ($server = __PACKAGE__->remote_account($account)) { # assignment, not comparison
- $logger->err(sprintf "Failed remote account mapping for %s (%s)", $account->host, $account->id);
- next;
- };
-# my $rf_starter = './'; # default to current dir
- if ($account->in_dir) {
- if ($account->in_dir =~ /\*+.*\//) {
- $logger->err("EDI in_dir has a slash after an asterisk in value: '" . $account->in_dir . "'. Skipping account with indeterminate target dir!");
- next;
- }
-# $rf_starter = $account->in_dir;
-# $rf_starter =~ s/((\/)?[^\/]*)\*+[^\/]*$//; # kill up to the first (possible) slash before the asterisk: keep the preceeding static dir
-# $rf_starter .= '/' if $rf_starter or $2; # recap the dir, or replace leading "/" if there was one (but don't add if empty)
- }
- my @files = ($server->ls({remote_file => ($account->in_dir || './')}));
- my @ok_files = grep {$_ !~ /\/\.?\.$/ and $_ ne '0'} @files;
- $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, $account->in_dir);
- # $server->remote_path(undef);
- foreach my $remote_file (@ok_files) {
- # my $remote_file = $rf_starter . $_;
- my $description = sprintf "%s/%s", $account->host, $remote_file;
-
- # deduplicate vs. acct/filenames already in DB
- my $hits = $e->search_acq_edi_message([
- {
- account => $account->id,
- remote_file => $remote_file,
- status => {'in' => [qw/ processed /]}, # if it never got processed, go ahead and get the new one (try again)
- # create_time => 'NOW() - 60 DAYS', # if we wanted to allow filenames to be reused after a certain time
- # ideally we would also use the date from FTP, but that info isn't available via RemoteAccount
- }
- # { flesh => 1, flesh_fields => {...}, }
- ]);
- if (scalar(@$hits)) {
- $logger->debug("EDI: $remote_file already retrieved. Skipping");
- warn "EDI: $remote_file already retrieved. Skipping";
- next;
- }
-
- ++$count;
- $max and $count > $max and last;
- $logger->info(sprintf "%s of %s targets: %s", $count, scalar(@ok_files), $description);
- print sprintf "%s of %s targets: %s\n", $count, scalar(@ok_files), $description;
- if ($test) {
- push @return, "test_$count";
- next;
- }
- my $content;
- my $io = IO::Scalar->new(\$content);
- unless ( $server->get({remote_file => $remote_file, local_file => $io}) ) {
- $logger->error("(S)FTP get($description) failed");
- next;
- }
- my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id, $e);
-# $server->delete(remote_file => $_); # delete remote copies of saved message
- push @return, $incoming->id;
- }
- }
- return \@return;
-}
-
-# my $in = OpenILS::Application::Acq::EDI->process_retrieval($file_content, $remote_filename, $server, $account_id, $editor);
-
-sub process_retrieval {
- my $incoming = Fieldmapper::acq::edi_message->new;
- my ($class, $content, $remote, $server, $account_or_id, $e) = @_;
- $content or return;
- $e ||= new_editor;
-
- my $account = __PACKAGE__->record_activity( $account_or_id, $e );
-
- my $z; # must predeclare
- $z = ( $content =~ s/('UNH\+\d+\+ORDRSP:)0(:96A:UN')/$1D$2/g )
- and $logger->warn("Patching bogus spec reference ORDRSP:0:96A:UN => ORDRSP:D:96A:UN ($z times)"); # Hack/fix some faulty "0" in (B&T) data
-
- $incoming->remote_file($remote);
- $incoming->account($account->id);
- $incoming->edi($content);
- $incoming->message_type(($content =~ /'UNH\+\d+\+(\S{6}):/) ? $1 : 'ORDRSP'); # cheap sniffing, ORDRSP fallback
- __PACKAGE__->attempt_translation($incoming);
- $e->xact_begin;
- $e->create_acq_edi_message($incoming);
- $e->xact_commit;
- # refresh: send process_jedi the updated row
- $e->xact_begin;
- my $outgoing = $e->retrieve_acq_edi_message($incoming->id); # refresh again!
- $e->xact_rollback;
- my $res = __PACKAGE__->process_jedi($outgoing, $server, $account, $e);
- $e->xact_begin;
- $outgoing = $e->retrieve_acq_edi_message($incoming->id); # refresh again!
- $e->xact_rollback;
- $outgoing->status($res ? 'processed' : 'proc_error');
- if ($res) {
- $e->xact_begin;
- $e->update_acq_edi_message($outgoing);
- $e->xact_commit;
- }
- return $outgoing;
-}
-
-# ->send_core
-# $account is a Fieldmapper object for acq.edi_account row
-# $messageset is an arrayref with acq.edi_message.id values
-# $e is optional editor object
-sub send_core {
- my ($class, $account, $message_ids, $e) = @_; # $e is a working editor
-
- ($account and scalar @$message_ids) or return;
- $e ||= new_editor();
-
- $e->xact_begin;
- my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids;
- $e->xact_rollback;
- my $m_count = scalar(@messageset);
- (scalar(@$message_ids) == $m_count) or
- $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)");
-
- my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host;
- $logger->info("$log_str: $m_count message(s)");
- $m_count or return;
-
- my $server;
- my $server_error;
- unless ($server = __PACKAGE__->remote_account($account, 1)) { # assignment, not comparison
- $logger->error("Failed remote account connection for $log_str");
- $server_error = 1;
- };
- foreach (@messageset) {
- $_ or next; # we already warned about bum ids
- my ($res, $error);
- if ($server_error) {
- $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below
- } elsif (! $_->edi) {
- $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content");
- $error = "EDI empty!";
- } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi, single_ext => 1})) {
- # This is the successful case!
- $_->remote_file($res);
- $_->status('complete');
- $_->process_time('NOW'); # For outbound files, sending is the end of processing on the EG side.
- $logger->info("Sent message (id " . $_->id. ") via $log_str");
- } else {
- $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
- $error = "put FAILED: " . ($server->error || 'UNKOWNN');
- }
- if ($error) {
- $_->error($error);
- $_->error_time('NOW');
- }
- $logger->info("Calling update_acq_edi_message");
- $e->xact_begin;
- unless ($e->update_acq_edi_message($_)) {
- $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_));
- OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_ ), '/tmp/update_acq_edi_message.FAIL');
- OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash');
- }
- # There's always an update, even if we failed.
- $e->xact_commit;
- __PACKAGE__->record_activity($account, $e); # There's always an update, even if we failed.
- }
- return \@messageset;
-}
-
-# attempt_translation does not touch the DB, just the object.
-sub attempt_translation {
- my ($class, $edi_message, $to_edi) = @_;
- my $tran = translator();
- my $ret = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi);
-# $logger->error("json: " . Dumper($json)); # debugging
- if (not $ret or (! ref($ret)) or $ret->is_fault) { # RPC::XML::fault on failure
- $edi_message->status('trans_error');
- $edi_message->error_time('NOW');
- my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed";
- my $message = ref($ret) ?
- ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) :
- ("$pre: " . __PACKAGE__->nice_string($ret) ) ;
- $edi_message->error($message);
- $logger->error( $message);
- return;
- }
- $edi_message->status('translated');
- $edi_message->translate_time('NOW');
- if ($to_edi) {
- $edi_message->edi($ret->value); # translator returns an object
- } else {
- $edi_message->jedi($ret->value); # translator returns an object
- }
- return $edi_message;
-}
-
-sub retrieve_vendors {
- my ($self, $e, $vendor_id, $last_activity) = @_; # $e is a working editor
-
- $e ||= new_editor();
-
- my $criteria = {'+acqpro' => {active => 't'}};
- $criteria->{'+acqpro'}->{id} = $vendor_id if $vendor_id;
- return $e->search_acq_edi_account([
- $criteria, {
- 'join' => 'acqpro',
- flesh => 1,
- flesh_fields => {
- acqedi => ['provider']
- }
- }
- ]);
-# {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
-}
-
-# This is the SRF-exposed call, so it does checkauth
-
-sub retrieve {
- my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- unless ($e and $e->checkauth()) {
- $logger->warn("checkauth failed for authtoken '$auth'");
- return ();
- }
- # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency); # add permission here ?
-
- my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
- return __PACKAGE__->retrieve_core($e, $set, $max);
-}
-
-
-# field_map takes the hashref of vendor data with fields from acq.edi_account and
-# maps them to the argument style needed for RemoteAccount. It also extrapolates
-# data from the remote_host string for type and port, when available.
-
-sub field_map {
- my $self = shift;
- my $vendor = shift or return;
- my $no_override = @_ ? shift : 0;
- my %args = ();
- $verbose and $logger->warn("vendor: " . Dumper($vendor));
- foreach (keys %map) {
- $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
- }
- unless ($no_override) {
- $args{remote_path} = $vendor->in_dir; # override "path" with "in_dir"
- }
- my $host = $args{remote_host} || '';
- ($host =~ s/^(S?FTP)://i and $args{type} = uc($1)) or
- ($host =~ s/^(SSH|SCP)://i and $args{type} = 'SCP' ) ;
- $host =~ s/:(\d+)$// and $args{port} = $1;
- ($args{remote_host} = $host) =~ s#/+##;
- $verbose and $logger->warn("field_map: " . Dumper(\%args));
- return %args;
-}
-
-
-# The point of remote_account is to get the RemoteAccount object with args from the DB
-
-sub remote_account {
- my ($self, $vendor, $outbound, $e) = @_;
-
- unless (ref($vendor)) { # It's not a hashref/object.
- $vendor or return; # If in fact it's nothing: abort!
- # else it's a vendor_id string, so get the full vendor data
- $e ||= new_editor();
- my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
- $vendor = shift @$set_of_one;
- }
-
- return OpenILS::Utils::RemoteAccount->new(
- $self->field_map($vendor, $outbound)
- );
-}
-
-# takes account ID or account Fieldmapper object
-
-sub record_activity {
- my ($class, $account_or_id, $e) = @_;
- $account_or_id or return;
- $e ||= new_editor();
- my $account = ref($account_or_id) ? $account_or_id : $e->retrieve_acq_edi_account($account_or_id);
- $logger->info("EDI record_activity calling update_acq_edi_account");
- $account->last_activity('NOW') or return;
- $e->xact_begin;
- $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
- $e->xact_commit;
- return $account;
-}
-
-sub nice_string {
- my $class = shift;
- my $string = shift or return '';
- chomp($string);
- my $head = @_ ? shift : 100;
- my $tail = @_ ? shift : 25;
- (length($string) < $head + $tail) and return $string;
- my $h = substr($string,0,$head);
- my $t = substr($string, -1*$tail);
- $h =~s/\s*$//o;
- $t =~s/\s*$//o;
- return "$h ... $t";
- # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
-}
-
-sub jedi2perl {
- my ($class, $jedi) = @_;
- $jedi or return;
- my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi );
- open (FOO, ">>/tmp/JSON2perl_dump.txt");
- print FOO Dumper($msg), "\n\n";
- close FOO;
- $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt");
- return $msg;
-}
-
-our @datecodes = (35, 359, 17, 191, 69, 76, 75, 79, 85, 74, 84, 223);
-our @noop_6063 = (21);
-
-# ->process_jedi($message, $server, $remote, $e)
-# $message is an edi_message object
-#
-sub process_jedi {
- my ($class, $message, $server, $remote, $e) = @_;
- $message or return;
- $server ||= {}; # context
- $remote ||= {}; # context
- $e ||= new_editor;
- my $jedi;
- unless (ref($message) and $jedi = $message->jedi) { # assignment, not comparison
- $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi)!");
- return;
- }
- my $perl = __PACKAGE__->jedi2perl($jedi);
- my $error = '';
- if (ref($message) and not $perl) {
- $error = ($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi";
- }
- elsif (! $perl->{body}) {
- $error = "EDI interchange body not found!";
- }
- elsif (! $perl->{body}->[0]) {
- $error = "EDI interchange body not a populated arrayref!";
- }
- if ($error) {
- $logger->warn($error);
- $message->error($error);
- $message->error_time('NOW');
- $e->xact_begin;
- $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!");
- $e->xact_commit;
- return;
- }
-
-# Crazy data structure. Most of the arrays will be 1 element... we think.
-# JEDI looks like:
-# {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ...
-#
-# So you might access it like:
-# $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH'
-
- $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " message(s)");
- my @ok_msg_codes = qw/ORDRSP OSTRPT/;
- my @messages;
- my $i = 0;
- foreach my $part (@{$perl->{body}}) {
- $i++;
- unless (ref $part and scalar keys %$part) {
- $logger->warn("EDI interchange message $i lacks structure. Skipping it.");
- next;
- }
- foreach my $key (keys %$part) {
- if (! grep {$_ eq $key} @ok_msg_codes) { # We only do one type for now. TODO: other types here
- $logger->warn("EDI interchange $i contains unhandled '$key' message. Ignoring it.");
- next;
- }
- my $msg = __PACKAGE__->message_object($part->{$key}) or next;
- push @messages, $msg;
-
- my $bgm = $msg->xpath('BGM') or $logger->warn("EDI No BGM segment found?!");
- my $tag4343 = $msg->xpath('BGM/4343');
- my $tag1225 = $msg->xpath('BGM/1225');
- if (ref $tag4343) {
- $logger->info(sprintf "EDI $key BGM/4343 Response Type: %s - %s", $tag4343->value, $tag4343->label)
- } else {
- $logger->warn("EDI $key BGM/4343 Response Type Code unrecognized"); # next; #?
- }
- if (ref $tag1225) {
- $logger->info(sprintf "EDI $key BGM/1225 Message Function: %s - %s", $tag1225->value, $tag1225->label);
- } else {
- $logger->warn("EDI $key BGM/1225 Message Function Code unrecognized"); # next; #?
- }
-
- # TODO: currency check, just to be paranoid
- # *should* be unnecessary (vendor should reply in currency we send in ORDERS)
- # That begs a policy question: how to handle mismatch? convert (bad accuracy), reject, or ignore? I say ignore.
-
- # ALL those codes below are basically some form of (lastest) delivery date/time
- # see, e.g.: http://www.stylusstudio.com/edifact/D04B/2005.htm
- # The order is the order of definitiveness (first match wins)
- # Note: if/when we do serials via EDI, dates (and ranges/periods) will need massive special handling
- my @dates;
- my $ddate;
-
- foreach my $date ($msg->xpath('delivery_schedule')) {
- my $val_2005 = $date->xpath_value('DTM/2005') or next;
- (grep {$val_2005 eq $_} @datecodes) or next; # no match means some other kind of date we don't care about
- push @dates, $date;
- }
- if (@dates) {
- DATECODE: foreach my $dcode (@datecodes) { # now cycle back through hits in order of dcode definitiveness
- foreach my $date (@dates) {
- $date->xpath_value('DTM/2005') == $dcode or next;
- $ddate = $date->xpath_value('DTM/2380') and last DATECODE;
- # TODO: conversion based on format specified in DTM/2379 (best encapsulated in Business::EDI)
- }
- }
- }
- foreach my $detail ($msg->part('line_detail')) {
- my $eg_line = __PACKAGE__->eg_li($detail, $remote, $server->{remote_host}, $e) or next;
- my $li_date = $detail->xpath_value('DTM/2380') || $ddate;
- my $price = $detail->xpath_value('line_price/PRI/5118') || '';
- $eg_line->expected_recv_time($li_date) if $li_date;
- $eg_line->estimated_unit_price($price) if $price;
- if (not $message->purchase_order) { # first good lineitem sets the message PO link
- $message->purchase_order($eg_line->purchase_order); # EG $message object NOT Business::EDI $msg object
- $e->xact_begin;
- $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message (for PO number) failed! $!");
- $e->xact_commit;
- }
- # $e->search_acq_edi_account([]);
- my $touches = 0;
- my $eg_lids = $e->search_acq_lineitem_detail({lineitem => $eg_line->id}); # should be the same as $eg_line->lineitem_details
- my $lidcount = scalar(@$eg_lids);
- $lidcount == $eg_line->item_count or $logger->warn(
- sprintf "EDI: LI %s itemcount (%d) mismatch, %d LIDs found", $eg_line->id, $eg_line->item_count, $lidcount
- );
- foreach my $qty ($detail->part('all_QTY')) {
- my $ubound = $qty->xpath_value('6060') or next; # nothing to do if qty is 0
- my $val_6063 = $qty->xpath_value('6063');
- $ubound > 0 or next; # don't be crazy!
- if (! $val_6063) {
- $logger->warn("EDI: Response for LI " . $eg_line->id . " specifies quantity $ubound with no 6063 code! Contact vendor to resolve.");
- next;
- }
-
- my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $val_6063); # DB populated w/ 6063 keys in 1200's
- if (! $eg_reason) {
- $logger->warn("EDI: Unhandled quantity code '$val_6063' (LI " . $eg_line->id . ") $ubound items unprocessed");
- next;
- } elsif (grep {$val_6063 == $_} @noop_6063) { # an FYI like "ordered quantity"
- $ubound eq $lidcount
- or $logger->warn("EDI: LI " . $eg_line->id . " -- Vendor says we ordered $ubound, but we have $lidcount LIDs!)");
- next;
- }
- # elsif ($val_6063 == 83) { # backorder
- #} elsif ($val_6063 == 85) { # cancel
- #} elsif ($val_6063 == 12 or $val_6063 == 57 or $val_6063 == 84 or $val_6063 == 118) {
- # despatched, in transit, urgent delivery, or quantity manifested
- #}
- if ($touches >= $lidcount) {
- $logger->warn("EDI: LI " . $eg_line->id . ", We already updated $touches of $lidcount LIDS, " .
- "but message wants QTY $ubound more set to " . $eg_reason->label . ". Ignoring!");
- next;
- }
- $e->xact_begin;
- foreach (1 .. $ubound) {
- my $eg_lid = shift @$eg_lids or $logger->warn("EDI: Used up all $lidcount LIDs! Ignoring extra status " . $eg_reason->label);
- $eg_lid or next;
- $logger->debug(sprintf "Updating LID %s to %s", $eg_lid->id, $eg_reason->label);
- $eg_lid->cancel_reason($eg_reason->id);
- $e->update_acq_lineitem_detail($eg_lid);
- $touches++;
- }
- $e->xact_commit;
- if ($ubound == $eg_line->item_count) {
- $eg_line->cancel_reason($eg_reason->id); # if ALL the items have the same cancel_reason, the PO gets it too
- }
- }
- $eg_line->edit_time('NOW'); # TODO: have this field automatically updated via ON UPDATE trigger.
- $e->xact_begin;
- $e->update_acq_lineitem($eg_line) or $logger->warn("EDI: update_acq_lineitem FAILED");
- $e->xact_commit;
- # print STDERR "Lineitem update: ", Dumper($eg_line);
- }
- }
- }
- return \@messages;
-}
-
-# returns message object if processing should continue
-# returns false/undef value if processing should abort
-
-sub message_object {
- my $class = shift;
- my $body = shift or return;
- my $key = shift if @_;
- my $keystring = $key || 'UNSPECIFIED';
-
- my $msg = Business::EDI::Message->new($body);
- unless ($msg) {
- $logger->error("EDI interchange message: $keystring body failed Business::EDI constructor. Skipping it.");
- return;
- }
- $key = $msg->code if ! $key; # Now we set the key for reference if it wasn't specified
- my $val_0065 = $msg->xpath_value('UNH/S009/0065') || '';
- unless ($val_0065 eq $key) {
- $logger->error("EDI $key UNH/S009/0065 ('$val_0065') conflicts w/ message type $key. Aborting");
- return;
- }
- my $val_0051 = $msg->xpath_value('UNH/S009/0051') || '';
- unless ($val_0051 eq 'UN') {
- $logger->warn("EDI $key UNH/S009/0051 designates '$val_0051', not 'UN' as controlling agency. Attempting to process anyway");
- }
- my $val_0054 = $msg->xpath_value('UNH/S009/0054') || '';
- if ($val_0054) {
- $logger->info("EDI $key UNH/S009/0054 uses Spec revision version '$val_0054'");
- # Possible Spec Version limitation
- # my $yy = $tag_0054 ? substr($val_0054,0,2) : '';
- # unless ($yy eq '00' or $yy > 94 ...) {
- # $logger->warn("EDI $key UNH/S009/0051 Spec revision version '$val_0054' not supported");
- # }
- } else {
- $logger->warn("EDI $key UNH/S009/0054 does not reference a known Spec revision version");
- }
- return $msg;
-}
-
-=head2 ->eg_li($lineitem_object, [$remote, $server_log_string, $editor])
-
-my $line_item = OpenILS::Application::Acq::EDI->eg_li($edi_line, $remote, "test_server_01", $e);
-
- $remote is a acq.edi_account Fieldmapper object.
- $server_log_string is an arbitrary string use to identify the remote host in potential log messages.
-
-Updates:
- acq.lineitem.estimated_unit_price,
- acq.lineitem.state (dependent on mapping codes),
- acq.lineitem.expected_recv_time,
- acq.lineitem.edit_time (consequently)
-
-=cut
-
-sub eg_li {
- my ($class, $line, $server, $server_log_string, $e) = @_;
- $line or return;
- $e ||= new_editor();
-
- my $id;
- # my $rff = $line->part('line_reference/RFF') or $logger->warn("EDI ORDRSP line_detail/RFF missing!");
- my $val_1153 = $line->xpath_value('line_reference/RFF/1153') || '';
- my $val_1154 = $line->xpath_value('line_reference/RFF/1154') || '';
- my $val_1082 = $line->xpath_value('LIN/1082') || '';
-
- my @po_nums;
-
- $val_1154 =~ s#^(.*)\/##; # Many sources send the ID as 'order_ID/LI_ID'
- $1 and push @po_nums, $1;
- $val_1082 =~ s#^(.*)\/##; # Many sources send the ID as 'order_ID/LI_ID'
- $1 and push @po_nums, $1;
-
- # TODO: possible check of po_nums
- # now do a lot of checking
-
- if ($val_1153 eq 'LI') {
- $id = $val_1154 or $logger->warn("EDI ORDRSP RFF/1154 reference to LI empty. Attempting failover to LIN/1082");
- } else {
- $logger->warn("EDI ORDRSP RFF/1153 unexpected value ('$val_1153', not 'LI'). Attempting failover to LIN/1082");
- }
-
- # FIXME - the line item ID in LIN/1082 ought to match RFF/1154, but
- # not all materials vendors obey this. Commenting out check for now
- # as being too strict.
- #if ($id and $val_1082 and $val_1082 ne $id) {
- # $logger->warn("EDI ORDRSP LIN/1082 Line Item ID mismatch ($id vs. $val_1082): cannot target update");
- # return;
- #}
-
- $id ||= $val_1082 || '';
- if ($id eq '') {
- $logger->warn('Cannot identify line item from EDI message');
- return;
- }
-
- $logger->info("EDI retrieve/update lineitem $id");
-
- my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id, {
- flesh_li_details => 1,
- }, 1); # Could send more {options}. The 1 is for no_auth.
-
- if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') {
- $logger->error("EDI failed to retrieve lineitem by id '$id' for server $server_log_string");
- return;
- }
- unless ((! $server) or (! $server->provider)) { # but here we want $server to be acq.edi_account instead of RemoteAccount
- if ($server->provider != $li->provider) {
- # links go both ways: acq.provider.edi_default and acq.edi_account.provider
- $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider("
- . $li->provider . "). Checking acq.provider.edi_default...");
- my $provider = $e->retrieve_acq_provider($li->provider);
- if ($provider->edi_default != $server->id) {
- $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s",
- $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default);
- return;
- }
- }
- }
-
- my @lin_1229 = $line->xpath('LIN/1229') or $logger->warn("EDI LIN/1229 Action Code missing!");
- my $key = $lin_1229[0] or return;
-
- my $eg_reason = $e->retrieve_acq_cancel_reason(1000 + $key->value); # DB populated w/ spec keys in 1000's
- $eg_reason or $logger->warn(sprintf "EDI LIN/1229 Action Code '%s' (%s) not recognized in acq.cancel_reason", $key->value, $key->label);
- $eg_reason or return;
-
- $li->cancel_reason($eg_reason->id);
- unless ($eg_reason->keep_debits) {
- $logger->warn("EDI LIN/1229 Action Code '%s' (%s) has keep_debits=0", $key->value, $key->label);
- }
-
- my @prices = $line->xpath_value("line_price/PRI/5118");
- $li->estimated_unit_price($prices[0]) if @prices;
-
- return $li;
-}
-
-# caching not needed for now (edi_fetcher is asynchronous)
-# sub get_reason {
-# my ($class, $key, $e) = @_;
-# $reasons->{$key} and return $reasons->{$key};
-# $e ||= new_editor();
-# $reasons->{$key} = $e->retrieve_acq_cancel_reason($key);
-# return $reasons->{$key};
-# }
-
-1;
-
-__END__
-
-Example JSON data.
-
-Note the pseudo-hash 2-element arrays.
-
-[
- 'SG26',
- [
- [
- 'LIN',
- {
- '1229' => '5',
- '1082' => 1,
- 'C212' => {
- '7140' => '9780446360272',
- '7143' => 'EN'
- }
- }
- ],
- [
- 'IMD',
- {
- '7081' => 'BST',
- '7077' => 'F',
- 'C273' => {
- '7008' => [
- 'NOT APPLIC WEBSTERS NEW WORLD THESA'
- ]
- }
- }
- ],
- [
- 'QTY',
- {
- 'C186' => {
- '6063' => '21',
- '6060' => 10
- }
- }
- ],
- [
- 'QTY',
- {
- 'C186' => {
- '6063' => '12',
- '6060' => 10
- }
- }
- ],
- [
- 'QTY',
- {
- 'C186' => {
- '6063' => '85',
- '6060' => 0
- }
- }
- ],
- [
- 'FTX',
- {
- '4451' => 'LIN',
- 'C107' => {
- '4441' => '01',
- '3055' => '28',
- '1131' => '8B'
- }
- }
- ],
- [
- 'SG30',
- [
- [
- 'PRI',
- {
- 'C509' => {
- '5118' => '4.5',
- '5387' => 'SRP',
- '5125' => 'AAB'
- }
- }
- ]
- ]
- ],
- [
- 'SG31',
- [
- [
- 'RFF',
- {
- 'C506' => {
- '1154' => '8/1',
- '1153' => 'LI'
- }
- }
- ]
- ]
- ]
- ]
-],
-
+++ /dev/null
-package OpenILS::Application::Acq::EDI::Translator;
-
-use warnings;
-use strict;
-
-use RPC::XML::Client;
-use Data::Dumper;
-
-# DEFAULTS
-my $proto = 'http://';
-my $host = $proto . 'localhost';
-my $path = '/EDI';
-my $port = 9191;
-my $verbose = 0;
-
-sub new {
- my ($class, %args) = @_;
- my $self = bless(\%args, $class);
- $self->init;
- return $self;
-}
-
-sub init {
- my $self = shift;
- $self->host_cleanup;
-}
-
-sub host_cleanup {
- my $self = shift;
- my $target = $self->{host} || $host;
- $target =~ /^\S+:\/\// or $target = ($self->{proto} || $proto) . $target;
- $target =~ /:\d+$/ or $target .= ':' . ($self->{port} || $port);
- $target .= ($self->{path} || $path);
- $self->{verbose} and print "Cleanup: $self->{host} ==> $target\n";
- $self->{host} = $target;
- return $target;
-}
-
-sub client {
- my $self = shift;
- return $self->{client} ||= RPC::XML::Client->new($self->{host}); # TODO: auth
-}
-
-sub debug_file {
- my $self = shift;
- my $text = shift;
- my $filename = @_ ? shift : ('/tmp/' . __PACKAGE__ . '_unknown.tmp');
- unless (open (TMP_EDI, ">$filename")) {
- warn "Cannot write $filename: $!";
- return;
- }
- print TMP_EDI $text, "\n";
- close TMP_EDI;
- return 1;
-}
-
-sub json2edi {
- my $self = shift;
- my $text = shift;
- $self->debug_file($text, '/tmp/perl_json2edi.tmp');
- my $client = $self->client();
- $self->{verbose} and print "Trying json2edi on host: $self->{host}\n";
- $client->request->header('Content-Type' => 'text/xml;charset=utf-8');
- my $resp = $client->send_request('json2edi', $text);
- $self->{verbose} and print Dumper($resp);
- return $resp;
-}
-
-sub edi2json {
- my $self = shift;
- my $text = shift;
- $self->debug_file($text, '/tmp/perl_edi2json.tmp');
- my $client = $self->client();
- $self->{verbose} and print "Trying edi2json on host: $self->{host}\n";
- $client->request->header('Content-Type' => 'text/xml;charset=utf-8');
- my $resp = $client->send_request('edi2json', $text);
- $self->{verbose} and print Dumper($resp);
- return $resp;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Acq::Financials;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Const qw/:const/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Event;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Acq::Lineitem;
-my $U = 'OpenILS::Application::AppUtils';
-
-# ----------------------------------------------------------------------------
-# Funding Sources
-# ----------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'create_funding_source',
- api_name => 'open-ils.acq.funding_source.create',
- signature => {
- desc => 'Creates a new funding_source',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'funding source object to create', type => 'object'}
- ],
- return => {desc => 'The ID of the new funding_source'}
- }
-);
-
-sub create_funding_source {
- my($self, $conn, $auth, $funding_source) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('ADMIN_FUNDING_SOURCE', $funding_source->owner);
- $e->create_acq_funding_source($funding_source) or return $e->die_event;
- $e->commit;
- return $funding_source->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_funding_source',
- api_name => 'open-ils.acq.funding_source.delete',
- signature => {
- desc => 'Deletes a funding_source',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'funding source ID', type => 'number'}
- ],
- return => {desc => '1 on success, Event on failure'}
- }
-);
-
-sub delete_funding_source {
- my($self, $conn, $auth, $funding_source_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $funding_source = $e->retrieve_acq_funding_source($funding_source_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('ADMIN_FUNDING_SOURCE', $funding_source->owner, $funding_source);
- $e->delete_acq_funding_source($funding_source) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_funding_source',
- api_name => 'open-ils.acq.funding_source.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a new funding_source',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'funding source ID', type => 'number'}
- ],
- return => {desc => 'The funding_source object on success, Event on failure'}
- }
-);
-
-sub retrieve_funding_source {
- my($self, $conn, $auth, $funding_source_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $options ||= {};
-
- my $flesh = {flesh => 1, flesh_fields => {acqfs => []}};
- push(@{$flesh->{flesh_fields}->{acqfs}}, 'credits') if $$options{flesh_credits};
- push(@{$flesh->{flesh_fields}->{acqfs}}, 'allocations') if $$options{flesh_allocations};
-
- my $funding_source = $e->retrieve_acq_funding_source([$funding_source_id, $flesh]) or return $e->event;
-
- return $e->event unless $e->allowed(
- ['ADMIN_FUNDING_SOURCE','MANAGE_FUNDING_SOURCE', 'VIEW_FUNDING_SOURCE'],
- $funding_source->owner, $funding_source);
-
- $funding_source->summary(retrieve_funding_source_summary_impl($e, $funding_source))
- if $$options{flesh_summary};
- return $funding_source;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_org_funding_sources',
- api_name => 'open-ils.acq.funding_source.org.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves all the funding_sources associated with an org unit that the requestor has access to see',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'List of org Unit IDs. If no IDs are provided, this method returns the
- full set of funding sources this user has permission to view', type => 'number'},
- {desc => q/Limiting permission. this permission is used find the work-org tree from which
- the list of orgs is generated if no org ids are provided.
- The default is ADMIN_FUNDING_SOURCE/, type => 'string'},
- ],
- return => {desc => 'The funding_source objects on success, empty array otherwise'}
- }
-);
-
-sub retrieve_org_funding_sources {
- my($self, $conn, $auth, $org_id_list, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $options ||= {};
-
- my $limit_perm = ($$options{limit_perm}) ? $$options{limit_perm} : 'ADMIN_FUNDING_SOURCE';
- return OpenILS::Event->new('BAD_PARAMS')
- unless $limit_perm =~ /(ADMIN|MANAGE|VIEW)_FUNDING_SOURCE/;
-
- my $org_ids = ($org_id_list and @$org_id_list) ? $org_id_list :
- $U->user_has_work_perm_at($e, $limit_perm, {descendants =>1});
-
- return [] unless @$org_ids;
- my $sources = $e->search_acq_funding_source({owner => $org_ids});
-
- for my $source (@$sources) {
- $source->summary(retrieve_funding_source_summary_impl($e, $source))
- if $$options{flesh_summary};
- $conn->respond($source);
- }
-
- return undef;
-}
-
-sub retrieve_funding_source_summary_impl {
- my($e, $source) = @_;
- my $at = $e->search_acq_funding_source_allocation_total({funding_source => $source->id})->[0];
- my $b = $e->search_acq_funding_source_balance({funding_source => $source->id})->[0];
- my $ct = $e->search_acq_funding_source_credit_total({funding_source => $source->id})->[0];
- return {
- allocation_total => ($at) ? $at->amount : 0,
- balance => ($b) ? $b->amount : 0,
- credit_total => ($ct) ? $ct->amount : 0,
- };
-}
-
-
-__PACKAGE__->register_method(
- method => 'create_funding_source_credit',
- api_name => 'open-ils.acq.funding_source_credit.create',
- signature => {
- desc => 'Create a new funding source credit',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'funding source credit object', type => 'object'}
- ],
- return => {desc => 'The ID of the new funding source credit on success, Event on failure'}
- }
-);
-
-sub create_funding_source_credit {
- my($self, $conn, $auth, $fs_credit) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->event unless $e->checkauth;
-
- my $fs = $e->retrieve_acq_funding_source($fs_credit->funding_source)
- or return $e->die_event;
- return $e->die_event unless $e->allowed(['MANAGE_FUNDING_SOURCE'], $fs->owner, $fs);
-
- $e->create_acq_funding_source_credit($fs_credit) or return $e->die_event;
- $e->commit;
- return $fs_credit->id;
-}
-
-
-# ---------------------------------------------------------------
-# funds
-# ---------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'create_fund',
- api_name => 'open-ils.acq.fund.create',
- signature => {
- desc => 'Creates a new fund',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund object to create', type => 'object'}
- ],
- return => {desc => 'The ID of the newly created fund object'}
- }
-);
-
-sub create_fund {
- my($self, $conn, $auth, $fund) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('ADMIN_FUND', $fund->org);
- $e->create_acq_fund($fund) or return $e->die_event;
- $e->commit;
- return $fund->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_fund',
- api_name => 'open-ils.acq.fund.delete',
- signature => {
- desc => 'Deletes a fund',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund ID', type => 'number'}
- ],
- return => {desc => '1 on success, Event on failure'}
- }
-);
-
-sub delete_fund {
- my($self, $conn, $auth, $fund_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $fund = $e->retrieve_acq_fund($fund_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('ADMIN_FUND', $fund->org, $fund);
- $e->delete_acq_fund($fund) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_fund',
- api_name => 'open-ils.acq.fund.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a new fund',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund ID', type => 'number'}
- ],
- return => {desc => 'The fund object on success, Event on failure'}
- }
-);
-
-sub retrieve_fund {
- my($self, $conn, $auth, $fund_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $options ||= {};
-
- my $flesh = {flesh => 2, flesh_fields => {acqf => []}};
- if ($options->{"flesh_tags"}) {
- push @{$flesh->{"flesh_fields"}->{"acqf"}}, "tags";
- $flesh->{"flesh_fields"}->{"acqftm"} = ["tag"];
- }
- push(@{$flesh->{flesh_fields}->{acqf}}, 'debits') if $$options{flesh_debits};
- push(@{$flesh->{flesh_fields}->{acqf}}, 'allocations') if $$options{flesh_allocations};
- push(@{$flesh->{flesh_fields}->{acqfa}}, 'funding_source') if $$options{flesh_allocation_sources};
-
- my $fund = $e->retrieve_acq_fund([$fund_id, $flesh]) or return $e->event;
- return $e->event unless $e->allowed(['ADMIN_FUND','MANAGE_FUND', 'VIEW_FUND'], $fund->org, $fund);
- $fund->summary(retrieve_fund_summary_impl($e, $fund))
- if $$options{flesh_summary};
- return $fund;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_org_funds',
- api_name => 'open-ils.acq.fund.org.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves all the funds associated with an org unit',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'List of org Unit IDs. If no IDs are provided, this method returns the
- full set of funding sources this user has permission to view', type => 'number'},
- {desc => q/Options hash.
- "limit_perm" -- this permission is used find the work-org tree from which
- the list of orgs is generated if no org ids are provided. The default is ADMIN_FUND.
- "flesh_summary" -- if true, the summary field on each fund is fleshed
- The default is ADMIN_FUND/, type => 'string'},
- ],
- return => {desc => 'The fund objects on success, Event on failure'}
- }
-);
-
-__PACKAGE__->register_method(
- method => 'retrieve_org_funds',
- api_name => 'open-ils.acq.fund.org.years.retrieve');
-
-
-sub retrieve_org_funds {
- my($self, $conn, $auth, $filter, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $filter ||= {};
- $options ||= {};
-
- my $limit_perm = ($$options{limit_perm}) ? $$options{limit_perm} : 'ADMIN_FUND';
- return OpenILS::Event->new('BAD_PARAMS')
- unless $limit_perm =~ /(ADMIN|MANAGE|VIEW)_FUND/;
-
- $filter->{org} = $filter->{org} ||
- $U->user_has_work_perm_at($e, $limit_perm, {descendants =>1});
- return undef unless @{$filter->{org}};
-
- my $query = [
- $filter,
- {
- limit => $$options{limit} || 50,
- offset => $$options{offset} || 0,
- order_by => $$options{order_by} || {acqf => 'name'}
- }
- ];
-
- if($self->api_name =~ /years/) {
- # return the distinct set of fund years covered by the selected funds
- my $data = $e->json_query({
- select => {
- acqf => [{column => 'year', transform => 'distinct'}]
- },
- from => 'acqf',
- where => $filter}
- );
-
- return [map { $_->{year} } @$data];
- }
-
- my $funds = $e->search_acq_fund($query);
-
- for my $fund (@$funds) {
- $fund->summary(retrieve_fund_summary_impl($e, $fund))
- if $$options{flesh_summary};
- $conn->respond($fund);
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_fund_summary',
- api_name => 'open-ils.acq.fund.summary.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Returns a summary of credits/debits/encumbrances for a fund',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund id', type => 'number' }
- ],
- return => {desc => 'A hash of summary information, Event on failure'}
- }
-);
-
-sub retrieve_fund_summary {
- my($self, $conn, $auth, $fund_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $fund = $e->retrieve_acq_fund($fund_id) or return $e->event;
- return $e->event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
- return retrieve_fund_summary_impl($e, $fund);
-}
-
-
-sub retrieve_fund_summary_impl {
- my($e, $fund) = @_;
-
- my $at = $e->search_acq_fund_allocation_total({fund => $fund->id})->[0];
- my $dt = $e->search_acq_fund_debit_total({fund => $fund->id})->[0];
- my $et = $e->search_acq_fund_encumbrance_total({fund => $fund->id})->[0];
- my $st = $e->search_acq_fund_spent_total({fund => $fund->id})->[0];
- my $cb = $e->search_acq_fund_combined_balance({fund => $fund->id})->[0];
- my $sb = $e->search_acq_fund_spent_balance({fund => $fund->id})->[0];
-
- return {
- allocation_total => ($at) ? $at->amount : 0,
- debit_total => ($dt) ? $dt->amount : 0,
- encumbrance_total => ($et) ? $et->amount : 0,
- spent_total => ($st) ? $st->amount : 0,
- combined_balance => ($cb) ? $cb->amount : 0,
- spent_balance => ($sb) ? $sb->amount : 0,
- };
-}
-
-__PACKAGE__->register_method(
- method => 'transfer_money_between_funds',
- api_name => 'open-ils.acq.funds.transfer_money',
- signature => {
- desc => 'Method for transfering money between funds',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Originating fund ID', type => 'number'},
- {desc => 'Amount of money to transfer away from the originating fund, in the same currency as said fund', type => 'number'},
- {desc => 'Destination fund ID', type => 'number'},
- {desc => 'Amount of money to transfer to the destination fund, in the same currency as said fund. If null, uses the same amount specified with the Originating Fund, and attempts a currency conversion if appropriate.', type => 'number'},
- {desc => 'Transfer Note', type => 'string'}
- ],
- return => {desc => '1 on success, Event on failure'}
- }
-);
-
-sub transfer_money_between_funds {
- my($self, $conn, $auth, $ofund_id, $ofund_amount, $dfund_id, $dfund_amount, $note) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $ofund = $e->retrieve_acq_fund($ofund_id) or return $e->event;
- return $e->die_event unless $e->allowed(['ADMIN_FUND','MANAGE_FUND'], $ofund->org, $ofund);
- my $dfund = $e->retrieve_acq_fund($dfund_id) or return $e->event;
- return $e->die_event unless $e->allowed(['ADMIN_FUND','MANAGE_FUND'], $dfund->org, $dfund);
-
- if (!defined $dfund_amount) {
- my $ratio = 1;
- if ($ofund->currency_type ne $dfund->currency_type) {
- my $exchange_rate = $e->json_query({
- "select"=>{"acqexr"=>["ratio"]},
- "from"=>"acqexr",
- "where"=>{
- "from_currency"=>$ofund->currency_type,
- "to_currency"=>$dfund->currency_type
- }
- });
- if (scalar(@$exchange_rate)<1) {
- $logger->error('Unable to find exchange rate for ' . $ofund->currency_type . ' to ' . $dfund->currency_type);
- return $e->die_event;
- }
- $ratio = @{$exchange_rate}[0]->{ratio};
- }
- $dfund_amount = $ofund_amount * $ratio;
- } else {
- return $e->die_event unless $e->allowed("ACQ_XFER_MANUAL_DFUND_AMOUNT");
- }
-
- $e->json_query({
- from => [
- 'acq.transfer_fund',
- $ofund_id, $ofund_amount, $dfund_id, $dfund_amount, $e->requestor->id, $note
- ]
- });
-
- $e->commit;
-
- return 1;
-}
-
-
-
-# ---------------------------------------------------------------
-# fund Allocations
-# ---------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'create_fund_alloc',
- api_name => 'open-ils.acq.fund_allocation.create',
- signature => {
- desc => 'Creates a new fund_allocation',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund allocation object to create', type => 'object'}
- ],
- return => {desc => 'The ID of the new fund_allocation'}
- }
-);
-
-sub create_fund_alloc {
- my($self, $conn, $auth, $fund_alloc) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- # this action is equivalent to both debiting a funding source and crediting a fund
-
- my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner);
-
- my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
-
- $fund_alloc->allocator($e->requestor->id);
- $e->create_acq_fund_allocation($fund_alloc) or return $e->die_event;
- $e->commit;
- return $fund_alloc->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_fund_alloc',
- api_name => 'open-ils.acq.fund_allocation.delete',
- signature => {
- desc => 'Deletes a fund_allocation',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund Alocation ID', type => 'number'}
- ],
- return => {desc => '1 on success, Event on failure'}
- }
-);
-
-sub delete_fund_alloc {
- my($self, $conn, $auth, $fund_alloc_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- my $fund_alloc = $e->retrieve_acq_fund_allocation($fund_alloc_id) or return $e->die_event;
-
- my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner, $source);
-
- my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
-
- $e->delete_acq_fund_allocation($fund_alloc) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_fund_alloc',
- api_name => 'open-ils.acq.fund_allocation.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a new fund_allocation',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund Allocation ID', type => 'number'}
- ],
- return => {desc => 'The fund allocation object on success, Event on failure'}
- }
-);
-
-sub retrieve_fund_alloc {
- my($self, $conn, $auth, $fund_alloc_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $fund_alloc = $e->retrieve_acq_fund_allocation($fund_alloc_id) or return $e->event;
-
- my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner, $source);
-
- my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
-
- return $fund_alloc;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_funding_source_allocations',
- api_name => 'open-ils.acq.funding_source.allocations.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a new fund_allocation',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'fund Allocation ID', type => 'number'}
- ],
- return => {desc => 'The fund allocation object on success, Event on failure'}
- }
-);
-
-sub retrieve_funding_source_allocations {
- my($self, $conn, $auth, $fund_alloc_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $fund_alloc = $e->retrieve_acq_fund_allocation($fund_alloc_id) or return $e->event;
-
- my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner, $source);
-
- my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
- return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
-
- return $fund_alloc;
-}
-
-# ----------------------------------------------------------------------------
-# Currency
-# ----------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'retrieve_all_currency_type',
- api_name => 'open-ils.acq.currency_type.all.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves all currency_type objects',
- params => [
- {desc => 'Authentication token', type => 'string'},
- ],
- return => {desc => 'List of currency_type objects', type => 'list'}
- }
-);
-
-sub retrieve_all_currency_type {
- my($self, $conn, $auth, $fund_alloc_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('GENERAL_ACQ');
- $conn->respond($_) for @{$e->retrieve_all_acq_currency_type()};
-}
-
-__PACKAGE__->register_method(
- method => 'create_lineitem_assets',
- api_name => 'open-ils.acq.lineitem.assets.create',
- signature => {
- desc => q/Creates the bibliographic data, volume, and copies associated with a lineitem./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'The lineitem id', type => 'number'},
- {desc => q/Options hash./}
- ],
- return => {desc => 'ID of newly created bib record, Event on error'}
- }
-);
-
-sub create_lineitem_assets {
- my($self, $conn, $auth, $li_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my ($count, $resp) = create_lineitem_assets_impl($e, $li_id, $options);
- return $resp if $resp;
- $e->commit;
- return $count;
-}
-
-sub create_lineitem_assets_impl {
- my($e, $li_id, $options) = @_;
- $options ||= {};
- my $evt;
-
- my $li = $e->retrieve_acq_lineitem([
- $li_id,
- { flesh => 1,
- flesh_fields => {jub => ['purchase_order', 'attributes']}
- }
- ]) or return (undef, $e->die_event);
-
- # -----------------------------------------------------------------
- # first, create the bib record if necessary
- # -----------------------------------------------------------------
- unless($li->eg_bib_id) {
-
- my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
- $e, $li->marc); #$rec->bib_source
-
- if($U->event_code($record)) {
- $e->rollback;
- return (undef, $record);
- }
-
- $li->editor($e->requestor->id);
- $li->edit_time('now');
- $li->eg_bib_id($record->id);
- $e->update_acq_lineitem($li) or return (undef, $e->die_event);
- }
-
- my $li_details = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
-
- # -----------------------------------------------------------------
- # for each lineitem_detail, create the volume if necessary, create
- # a copy, and link them all together.
- # -----------------------------------------------------------------
- my %volcache;
- for my $li_detail_id (@{$li_details}) {
-
- my $li_detail = $e->retrieve_acq_lineitem_detail($li_detail_id)
- or return (undef, $e->die_event);
-
- # Create the volume object if necessary
- my $volume = $volcache{$li_detail->cn_label};
- unless($volume and $volume->owning_lib == $li_detail->owning_lib) {
- ($volume, $evt) =
- OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
- $e, $li_detail->cn_label, $li->eg_bib_id, $li_detail->owning_lib);
- return (undef, $evt) if $evt;
- $volcache{$volume->id} = $volume;
- }
-
- my $copy = Fieldmapper::asset::copy->new;
- $copy->isnew(1);
- $copy->loan_duration(2);
- $copy->fine_level(2);
- $copy->status(OILS_COPY_STATUS_ON_ORDER);
- $copy->barcode($li_detail->barcode);
- $copy->location($li_detail->location);
- $copy->call_number($volume->id);
- $copy->circ_lib($volume->owning_lib);
- $copy->circ_modifier($$options{circ_modifier} || 'book');
-
- $evt = OpenILS::Application::Cat::AssetCommon->create_copy($e, $volume, $copy);
- return (undef, $evt) if $evt;
-
- $li_detail->eg_copy_id($copy->id);
- $e->update_acq_lineitem_detail($li_detail) or return (undef, $e->die_event);
- }
-
- return (scalar @{$li_details});
-}
-
-
-
-
-sub create_purchase_order_impl {
- my($e, $p_order) = @_;
-
- $p_order->creator($e->requestor->id);
- $p_order->editor($e->requestor->id);
- $p_order->owner($e->requestor->id);
- $p_order->edit_time('now');
-
- return $e->die_event unless
- $e->allowed('CREATE_PURCHASE_ORDER', $p_order->ordering_agency);
-
- my $provider = $e->retrieve_acq_provider($p_order->provider)
- or return $e->die_event;
- return $e->die_event unless
- $e->allowed('MANAGE_PROVIDER', $provider->owner, $provider);
-
- $e->create_acq_purchase_order($p_order) or return $e->die_event;
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_all_user_purchase_order',
- api_name => 'open-ils.acq.purchase_order.user.all.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves a purchase order',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'purchase_order to retrieve', type => 'number'},
- {desc => q/Options hash. flesh_lineitems: to get the lineitems and lineitem_attrs;
- clear_marc: to clear the MARC data from the lineitem (for reduced bandwidth);
- limit: number of items to return ,defaults to 50;
- offset: offset in the list of items to return
- order_by: sort the result, provide one or more colunm names, separated by commas,
- optionally followed by ASC or DESC as a single string
- li_limit : number of lineitems to return if fleshing line items;
- li_offset : lineitem offset if fleshing line items
- li_order_by : lineitem sort definition if fleshing line items
- flesh_lineitem_detail_count : flesh lineitem_detail_count field
- /,
- type => 'hash'}
- ],
- return => {desc => 'The purchase order, Event on failure'}
- }
-);
-
-sub retrieve_all_user_purchase_order {
- my($self, $conn, $auth, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $options ||= {};
-
- # grab purchase orders I have
- my $perm_orgs = $U->user_has_work_perm_at($e, 'MANAGE_PROVIDER', {descendants =>1});
- return OpenILS::Event->new('PERM_FAILURE', ilsperm => 'MANAGE_PROVIDER')
- unless @$perm_orgs;
- my $provider_ids = $e->search_acq_provider({owner => $perm_orgs}, {idlist=>1});
- my $po_ids = $e->search_acq_purchase_order({provider => $provider_ids}, {idlist=>1});
-
- # grab my purchase orders
- push(@$po_ids, @{$e->search_acq_purchase_order({owner => $e->requestor->id}, {idlist=>1})});
-
- return undef unless @$po_ids;
-
- # now get the db to limit/sort for us
- $po_ids = $e->search_acq_purchase_order(
- [ {id => $po_ids}, {
- limit => $$options{limit} || 50,
- offset => $$options{offset} || 0,
- order_by => {acqpo => $$options{order_by} || 'create_time'}
- }
- ],
- {idlist => 1}
- );
-
- $conn->respond(retrieve_purchase_order_impl($e, $_, $options)) for @$po_ids;
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'search_purchase_order',
- api_name => 'open-ils.acq.purchase_order.search',
- stream => 1,
- signature => {
- desc => 'Search for a purchase order',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => q/Search hash. Search fields include id, provider/, type => 'hash'}
- ],
- return => {desc => 'A stream of POs'}
- }
-);
-
-sub search_purchase_order {
- my($self, $conn, $auth, $search, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $po_ids = $e->search_acq_purchase_order($search, {idlist=>1});
- for my $po_id (@$po_ids) {
- $conn->respond($e->retrieve_acq_purchase_order($po_id))
- unless po_perm_failure($e, $po_id);
- }
-
- return undef;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_purchase_order',
- api_name => 'open-ils.acq.purchase_order.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves a purchase order',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'purchase_order to retrieve', type => 'number'},
- {desc => q/Options hash. flesh_lineitems, to get the lineitems and lineitem_attrs;
- clear_marc, to clear the MARC data from the lineitem (for reduced bandwidth)
- li_limit : number of lineitems to return if fleshing line items;
- li_offset : lineitem offset if fleshing line items
- li_order_by : lineitem sort definition if fleshing line items,
- flesh_po_items : po_item objects
- /,
- type => 'hash'}
- ],
- return => {desc => 'The purchase order, Event on failure'}
- }
-);
-
-sub retrieve_purchase_order {
- my($self, $conn, $auth, $po_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- $po_id = [ $po_id ] unless ref $po_id;
- for ( @{$po_id} ) {
- my $rv;
- if ( po_perm_failure($e, $_) )
- { $rv = $e->event }
- else
- { $rv = retrieve_purchase_order_impl($e, $_, $options) }
-
- $conn->respond($rv);
- }
-
- return undef;
-}
-
-
-# if the user does not have permission to perform actions on this PO, return the perm failure event
-sub po_perm_failure {
- my($e, $po_id, $fund_id) = @_;
- my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency, $po);
- return undef;
-}
-
-sub build_price_summary {
- my ($e, $po_id) = @_;
-
- # TODO: Add summary value for estimated amount (pre-encumber)
-
- # fetch the fund debits for this purchase order
- my $debits = $e->json_query({
- "select" => {"acqfdeb" => [qw/encumbrance amount/]},
- "from" => {
- "acqlid" => {
- "jub" => {
- "fkey" => "lineitem",
- "field" => "id",
- "join" => {
- "acqpo" => {
- "fkey" => "purchase_order", "field" => "id"
- }
- }
- },
- "acqfdeb" => {"fkey" => "fund_debit", "field" => "id"}
- }
- },
- "where" => {"+acqpo" => {"id" => $po_id}}
- });
-
- # add any debits for non-bib po_items
- push(@$debits, @{
- $e->json_query({
- "select" => {"acqfdeb" => [qw/encumbrance amount/]},
- "from" => {acqpoi => 'acqfdeb'},
- "where" => {"+acqpoi" => {"purchase_order" => $po_id}}
- })
- });
-
- my ($enc, $spent) = (0, 0);
- for my $deb (@$debits) {
- if($U->is_true($deb->{encumbrance})) {
- $enc += $deb->{amount};
- } else {
- $spent += $deb->{amount};
- }
- }
- ($enc, $spent);
-}
-
-
-sub retrieve_purchase_order_impl {
- my($e, $po_id, $options) = @_;
-
- my $flesh = {"flesh" => 1, "flesh_fields" => {"acqpo" => []}};
-
- $options ||= {};
- unless ($options->{"no_flesh_cancel_reason"}) {
- push @{$flesh->{"flesh_fields"}->{"acqpo"}}, "cancel_reason";
- }
- if ($options->{"flesh_notes"}) {
- push @{$flesh->{"flesh_fields"}->{"acqpo"}}, "notes";
- }
- if ($options->{"flesh_provider"}) {
- push @{$flesh->{"flesh_fields"}->{"acqpo"}}, "provider";
- }
-
- push (@{$flesh->{flesh_fields}->{acqpo}}, 'po_items') if $options->{flesh_po_items};
-
- my $args = (@{$flesh->{"flesh_fields"}->{"acqpo"}}) ?
- [$po_id, $flesh] : $po_id;
-
- my $po = $e->retrieve_acq_purchase_order($args)
- or return $e->event;
-
- if($$options{flesh_lineitems}) {
-
- my $flesh_fields = { jub => ['attributes'] };
- $flesh_fields->{jub}->[1] = 'lineitem_details' if $$options{flesh_lineitem_details};
- $flesh_fields->{acqlid} = ['fund_debit'] if $$options{flesh_fund_debit};
-
- my $items = $e->search_acq_lineitem([
- {purchase_order => $po_id},
- {
- flesh => 3,
- flesh_fields => $flesh_fields,
- limit => $$options{li_limit} || 50,
- offset => $$options{li_offset} || 0,
- order_by => {jub => $$options{li_order_by} || 'create_time'}
- }
- ]);
-
- if($$options{clear_marc}) {
- $_->clear_marc for @$items;
- }
-
- $po->lineitems($items);
- $po->lineitem_count(scalar(@$items));
-
- } elsif( $$options{flesh_lineitem_ids} ) {
- $po->lineitems($e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1}));
-
- } elsif( $$options{flesh_lineitem_count} ) {
-
- my $items = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist=>1});
- $po->lineitem_count(scalar(@$items));
- }
-
- if($$options{flesh_price_summary}) {
- my ($enc, $spent) = build_price_summary($e, $po_id);
- $po->amount_encumbered($enc);
- $po->amount_spent($spent);
- }
-
- return $po;
-}
-
-
-__PACKAGE__->register_method(
- method => 'format_po',
- api_name => 'open-ils.acq.purchase_order.format'
-);
-
-sub format_po {
- my($self, $conn, $auth, $po_id, $format) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency);
-
- my $hook = "format.po.$format";
- return $U->fire_object_event(undef, $hook, $po, $po->ordering_agency);
-}
-
-__PACKAGE__->register_method(
- method => 'format_lineitem',
- api_name => 'open-ils.acq.lineitem.format'
-);
-
-sub format_lineitem {
- my($self, $conn, $auth, $li_id, $format, $user_data) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $li = $e->retrieve_acq_lineitem($li_id) or return $e->event;
-
- my $context_org;
- if (defined $li->purchase_order) {
- my $po = $e->retrieve_acq_purchase_order($li->purchase_order) or return $e->die_event;
- return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency);
- $context_org = $po->ordering_agency;
- } else {
- my $pl = $e->retrieve_acq_picklist($li->picklist) or return $e->die_event;
- if($e->requestor->id != $pl->owner) {
- return $e->event unless
- $e->allowed('VIEW_PICKLIST', $pl->org_unit, $pl);
- }
- $context_org = $pl->org_unit;
- }
-
- my $hook = "format.acqli.$format";
- return $U->fire_object_event(undef, $hook, $li, $context_org, 'print-on-demand', $user_data);
-}
-
-__PACKAGE__->register_method (
- method => 'po_events',
- api_name => 'open-ils.acq.purchase_order.events.owner',
- stream => 1,
- signature => q/
- Retrieve EDI-related purchase order events (format.po.jedi), by default those which are pending.
- @param authtoken Login session key
- @param owner Id or array of id's for the purchase order Owner field. Filters the events to just those pertaining to PO's meeting this criteria.
- @param options Object for tweaking the selection criteria and fleshing options.
- /
-);
-
-__PACKAGE__->register_method (
- method => 'po_events',
- api_name => 'open-ils.acq.purchase_order.events.ordering_agency',
- stream => 1,
- signature => q/
- Retrieve EDI-related purchase order events (format.po.jedi), by default those which are pending.
- @param authtoken Login session key
- @param owner Id or array of id's for the purchase order Ordering Agency field. Filters the events to just those pertaining to PO's meeting this criteria.
- @param options Object for tweaking the selection criteria and fleshing options.
- /
-);
-
-__PACKAGE__->register_method (
- method => 'po_events',
- api_name => 'open-ils.acq.purchase_order.events.id',
- stream => 1,
- signature => q/
- Retrieve EDI-related purchase order events (format.po.jedi), by default those which are pending.
- @param authtoken Login session key
- @param owner Id or array of id's for the purchase order Id field. Filters the events to just those pertaining to PO's meeting this criteria.
- @param options Object for tweaking the selection criteria and fleshing options.
- /
-);
-
-sub po_events {
- my($self, $conn, $auth, $search_value, $options) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- (my $search_field = $self->api_name) =~ s/.*\.([_a-z]+)$/$1/;
- my $obj_type = 'acqpo';
-
- if ($search_field eq 'ordering_agency') {
- $search_value = $U->get_org_descendants($search_value);
- }
-
- my $query = {
- "select"=>{"atev"=>["id"]},
- "from"=>"atev",
- "where"=>{
- "target"=>{
- "in"=>{
- "select"=>{$obj_type=>["id"]},
- "from"=>$obj_type,
- "where"=>{$search_field=>$search_value}
- }
- },
- "event_def"=>{
- "in"=>{
- "select"=>{atevdef=>["id"]},
- "from"=>"atevdef",
- "where"=>{
- "hook"=>"format.po.jedi"
- }
- }
- },
- "state"=>"pending"
- },
- "order_by"=>[{"class"=>"atev", "field"=>"run_time", "direction"=>"desc"}]
- };
-
- if ($options && defined $options->{state}) {
- $query->{'where'}{'state'} = $options->{state}
- }
-
- if ($options && defined $options->{start_time}) {
- $query->{'where'}{'start_time'} = $options->{start_time};
- }
-
- if ($options && defined $options->{order_by}) {
- $query->{'order_by'} = $options->{order_by};
- }
- my $po_events = $e->json_query($query);
-
- my $flesh_fields = { 'atev' => [ 'event_def' ] };
- my $flesh_depth = 1;
-
- for my $id (@$po_events) {
- my $event = $e->retrieve_action_trigger_event([
- $id->{id},
- {flesh => $flesh_depth, flesh_fields => $flesh_fields}
- ]);
- if (! $event) { next; }
-
- my $po = retrieve_purchase_order_impl(
- $e,
- $event->target(),
- {flesh_lineitem_count=>1,flesh_price_summary=>1}
- );
-
- if ($e->allowed( ['CREATE_PURCHASE_ORDER','VIEW_PURCHASE_ORDER'], $po->ordering_agency() )) {
- $event->target( $po );
- $conn->respond($event);
- }
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method (
- method => 'update_po_events',
- api_name => 'open-ils.acq.purchase_order.event.cancel.batch',
- stream => 1,
-);
-__PACKAGE__->register_method (
- method => 'update_po_events',
- api_name => 'open-ils.acq.purchase_order.event.reset.batch',
- stream => 1,
-);
-
-sub update_po_events {
- my($self, $conn, $auth, $event_ids) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $x = 1;
- for my $id (@$event_ids) {
-
- # do a little dance to determine what libraries we are ultimately affecting
- my $event = $e->retrieve_action_trigger_event([
- $id,
- { flesh => 2,
- flesh_fields => {atev => ['event_def'], atevdef => ['hook']}
- }
- ]) or return $e->die_event;
-
- my $po = retrieve_purchase_order_impl(
- $e,
- $event->target(),
- {}
- );
-
- return $e->die_event unless $e->allowed( ['CREATE_PURCHASE_ORDER','VIEW_PURCHASE_ORDER'], $po->ordering_agency() );
-
- if($self->api_name =~ /cancel/) {
- $event->state('invalid');
- } elsif($self->api_name =~ /reset/) {
- $event->clear_start_time;
- $event->clear_update_time;
- $event->state('pending');
- }
-
- $e->update_action_trigger_event($event) or return $e->die_event;
- $conn->respond({maximum => scalar(@$event_ids), progress => $x++});
- }
-
- $e->commit;
- return {complete => 1};
-}
-
-
-__PACKAGE__->register_method (
- method => 'process_fiscal_rollover',
- api_name => 'open-ils.acq.fiscal_rollover.combined',
- stream => 1,
- signature => {
- desc => q/
- Performs a combined fiscal fund rollover process.
-
- Creates a new series of funds for the following year, copying the old years
- funds that are marked as propagable. They apply to the funds belonging to
- either an org unit or to an org unit and all of its dependent org units.
- The procedures may be run repeatedly; if any fund has already been propagated,
- both the old and the new funds will be left alone.
-
- Closes out any applicable funds (by org unit or by org unit and dependents)
- that are marked as propagable. If such a fund has not already been propagated
- to the new year, it will be propagated at closing time.
-
- If a fund is marked as subject to rollover, any unspent balance in the old year's
- fund (including money encumbered but not spent) is transferred to the new year's
- fund. Otherwise it is deallocated back to the funding source(s).
-
- In either case, any encumbrance debits are transferred to the new fund, along
- with the corresponding lineitem details. The old year's fund is marked as inactive
- so that new debits may not be charged to it.
- /,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Fund Year to roll over', type => 'integer'},
- {desc => 'Org unit ID', type => 'integer'},
- {desc => 'Include Descendant Orgs (boolean)', type => 'integer'},
- ],
- return => {desc => 'Returns a stream of all related funds for the next year including fund summary for each'}
- }
-
-);
-
-__PACKAGE__->register_method (
- method => 'process_fiscal_rollover',
- api_name => 'open-ils.acq.fiscal_rollover.combined.dry_run',
- stream => 1,
- signature => {
- desc => q/
- @see open-ils.acq.fiscal_rollover.combined
- This is the dry-run version. The action is performed,
- new fund information is returned, then all changes are rolled back.
- /
- }
-
-);
-
-__PACKAGE__->register_method (
- method => 'process_fiscal_rollover',
- api_name => 'open-ils.acq.fiscal_rollover.propagate',
- stream => 1,
- signature => {
- desc => q/
- @see open-ils.acq.fiscal_rollover.combined
- This version performs fund propagation only. I.e, creation of
- the following year's funds. It does not rollover over balances, encumbrances,
- or mark the previous year's funds as complete.
- /
- }
-);
-
-__PACKAGE__->register_method (
- method => 'process_fiscal_rollover',
- api_name => 'open-ils.acq.fiscal_rollover.propagate.dry_run',
- stream => 1,
- signature => { desc => q/
- @see open-ils.acq.fiscal_rollover.propagate
- This is the dry-run version. The action is performed,
- new fund information is returned, then all changes are rolled back.
- / }
-);
-
-
-
-sub process_fiscal_rollover {
- my( $self, $conn, $auth, $year, $org_id, $descendants, $options ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('ADMIN_FUND', $org_id);
- $options ||= {};
-
- my $combined = ($self->api_name =~ /combined/);
-
- my $org_ids = ($descendants) ?
- [
- map
- { $_->{id} } # fetch my descendants
- @{$e->json_query({from => ['actor.org_unit_descendants', $org_id]})}
- ]
- : [$org_id];
-
- # Create next year's funds
- # Note, it's safe to run this more than once.
- # IOW, it will not create duplicate new funds.
- $e->json_query({
- from => [
- ($descendants) ?
- 'acq.propagate_funds_by_org_tree' :
- 'acq.propagate_funds_by_org_unit',
- $year, $e->requestor->id, $org_id
- ]
- });
-
- if($combined) {
-
- # Roll the uncumbrances over to next year's funds
- # Mark the funds for $year as inactive
-
- $e->json_query({
- from => [
- ($descendants) ?
- 'acq.rollover_funds_by_org_tree' :
- 'acq.rollover_funds_by_org_unit',
- $year, $e->requestor->id, $org_id
- ]
- });
- }
-
- # Fetch all funds for the specified org units for the subsequent year
- my $fund_ids = $e->search_acq_fund([
- {
- year => int($year) + 1,
- org => $org_ids,
- propagate => 't'
- }, {
- limit => $$options{limit} || 20,
- offset => $$options{offset} || 0,
- }
- ],
- {idlist => 1}
- );
-
- foreach (@$fund_ids) {
- my $fund = $e->retrieve_acq_fund($_) or return $e->die_event;
- $fund->summary(retrieve_fund_summary_impl($e, $fund));
-
- my $amount = 0;
- if($combined and $U->is_true($fund->rollover)) {
- # see how much money was rolled over
-
- my $sum = $e->json_query({
- select => {acqftr => [{column => 'dest_amount', transform => 'sum'}]},
- from => 'acqftr',
- where => {dest_fund => $fund->id, note => 'Rollover'}
- })->[0];
-
- $amount = $sum->{dest_amount} if $sum;
- }
-
- $conn->respond({fund => $fund, rollover_amount => $amount});
- }
-
- $self->api_name =~ /dry_run/ and $e->rollback or $e->commit;
- return undef;
-}
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Acq::Invoice;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Event;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-__PACKAGE__->register_method(
- method => 'build_invoice_api',
- api_name => 'open-ils.acq.invoice.update',
- signature => {
- desc => q/Creates, updates, and deletes invoices, and related invoice entries, and invoice items/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => q/Invoice/, type => 'number'},
- {desc => q/Entries. Array of 'acqie' objects/, type => 'array'},
- {desc => q/Items. Array of 'acqii' objects/, type => 'array'},
- ],
- return => {desc => 'The invoice w/ entries and items attached', type => 'object', class => 'acqinv'}
- }
-);
-
-sub build_invoice_api {
- my($self, $conn, $auth, $invoice, $entries, $items) = @_;
-
- my $e = new_editor(xact => 1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $evt;
-
- if(ref $invoice) {
- if($invoice->isnew) {
- $invoice->receiver($e->requestor->ws_ou) unless $invoice->receiver;
- $invoice->recv_method('PPR') unless $invoice->recv_method;
- $invoice->recv_date('now') unless $invoice->recv_date;
- $e->create_acq_invoice($invoice) or return $e->die_event;
- } elsif($invoice->isdeleted) {
- i$e->delete_acq_invoice($invoice) or return $e->die_event;
- } else {
- $e->update_acq_invoice($invoice) or return $e->die_event;
- }
- } else {
- # caller only provided the ID
- $invoice = $e->retrieve_acq_invoice($invoice) or return $e->die_event;
- }
-
- return $e->die_event unless $e->allowed('CREATE_INVOICE', $invoice->receiver);
-
- if($entries) {
- for my $entry (@$entries) {
- $entry->invoice($invoice->id);
-
- if($entry->isnew) {
-
- $e->create_acq_invoice_entry($entry) or return $e->die_event;
- return $evt if $evt = update_entry_debits($e, $entry);
-
- } elsif($entry->isdeleted) {
-
- return $evt if $evt = rollback_entry_debits($e, $entry);
- $e->delete_acq_invoice_entry($entry) or return $e->die_event;
-
- } elsif($entry->ischanged) {
-
- my $orig_entry = $e->retrieve_acq_invoice_entry($entry->id) or return $e->die_event;
-
- if($orig_entry->amount_paid != $entry->amount_paid or
- $entry->phys_item_count != $orig_entry->phys_item_count) {
-
- return $evt if $evt = rollback_entry_debits($e, $orig_entry);
- return $evt if $evt = update_entry_debits($e, $entry);
-
- }
-
- $e->update_acq_invoice_entry($entry) or return $e->die_event;
- }
- }
- }
-
- if($items) {
- for my $item (@$items) {
- $item->invoice($invoice->id);
-
- if($item->isnew) {
-
- $e->create_acq_invoice_item($item) or return $e->die_event;
-
- # future: cache item types
- my $item_type = $e->retrieve_acq_invoice_item_type(
- $item->inv_item_type) or return $e->die_event;
-
- # prorated items are handled separately
- unless($U->is_true($item_type->prorate)) {
- my $debit;
- if($item->po_item) {
- my $po_item = $e->retrieve_acq_po_item($item->po_item) or return $e->die_event;
- $debit = $e->retrieve_acq_fund_debit($po_item->fund_debit) or return $e->die_event;
- } else {
- $debit = Fieldmapper::acq::fund_debit->new;
- $debit->isnew(1);
- }
- $debit->fund($item->fund);
- $debit->amount($item->amount_paid);
- $debit->origin_amount($item->amount_paid);
- $debit->origin_currency_type($e->retrieve_acq_fund($item->fund)->currency_type); # future: cache funds locally
- $debit->encumbrance('f');
- $debit->debit_type('direct_charge');
-
- if($debit->isnew) {
- $e->create_acq_fund_debit($debit) or return $e->die_event;
- } else {
- $e->update_acq_fund_debit($debit) or return $e->die_event;
- }
-
- $item->fund_debit($debit->id);
- $e->update_acq_invoice_item($item) or return $e->die_event;
- }
-
- } elsif($item->isdeleted) {
-
- $e->delete_acq_invoice_item($item) or return $e->die_event;
-
- if($item->po_item and $e->retrieve_acq_po_item($item->po_item)->fund_debit == $item->fund_debit) {
- # the debit is attached to the po_item. instead of deleting it, roll it back
- # to being an encumbrance. Note: a prorated invoice_item that points to a po_item
- # could point to a different fund_debit. We can't go back in time to collect all the
- # prorated invoice_items (nor is the caller asking us too), so when that happens,
- # just delete the extraneous debit (in the else block).
- my $debit = $e->retrieve_acq_fund_debit($item->fund_debit);
- $debit->encumbrance('t');
- $e->update_acq_fund_debit($debit) or return $e->die_event;
- } else {
- $e->delete_acq_fund_debit($e->retrieve_acq_fund_debit($item->fund_debit))
- or return $e->die_event;
- }
-
-
- } elsif($item->ischanged) {
-
- my $debit = $e->retrieve_acq_fund_debit($item->fund_debit) or return $e->die_event;
- $debit->amount($item->amount_paid);
- $debit->fund($item->fund);
- $e->update_acq_fund_debit($debit) or return $e->die_event;
- $e->update_acq_invoice_item($item) or return $e->die_event;
- }
- }
- }
-
- $invoice = fetch_invoice_impl($e, $invoice->id);
- $e->commit;
-
- return $invoice;
-}
-
-
-sub rollback_entry_debits {
- my($e, $entry) = @_;
- my $debits = find_entry_debits($e, $entry, 'f', entry_amount_per_item($entry));
- my $lineitem = $e->retrieve_acq_lineitem($entry->lineitem) or return $e->die_event;
-
- for my $debit (@$debits) {
- # revert to the original estimated amount re-encumber
- $debit->encumbrance('t');
- $debit->amount($lineitem->estimated_unit_price());
- $e->update_acq_fund_debit($debit) or return $e->die_event;
- update_copy_cost($e, $debit) or return $e->die_event; # clear the cost
- }
-
- return undef;
-}
-
-sub update_entry_debits {
- my($e, $entry) = @_;
-
- my $debits = find_entry_debits($e, $entry, 't');
- return undef unless @$debits;
-
- if($entry->phys_item_count > @$debits) {
- $e->rollback;
- # We can't invoice for more items than we have debits for
- return OpenILS::Event->new(
- 'ACQ_INVOICE_ENTRY_COUNT_EXCEEDS_DEBITS',
- payload => {entry => $entry->id});
- }
-
- for my $debit (@$debits) {
- my $amount = entry_amount_per_item($entry);
- $debit->amount($amount);
- $debit->encumbrance('f');
- $e->update_acq_fund_debit($debit) or return $e->die_event;
-
- # TODO: this does not reflect ancillary charges, like taxes, etc.
- # We may need a way to indicate whether the amount attached to an
- # invoice_item should be prorated and included in the copy cost.
- # Note that acq.invoice_item_type.prorate does not necessarily
- # mean a charge should be included in the copy price, only that
- # it should spread accross funds.
- update_copy_cost($e, $debit, $amount) or return $e->die_event;
- }
-
- return undef;
-}
-
-# update the linked copy to reflect the amount paid for the item
-# returns true on success, false on error
-sub update_copy_cost {
- my ($e, $debit, $amount) = @_;
-
- my $lid = $e->search_acq_lineitem_detail([
- {fund_debit => $debit->id},
- {flesh => 1, flesh_fields => {acqlid => ['eg_copy_id']}}
- ])->[0];
-
- if($lid and my $copy = $lid->eg_copy_id) {
- defined $amount and $copy->cost($amount) or $copy->clear_cost;
- $copy->editor($e->requestor->id);
- $copy->edit_date('now');
- $e->update_asset_copy($copy) or return 0;
- }
-
- return 1;
-}
-
-
-sub entry_amount_per_item {
- my $entry = shift;
- return $entry->amount_paid if $U->is_true($entry->billed_per_item);
- return 0 if $entry->phys_item_count == 0;
- return $entry->amount_paid / $entry->phys_item_count;
-}
-
-sub easy_money { # TODO XXX replace with something from a library
- my ($val) = @_;
-
- my $rounded = int($val * 100) / 100.0;
- if ($rounded == $val) {
- return sprintf("%.02f", $val);
- } else {
- return sprintf("%g", $val);
- }
-}
-
-# 0 on failure (caller should call $e->die_event), array on success
-sub amounts_spent_per_fund {
- my ($e, $inv_id) = @_;
-
- my $entries = $e->search_acq_invoice_entry({"invoice" => $inv_id}) or
- return 0;
-
- my $items = $e->search_acq_invoice_item({"invoice" => $inv_id}) or
- return 0;
-
- my %totals_by_fund;
- foreach my $entry (@$entries) {
- my $debits = find_entry_debits($e, $entry, "f") or return 0;
- foreach (@$debits) {
- $totals_by_fund{$_->fund} ||= 0.0;
- $totals_by_fund{$_->fund} += $_->amount;
- }
- }
-
- foreach my $item (@$items) {
- next unless $item->fund and $item->amount_paid;
- $totals_by_fund{$item->fund} ||= 0.0;
- $totals_by_fund{$item->fund} += $item->amount_paid;
- }
-
- my @totals;
- foreach my $fund_id (keys %totals_by_fund) {
- my $fund = $e->retrieve_acq_fund($fund_id) or return 0;
- push @totals, {
- "fund" => $fund->to_bare_hash,
- "total" => easy_money($totals_by_fund{$fund_id})
- };
- }
-
- return \@totals;
-}
-
-# there is no direct link between invoice_entry and fund debits.
-# when we need to retrieve the related debits, we have to do some searching
-sub find_entry_debits {
- my($e, $entry, $encumbrance, $amount) = @_;
-
- my $query = {
- select => {acqfdeb => ['id']},
- from => {
- acqfdeb => {
- acqlid => {
- join => {
- jub => {
- join => {
- acqie => {
- filter => {id => $entry->id}
- }
- }
- }
- }
- }
- }
- },
- where => {'+acqfdeb' => {encumbrance => $encumbrance}},
- order_by => {'acqlid' => ['recv_time']}, # un-received items will sort to the end
- limit => $entry->phys_item_count
- };
-
- $query->{where}->{'+acqfdeb'}->{amount} = $amount if $amount;
-
- my $debits = $e->json_query($query);
- my $debit_ids = [map { $_->{id} } @$debits];
- return (@$debit_ids) ? $e->search_acq_fund_debit({id => $debit_ids}) : [];
-}
-
-
-__PACKAGE__->register_method(
- method => 'build_invoice_api',
- api_name => 'open-ils.acq.invoice.retrieve',
- authoritative => 1,
- signature => {
- desc => q/Creates a new stub invoice/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => q/Invoice Id/, type => 'number'},
- ],
- return => {desc => 'The new invoice w/ entries and items attached', type => 'object', class => 'acqinv'}
- }
-);
-
-
-sub fetch_invoice_api {
- my($self, $conn, $auth, $invoice_id, $options) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $invoice = fetch_invoice_impl($e, $invoice_id, $options) or
- return $e->event;
- return $e->event unless $e->allowed(['VIEW_INVOICE', 'CREATE_INVOICE'], $invoice->receiver);
-
- return $invoice;
-}
-
-sub fetch_invoice_impl {
- my ($e, $invoice_id, $options) = @_;
-
- $options ||= {};
-
- my $args = $options->{"no_flesh_misc"} ? $invoice_id : [
- $invoice_id,
- {
- "flesh" => 6,
- "flesh_fields" => {
- "acqinv" => ["entries", "items"],
- "acqii" => ["fund_debit", "purchase_order", "po_item"]
- }
- }
- ];
-
- return $e->retrieve_acq_invoice($args);
-}
-
-__PACKAGE__->register_method(
- method => 'prorate_invoice',
- api_name => 'open-ils.acq.invoice.apply_prorate',
- signature => {
- desc => q/
- For all invoice items that have the prorate flag set to true, this will create the necessary
- additional invoice_item's to prorate the cost across all affected funds by percent spent for each fund.
- /,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => q/Invoice Id/, type => 'number'},
- ],
- return => {desc => 'The updated invoice w/ entries and items attached', type => 'object', class => 'acqinv'}
- }
-);
-
-
-sub prorate_invoice {
- my($self, $conn, $auth, $invoice_id) = @_;
-
- my $e = new_editor(xact => 1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- my $invoice = fetch_invoice_impl($e, $invoice_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('CREATE_INVOICE', $invoice->receiver);
-
- my @lid_debits;
- push(@lid_debits, @{find_entry_debits($e, $_, 'f', entry_amount_per_item($_))}) for @{$invoice->entries};
-
- my $inv_items = $e->search_acq_invoice_item([
- {"invoice" => $invoice_id, "fund_debit" => {"!=" => undef}},
- {"flesh" => 1, "flesh_fields" => {"acqii" => ["fund_debit"]}}
- ]) or return $e->die_event;
-
- my @item_debits = map { $_->fund_debit } @$inv_items;
-
- my %fund_totals;
- my $total_entry_paid = 0;
- for my $debit (@lid_debits, @item_debits) {
- $fund_totals{$debit->fund} = 0 unless $fund_totals{$debit->fund};
- $fund_totals{$debit->fund} += $debit->amount;
- $total_entry_paid += $debit->amount;
- }
-
- $logger->info("invoice: prorating against invoice amount $total_entry_paid");
-
- for my $item (@{$invoice->items}) {
-
- next if $item->fund_debit; # item has already been processed
-
- # future: cache item types locally
- my $item_type = $e->retrieve_acq_invoice_item_type($item->inv_item_type) or return $e->die_event;
- next unless $U->is_true($item_type->prorate);
-
- # Prorate charges across applicable funds
- my $full_item_paid = $item->amount_paid; # total amount paid for this item before splitting
- my $full_item_cost = $item->cost_billed; # total amount invoiced for this item before splitting
- my $first_round = 1;
- my $largest_debit;
- my $largest_item;
- my $total_debited = 0;
- my $total_costed = 0;
-
- for my $fund_id (keys %fund_totals) {
-
- my $spent_for_fund = $fund_totals{$fund_id};
- next unless $spent_for_fund > 0;
-
- my $prorated_amount = ($spent_for_fund / $total_entry_paid) * $full_item_paid;
- my $prorated_cost = ($spent_for_fund / $total_entry_paid) * $full_item_cost;
- $logger->info("invoice: attaching prorated amount $prorated_amount to fund $fund_id for invoice $invoice_id");
-
- my $debit;
- if($first_round and $item->po_item) {
- # if this item is the result of a PO item, repurpose the original debit
- # for the first chunk of the prorated amount
- $debit = $e->retrieve_acq_fund_debit($item->po_item->fund_debit);
- } else {
- $debit = Fieldmapper::acq::fund_debit->new;
- $debit->isnew(1);
- }
-
- $debit->fund($fund_id);
- $debit->amount($prorated_amount);
- $debit->origin_amount($prorated_amount);
- $debit->origin_currency_type($e->retrieve_acq_fund($fund_id)->currency_type); # future: cache funds locally
- $debit->encumbrance('f');
- $debit->debit_type('prorated_charge');
-
- if($debit->isnew) {
- $e->create_acq_fund_debit($debit) or return $e->die_event;
- } else {
- $e->update_acq_fund_debit($debit) or return $e->die_event;
- }
-
- $total_debited += $prorated_amount;
- $total_costed += $prorated_cost;
- $largest_debit = $debit if !$largest_debit or $prorated_amount > $largest_debit->amount;
-
- if($first_round) {
-
- # re-purpose the original invoice_item for the first prorated amount
- $item->fund($fund_id);
- $item->fund_debit($debit->id);
- $item->amount_paid($prorated_amount);
- $item->cost_billed($prorated_cost);
- $e->update_acq_invoice_item($item) or return $e->die_event;
- $largest_item = $item if !$largest_item or $prorated_amount > $largest_item->amount_paid;
-
- } else {
-
- # for subsequent prorated amounts, create a new invoice_item
- my $new_item = $item->clone;
- $new_item->clear_id;
- $new_item->fund($fund_id);
- $new_item->fund_debit($debit->id);
- $new_item->amount_paid($prorated_amount);
- $new_item->cost_billed($prorated_cost);
- $e->create_acq_invoice_item($new_item) or return $e->die_event;
- $largest_item = $new_item if !$largest_item or $prorated_amount > $largest_item->amount_paid;
- }
-
- $first_round = 0;
- }
-
- # make sure the percentages didn't leave a small sliver of money over/under-debited
- # if so, tweak the largest debit to smooth out the difference
- if($total_debited != $full_item_paid or $total_costed != $full_item_cost) {
-
- my $paid_diff = $full_item_paid - $total_debited;
- my $cost_diff = $full_item_cost - $total_debited;
- $logger->info("invoice: repairing prorate descrepency of paid:$paid_diff and cost:$cost_diff");
- my $new_paid = $largest_item->amount_paid + $paid_diff;
- my $new_cost = $largest_item->cost_billed + $cost_diff;
-
- $largest_debit = $e->retrieve_acq_fund_debit($largest_debit->id); # get latest copy
- $largest_debit->amount($new_paid);
- $e->update_acq_fund_debit($largest_debit) or return $e->die_event;
-
- $largest_item = $e->retrieve_acq_invoice_item($largest_item->id); # get latest copy
- $largest_item->amount_paid($new_paid);
- $largest_item->cost_billed($new_cost);
-
- $e->update_acq_invoice_item($largest_item) or return $e->die_event;
- }
- }
-
- $invoice = fetch_invoice_impl($e, $invoice_id);
- $e->commit;
-
- return $invoice;
-}
-
-
-__PACKAGE__->register_method(
- method => "print_html_invoice",
- api_name => "open-ils.acq.invoice.print.html",
- stream => 1,
- signature => {
- desc => "Retrieve printable HTML vouchers for each given invoice",
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Invoice ID or a list of them", type => "mixed"},
- ],
- return => {
- desc => q{One A/T event containing a printable HTML voucher for
- each given invoice},
- type => "object", class => "atev"}
- }
-);
-
-
-sub print_html_invoice {
- my ($self, $conn, $auth, $id_list) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- $id_list = [$id_list] unless ref $id_list;
-
- my $invoices = $e->search_acq_invoice({"id" => $id_list}) or
- return $e->die_event;
-
- foreach my $invoice (@$invoices) {
- return $e->die_event unless
- $e->allowed("VIEW_INVOICE", $invoice->receiver);
-
- my $amounts = amounts_spent_per_fund($e, $invoice->id) or
- return $e->die_event;
-
- $conn->respond(
- $U->fire_object_event(
- undef, "format.acqinv.html", $invoice, $invoice->receiver,
- "print-on-demand", $amounts
- )
- );
- }
-
- $e->disconnect;
- undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Acq::Lineitem;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenILS::Event;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Const qw/:const/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Acq::Financials;
-use OpenILS::Application::Cat::BibCommon;
-use OpenILS::Application::Cat::AssetCommon;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-__PACKAGE__->register_method(
- method => 'create_lineitem',
- api_name => 'open-ils.acq.lineitem.create',
- signature => {
- desc => 'Creates a lineitem',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'The lineitem object to create', type => 'object'},
- ],
- return => {desc => 'ID of newly created lineitem on success, Event on error'}
- }
-);
-
-sub create_lineitem {
- my($self, $conn, $auth, $li) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
-
- if($li->picklist) {
- my $picklist = $e->retrieve_acq_picklist($li->picklist)
- or return $e->die_event;
-
- if($picklist->owner != $e->requestor->id) {
- return $e->die_event unless
- $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
- }
-
- # indicate the picklist was updated
- $picklist->edit_time('now');
- $picklist->editor($e->requestor->id);
- $e->update_acq_picklist($picklist) or return $e->die_event;
- }
-
- if($li->purchase_order) {
- my $po = $e->retrieve_acq_purchase_order($li->purchase_order)
- or return $e->die_event;
- return $e->die_event unless
- $e->allowed('MANAGE_PROVIDER', $po->ordering_agency, $po);
-
- $li->provider($po->provider) unless defined $li->provider;
- }
-
- $li->selector($e->requestor->id);
- $e->create_acq_lineitem($li) or return $e->die_event;
-
- $e->commit;
- return $li->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_lineitem',
- api_name => 'open-ils.acq.lineitem.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a lineitem',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID to retrieve', type => 'number'},
- {options => q/Hash of options, including:
-flesh_attrs : for attributes,
-flesh_notes : for notes,
-flesh_cancel_reason : for cancel reason,
-flesh_li_details : for order details objects,
-clear_marc : to clear marcxml from lineitem/, type => 'hash'},
- ],
- return => {desc => 'lineitem object on success, Event on error'}
- }
-);
-
-
-sub retrieve_lineitem {
- my($self, $conn, $auth, $li_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return retrieve_lineitem_impl($e, $li_id, $options);
-}
-
-sub retrieve_lineitem_impl {
- my ($e, $li_id, $options, $no_auth) = @_; # no_auth needed for EDI scripts
- $options ||= {};
-
- my $flesh = {
- flesh => 3,
- flesh_fields => {
- jub => ['purchase_order', 'picklist'], # needed for permission check
- acqlid => [],
- acqlin => []
- }
- };
-
- my $fields = $flesh->{flesh_fields};
-
- push(@{$fields->{jub} }, 'attributes') if $$options{flesh_attrs};
- push(@{$fields->{jub} },'lineitem_notes') if $$options{flesh_notes};
- push(@{$fields->{acqlin}}, 'alert_text') if $$options{flesh_notes};
- push(@{$fields->{jub} }, 'order_summary') if $$options{flesh_order_summary};
- push(@{$fields->{acqlin}}, 'cancel_reason') if $$options{flesh_cancel_reason};
-
- if($$options{flesh_li_details}) {
- push(@{$fields->{jub} }, 'lineitem_details');
- push(@{$fields->{acqlid}}, 'fund' ) if $$options{flesh_fund};
- push(@{$fields->{acqlid}}, 'fund_debit' ) if $$options{flesh_fund_debit};
- push(@{$fields->{acqlid}}, 'cancel_reason') if $$options{flesh_cancel_reason};
- }
-
- if($$options{clear_marc}) { # avoid fetching marc blob
- my @fields = grep { $_ ne 'marc' } Fieldmapper::acq::lineitem->new->real_fields;
- $flesh->{select} = {jub => [@fields]};
- }
-
- my $li = $e->retrieve_acq_lineitem([$li_id, $flesh]) or return $e->event;
-
- # collect the # of lids
- if($$options{flesh_li_details}) {
- $li->item_count(scalar(@{$li->lineitem_details}));
- } else {
- my $details = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
- $li->item_count(scalar(@$details));
- }
-
- # attach claims to LIDs
- if($$options{flesh_li_details}) {
- foreach (@{$li->lineitem_details}) {
- $_->claims(
- $e->search_acq_claim([
- {"lineitem_detail", $_->id}, {
- "flesh" => 1, "flesh_fields" => {"acqcl" => ["type"]}
- }
- ])
- );
- }
- }
-
- return $e->event unless ((
- $li->purchase_order and
- ($no_auth or $e->allowed(['VIEW_PURCHASE_ORDER', 'CREATE_PURCHASE_ORDER'],
- $li->purchase_order->ordering_agency, $li->purchase_order))
- ) or (
- $li->picklist and !$li->purchase_order and # user doesn't have view_po perms
- ($no_auth or $e->allowed(['VIEW_PICKLIST', 'CREATE_PICKLIST'],
- $li->picklist->org_unit, $li->picklist))
- ));
-
- unless ($$options{flesh_po}) {
- $li->purchase_order(
- $li->purchase_order ? $li->purchase_order->id : undef
- );
- }
- unless ($$options{flesh_pl}) {
- $li->picklist($li->picklist ? $li->picklist->id : undef);
- }
- return $li;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'delete_lineitem',
- api_name => 'open-ils.acq.lineitem.delete',
- signature => {
- desc => 'Deletes a lineitem',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID to delete', type => 'number'},
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-__PACKAGE__->register_method(
- method => 'delete_lineitem',
- api_name => 'open-ils.acq.purchase_order.lineitem.delete',
- signature => {
- desc => 'Deletes a lineitem from a purchase order',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID to delete', type => 'number'},
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-__PACKAGE__->register_method(
- method => 'delete_lineitem',
- api_name => 'open-ils.acq.picklist.lineitem.delete',
- signature => {
- desc => 'Deletes a lineitem from a picklist',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID to delete', type => 'number'},
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub delete_lineitem {
- my($self, $conn, $auth, $li_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- my $li = $e->retrieve_acq_lineitem($li_id)
- or return $e->die_event;
-
- # XXX check state
-
- if($li->picklist) {
- my $picklist = $e->retrieve_acq_picklist($li->picklist)
- or return $e->die_event;
- return OpenILS::Event->new('BAD_PARAMS')
- if $picklist->owner != $e->requestor->id;
- } else {
- # check PO perms
- }
-
- # once a LI is attached to a PO, deleting it
- # from a picklist means *detaching* it from the picklist
- if ($self->api_name =~ /picklist/ && $li->purchase_order) {
- $li->clear_picklist;
- my $evt = update_lineitem_impl($e, $li);
- return $evt if $evt;
- $e->commit;
- return 1;
- }
-
- # delete the attached lineitem_details
- my $lid_ids = $e->search_acq_lineitem_detail(
- {lineitem => $li_id}, {idlist=>1});
-
- for my $lid_id (@$lid_ids) {
- $e->delete_acq_lineitem_detail(
- $e->retrieve_acq_lineitem_detail($lid_id))
- or return $e->die_event;
- }
-
- $e->delete_acq_lineitem($li) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'update_lineitem',
- api_name => 'open-ils.acq.lineitem.update',
- signature => {
- desc => 'Update one or many lineitems',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem object update', type => 'object'}
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub update_lineitem {
- my($self, $conn, $auth, $li) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- $li = [$li] unless ref $li eq "ARRAY";
- foreach (@$li) {
- my $evt = update_lineitem_impl($e, $_);
- return $evt if $evt;
- }
-
- $e->commit;
- return 1;
-}
-
-sub update_lineitem_impl {
- my($e, $li) = @_;
-
- my $orig_li = $e->retrieve_acq_lineitem([
- $li->id,
- { flesh => 1, # grab the lineitem with picklist attached
- flesh_fields => {jub => ['picklist', 'purchase_order']}
- }
- ]) or return $e->die_event;
-
- # the marc may have been cleared on retrieval...
- $li->marc($orig_li->marc) unless $li->marc;
-
- $li->editor($e->requestor->id);
- $li->edit_time('now');
- $e->update_acq_lineitem($li) or return $e->die_event;
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'lineitem_search',
- api_name => 'open-ils.acq.lineitem.search',
- stream => 1,
- signature => {
- desc => 'Searches lineitems',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Search definition', type => 'object'},
- {desc => 'Options hash. idlist=true', type => 'object'},
- {desc => 'List of lineitems', type => 'object/number'},
- ]
- }
-);
-
-sub lineitem_search {
- my($self, $conn, $auth, $search, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('CREATE_PICKLIST');
- # XXX needs permissions consideration
- my $lis = $e->search_acq_lineitem($search, {idlist=>1});
- for my $li_id (@$lis) {
- if($$options{idlist}) {
- $conn->respond($li_id);
- } else {
- my $res = retrieve_lineitem($self, $conn, $auth, $li_id, $options);
- $conn->respond($res) unless $U->event_code($res);
- }
- }
- return undef;
-}
-
-__PACKAGE__->register_method (
- method => 'lineitems_related_by_bib',
- api_name => 'open-ils.acq.lineitems_for_bib.by_bib_id',
- stream => 1,
- signature => q/
- Retrieves lineitems attached to same bib record, subject to the PO ordering agency. This variant takes the bib id.
- @param authtoken Login session key
- @param bib_id Id for the pertinent bib record.
- @param options Object for tweaking the selection criteria and fleshing options.
- /
-);
-
-__PACKAGE__->register_method (
- method => 'lineitems_related_by_bib',
- api_name => 'open-ils.acq.lineitems_for_bib.by_lineitem_id',
- stream => 1,
- signature => q/
- Retrieves lineitems attached to same bib record, subject to the PO ordering agency. This variant takes the id for any of the pertinent lineitems.
- @param authtoken Login session key
- @param bib_id Id for a pertinent lineitem.
- @param options Object for tweaking the selection criteria and fleshing options.
- /
-);
-
-__PACKAGE__->register_method (
- method => 'lineitems_related_by_bib',
- api_name => 'open-ils.acq.lineitems_for_bib.by_lineitem_id.count',
- stream => 1,
- signature => q/See open-ils.acq.lineitems_for_bib.by_lineitem_id. This version returns numbers of lineitems only (XXX may count lineitems we don't actually have permission to retrieve)/
-);
-
-sub lineitems_related_by_bib {
- my($self, $conn, $auth, $test_value, $options) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $perm_orgs = $U->user_has_work_perm_at($e, 'VIEW_PURCHASE_ORDER', {descendants =>1}, $e->requestor->id);
-
- my $query = {
- "select"=>{"jub"=>["id"]},
- "from"=>{"jub" => {"acqpo" => {type => 'left'}, "acqpl" => {type => 'left'}}},
- "where"=>{
- '-or' => [
- { "+acqpo"=>{ "ordering_agency" => $perm_orgs } },
- { '+acqpl' => { org_unit => $perm_orgs } }
- ]
- },
- "order_by"=>[{"class"=>"jub", "field"=>"create_time", "direction"=>"desc"}]
- };
-
- # Be sure we just return the original LI if no related bibs
- if ($self->api_name =~ /by_lineitem_id/) {
- my $orig = retrieve_lineitem($self, $conn, $auth, $test_value) or
- return $e->die_event;
- if ($test_value = $orig->eg_bib_id) {
- $query->{"where"}->{"eg_bib_id"} = $test_value;
- } else {
- $query->{"where"}->{"id"} = $orig->id;
- }
- } elsif ($test_value) {
- $query->{"where"}->{"eg_bib_id"} = $test_value;
- } else {
- $e->disconnect;
- return new OpenILS::Event("BAD_PARAMS", "Null bib id");
- }
-
- if ($options && defined $options->{lineitem_state}) {
- $query->{'where'}{'jub'}{'state'} = $options->{lineitem_state};
- }
-
- if ($options && defined $options->{po_state}) {
- $query->{'where'}{'+acqpo'}{'state'} = $options->{po_state};
- }
-
- if ($options && defined $options->{order_by}) {
- $query->{'order_by'} = $options->{order_by};
- }
-
- my $results = $e->json_query($query);
- if ($self->api_name =~ /count$/) {
- return scalar(@$results);
- } else {
- for my $result (@$results) {
- # retrieve_lineitem takes care of POs and PLs and also handles
- # options like flesh_notes and permissions checking.
- $conn->respond(
- retrieve_lineitem($self, $conn, $auth, $result->{"id"}, $options)
- );
- }
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "lineitem_search_by_attributes",
- api_name => "open-ils.acq.lineitem.search.by_attributes",
- stream => 1,
- signature => {
- desc => "Performs a search against lineitem_attrs",
- params => [
- {desc => "Authentication token", type => "string"},
- { desc => q/
-Search definition:
- attr_value_pairs : list of pairs of (attr definition ID, attr value) where value can be scalar (fuzzy match) or array (exact match)
- li_states : list of lineitem states
- po_agencies : list of purchase order ordering agencies (org) ids
-
-At least one of these search terms is required.
- /,
- type => "object"},
- { desc => q/
-Options hash:
- idlist : if set, only return lineitem IDs
- clear_marc : if set, strip the MARC xml from the lineitem before delivery
- flesh_attrs : flesh lineitem attributes;
- /,
- type => "object"}
- ]
- }
-);
-
-__PACKAGE__->register_method(
- method => "lineitem_search_by_attributes",
- api_name => "open-ils.acq.lineitem.search.by_attributes.ident",
- stream => 1,
- signature => {
- desc => "Performs a search against lineitem_attrs where ident is true. ".
- "See open-ils.acq.lineitem.search.by_attributes for params."
- }
-);
-
-sub lineitem_search_by_attributes {
- my ($self, $conn, $auth, $search, $options) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- # XXX needs permissions consideration
-
- return [] unless $search;
- my $attr_value_pairs = $search->{attr_value_pairs};
- my $li_states = $search->{li_states};
- my $po_agencies = $search->{po_agencies}; # XXX if none, base it on perms
-
- my $query = {
- "select" => {"acqlia" =>
- [{"column" => "lineitem", "transform" => "distinct"}]
- },
- "from" => {
- "acqlia" => {
- "acqliad" => {"field" => "id", "fkey" => "definition"},
- "jub" => {
- "field" => "id",
- "fkey" => "lineitem",
- "join" => {
- "acqpo" => {
- "type" => "left",
- "field" => "id",
- "fkey" => "purchase_order"
- }
- }
- }
- }
- }
- };
-
- my $where = {};
- $where->{"+acqliad"} = {"ident" => "t"}
- if $self->api_name =~ /\.ident/;
-
- my $searched_for_something = 0;
-
- if (ref $attr_value_pairs eq "ARRAY") {
- $where->{"-or"} = [];
- foreach (@$attr_value_pairs) {
- next if @$_ != 2;
- my ($def, $value) = @$_;
- push @{$where->{"-or"}}, {
- "-and" => {
- "attr_value" => (ref $value) ?
- $value : {"ilike" => "%" . $value . "%"},
- "definition" => $def
- }
- };
- }
- $searched_for_something = 1;
- }
-
- if ($li_states and @$li_states) {
- $where->{"+jub"} = {"state" => $li_states};
- $searched_for_something = 1;
- }
-
- if ($po_agencies and @$po_agencies) {
- $where->{"+acqpo"} = {"ordering_agency" => $po_agencies};
- $searched_for_something = 1;
- }
-
- if (not $searched_for_something) {
- $e->rollback;
- return new OpenILS::Event(
- "BAD_PARAMS", note => "You have provided no search terms."
- );
- }
-
- $query->{"where"} = $where;
- my $lis = $e->json_query($query);
-
- for my $li_id_obj (@$lis) {
- my $li_id = $li_id_obj->{"lineitem"};
- if($options->{"idlist"}) {
- $conn->respond($li_id);
- } else {
- $conn->respond(
- retrieve_lineitem($self, $conn, $auth, $li_id, $options)
- );
- }
- }
- undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'lineitem_search_ident',
- api_name => 'open-ils.acq.lineitem.search.ident',
- stream => 1,
- signature => {
- desc => 'Performs a search against lineitem_attrs where ident is true',
- params => [
- {desc => 'Authentication token', type => 'string'},
- { desc => q/Search definition. Options are:
- attr_values : list of attribute values (required)
- li_states : list of lineitem states
- po_agencies : list of purchase order ordering agencies (org) ids
- /,
- type => 'object',
- },
- { desc => q/
- Options hash. Options are:
- idlist : if set, only return lineitem IDs
- clear_marc : if set, strip the MARC xml from the lineitem before delivery
- flesh_attrs : flesh lineitem attributes;
- /,
- type => 'object',
- }
- ]
- }
-);
-
-my $LI_ATTR_SEARCH = {
- select => { acqlia => ['lineitem'] },
- from => {
- acqlia => {
- acqliad => {
- field => 'id',
- fkey => 'definition'
- },
- jub => {
- field => 'id',
- fkey => 'lineitem',
- join => {
- acqpo => {
- field => 'id',
- fkey => 'purchase_order'
- }
- }
- }
- }
- }
-};
-
-sub lineitem_search_ident {
- my($self, $conn, $auth, $search, $options) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->event unless $e->checkauth;
- # XXX needs permissions consideration
-
- return [] unless $search;
- my $attr_values = $search->{attr_values};
- my $li_states = $search->{li_states};
- my $po_agencies = $search->{po_agencies}; # XXX if none, base it on perms
-
- my $where_clause = {
- '-or' => [],
- '+acqlia' => {
- '+acqliad' => {ident => 't'},
- }
- };
-
- push(@{$where_clause->{'-or'}}, {attr_value => {ilike => "%$_%"}}) for @$attr_values;
-
- $where_clause->{'+jub'} = {state => {in => $li_states}}
- if $li_states and @$li_states;
-
- $where_clause->{'+acqpo'} = {ordering_agency => $po_agencies}
- if $po_agencies and @$po_agencies;
-
- $LI_ATTR_SEARCH->{where} = $where_clause;
-
- my $lis = $e->json_query($LI_ATTR_SEARCH);
-
- for my $li_id_obj (@$lis) {
- my $li_id = $li_id_obj->{lineitem};
- if($$options{idlist}) {
- $conn->respond($li_id);
- } else {
- my $li;
- if($$options{flesh_attrs}) {
- $li = $e->retrieve_acq_lineitem([
- $li_id, {flesh => 1, flesh_fields => {jub => ['attributes']}}])
- } else {
- $li = $e->retrieve_acq_lineitem($li_id);
- }
- $li->clear_marc if $$options{clear_marc};
- $conn->respond($li);
- }
- }
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_lineitem_detail',
- api_name => 'open-ils.acq.lineitem_detail.retrieve',
- authoritative => 1,
- signature => {
- desc => q/Updates a lineitem detail/,
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'id of lineitem_detail to retrieve', type => 'number' },
- ],
- return => { desc => 'object on success, Event on failure' }
- }
-);
-sub retrieve_lineitem_detail {
- my($self, $conn, $auth, $li_detail_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $li_detail = $e->retrieve_acq_lineitem_detail($li_detail_id)
- or return $e->event;
-
- if($li_detail->fund) {
- my $fund = $e->retrieve_acq_fund($li_detail->fund) or return $e->event;
- return $e->event unless
- $e->allowed('MANAGE_FUND', $fund->org, $fund);
- }
-
- # XXX check lineitem perms
- return $li_detail;
-}
-
-
-__PACKAGE__->register_method(
- method => 'approve_lineitem',
- api_name => 'open-ils.acq.lineitem.approve',
- signature => {
- desc => 'Mark a lineitem as approved',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'lineitem ID', type => 'number' }
- ],
- return => { desc => '1 on success, Event on error' }
- }
-);
-sub approve_lineitem {
- my($self, $conn, $auth, $li_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- # XXX perm checks for each lineitem detail
-
- my $li = $e->retrieve_acq_lineitem($li_id)
- or return $e->die_event;
-
- return OpenILS::Event->new('ACQ_LINEITEM_APPROVED', payload => $li_id)
- if $li->state eq 'approved';
-
- my $details = $e->search_acq_lineitem_detail({lineitem => $li_id});
- return OpenILS::Event->new('ACQ_LINEITEM_NO_COPIES', payload => $li_id)
- unless scalar(@$details) > 0;
-
- for my $detail (@$details) {
- return OpenILS::Event->new('ACQ_LINEITEM_DETAIL_NO_FUND', payload => $detail->id)
- unless $detail->fund;
-
- return OpenILS::Event->new('ACQ_LINEITEM_DETAIL_NO_ORG', payload => $detail->id)
- unless $detail->owning_lib;
- }
-
- $li->state('approved');
- $li->edit_time('now');
- $e->update_acq_lineitem($li) or return $e->die_event;
-
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'set_lineitem_attr',
- api_name => 'open-ils.acq.lineitem_usr_attr.set',
- signature => {
- desc => 'Sets a lineitem_usr_attr value',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Lineitem ID', type => 'number' },
- { desc => 'Attr name', type => 'string' },
- { desc => 'Attr value', type => 'string' }
- ],
- return => { desc => '1 on success, Event on error' }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'set_lineitem_attr',
- api_name => 'open-ils.acq.lineitem_local_attr.set',
- signature => {
- desc => 'Sets a lineitem_local_attr value',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Lineitem ID', type => 'number' },
- { desc => 'Attr name', type => 'string' },
- { desc => 'Attr value', type => 'string' }
- ],
- return => { desc => 'ID of the attr object on success, Event on error' }
- }
-);
-
-
-sub set_lineitem_attr {
- my($self, $conn, $auth, $li_id, $attr_name, $attr_value) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- # XXX perm
-
- my $attr_type = $self->api_name =~ /local_attr/ ?
- 'lineitem_local_attr_definition' : 'lineitem_usr_attr_definition';
-
- my $attr = $e->search_acq_lineitem_attr({
- lineitem => $li_id,
- attr_type => $attr_type,
- attr_name => $attr_name})->[0];
-
- my $find = "search_acq_$attr_type";
-
- if($attr) {
- $attr->attr_value($attr_value);
- $e->update_acq_lineitem_attr($attr) or return $e->die_event;
- } else {
- $attr = Fieldmapper::acq::lineitem_attr->new;
- $attr->lineitem($li_id);
- $attr->attr_type($attr_type);
- $attr->attr_name($attr_name);
- $attr->attr_value($attr_value);
-
- my $attr_def_id = $e->$find({code => $attr_name}, {idlist=>1})->[0]
- or return $e->die_event;
- $attr->definition($attr_def_id);
- $e->create_acq_lineitem_attr($attr) or return $e->die_event;
- }
-
- $e->commit;
- return $attr->id;
-}
-
-__PACKAGE__->register_method(
- method => 'get_lineitem_attr_defs',
- api_name => 'open-ils.acq.lineitem_attr_definition.retrieve.all',
- authoritative => 1,
- signature => {
- desc => 'Retrieve lineitem attr definitions',
- params => [ { desc => 'Authentication token', type => 'string' }, ],
- return => { desc => 'List of attr definitions' }
- }
-);
-
-sub get_lineitem_attr_defs {
- my($self, $conn, $auth) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my %results;
- for my $type (qw/generated marc local usr provider/) {
- my $call = "retrieve_all_acq_lineitem_${type}_attr_definition";
- $results{$type} = $e->$call;
- }
- return \%results;
-}
-
-
-__PACKAGE__->register_method(
- method => 'lineitem_note_CUD_batch',
- api_name => 'open-ils.acq.lineitem_note.cud.batch',
- stream => 1,
- signature => {
- desc => q/Manage lineitem notes/,
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'List of lineitem_notes to manage', type => 'array' },
- ],
- return =>
- { desc => 'Streaming response of current position in the array' }
- }
-);
-
-sub lineitem_note_CUD_batch {
- my($self, $conn, $auth, $li_notes) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- # XXX perms
-
- my $total = @$li_notes;
- my $count = 0;
-
- for my $note (@$li_notes) {
-
- $note->editor($e->requestor->id);
- $note->edit_time('now');
-
- if($note->isnew) {
- $note->creator($e->requestor->id);
- $note = $e->create_acq_lineitem_note($note) or return $e->die_event;
-
- } elsif($note->isdeleted) {
- $e->delete_acq_lineitem_note($note) or return $e->die_event;
-
- } elsif($note->ischanged) {
- $e->update_acq_lineitem_note($note) or return $e->die_event;
- }
-
- if(!$note->isdeleted) {
- $note = $e->retrieve_acq_lineitem_note([
- $note->id, {
- "flesh" => 1, "flesh_fields" => {"acqlin" => ["alert_text"]}
- }
- ]);
- }
-
- $conn->respond({maximum => $total, progress => ++$count, note => $note});
- }
-
- $e->commit;
- return {complete => 1};
-}
-
-__PACKAGE__->register_method(
- method => 'ranged_line_item_alert_text',
- api_name => 'open-ils.acq.line_item_alert_text.ranged.retrieve.all'); # TODO: signature
-
-sub ranged_line_item_alert_text {
- my($self, $conn, $auth, $org_id, $depth) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('ADMIN_ACQ_LINEITEM_ALERT_TEXT', $org_id);
- return $e->search_acq_lineitem_alert_text(
- {owning_lib => $U->get_org_full_path($org_id, $depth)});
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_lineitem_by_copy_id",
- api_name => "open-ils.acq.lineitem.retrieve.by_copy_id",
- authoritative => 1,
- signature => {
- desc => q/Manage lineitem notes/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Evergreen internal copy ID", type => "number"},
- {desc => "Hash of options (see open-ils.acq.lineitem.retrieve",
- type => "object"}
- ],
- return => {
- desc => "Lineitem associated with given copy",
- type => "object", class => "jub"
- }
- }
-);
-
-sub retrieve_lineitem_by_copy_id {
- my ($self, $conn, $auth, $object_id, $options) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $result = $e->json_query({
- "select" => {"acqlid" => ["lineitem"]},
- "from" => "acqlid",
- "where" => {"eg_copy_id" => $object_id}
- })->[0] or do {
- $e->disconnect;
- return new OpenILS::Event("ACQ_LINEITEM_NOT_FOUND");
- };
-
- my $li = retrieve_lineitem_impl($e, $result->{"lineitem"}, $options) or
- return $e->die_event;
-
- $e->disconnect;
- return $li;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Acq::BatchManager;
-use OpenILS::Application::Acq::Financials;
-use OpenSRF::AppSession;
-use OpenSRF::EX qw/:try/;
-use strict; use warnings;
-
-sub new {
- my($class, %args) = @_;
- my $self = bless(\%args, $class);
- $self->{args} = {
- lid => 0,
- li => 0,
- copies => 0,
- bibs => 0,
- progress => 0,
- debits_accrued => 0,
- purchase_order => undef,
- picklist => undef,
- complete => 0,
- indexed => 0,
- total => 0
- };
- $self->{ingest_queue} = [];
- $self->{cache} = {};
- $self->throttle(5) unless $self->throttle;
- $self->{post_proc_queue} = [];
- $self->{last_respond_progress} = 0;
- return $self;
-}
-
-sub conn {
- my($self, $val) = @_;
- $self->{conn} = $val if $val;
- return $self->{conn};
-}
-sub throttle {
- my($self, $val) = @_;
- $self->{throttle} = $val if $val;
- return $self->{throttle};
-}
-sub respond {
- my($self, %other_args) = @_;
- if($self->throttle and not %other_args) {
- return unless (
- ($self->{args}->{progress} - $self->{last_respond_progress}) >= $self->throttle
- );
- }
- $self->conn->respond({ %{$self->{args}}, %other_args });
- $self->{last_respond_progress} = $self->{args}->{progress};
-}
-sub respond_complete {
- my($self, %other_args) = @_;
- $self->complete;
- $self->conn->respond_complete({ %{$self->{args}}, %other_args });
- $self->run_post_response_hooks;
- return undef;
-}
-
-# run the post response hook subs, shifting them off as we go
-sub run_post_response_hooks {
- my($self) = @_;
- (shift @{$self->{post_proc_queue}})->() while @{$self->{post_proc_queue}};
-}
-
-# any subs passed to this method will be run after the call to respond_complete
-sub post_process {
- my($self, $sub) = @_;
- push(@{$self->{post_proc_queue}}, $sub);
-}
-
-sub total {
- my($self, $val) = @_;
- $self->{args}->{total} = $val if defined $val;
- $self->{args}->{maximum} = $self->{args}->{total};
- return $self->{args}->{total};
-}
-sub purchase_order {
- my($self, $val) = @_;
- $self->{args}->{purchase_order} = $val if $val;
- return $self;
-}
-sub picklist {
- my($self, $val) = @_;
- $self->{args}->{picklist} = $val if $val;
- return $self;
-}
-sub add_lid {
- my $self = shift;
- $self->{args}->{lid} += 1;
- $self->{args}->{progress} += 1;
- return $self;
-}
-sub add_li {
- my $self = shift;
- $self->{args}->{li} += 1;
- $self->{args}->{progress} += 1;
- return $self;
-}
-sub add_copy {
- my $self = shift;
- $self->{args}->{copies} += 1;
- $self->{args}->{progress} += 1;
- return $self;
-}
-sub add_bib {
- my $self = shift;
- $self->{args}->{bibs} += 1;
- $self->{args}->{progress} += 1;
- return $self;
-}
-sub add_debit {
- my($self, $amount) = @_;
- $self->{args}->{debits_accrued} += $amount;
- $self->{args}->{progress} += 1;
- return $self;
-}
-sub editor {
- my($self, $editor) = @_;
- $self->{editor} = $editor if defined $editor;
- return $self->{editor};
-}
-sub complete {
- my $self = shift;
- $self->{args}->{complete} = 1;
- return $self;
-}
-
-sub ingest_ses {
- my($self, $val) = @_;
- $self->{ingest_ses} = $val if $val;
- return $self->{ingest_ses};
-}
-
-sub push_ingest_queue {
- my($self, $rec_id) = @_;
-
- $self->ingest_ses(OpenSRF::AppSession->connect('open-ils.ingest'))
- unless $self->ingest_ses;
-
- my $req = $self->ingest_ses->request('open-ils.ingest.full.biblio.record', $rec_id);
-
- push(@{$self->{ingest_queue}}, $req);
-}
-
-sub process_ingest_records {
- my $self = shift;
- return unless @{$self->{ingest_queue}};
-
- for my $req (@{$self->{ingest_queue}}) {
-
- try {
- $req->gather(1);
- $self->{args}->{indexed} += 1;
- $self->{args}->{progress} += 1;
- } otherwise {};
-
- $self->respond;
- }
- $self->ingest_ses->disconnect;
-}
-
-
-sub cache {
- my($self, $org, $key, $val) = @_;
- $self->{cache}->{$org} = {} unless $self->{cache}->{org};
- $self->{cache}->{$org}->{$key} = $val if defined $val;
- return $self->{cache}->{$org}->{$key};
-}
-
-
-package OpenILS::Application::Acq::Order;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-# ----------------------------------------------------------------------------
-# Break up each component of the order process and pieces into managable
-# actions that can be shared across different workflows
-# ----------------------------------------------------------------------------
-use OpenILS::Event;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenSRF::Utils::JSON;
-use OpenSRF::AppSession;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Const qw/:const/;
-use OpenSRF::EX q/:try/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Cat::BibCommon;
-use OpenILS::Application::Cat::AssetCommon;
-use MARC::Record;
-use MARC::Batch;
-use MARC::File::XML;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-# ----------------------------------------------------------------------------
-# Lineitem
-# ----------------------------------------------------------------------------
-sub create_lineitem {
- my($mgr, %args) = @_;
- my $li = Fieldmapper::acq::lineitem->new;
- $li->creator($mgr->editor->requestor->id);
- $li->selector($li->creator);
- $li->editor($li->creator);
- $li->create_time('now');
- $li->edit_time('now');
- $li->state('new');
- $li->$_($args{$_}) for keys %args;
- $li->clear_id;
- $mgr->add_li;
- $mgr->editor->create_acq_lineitem($li) or return 0;
-
- unless($li->estimated_unit_price) {
- # extract the price from the MARC data
- my $price = get_li_price_from_attr($mgr->editor, $li) or return $li;
- $li->estimated_unit_price($price);
- return update_lineitem($mgr, $li);
- }
-
- return $li;
-}
-
-sub get_li_price_from_attr {
- my($e, $li) = @_;
- my $attrs = $li->attributes || $e->search_acq_lineitem_attr({lineitem => $li->id});
-
- for my $attr_type (qw/
- lineitem_local_attr_definition
- lineitem_prov_attr_definition
- lineitem_marc_attr_definition/) {
-
- my ($attr) = grep {
- $_->attr_name eq 'estimated_price' and
- $_->attr_type eq $attr_type } @$attrs;
-
- return $attr->attr_value if $attr;
- }
-
- return undef;
-}
-
-
-sub update_lineitem {
- my($mgr, $li) = @_;
- $li->edit_time('now');
- $li->editor($mgr->editor->requestor->id);
- $mgr->add_li;
- return $mgr->editor->retrieve_acq_lineitem($mgr->editor->data) if
- $mgr->editor->update_acq_lineitem($li);
- return undef;
-}
-
-
-# ----------------------------------------------------------------------------
-# Create real holds from patron requests for a given lineitem
-# ----------------------------------------------------------------------------
-sub promote_lineitem_holds {
- my($mgr, $li) = @_;
-
- my $requests = $mgr->editor->search_acq_user_request(
- { lineitem => $li->id,
- '-or' =>
- [ { need_before => {'>' => 'now'} },
- { need_before => undef }
- ]
- }
- );
-
- for my $request ( @$requests ) {
-
- $request->eg_bib( $li->eg_bib_id );
- $mgr->editor->update_acq_user_request( $request ) or return 0;
-
- next unless ($U->is_true( $request->hold ));
-
- my $hold = Fieldmapper::action::hold_request->new;
- $hold->usr( $request->usr );
- $hold->requestor( $request->usr );
- $hold->request_time( $request->request_date );
- $hold->pickup_lib( $request->pickup_lib );
- $hold->request_lib( $request->pickup_lib );
- $hold->selection_ou( $request->pickup_lib );
- $hold->phone_notify( $request->phone_notify );
- $hold->email_notify( $request->email_notify );
- $hold->expire_time( $request->need_before );
-
- if ($request->holdable_formats) {
- my $mrm = $mgr->editor->search_metabib_metarecord_source_map( { source => $li->eg_bib_id } )->[0];
- if ($mrm) {
- $hold->hold_type( 'M' );
- $hold->holdable_formats( $request->holdable_formats );
- $hold->target( $mrm->metarecord );
- }
- }
-
- if (!$hold->target) {
- $hold->hold_type( 'T' );
- $hold->target( $li->eg_bib_id );
- }
-
- $mgr->editor->create_actor_hold_request( $hold ) or return 0;
- }
-
- return $li;
-}
-
-sub delete_lineitem {
- my($mgr, $li) = @_;
- $li = $mgr->editor->retrieve_acq_lineitem($li) unless ref $li;
-
- # delete the attached lineitem_details
- my $lid_ids = $mgr->editor->search_acq_lineitem_detail({lineitem => $li->id}, {idlist=>1});
- for my $lid_id (@$lid_ids) {
- return 0 unless delete_lineitem_detail($mgr, $lid_id);
- }
-
- $mgr->add_li;
- return $mgr->editor->delete_acq_lineitem($li);
-}
-
-# begins and commit transactions as it goes
-sub create_lineitem_list_assets {
- my($mgr, $li_ids) = @_;
- return undef if check_import_li_marc_perms($mgr, $li_ids);
-
- # create the bibs/volumes/copies and ingest the records
- for my $li_id (@$li_ids) {
- $mgr->editor->xact_begin;
- my $data = create_lineitem_assets($mgr, $li_id) or return undef;
- $mgr->editor->xact_commit;
- # XXX ingest is in-db now
- #$mgr->push_ingest_queue($data->{li}->eg_bib_id) if $data->{new_bib};
- $mgr->respond;
- }
- $mgr->process_ingest_records;
- return 1;
-}
-
-# returns event on error, undef on success
-sub check_import_li_marc_perms {
- my($mgr, $li_ids) = @_;
-
- # if there are any order records that are not linked to
- # in-db bib records, verify staff has perms to import order records
- my $order_li = $mgr->editor->search_acq_lineitem(
- [{id => $li_ids, eg_bib_id => undef}, {limit => 1}], {idlist => 1})->[0];
-
- if($order_li) {
- return $mgr->editor->die_event unless
- $mgr->editor->allowed('IMPORT_ACQ_LINEITEM_BIB_RECORD');
- }
-
- return undef;
-}
-
-
-# ----------------------------------------------------------------------------
-# if all of the lineitem details for this lineitem have
-# been received, mark the lineitem as received
-# returns 1 on non-received, li on received, 0 on error
-# ----------------------------------------------------------------------------
-
-sub describe_affected_po {
- my ($e, $po) = @_;
-
- my ($enc, $spent) =
- OpenILS::Application::Acq::Financials::build_price_summary(
- $e, $po->id
- );
-
- +{$po->id => {
- "state" => $po->state,
- "amount_encumbered" => $enc,
- "amount_spent" => $spent
- }
- };
-}
-
-sub check_lineitem_received {
- my($mgr, $li_id) = @_;
-
- my $non_recv = $mgr->editor->search_acq_lineitem_detail(
- {recv_time => undef, lineitem => $li_id}, {idlist=>1});
-
- return 1 if @$non_recv;
-
- my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
- $li->state('received');
- return update_lineitem($mgr, $li);
-}
-
-sub receive_lineitem {
- my($mgr, $li_id, $skip_complete_check) = @_;
- my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
-
- my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
- {lineitem => $li_id, recv_time => undef}, {idlist => 1});
-
- for my $lid_id (@$lid_ids) {
- receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
- }
-
- $mgr->add_li;
- $li->state('received');
-
- $li = update_lineitem($mgr, $li) or return 0;
- $mgr->post_process( sub { create_lineitem_status_events($mgr, $li_id, 'aur.received'); });
-
- my $po;
- return 0 unless
- $skip_complete_check or (
- $po = check_purchase_order_received($mgr, $li->purchase_order)
- );
-
- my $result = {"li" => {$li->id => {"state" => $li->state}}};
- $result->{"po"} = describe_affected_po($mgr->editor, $po) if ref $po;
- return $result;
-}
-
-sub rollback_receive_lineitem {
- my($mgr, $li_id) = @_;
- my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
-
- my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
- {lineitem => $li_id, recv_time => {'!=' => undef}}, {idlist => 1});
-
- for my $lid_id (@$lid_ids) {
- rollback_receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
- }
-
- $mgr->add_li;
- $li->state('on-order');
- return update_lineitem($mgr, $li);
-}
-
-
-sub create_lineitem_status_events {
- my($mgr, $li_id, $hook) = @_;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->connect;
- my $user_reqs = $mgr->editor->search_acq_user_request([
- {lineitem => $li_id},
- {flesh => 1, flesh_fields => {aur => ['usr']}}
- ]);
-
- for my $user_req (@$user_reqs) {
- my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $user_req->usr->home_ou);
- $req->recv;
- }
-
- $ses->disconnect;
- return undef;
-}
-
-# ----------------------------------------------------------------------------
-# Lineitem Detail
-# ----------------------------------------------------------------------------
-sub create_lineitem_detail {
- my($mgr, %args) = @_;
- my $lid = Fieldmapper::acq::lineitem_detail->new;
- $lid->$_($args{$_}) for keys %args;
- $lid->clear_id;
- $mgr->add_lid;
- return $mgr->editor->create_acq_lineitem_detail($lid);
-}
-
-
-# flesh out any required data with default values where appropriate
-sub complete_lineitem_detail {
- my($mgr, $lid) = @_;
- unless($lid->barcode) {
- my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_barcode_prefix') || 'ACQ';
- $lid->barcode($pfx.$lid->id);
- }
-
- unless($lid->cn_label) {
- my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_callnumber_prefix') || 'ACQ';
- $lid->cn_label($pfx.$lid->id);
- }
-
- if(!$lid->location and my $loc = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.default_copy_location')) {
- $lid->location($loc);
- }
-
- $lid->circ_modifier(get_default_circ_modifier($mgr, $lid->owning_lib))
- unless defined $lid->circ_modifier;
-
- $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
- return $lid;
-}
-
-sub get_default_circ_modifier {
- my($mgr, $org) = @_;
- my $code = $mgr->cache($org, 'def_circ_mod');
- $code = $U->ou_ancestor_setting_value($org, 'acq.default_circ_modifier') unless defined $code;
- return $mgr->cache($org, 'def_circ_mod', $code) if defined $code;
- return undef;
-}
-
-sub delete_lineitem_detail {
- my($mgr, $lid) = @_;
- $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid) unless ref $lid;
- return $mgr->editor->delete_acq_lineitem_detail($lid);
-}
-
-
-sub receive_lineitem_detail {
- my($mgr, $lid_id, $skip_complete_check) = @_;
- my $e = $mgr->editor;
-
- my $lid = $e->retrieve_acq_lineitem_detail([
- $lid_id,
- { flesh => 1,
- flesh_fields => {
- acqlid => ['fund_debit']
- }
- }
- ]) or return 0;
-
- return 1 if $lid->recv_time;
-
- $lid->recv_time('now');
- $e->update_acq_lineitem_detail($lid) or return 0;
-
- my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
- $copy->status(OILS_COPY_STATUS_IN_PROCESS);
- $copy->edit_date('now');
- $copy->editor($e->requestor->id);
- $e->update_asset_copy($copy) or return 0;
-
- $mgr->add_lid;
-
- return 1 if $skip_complete_check;
-
- my $li = check_lineitem_received($mgr, $lid->lineitem) or return 0;
- return 1 if $li == 1; # li not received
-
- return check_purchase_order_received($mgr, $li->purchase_order) or return 0;
-}
-
-
-sub rollback_receive_lineitem_detail {
- my($mgr, $lid_id) = @_;
- my $e = $mgr->editor;
-
- my $lid = $e->retrieve_acq_lineitem_detail([
- $lid_id,
- { flesh => 1,
- flesh_fields => {
- acqlid => ['fund_debit']
- }
- }
- ]) or return 0;
-
- return 1 unless $lid->recv_time;
-
- $lid->clear_recv_time;
- $e->update_acq_lineitem_detail($lid) or return 0;
-
- my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
- $copy->status(OILS_COPY_STATUS_ON_ORDER);
- $copy->edit_date('now');
- $copy->editor($e->requestor->id);
- $e->update_asset_copy($copy) or return 0;
-
- $mgr->add_lid;
- return $lid;
-}
-
-# ----------------------------------------------------------------------------
-# Lineitem Attr
-# ----------------------------------------------------------------------------
-sub set_lineitem_attr {
- my($mgr, %args) = @_;
- my $attr_type = $args{attr_type};
-
- # first, see if it's already set. May just need to overwrite it
- my $attr = $mgr->editor->search_acq_lineitem_attr({
- lineitem => $args{lineitem},
- attr_type => $args{attr_type},
- attr_name => $args{attr_name}
- })->[0];
-
- if($attr) {
- $attr->attr_value($args{attr_value});
- return $attr if $mgr->editor->update_acq_lineitem_attr($attr);
- return undef;
-
- } else {
-
- $attr = Fieldmapper::acq::lineitem_attr->new;
- $attr->$_($args{$_}) for keys %args;
-
- unless($attr->definition) {
- my $find = "search_acq_$attr_type";
- my $attr_def_id = $mgr->editor->$find({code => $attr->attr_name}, {idlist=>1})->[0] or return 0;
- $attr->definition($attr_def_id);
- }
- return $mgr->editor->create_acq_lineitem_attr($attr);
- }
-}
-
-# ----------------------------------------------------------------------------
-# Lineitem Debits
-# ----------------------------------------------------------------------------
-sub create_lineitem_debits {
- my ($mgr, $li, $dry_run) = @_;
-
- unless($li->estimated_unit_price) {
- $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PRICE', payload => $li->id));
- $mgr->editor->rollback;
- return 0;
- }
-
- unless($li->provider) {
- $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PROVIDER', payload => $li->id));
- $mgr->editor->rollback;
- return 0;
- }
-
- my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
- {lineitem => $li->id},
- {idlist=>1}
- );
-
- for my $lid_id (@$lid_ids) {
-
- my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
- $lid_id,
- { flesh => 1,
- flesh_fields => {acqlid => ['fund']}
- }
- ]);
-
- create_lineitem_detail_debit($mgr, $li, $lid, $dry_run) or return 0;
- }
-
- return 1;
-}
-
-
-# flesh li->provider
-# flesh lid->fund
-sub create_lineitem_detail_debit {
- my ($mgr, $li, $lid, $dry_run, $no_translate) = @_;
-
- # don't create the debit if one already exists
- return $mgr->editor->retrieve_acq_fund_debit($lid->fund_debit) if $lid->fund_debit;
-
- my $li_id = ref($li) ? $li->id : $li;
-
- unless(ref $li and ref $li->provider) {
- $li = $mgr->editor->retrieve_acq_lineitem([
- $li_id,
- { flesh => 1,
- flesh_fields => {jub => ['provider']},
- }
- ]);
- }
-
- if(ref $lid) {
- $lid->fund($mgr->editor->retrieve_acq_fund($lid->fund)) unless(ref $lid->fund);
- } else {
- $lid = $mgr->editor->retrieve_acq_lineitem_detail([
- $lid,
- { flesh => 1,
- flesh_fields => {acqlid => ['fund']}
- }
- ]);
- }
-
- unless ($lid->fund) {
- $mgr->editor->event(
- new OpenILS::Event("ACQ_FUND_NOT_FOUND") # close enough
- );
- return 0;
- }
-
- my $amount = $li->estimated_unit_price;
- if($li->provider->currency_type ne $lid->fund->currency_type and !$no_translate) {
-
- # At Fund debit creation time, translate into the currency of the fund
- # TODO: org setting to disable automatic currency conversion at debit create time?
-
- $amount = $mgr->editor->json_query({
- from => [
- 'acq.exchange_ratio',
- $li->provider->currency_type, # source currency
- $lid->fund->currency_type, # destination currency
- $li->estimated_unit_price # source amount
- ]
- })->[0]->{value};
- }
-
- my $debit = create_fund_debit(
- $mgr,
- $dry_run,
- fund => $lid->fund->id,
- origin_amount => $li->estimated_unit_price,
- origin_currency_type => $li->provider->currency_type,
- amount => $amount
- ) or return 0;
-
- $lid->fund_debit($debit->id);
- $lid->fund($lid->fund->id);
- $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
- return $debit;
-}
-
-
-__PACKAGE__->register_method(
- "method" => "fund_exceeds_balance_percent_api",
- "api_name" => "open-ils.acq.fund.check_balance_percentages",
- "signature" => {
- "desc" => q/Determine whether a given fund exceeds its defined
- "balance stop and warning percentages"/,
- "params" => [
- {"desc" => "Authentication token", "type" => "string"},
- {"desc" => "Fund ID", "type" => "number"},
- {"desc" => "Theoretical debit amount (optional)",
- "type" => "number"}
- ],
- "return" => {"desc" => q/An array of two values, for stop and warning,
- in that order: 1 if fund exceeds that balance percentage, else 0/}
- }
-);
-
-sub fund_exceeds_balance_percent_api {
- my ($self, $conn, $auth, $fund_id, $debit_amount) = @_;
-
- $debit_amount ||= 0;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $fund = $e->retrieve_acq_fund($fund_id) or return $e->die_event;
- return $e->die_event unless $e->allowed("VIEW_FUND", $fund->org);
-
- my $result = [
- fund_exceeds_balance_percent($fund, $debit_amount, $e, "stop"),
- fund_exceeds_balance_percent($fund, $debit_amount, $e, "warning")
- ];
-
- $e->disconnect;
- return $result;
-}
-
-sub fund_exceeds_balance_percent {
- my ($fund, $debit_amount, $e, $which) = @_;
-
- my ($method_name, $event_name) = @{{
- "warning" => [
- "balance_warning_percent", "ACQ_FUND_EXCEEDS_WARN_PERCENT"
- ],
- "stop" => [
- "balance_stop_percent", "ACQ_FUND_EXCEEDS_STOP_PERCENT"
- ]
- }->{$which}};
-
- if ($fund->$method_name) {
- my $balance =
- $e->search_acq_fund_combined_balance({"fund" => $fund->id})->[0];
- my $allocations =
- $e->search_acq_fund_allocation_total({"fund" => $fund->id})->[0];
-
- $balance = ($balance) ? $balance->amount : 0;
- $allocations = ($allocations) ? $allocations->amount : 0;
-
- if (
- $allocations == 0 || # if no allocations were ever made, assume we have hit the stop percent
- ((($allocations - $balance + $debit_amount) / $allocations) * 100) > $fund->$method_name
- ) {
- $logger->info("fund would hit a limit: " . $fund->id . ", $balance, $debit_amount, $allocations, $method_name");
- $e->event(
- new OpenILS::Event(
- $event_name,
- "payload" => {
- "fund" => $fund, "debit_amount" => $debit_amount
- }
- )
- );
- return 1;
- }
- }
- return 0;
-}
-
-# ----------------------------------------------------------------------------
-# Fund Debit
-# ----------------------------------------------------------------------------
-sub create_fund_debit {
- my($mgr, $dry_run, %args) = @_;
-
- # Verify the fund is not being spent beyond the hard stop amount
- my $fund = $mgr->editor->retrieve_acq_fund($args{fund}) or return 0;
-
- return 0 if
- fund_exceeds_balance_percent(
- $fund, $args{"amount"}, $mgr->editor, "stop"
- );
- return 0 if
- $dry_run and fund_exceeds_balance_percent(
- $fund, $args{"amount"}, $mgr->editor, "warning"
- );
-
- my $debit = Fieldmapper::acq::fund_debit->new;
- $debit->debit_type('purchase');
- $debit->encumbrance('t');
- $debit->$_($args{$_}) for keys %args;
- $debit->clear_id;
- $mgr->add_debit($debit->amount);
- return $mgr->editor->create_acq_fund_debit($debit);
-}
-
-
-# ----------------------------------------------------------------------------
-# Picklist
-# ----------------------------------------------------------------------------
-sub create_picklist {
- my($mgr, %args) = @_;
- my $picklist = Fieldmapper::acq::picklist->new;
- $picklist->creator($mgr->editor->requestor->id);
- $picklist->owner($picklist->creator);
- $picklist->editor($picklist->creator);
- $picklist->create_time('now');
- $picklist->edit_time('now');
- $picklist->org_unit($mgr->editor->requestor->ws_ou);
- $picklist->owner($mgr->editor->requestor->id);
- $picklist->$_($args{$_}) for keys %args;
- $picklist->clear_id;
- $mgr->picklist($picklist);
- return $mgr->editor->create_acq_picklist($picklist);
-}
-
-sub update_picklist {
- my($mgr, $picklist) = @_;
- $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
- $picklist->edit_time('now');
- $picklist->editor($mgr->editor->requestor->id);
- if ($mgr->editor->update_acq_picklist($picklist)) {
- $picklist = $mgr->editor->retrieve_acq_picklist($mgr->editor->data);
- $mgr->picklist($picklist);
- return $picklist;
- } else {
- return undef;
- }
-}
-
-sub delete_picklist {
- my($mgr, $picklist) = @_;
- $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
-
- # delete all 'new' lineitems
- my $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => 'new'}, {idlist => 1});
- for my $li_id (@$li_ids) {
- my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
- return 0 unless delete_lineitem($mgr, $li);
- $mgr->respond;
- }
-
- # detach all non-'new' lineitems
- $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}}, {idlist => 1});
- for my $li_id (@$li_ids) {
- my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
- $li->clear_picklist;
- return 0 unless update_lineitem($mgr, $li);
- $mgr->respond;
- }
-
- # remove any picklist-specific object perms
- my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => ''.$picklist->id});
- for my $op (@$ops) {
- return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
- }
-
- return $mgr->editor->delete_acq_picklist($picklist);
-}
-
-# ----------------------------------------------------------------------------
-# Purchase Order
-# ----------------------------------------------------------------------------
-sub update_purchase_order {
- my($mgr, $po) = @_;
- $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
- $po->editor($mgr->editor->requestor->id);
- $po->edit_time('now');
- $mgr->purchase_order($po);
- return $mgr->editor->retrieve_acq_purchase_order($mgr->editor->data)
- if $mgr->editor->update_acq_purchase_order($po);
- return undef;
-}
-
-sub create_purchase_order {
- my($mgr, %args) = @_;
-
- # verify the chosen provider is still active
- my $provider = $mgr->editor->retrieve_acq_provider($args{provider}) or return 0;
- unless($U->is_true($provider->active)) {
- $logger->error("provider is not active. cannot create PO");
- $mgr->editor->event(OpenILS::Event->new('ACQ_PROVIDER_INACTIVE'));
- return 0;
- }
-
- my $po = Fieldmapper::acq::purchase_order->new;
- $po->creator($mgr->editor->requestor->id);
- $po->editor($mgr->editor->requestor->id);
- $po->owner($mgr->editor->requestor->id);
- $po->edit_time('now');
- $po->create_time('now');
- $po->state('pending');
- $po->ordering_agency($mgr->editor->requestor->ws_ou);
- $po->$_($args{$_}) for keys %args;
- $po->clear_id;
- $mgr->purchase_order($po);
- return $mgr->editor->create_acq_purchase_order($po);
-}
-
-# ----------------------------------------------------------------------------
-# if all of the lineitems for this PO are received,
-# mark the PO as received
-# ----------------------------------------------------------------------------
-sub check_purchase_order_received {
- my($mgr, $po_id) = @_;
-
- my $non_recv_li = $mgr->editor->search_acq_lineitem(
- { purchase_order => $po_id,
- state => {'!=' => 'received'}
- }, {idlist=>1});
-
- my $po = $mgr->editor->retrieve_acq_purchase_order($po_id);
- return $po if @$non_recv_li;
-
- $po->state('received');
- return update_purchase_order($mgr, $po);
-}
-
-
-# ----------------------------------------------------------------------------
-# Bib, Callnumber, and Copy data
-# ----------------------------------------------------------------------------
-
-sub create_lineitem_assets {
- my($mgr, $li_id) = @_;
- my $evt;
-
- my $li = $mgr->editor->retrieve_acq_lineitem([
- $li_id,
- { flesh => 1,
- flesh_fields => {jub => ['purchase_order', 'attributes']}
- }
- ]) or return 0;
-
- # -----------------------------------------------------------------
- # first, create the bib record if necessary
- # -----------------------------------------------------------------
- my $new_bib = 0;
- unless($li->eg_bib_id) {
- create_bib($mgr, $li) or return 0;
- $new_bib = 1;
- }
-
-
- # -----------------------------------------------------------------
- # The lineitem is going live, promote user request holds to real holds
- # -----------------------------------------------------------------
- promote_lineitem_holds($mgr, $li) or return 0;
-
- my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
-
- # -----------------------------------------------------------------
- # for each lineitem_detail, create the volume if necessary, create
- # a copy, and link them all together.
- # -----------------------------------------------------------------
- my $first_cn;
- for my $lid_id (@{$li_details}) {
-
- my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
- next if $lid->eg_copy_id;
-
- # use the same callnumber label for all items within this lineitem
- $lid->cn_label($first_cn) if $first_cn and not $lid->cn_label;
-
- # apply defaults if necessary
- return 0 unless complete_lineitem_detail($mgr, $lid);
-
- $first_cn = $lid->cn_label unless $first_cn;
-
- my $org = $lid->owning_lib;
- my $label = $lid->cn_label;
- my $bibid = $li->eg_bib_id;
-
- my $volume = $mgr->cache($org, "cn.$bibid.$label");
- unless($volume) {
- $volume = create_volume($mgr, $li, $lid) or return 0;
- $mgr->cache($org, "cn.$bibid.$label", $volume);
- }
- create_copy($mgr, $volume, $lid, $li) or return 0;
- }
-
- return { li => $li, new_bib => $new_bib };
-}
-
-sub create_bib {
- my($mgr, $li) = @_;
-
- my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
- $mgr->editor,
- $li->marc,
- undef, # bib source
- undef,
- 1, # override tcn collisions
- );
-
- if($U->event_code($record)) {
- $mgr->editor->event($record);
- $mgr->editor->rollback;
- return 0;
- }
-
- $li->eg_bib_id($record->id);
- $mgr->add_bib;
- return update_lineitem($mgr, $li);
-}
-
-sub create_volume {
- my($mgr, $li, $lid) = @_;
-
- my ($volume, $evt) =
- OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
- $mgr->editor,
- $lid->cn_label,
- $li->eg_bib_id,
- $lid->owning_lib
- );
-
- if($evt) {
- $mgr->editor->event($evt);
- return 0;
- }
-
- return $volume;
-}
-
-sub create_copy {
- my($mgr, $volume, $lid, $li) = @_;
- my $copy = Fieldmapper::asset::copy->new;
- $copy->isnew(1);
- $copy->loan_duration(2);
- $copy->fine_level(2);
- $copy->status(($lid->recv_time) ? OILS_COPY_STATUS_IN_PROCESS : OILS_COPY_STATUS_ON_ORDER);
- $copy->barcode($lid->barcode);
- $copy->location($lid->location);
- $copy->call_number($volume->id);
- $copy->circ_lib($volume->owning_lib);
- $copy->circ_modifier($lid->circ_modifier);
-
- # AKA list price. We might need a $li->list_price field since
- # estimated price is not necessarily the same as list price
- $copy->price($li->estimated_unit_price);
-
- my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
- if($evt) {
- $mgr->editor->event($evt);
- return 0;
- }
-
- $mgr->add_copy;
- $lid->eg_copy_id($copy->id);
- $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
-}
-
-
-
-
-
-
-# ----------------------------------------------------------------------------
-# Workflow: Build a selection list from a Z39.50 search
-# ----------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'zsearch',
- api_name => 'open-ils.acq.picklist.search.z3950',
- stream => 1,
- signature => {
- desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Search definition', type => 'object'},
- {desc => 'Picklist name, optional', type => 'string'},
- ]
- }
-);
-
-sub zsearch {
- my($self, $conn, $auth, $search, $name, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('CREATE_PICKLIST');
-
- $search->{limit} ||= 10;
- $options ||= {};
-
- my $ses = OpenSRF::AppSession->create('open-ils.search');
- my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
-
- my $first = 1;
- my $picklist;
- my $mgr;
- while(my $resp = $req->recv(timeout=>60)) {
-
- if($first) {
- my $e = new_editor(requestor=>$e->requestor, xact=>1);
- $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
- $picklist = zsearch_build_pl($mgr, $name);
- $first = 0;
- }
-
- my $result = $resp->content;
- my $count = $result->{count} || 0;
- $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
-
- for my $rec (@{$result->{records}}) {
-
- my $li = create_lineitem($mgr,
- picklist => $picklist->id,
- source_label => $result->{service},
- marc => $rec->{marcxml},
- eg_bib_id => $rec->{bibid}
- );
-
- if($$options{respond_li}) {
- $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
- if $$options{flesh_attrs};
- $li->clear_marc if $$options{clear_marc};
- $mgr->respond(lineitem => $li);
- } else {
- $mgr->respond;
- }
- }
- }
-
- $mgr->editor->commit;
- return $mgr->respond_complete;
-}
-
-sub zsearch_build_pl {
- my($mgr, $name) = @_;
- $name ||= '';
-
- my $picklist = $mgr->editor->search_acq_picklist({
- owner => $mgr->editor->requestor->id,
- name => $name
- })->[0];
-
- if($name eq '' and $picklist) {
- return 0 unless delete_picklist($mgr, $picklist);
- $picklist = undef;
- }
-
- return update_picklist($mgr, $picklist) if $picklist;
- return create_picklist($mgr, name => $name);
-}
-
-
-# ----------------------------------------------------------------------------
-# Workflow: Build a selection list / PO by importing a batch of MARC records
-# ----------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'upload_records',
- api_name => 'open-ils.acq.process_upload_records',
- stream => 1,
-);
-
-sub upload_records {
- my($self, $conn, $auth, $key) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $cache = OpenSRF::Utils::Cache->new;
-
- my $data = $cache->get_cache("vandelay_import_spool_$key");
- my $purpose = $data->{purpose};
- my $filename = $data->{path};
- my $provider = $data->{provider};
- my $picklist = $data->{picklist};
- my $create_po = $data->{create_po};
- my $activate_po = $data->{activate_po};
- my $ordering_agency = $data->{ordering_agency};
- my $create_assets = $data->{create_assets};
- my $po;
- my $evt;
-
- unless(-r $filename) {
- $logger->error("unable to read MARC file $filename");
- $e->rollback;
- return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
- }
-
- $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
-
- if($picklist) {
- $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
- if($picklist->owner != $e->requestor->id) {
- return $e->die_event unless
- $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
- }
- $mgr->picklist($picklist);
- }
-
- if($create_po) {
-
- $po = create_purchase_order($mgr,
- ordering_agency => $ordering_agency,
- provider => $provider->id,
- state => 'on-order'
- ) or return $mgr->editor->die_event;
- }
-
- $logger->info("acq processing MARC file=$filename");
-
- my $batch = new MARC::Batch ('USMARC', $filename);
- $batch->strict_off;
-
- my $count = 0;
- my @li_list;
-
- while(1) {
-
- my ($err, $xml, $r);
- $count++;
-
- try {
- $r = $batch->next;
- } catch Error with {
- $err = shift;
- $logger->warn("Proccessing of record $count in set $key failed with error $err. Skipping this record");
- };
-
- next if $err;
- last unless $r;
-
- try {
- ($xml = $r->as_xml_record()) =~ s/\n//sog;
- $xml =~ s/^<\?xml.+\?\s*>//go;
- $xml =~ s/>\s+</></go;
- $xml =~ s/\p{Cc}//go;
- $xml = $U->entityize($xml);
- $xml =~ s/[\x00-\x1f]//go;
-
- } catch Error with {
- $err = shift;
- $logger->warn("Proccessing XML of record $count in set $key failed with error $err. Skipping this record");
- };
-
- next if $err or not $xml;
-
- my %args = (
- source_label => $provider->code,
- provider => $provider->id,
- marc => $xml,
- );
-
- $args{picklist} = $picklist->id if $picklist;
- if($po) {
- $args{purchase_order} = $po->id;
- $args{state} = 'pending-order';
- }
-
- my $li = create_lineitem($mgr, %args) or return $mgr->editor->die_event;
- $mgr->respond;
- $li->provider($provider); # flesh it, we'll need it later
-
- import_lineitem_details($mgr, $ordering_agency, $li) or return $mgr->editor->die_event;
- $mgr->respond;
-
- push(@li_list, $li->id);
- $mgr->respond;
- }
-
- my $die_event = activate_purchase_order_impl($mgr, $po->id) if $po and $activate_po;
- return $die_event if $die_event;
-
- $e->commit;
- unlink($filename);
- $cache->delete_cache('vandelay_import_spool_' . $key);
-
- if ($create_assets) {
- create_lineitem_list_assets($mgr, \@li_list) or return $e->die_event;
- }
-
- return $mgr->respond_complete;
-}
-
-sub import_lineitem_details {
- my($mgr, $ordering_agency, $li) = @_;
-
- my $holdings = $mgr->editor->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
- return 1 unless @$holdings;
- my $org_path = $U->get_org_ancestors($ordering_agency);
- $org_path = [ reverse (@$org_path) ];
- my $price;
-
-
- my $idx = 1;
- while(1) {
- # create a lineitem detail for each copy in the data
-
- my $compiled = extract_lineitem_detail_data($mgr, $org_path, $holdings, $idx);
- last unless defined $compiled;
- return 0 unless $compiled;
-
- # this takes the price of the last copy and uses it as the lineitem price
- # need to determine if a given record would include different prices for the same item
- $price = $$compiled{estimated_price};
-
- last unless $$compiled{quantity};
-
- for(1..$$compiled{quantity}) {
- my $lid = create_lineitem_detail(
- $mgr,
- lineitem => $li->id,
- owning_lib => $$compiled{owning_lib},
- cn_label => $$compiled{call_number},
- fund => $$compiled{fund},
- circ_modifier => $$compiled{circ_modifier},
- note => $$compiled{note},
- location => $$compiled{copy_location},
- collection_code => $$compiled{collection_code}
- ) or return 0;
- }
-
- $mgr->respond;
- $idx++;
- }
-
- $li->estimated_unit_price($price);
- update_lineitem($mgr, $li) or return 0;
- return 1;
-}
-
-# return hash on success, 0 on error, undef on no more holdings
-sub extract_lineitem_detail_data {
- my($mgr, $org_path, $holdings, $index) = @_;
-
- my @data_list = grep { $_->{holding} eq $index } @$holdings;
- return undef unless @data_list;
-
- my %compiled = map { $_->{attr} => $_->{data} } @data_list;
- my $base_org = $$org_path[0];
-
- my $killme = sub {
- my $msg = shift;
- $logger->error("Item import extraction error: $msg");
- $logger->error('Holdings Data: ' . OpenSRF::Utils::JSON->perl2JSON(\%compiled));
- $mgr->editor->rollback;
- $mgr->editor->event(OpenILS::Event->new('ACQ_IMPORT_ERROR', payload => $msg));
- return 0;
- };
-
- # ---------------------------------------------------------------------
- # Fund
- if(my $code = $compiled{fund_code}) {
-
- my $fund = $mgr->cache($base_org, "fund.$code");
- unless($fund) {
- # search up the org tree for the most appropriate fund
- for my $org (@$org_path) {
- $fund = $mgr->editor->search_acq_fund(
- {org => $org, code => $code, year => DateTime->now->year}, {idlist => 1})->[0];
- last if $fund;
- }
- }
- return $killme->("no fund with code $code at orgs [@$org_path]") unless $fund;
- $compiled{fund} = $fund;
- $mgr->cache($base_org, "fund.$code", $fund);
- }
-
-
- # ---------------------------------------------------------------------
- # Owning lib
- if(my $sn = $compiled{owning_lib}) {
- my $org_id = $mgr->cache($base_org, "orgsn.$sn") ||
- $mgr->editor->search_actor_org_unit({shortname => $sn}, {idlist => 1})->[0];
- return $killme->("invalid owning_lib defined: $sn") unless $org_id;
- $compiled{owning_lib} = $org_id;
- $mgr->cache($$org_path[0], "orgsn.$sn", $org_id);
- }
-
-
- # ---------------------------------------------------------------------
- # Circ Modifier
- my $code = $compiled{circ_modifier};
-
- if(defined $code) {
-
- # verify this is a valid circ modifier
- return $killme->("invlalid circ_modifier $code") unless
- defined $mgr->cache($base_org, "mod.$code") or
- $mgr->editor->retrieve_config_circ_modifier($code);
-
- # if valid, cache for future tests
- $mgr->cache($base_org, "mod.$code", $code);
-
- } else {
- $compiled{circ_modifier} = get_default_circ_modifier($mgr, $base_org);
- }
-
-
- # ---------------------------------------------------------------------
- # Shelving Location
- if( my $name = $compiled{copy_location}) {
- my $loc = $mgr->cache($base_org, "copy_loc.$name");
- unless($loc) {
- for my $org (@$org_path) {
- $loc = $mgr->editor->search_asset_copy_location(
- {owning_lib => $org, name => $name}, {idlist => 1})->[0];
- last if $loc;
- }
- }
- return $killme->("Invalid copy location $name") unless $loc;
- $compiled{copy_location} = $loc;
- $mgr->cache($base_org, "copy_loc.$name", $loc);
- }
-
- return \%compiled;
-}
-
-
-
-# ----------------------------------------------------------------------------
-# Workflow: Given an existing purchase order, import/create the bibs,
-# callnumber and copy objects
-# ----------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'create_po_assets',
- api_name => 'open-ils.acq.purchase_order.assets.create',
- signature => {
- desc => q/Creates assets for each lineitem in the purchase order/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'The purchase order id', type => 'number'},
- ],
- return => {desc => 'Streams a total versus completed counts object, event on error'}
- }
-);
-
-sub create_po_assets {
- my($self, $conn, $auth, $po_id) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
-
- my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
-
- # it's ugly, but it's fast. Get the total count of lineitem detail objects to process
- my $lid_total = $e->json_query({
- select => { acqlid => [{aggregate => 1, transform => 'count', column => 'id'}] },
- from => {
- acqlid => {
- jub => {
- fkey => 'lineitem',
- field => 'id',
- join => {acqpo => {fkey => 'purchase_order', field => 'id'}}
- }
- }
- },
- where => {'+acqpo' => {id => $po_id}}
- })->[0]->{id};
-
- $mgr->total(scalar(@$li_ids) + $lid_total);
-
- create_lineitem_list_assets($mgr, $li_ids) or return $e->die_event;
-
- $e->xact_begin;
- update_purchase_order($mgr, $po) or return $e->die_event;
- $e->commit;
-
- return $mgr->respond_complete;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'create_purchase_order_api',
- api_name => 'open-ils.acq.purchase_order.create',
- signature => {
- desc => 'Creates a new purchase order',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'purchase_order to create', type => 'object'}
- ],
- return => {desc => 'The purchase order id, Event on failure'}
- }
-);
-
-sub create_purchase_order_api {
- my($self, $conn, $auth, $po, $args) = @_;
- $args ||= {};
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- # create the PO
- my %pargs = (ordering_agency => $e->requestor->ws_ou); # default
- $pargs{provider} = $po->provider if $po->provider;
- $pargs{ordering_agency} = $po->ordering_agency if $po->ordering_agency;
- $pargs{prepayment_required} = $po->prepayment_required if $po->prepayment_required;
-
- $po = create_purchase_order($mgr, %pargs) or return $e->die_event;
-
- my $li_ids = $$args{lineitems};
-
- if($li_ids) {
-
- for my $li_id (@$li_ids) {
-
- my $li = $e->retrieve_acq_lineitem([
- $li_id,
- {flesh => 1, flesh_fields => {jub => ['attributes']}}
- ]) or return $e->die_event;
-
- $li->provider($po->provider);
- $li->purchase_order($po->id);
- $li->state('pending-order');
- update_lineitem($mgr, $li) or return $e->die_event;
- $mgr->respond;
- }
- }
-
- # commit before starting the asset creation
- $e->xact_commit;
-
- if($li_ids and $$args{create_assets}) {
- create_lineitem_list_assets($mgr, $li_ids) or return $e->die_event;
- }
-
- return $mgr->respond_complete;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'update_lineitem_fund_batch',
- api_name => 'open-ils.acq.lineitem.fund.update.batch',
- stream => 1,
- signature => {
- desc => q/Given a set of lineitem IDS, updates the fund for all attached lineitem details/
- }
-);
-
-sub update_lineitem_fund_batch {
- my($self, $conn, $auth, $li_ids, $fund_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
- for my $li_id (@$li_ids) {
- my ($li, $evt) = fetch_and_check_li($e, $li_id, 'write');
- return $evt if $evt;
- my $li_details = $e->search_acq_lineitem_detail({lineitem => $li_id});
- $_->fund($fund_id) and $_->ischanged(1) for @$li_details;
- $evt = lineitem_detail_CUD_batch($mgr, $li_details);
- return $evt if $evt;
- $mgr->add_li;
- $mgr->respond;
- }
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'lineitem_detail_CUD_batch_api',
- api_name => 'open-ils.acq.lineitem_detail.cud.batch',
- stream => 1,
- signature => {
- desc => q/Creates a new purchase order line item detail. / .
- q/Additionally creates the associated fund_debit/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'List of lineitem_details to create', type => 'array'},
- {desc => 'Create Debits. Used for creating post-po-asset-creation debits', type => 'bool'},
- ],
- return => {desc => 'Streaming response of current position in the array'}
- }
-);
-
-__PACKAGE__->register_method(
- method => 'lineitem_detail_CUD_batch_api',
- api_name => 'open-ils.acq.lineitem_detail.cud.batch.dry_run',
- stream => 1,
- signature => {
- desc => q/
- Dry run version of open-ils.acq.lineitem_detail.cud.batch.
- In dry_run mode, updated fund_debit's the exceed the warning
- percent return an event.
- /
- }
-);
-
-
-sub lineitem_detail_CUD_batch_api {
- my($self, $conn, $auth, $li_details, $create_debits) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
- my $dry_run = ($self->api_name =~ /dry_run/o);
- my $evt = lineitem_detail_CUD_batch($mgr, $li_details, $create_debits, $dry_run);
- return $evt if $evt;
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-sub lineitem_detail_CUD_batch {
- my($mgr, $li_details, $create_debits, $dry_run) = @_;
-
- $mgr->total(scalar(@$li_details));
- my $e = $mgr->editor;
-
- my $li;
- my %li_cache;
- my $fund_cache = {};
- my $evt;
-
- for my $lid (@$li_details) {
-
- unless($li = $li_cache{$lid->lineitem}) {
- ($li, $evt) = fetch_and_check_li($e, $lid->lineitem, 'write');
- return $evt if $evt;
- }
-
- if($lid->isnew) {
- $lid = create_lineitem_detail($mgr, %{$lid->to_bare_hash}) or return $e->die_event;
- if($create_debits) {
- $li->provider($e->retrieve_acq_provider($li->provider)) or return $e->die_event;
- $lid->fund($e->retrieve_acq_fund($lid->fund)) or return $e->die_event;
- create_lineitem_detail_debit($mgr, $li, $lid, 0, 1) or return $e->die_event;
- }
-
- } elsif($lid->ischanged) {
- return $evt if $evt = handle_changed_lid($e, $lid, $dry_run, $fund_cache);
-
- } elsif($lid->isdeleted) {
- delete_lineitem_detail($mgr, $lid) or return $e->die_event;
- }
-
- $mgr->respond(li => $li);
- $li_cache{$lid->lineitem} = $li;
- }
-
- return undef;
-}
-
-sub handle_changed_lid {
- my($e, $lid, $dry_run, $fund_cache) = @_;
-
- my $orig_lid = $e->retrieve_acq_lineitem_detail($lid->id) or return $e->die_event;
-
- # updating the fund, so update the debit
- if($orig_lid->fund_debit and $orig_lid->fund != $lid->fund) {
-
- my $debit = $e->retrieve_acq_fund_debit($orig_lid->fund_debit);
- my $new_fund = $$fund_cache{$lid->fund} =
- $$fund_cache{$lid->fund} || $e->retrieve_acq_fund($lid->fund);
-
- # check the thresholds
- return $e->die_event if
- fund_exceeds_balance_percent($new_fund, $debit->amount, $e, "stop");
- return $e->die_event if $dry_run and
- fund_exceeds_balance_percent($new_fund, $debit->amount, $e, "warning");
-
- $debit->fund($new_fund->id);
- $e->update_acq_fund_debit($debit) or return $e->die_event;
- }
-
- $e->update_acq_lineitem_detail($lid) or return $e->die_event;
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'receive_po_api',
- api_name => 'open-ils.acq.purchase_order.receive'
-);
-
-sub receive_po_api {
- my($self, $conn, $auth, $po_id) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
-
- my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
-
- for my $li_id (@$li_ids) {
- receive_lineitem($mgr, $li_id) or return $e->die_event;
- $mgr->respond;
- }
-
- $po->state('received');
- update_purchase_order($mgr, $po) or return $e->die_event;
-
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-# At the moment there's a lack of parallelism between the receive and unreceive
-# API methods for POs and the API methods for LIs and LIDs. The methods for
-# POs stream back objects as they act, whereas the methods for LIs and LIDs
-# atomically return an object that describes only what changed (in LIs and LIDs
-# themselves or in the objects to which to LIs and LIDs belong).
-#
-# The methods for LIs and LIDs work the way they do to faciliate the UI's
-# maintaining correct information about the state of these things when a user
-# wants to receive or unreceive these objects without refreshing their whole
-# display. The UI feature for receiving and un-receiving a whole PO just
-# refreshes the whole display, so this absence of parallelism in the UI is also
-# relected in this module.
-#
-# This could be neatened in the future by making POs receive and unreceive in
-# the same way the LIs and LIDs do.
-
-__PACKAGE__->register_method(
- method => 'receive_lineitem_detail_api',
- api_name => 'open-ils.acq.lineitem_detail.receive',
- signature => {
- desc => 'Mark a lineitem_detail as received',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem detail ID', type => 'number'}
- ],
- return => {desc =>
- "on success, object describing changes to LID and possibly " .
- "to LI and PO; on error, Event"
- }
- }
-);
-
-sub receive_lineitem_detail_api {
- my($self, $conn, $auth, $lid_id) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $fleshing = {
- "flesh" => 2, "flesh_fields" => {
- "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
- }
- };
-
- my $lid = $e->retrieve_acq_lineitem_detail([$lid_id, $fleshing]);
-
- return $e->die_event unless $e->allowed(
- 'RECEIVE_PURCHASE_ORDER', $lid->lineitem->purchase_order->ordering_agency);
-
- # update ...
- my $recvd = receive_lineitem_detail($mgr, $lid_id) or return $e->die_event;
-
- # .. and re-retrieve
- $lid = $e->retrieve_acq_lineitem_detail([$lid_id, $fleshing]);
-
- # Now build result data structure.
- my $result = {"lid" => {$lid->id => {"recv_time" => $lid->recv_time}}};
-
- if (ref $recvd) {
- if ($recvd->class_name =~ /::purchase_order/) {
- $result->{"po"} = describe_affected_po($e, $recvd);
- $result->{"li"} = {
- $lid->lineitem->id => {"state" => $lid->lineitem->state}
- };
- } elsif ($recvd->class_name =~ /::lineitem/) {
- $result->{"li"} = {$recvd->id => {"state" => $recvd->state}};
- }
- }
- $result->{"po"} ||=
- describe_affected_po($e, $lid->lineitem->purchase_order);
-
- $e->commit;
- return $result;
-}
-
-__PACKAGE__->register_method(
- method => 'receive_lineitem_api',
- api_name => 'open-ils.acq.lineitem.receive',
- signature => {
- desc => 'Mark a lineitem as received',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID', type => 'number'}
- ],
- return => {desc =>
- "on success, object describing changes to LI and possibly PO; " .
- "on error, Event"
- }
- }
-);
-
-sub receive_lineitem_api {
- my($self, $conn, $auth, $li_id) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $li = $e->retrieve_acq_lineitem([
- $li_id, {
- flesh => 1,
- flesh_fields => {
- jub => ['purchase_order']
- }
- }
- ]) or return $e->die_event;
-
- return $e->die_event unless $e->allowed(
- 'RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);
-
- my $res = receive_lineitem($mgr, $li_id) or return $e->die_event;
- $e->commit;
- $conn->respond_complete($res);
- $mgr->run_post_response_hooks;
-}
-
-
-__PACKAGE__->register_method(
- method => 'rollback_receive_po_api',
- api_name => 'open-ils.acq.purchase_order.receive.rollback'
-);
-
-sub rollback_receive_po_api {
- my($self, $conn, $auth, $po_id) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
-
- my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
-
- for my $li_id (@$li_ids) {
- rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
- $mgr->respond;
- }
-
- $po->state('on-order');
- update_purchase_order($mgr, $po) or return $e->die_event;
-
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-__PACKAGE__->register_method(
- method => 'rollback_receive_lineitem_detail_api',
- api_name => 'open-ils.acq.lineitem_detail.receive.rollback',
- signature => {
- desc => 'Mark a lineitem_detail as Un-received',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem detail ID', type => 'number'}
- ],
- return => {desc =>
- "on success, object describing changes to LID and possibly " .
- "to LI and PO; on error, Event"
- }
- }
-);
-
-sub rollback_receive_lineitem_detail_api {
- my($self, $conn, $auth, $lid_id) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $lid = $e->retrieve_acq_lineitem_detail([
- $lid_id, {
- flesh => 2,
- flesh_fields => {
- acqlid => ['lineitem'],
- jub => ['purchase_order']
- }
- }
- ]);
- my $li = $lid->lineitem;
- my $po = $li->purchase_order;
-
- return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
-
- my $result = {};
-
- my $recvd = rollback_receive_lineitem_detail($mgr, $lid_id)
- or return $e->die_event;
-
- if (ref $recvd) {
- $result->{"lid"} = {$recvd->id => {"recv_time" => $recvd->recv_time}};
- } else {
- $result->{"lid"} = {$lid->id => {"recv_time" => $lid->recv_time}};
- }
-
- if ($li->state eq "received") {
- $li->state("on-order");
- $li = update_lineitem($mgr, $li) or return $e->die_event;
- $result->{"li"} = {$li->id => {"state" => $li->state}};
- }
-
- if ($po->state eq "received") {
- $po->state("on-order");
- $po = update_purchase_order($mgr, $po) or return $e->die_event;
- }
- $result->{"po"} = describe_affected_po($e, $po);
-
- $e->commit and return $result or return $e->die_event;
-}
-
-__PACKAGE__->register_method(
- method => 'rollback_receive_lineitem_api',
- api_name => 'open-ils.acq.lineitem.receive.rollback',
- signature => {
- desc => 'Mark a lineitem as Un-received',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID', type => 'number'}
- ],
- return => {desc =>
- "on success, object describing changes to LI and possibly PO; " .
- "on error, Event"
- }
- }
-);
-
-sub rollback_receive_lineitem_api {
- my($self, $conn, $auth, $li_id) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $li = $e->retrieve_acq_lineitem([
- $li_id, {
- "flesh" => 1, "flesh_fields" => {"jub" => ["purchase_order"]}
- }
- ]);
- my $po = $li->purchase_order;
-
- return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
-
- $li = rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
-
- my $result = {"li" => {$li->id => {"state" => $li->state}}};
- if ($po->state eq "received") {
- $po->state("on-order");
- $po = update_purchase_order($mgr, $po) or return $e->die_event;
- }
- $result->{"po"} = describe_affected_po($e, $po);
-
- $e->commit and return $result or return $e->die_event;
-}
-
-
-__PACKAGE__->register_method(
- method => 'set_lineitem_price_api',
- api_name => 'open-ils.acq.lineitem.price.set',
- signature => {
- desc => 'Set lineitem price. If debits already exist, update them as well',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'lineitem ID', type => 'number'}
- ],
- return => {desc => 'status blob, Event on error'}
- }
-);
-
-sub set_lineitem_price_api {
- my($self, $conn, $auth, $li_id, $price) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my ($li, $evt) = fetch_and_check_li($e, $li_id, 'write');
- return $evt if $evt;
-
- $li->estimated_unit_price($price);
- update_lineitem($mgr, $li) or return $e->die_event;
-
- my $lid_ids = $e->search_acq_lineitem_detail(
- {lineitem => $li_id, fund_debit => {'!=' => undef}},
- {idlist => 1}
- );
-
- for my $lid_id (@$lid_ids) {
-
- my $lid = $e->retrieve_acq_lineitem_detail([
- $lid_id, {
- flesh => 1, flesh_fields => {acqlid => ['fund', 'fund_debit']}}
- ]);
-
- $lid->fund_debit->amount($price);
- $e->update_acq_fund_debit($lid->fund_debit) or return $e->die_event;
- $mgr->add_lid;
- $mgr->respond;
- }
-
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-__PACKAGE__->register_method(
- method => 'clone_picklist_api',
- api_name => 'open-ils.acq.picklist.clone',
- signature => {
- desc => 'Clones a picklist, including lineitem and lineitem details',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist ID', type => 'number'},
- {desc => 'New Picklist Name', type => 'string'}
- ],
- return => {desc => 'status blob, Event on error'}
- }
-);
-
-sub clone_picklist_api {
- my($self, $conn, $auth, $pl_id, $name) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- my $old_pl = $e->retrieve_acq_picklist($pl_id);
- my $new_pl = create_picklist($mgr, %{$old_pl->to_bare_hash}, name => $name) or return $e->die_event;
-
- my $li_ids = $e->search_acq_lineitem({picklist => $pl_id}, {idlist => 1});
-
- for my $li_id (@$li_ids) {
-
- # copy the lineitems
- my $li = $e->retrieve_acq_lineitem($li_id);
- my $new_li = create_lineitem($mgr, %{$li->to_bare_hash}, picklist => $new_pl->id) or return $e->die_event;
-
- my $lid_ids = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist => 1});
- for my $lid_id (@$lid_ids) {
-
- # copy the lineitem details
- my $lid = $e->retrieve_acq_lineitem_detail($lid_id);
- create_lineitem_detail($mgr, %{$lid->to_bare_hash}, lineitem => $new_li->id) or return $e->die_event;
- }
-
- $mgr->respond;
- }
-
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-__PACKAGE__->register_method(
- method => 'merge_picklist_api',
- api_name => 'open-ils.acq.picklist.merge',
- signature => {
- desc => 'Merges 2 or more picklists into a single list',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Lead Picklist ID', type => 'number'},
- {desc => 'List of subordinate picklist IDs', type => 'array'}
- ],
- return => {desc => 'status blob, Event on error'}
- }
-);
-
-sub merge_picklist_api {
- my($self, $conn, $auth, $lead_pl, $pl_list) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
-
- # XXX perms on each picklist modified
-
- $lead_pl = $e->retrieve_acq_picklist($lead_pl) or return $e->die_event;
- # point all of the lineitems at the lead picklist
- my $li_ids = $e->search_acq_lineitem({picklist => $pl_list}, {idlist => 1});
-
- for my $li_id (@$li_ids) {
- my $li = $e->retrieve_acq_lineitem($li_id);
- $li->picklist($lead_pl);
- update_lineitem($mgr, $li) or return $e->die_event;
- $mgr->respond;
- }
-
- # now delete the subordinate lists
- for my $pl_id (@$pl_list) {
- my $pl = $e->retrieve_acq_picklist($pl_id);
- $e->delete_acq_picklist($pl) or return $e->die_event;
- }
-
- update_picklist($mgr, $lead_pl) or return $e->die_event;
-
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_picklist_api',
- api_name => 'open-ils.acq.picklist.delete',
- signature => {
- desc => q/Deletes a picklist. It also deletes any lineitems in the "new" state. / .
- q/Other attached lineitems are detached/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist ID to delete', type => 'number'}
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub delete_picklist_api {
- my($self, $conn, $auth, $picklist_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
- my $pl = $e->retrieve_acq_picklist($picklist_id) or return $e->die_event;
- delete_picklist($mgr, $pl) or return $e->die_event;
- $e->commit;
- return $mgr->respond_complete;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'activate_purchase_order',
- api_name => 'open-ils.acq.purchase_order.activate.dry_run'
-);
-
-__PACKAGE__->register_method(
- method => 'activate_purchase_order',
- api_name => 'open-ils.acq.purchase_order.activate',
- signature => {
- desc => q/Activates a purchase order. This updates the status of the PO / .
- q/and Lineitems to 'on-order'. Activated PO's are ready for EDI delivery if appropriate./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Purchase ID', type => 'number'}
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub activate_purchase_order {
- my($self, $conn, $auth, $po_id) = @_;
-
- my $dry_run = ($self->api_name =~ /\.dry_run/) ? 1 : 0;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
- my $die_event = activate_purchase_order_impl($mgr, $po_id, $dry_run);
- return $e->die_event if $die_event;
- if ($dry_run) {
- $e->rollback;
- } else {
- $e->commit;
- }
- $conn->respond_complete(1);
- $mgr->run_post_response_hooks;
- return undef;
-}
-
-sub activate_purchase_order_impl {
- my ($mgr, $po_id, $dry_run) = @_;
- my $e = $mgr->editor;
-
- my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
-
- my $provider = $e->retrieve_acq_provider($po->provider);
-
- $po->state('on-order');
- $po->order_date('now');
- update_purchase_order($mgr, $po) or return $e->die_event;
-
- my $query = [
- {
- purchase_order => $po_id,
- state => [qw/pending-order new order-ready/]
- },
- {limit => 1}
- ];
-
- while( my $li_id = $e->search_acq_lineitem($query, {idlist => 1})->[0] ) {
-
- my $li;
- if($dry_run) {
- $li = $e->retrieve_acq_lineitem($li_id);
- } else {
- # can't activate a PO w/o assets. Create lineitem assets as necessary
- my $data = create_lineitem_assets($mgr, $li_id) or return $e->die_event;
- $li = $data->{li};
- }
-
- $li->state('on-order');
- $li->claim_policy($provider->default_claim_policy)
- if $provider->default_claim_policy and !$li->claim_policy;
- create_lineitem_debits($mgr, $li, $dry_run) or return $e->die_event;
- update_lineitem($mgr, $li) or return $e->die_event;
- $mgr->post_process( sub { create_lineitem_status_events($mgr, $li->id, 'aur.ordered'); });
- $mgr->respond;
- }
-
- for my $po_item (@{$e->search_acq_po_item({purchase_order => $po_id})}) {
-
- my $debit = create_fund_debit(
- $mgr,
- $dry_run,
- debit_type => 'direct_charge', # to match invoicing
- origin_amount => $po_item->estimated_cost,
- origin_currency_type => $e->retrieve_acq_fund($po_item->fund)->currency_type,
- amount => $po_item->estimated_cost,
- fund => $po_item->fund
- ) or return $e->die_event;
- $po_item->fund_debit($debit->id);
- $e->update_acq_po_item($po_item) or return $e->die_event;
- $mgr->respond;
- }
-
- # tell the world we activated a PO
- $U->create_events_for_hook('acqpo.activated', $po, $po->ordering_agency) unless $dry_run;
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'split_purchase_order_by_lineitems',
- api_name => 'open-ils.acq.purchase_order.split_by_lineitems',
- signature => {
- desc => q/Splits a PO into many POs, 1 per lineitem. Only works for / .
- q/POs a) with more than one lineitems, and b) in the "pending" state./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Purchase order ID', type => 'number'}
- ],
- return => {desc => 'list of new PO IDs on success, Event on error'}
- }
-);
-
-sub split_purchase_order_by_lineitems {
- my ($self, $conn, $auth, $po_id) = @_;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $po = $e->retrieve_acq_purchase_order([
- $po_id, {
- "flesh" => 1,
- "flesh_fields" => {"acqpo" => [qw/lineitems notes/]}
- }
- ]) or return $e->die_event;
-
- return $e->die_event
- unless $e->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
-
- unless ($po->state eq "pending") {
- $e->rollback;
- return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_LATE");
- }
-
- unless (@{$po->lineitems} > 1) {
- $e->rollback;
- return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_SHORT");
- }
-
- # To split an existing PO into many, it seems unwise to just delete the
- # original PO, so we'll instead detach all of the original POs' lineitems
- # but the first, then create new POs for each of the remaining LIs, and
- # then attach the LIs to their new POs.
-
- my @po_ids = ($po->id);
- my @moving_li = @{$po->lineitems};
- shift @moving_li; # discard first LI
-
- foreach my $li (@moving_li) {
- my $new_po = $po->clone;
- $new_po->clear_id;
- $new_po->clear_name;
- $new_po->creator($e->requestor->id);
- $new_po->editor($e->requestor->id);
- $new_po->owner($e->requestor->id);
- $new_po->edit_time("now");
- $new_po->create_time("now");
-
- $new_po = $e->create_acq_purchase_order($new_po);
-
- # Clone any notes attached to the old PO and attach to the new one.
- foreach my $note (@{$po->notes}) {
- my $new_note = $note->clone;
- $new_note->clear_id;
- $new_note->edit_time("now");
- $new_note->purchase_order($new_po->id);
- $e->create_acq_po_note($new_note);
- }
-
- $li->edit_time("now");
- $li->purchase_order($new_po->id);
- $e->update_acq_lineitem($li);
-
- push @po_ids, $new_po->id;
- }
-
- $po->edit_time("now");
- $e->update_acq_purchase_order($po);
-
- return \@po_ids if $e->commit;
- return $e->die_event;
-}
-
-
-sub not_cancelable {
- my $o = shift;
- (ref $o eq "HASH" and $o->{"textcode"} eq "ACQ_NOT_CANCELABLE");
-}
-
-__PACKAGE__->register_method(
- method => "cancel_purchase_order_api",
- api_name => "open-ils.acq.purchase_order.cancel",
- signature => {
- desc => q/Cancels an on-order purchase order/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "PO ID to cancel", type => "number"},
- {desc => "Cancel reason ID", type => "number"}
- ],
- return => {desc => q/Object describing changed POs, LIs and LIDs
- on success; Event on error./}
- }
-);
-
-sub cancel_purchase_order_api {
- my ($self, $conn, $auth, $po_id, $cancel_reason) = @_;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = new OpenILS::Application::Acq::BatchManager(
- "editor" => $e, "conn" => $conn
- );
-
- $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
- return new OpenILS::Event(
- "BAD_PARAMS", "note" => "Provide cancel reason ID"
- );
-
- my $result = cancel_purchase_order($mgr, $po_id, $cancel_reason) or
- return $e->die_event;
- if (not_cancelable($result)) { # event not from CStoreEditor
- $e->rollback;
- return $result;
- } elsif ($result == -1) {
- $e->rollback;
- return new OpenILS::Event("ACQ_ALREADY_CANCELED");
- }
-
- $e->commit or return $e->die_event;
-
- # XXX create purchase order status events?
-
- if ($mgr->{post_commit}) {
- foreach my $func (@{$mgr->{post_commit}}) {
- $func->();
- }
- }
-
- return $result;
-}
-
-sub cancel_purchase_order {
- my ($mgr, $po_id, $cancel_reason) = @_;
-
- my $po = $mgr->editor->retrieve_acq_purchase_order($po_id) or return 0;
-
- # XXX is "cancelled" a typo? It's not correct US spelling, anyway.
- # Depending on context, this may not warrant an event.
- return -1 if $po->state eq "cancelled";
-
- # But this always does.
- return new OpenILS::Event(
- "ACQ_NOT_CANCELABLE", "note" => "purchase_order $po_id"
- ) unless ($po->state eq "on-order" or $po->state eq "pending");
-
- return 0 unless
- $mgr->editor->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
-
- $po->state("cancelled");
- $po->cancel_reason($cancel_reason->id);
-
- my $li_ids = $mgr->editor->search_acq_lineitem(
- {"purchase_order" => $po_id}, {"idlist" => 1}
- );
-
- my $result = {"li" => {}, "lid" => {}};
- foreach my $li_id (@$li_ids) {
- my $li_result = cancel_lineitem($mgr, $li_id, $cancel_reason)
- or return 0;
-
- next if $li_result == -1; # already canceled:skip.
- return $li_result if not_cancelable($li_result); # not cancelable:stop.
-
- # Merge in each LI result (there's only going to be
- # one per call to cancel_lineitem).
- my ($k, $v) = each %{$li_result->{"li"}};
- $result->{"li"}->{$k} = $v;
-
- # Merge in each LID result (there may be many per call to
- # cancel_lineitem).
- while (($k, $v) = each %{$li_result->{"lid"}}) {
- $result->{"lid"}->{$k} = $v;
- }
- }
-
- # TODO who/what/where/how do we indicate this change for electronic orders?
- # TODO return changes to encumbered/spent
- # TODO maybe cascade up from smaller object to container object if last
- # smaller object in the container has been canceled?
-
- update_purchase_order($mgr, $po) or return 0;
- $result->{"po"} = {
- $po_id => {"state" => $po->state, "cancel_reason" => $cancel_reason}
- };
- return $result;
-}
-
-
-__PACKAGE__->register_method(
- method => "cancel_lineitem_api",
- api_name => "open-ils.acq.lineitem.cancel",
- signature => {
- desc => q/Cancels an on-order lineitem/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Lineitem ID to cancel", type => "number"},
- {desc => "Cancel reason ID", type => "number"}
- ],
- return => {desc => q/Object describing changed LIs and LIDs on success;
- Event on error./}
- }
-);
-
-__PACKAGE__->register_method(
- method => "cancel_lineitem_api",
- api_name => "open-ils.acq.lineitem.cancel.batch",
- signature => {
- desc => q/Batched version of open-ils.acq.lineitem.cancel/,
- return => {desc => q/Object describing changed LIs and LIDs on success;
- Event on error./}
- }
-);
-
-sub cancel_lineitem_api {
- my ($self, $conn, $auth, $li_id, $cancel_reason) = @_;
-
- my $batched = $self->api_name =~ /\.batch/;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = new OpenILS::Application::Acq::BatchManager(
- "editor" => $e, "conn" => $conn
- );
-
- $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
- return new OpenILS::Event(
- "BAD_PARAMS", "note" => "Provide cancel reason ID"
- );
-
- my ($result, $maybe_event);
-
- if ($batched) {
- $result = {"li" => {}, "lid" => {}};
- foreach my $one_li_id (@$li_id) {
- my $one = cancel_lineitem($mgr, $one_li_id, $cancel_reason) or
- return $e->die_event;
- if (not_cancelable($one)) {
- $maybe_event = $one;
- } elsif ($result == -1) {
- $maybe_event = new OpenILS::Event("ACQ_ALREADY_CANCELED");
- } else {
- my ($k, $v);
- if ($one->{"li"}) {
- while (($k, $v) = each %{$one->{"li"}}) {
- $result->{"li"}->{$k} = $v;
- }
- }
- if ($one->{"lid"}) {
- while (($k, $v) = each %{$one->{"lid"}}) {
- $result->{"lid"}->{$k} = $v;
- }
- }
- }
- }
- } else {
- $result = cancel_lineitem($mgr, $li_id, $cancel_reason) or
- return $e->die_event;
-
- if (not_cancelable($result)) {
- $e->rollback;
- return $result;
- } elsif ($result == -1) {
- $e->rollback;
- return new OpenILS::Event("ACQ_ALREADY_CANCELED");
- }
- }
-
- if ($batched and not scalar keys %{$result->{"li"}}) {
- $e->rollback;
- return $maybe_event;
- } else {
- $e->commit or return $e->die_event;
- # create_lineitem_status_events should handle array li_id ok
- create_lineitem_status_events($mgr, $li_id, "aur.cancelled");
-
- if ($mgr->{post_commit}) {
- foreach my $func (@{$mgr->{post_commit}}) {
- $func->();
- }
- }
-
- return $result;
- }
-}
-
-sub cancel_lineitem {
- my ($mgr, $li_id, $cancel_reason) = @_;
- my $li = $mgr->editor->retrieve_acq_lineitem([
- $li_id, {flesh => 1, flesh_fields => {jub => ['purchase_order']}}
- ]) or return 0;
-
- return 0 unless $mgr->editor->allowed(
- "CREATE_PURCHASE_ORDER", $li->purchase_order->ordering_agency
- );
-
- # Depending on context, this may not warrant an event.
- return -1 if $li->state eq "cancelled";
-
- # But this always does.
- return new OpenILS::Event(
- "ACQ_NOT_CANCELABLE", "note" => "lineitem $li_id"
- ) unless (
- (! $li->purchase_order) or (
- $li->purchase_order and (
- $li->state eq "on-order" or $li->state eq "pending-order"
- )
- )
- );
-
- $li->state("cancelled");
- $li->cancel_reason($cancel_reason->id);
-
- my $lids = $mgr->editor->search_acq_lineitem_detail([{
- "lineitem" => $li_id
- }, {
- flesh => 1,
- flesh_fields => { acqlid => ['eg_copy_id'] }
- }]);
-
- my $result = {"lid" => {}};
- my $copies = [];
- foreach my $lid (@$lids) {
- my $lid_result = cancel_lineitem_detail($mgr, $lid->id, $cancel_reason)
- or return 0;
-
- # gathering any real copies for deletion
- if ($lid->eg_copy_id) {
- $lid->eg_copy_id->isdeleted('t');
- push @$copies, $lid->eg_copy_id;
- }
-
- next if $lid_result == -1; # already canceled: just skip it.
- return $lid_result if not_cancelable($lid_result); # not cxlable: stop.
-
- # Merge in each LID result (there's only going to be one per call to
- # cancel_lineitem_detail).
- my ($k, $v) = each %{$lid_result->{"lid"}};
- $result->{"lid"}->{$k} = $v;
- }
-
- # Attempt to delete the gathered copies (this will also handle volume deletion and bib deletion)
- # Delete empty bibs according org unit setting
- my $force_delete_empty_bib = $U->ou_ancestor_setting_value(
- $mgr->editor->requestor->ws_ou, 'cat.bib.delete_on_no_copy_via_acq_lineitem_cancel', $mgr->editor);
- if (scalar(@$copies)>0) {
- my $override = 1;
- my $delete_stats = undef;
- my $retarget_holds = [];
- my $cat_evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
- $mgr->editor, $override, undef, $copies, $delete_stats, $retarget_holds,$force_delete_empty_bib);
-
- if( $cat_evt ) {
- $logger->info("fleshed copy update failed with event: ".OpenSRF::Utils::JSON->perl2JSON($cat_evt));
- return new OpenILS::Event(
- "ACQ_NOT_CANCELABLE", "note" => "lineitem $li_id", "payload" => $cat_evt
- );
- }
-
- # We can't do the following and stay within the same transaction, but that's okay, the hold targeter will pick these up later.
- #my $ses = OpenSRF::AppSession->create('open-ils.circ');
- #$ses->request('open-ils.circ.hold.reset.batch', $auth, $retarget_holds);
- }
-
- # if we have a bib, check to see whether it has been deleted. if so, cancel any active holds targeting that bib
- if ($li->eg_bib_id) {
- my $bib = $mgr->editor->retrieve_biblio_record_entry($li->eg_bib_id) or return new OpenILS::Event(
- "ACQ_NOT_CANCELABLE", "note" => "Could not retrieve bib " . $li->eg_bib_id . " for lineitem $li_id"
- );
- if ($U->is_true($bib->deleted)) {
- my $holds = $mgr->editor->search_action_hold_request(
- { cancel_time => undef,
- fulfillment_time => undef,
- target => $li->eg_bib_id
- }
- );
-
- my %cached_usr_home_ou = ();
-
- for my $hold (@$holds) {
-
- $logger->info("Cancelling hold ".$hold->id.
- " due to acq lineitem cancellation.");
-
- $hold->cancel_time('now');
- $hold->cancel_cause(5); # 'Staff forced'--we may want a new hold cancel cause reason for this
- $hold->cancel_note('Corresponding Acquistion Lineitem/Purchase Order was cancelled.');
- unless($mgr->editor->update_action_hold_request($hold)) {
- my $evt = $mgr->editor->event;
- $logger->error("Error updating hold ". $evt->textcode .":". $evt->desc .":". $evt->stacktrace);
- return new OpenILS::Event(
- "ACQ_NOT_CANCELABLE", "note" => "Could not cancel hold " . $hold->id . " for lineitem $li_id", "payload" => $evt
- );
- }
- if (! defined $mgr->{post_commit}) { # we need a mechanism for creating trigger events, but only if the transaction gets committed
- $mgr->{post_commit} = [];
- }
- push @{ $mgr->{post_commit} }, sub {
- my $home_ou = $cached_usr_home_ou{$hold->usr};
- if (! $home_ou) {
- my $user = $mgr->editor->retrieve_actor_user($hold->usr); # FIXME: how do we want to handle failures here?
- $home_ou = $user->home_ou;
- $cached_usr_home_ou{$hold->usr} = $home_ou;
- }
- $U->create_events_for_hook('hold_request.cancel.cancelled_order', $hold, $home_ou);
- };
- }
- }
- }
-
- update_lineitem($mgr, $li) or return 0;
- $result->{"li"} = {
- $li_id => {
- "state" => $li->state,
- "cancel_reason" => $cancel_reason
- }
- };
- return $result;
-}
-
-
-__PACKAGE__->register_method(
- method => "cancel_lineitem_detail_api",
- api_name => "open-ils.acq.lineitem_detail.cancel",
- signature => {
- desc => q/Cancels an on-order lineitem detail/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Lineitem detail ID to cancel", type => "number"},
- {desc => "Cancel reason ID", type => "number"}
- ],
- return => {desc => q/Object describing changed LIDs on success;
- Event on error./}
- }
-);
-
-sub cancel_lineitem_detail_api {
- my ($self, $conn, $auth, $lid_id, $cancel_reason) = @_;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
- my $mgr = new OpenILS::Application::Acq::BatchManager(
- "editor" => $e, "conn" => $conn
- );
-
- $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
- return new OpenILS::Event(
- "BAD_PARAMS", "note" => "Provide cancel reason ID"
- );
-
- my $result = cancel_lineitem_detail($mgr, $lid_id, $cancel_reason) or
- return $e->die_event;
-
- if (not_cancelable($result)) {
- $e->rollback;
- return $result;
- } elsif ($result == -1) {
- $e->rollback;
- return new OpenILS::Event("ACQ_ALREADY_CANCELED");
- }
-
- $e->commit or return $e->die_event;
-
- # XXX create lineitem detail status events?
- return $result;
-}
-
-sub cancel_lineitem_detail {
- my ($mgr, $lid_id, $cancel_reason) = @_;
- my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
- $lid_id, {
- "flesh" => 2,
- "flesh_fields" => {
- "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
- }
- }
- ]) or return 0;
-
- # Depending on context, this may not warrant an event.
- return -1 if $lid->cancel_reason;
-
- # But this always does.
- return new OpenILS::Event(
- "ACQ_NOT_CANCELABLE", "note" => "lineitem_detail $lid_id"
- ) unless (
- (! $lid->lineitem->purchase_order) or
- (
- (not $lid->recv_time) and
- $lid->lineitem and
- $lid->lineitem->purchase_order and (
- $lid->lineitem->state eq "on-order" or
- $lid->lineitem->state eq "pending-order"
- )
- )
- );
-
- return 0 unless $mgr->editor->allowed(
- "CREATE_PURCHASE_ORDER",
- $lid->lineitem->purchase_order->ordering_agency
- ) or (! $lid->lineitem->purchase_order);
-
- $lid->cancel_reason($cancel_reason->id);
-
- unless($U->is_true($cancel_reason->keep_debits)) {
- my $debit_id = $lid->fund_debit;
- $lid->clear_fund_debit;
-
- if($debit_id) {
- # item is cancelled. Remove the fund debit.
- my $debit = $mgr->editor->retrieve_acq_fund_debit($debit_id);
- if (!$U->is_true($debit->encumbrance)) {
- $mgr->editor->rollback;
- return OpenILS::Event->new('ACQ_NOT_CANCELABLE',
- note => "Debit is marked as paid: $debit_id");
- }
- $mgr->editor->delete_acq_fund_debit($debit) or return $mgr->editor->die_event;
- }
- }
-
- # XXX LIDs don't have either an editor or a edit_time field. Should we
- # update these on the LI when we alter an LID?
- $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
-
- return {"lid" => {$lid_id => {"cancel_reason" => $cancel_reason}}};
-}
-
-
-__PACKAGE__->register_method(
- method => 'user_requests',
- api_name => 'open-ils.acq.user_request.retrieve.by_user_id',
- stream => 1,
- signature => {
- desc => 'Retrieve fleshed user requests and related data for a given user.',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User ID of the owner, or array of IDs', },
- { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
- type => 'object'
- }
- ],
- return => {
- desc => 'Fleshed user requests and related data',
- type => 'object'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'user_requests',
- api_name => 'open-ils.acq.user_request.retrieve.by_home_ou',
- stream => 1,
- signature => {
- desc => 'Retrieve fleshed user requests and related data for a given org unit or units.',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Org unit ID, or array of IDs', },
- { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
- type => 'object'
- }
- ],
- return => {
- desc => 'Fleshed user requests and related data',
- type => 'object'
- }
- }
-);
-
-sub user_requests {
- my($self, $conn, $auth, $search_value, $options) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- my $rid = $e->requestor->id;
- $options ||= {};
-
- my $query = {
- "select"=>{"aur"=>["id"],"au"=>["home_ou", {column => 'id', alias => 'usr_id'} ]},
- "from"=>{ "aur" => { "au" => {}, "jub" => { "type" => "left" } } },
- "where"=>{
- "+jub"=> {
- "-or" => [
- {"id"=>undef}, # this with the left-join pulls in requests without lineitems
- {"state"=>["new","on-order","pending-order"]} # FIXME - probably needs softcoding
- ]
- }
- },
- "order_by"=>[{"class"=>"aur", "field"=>"request_date", "direction"=>"desc"}]
- };
-
- foreach (qw/ order_by limit offset /) {
- $query->{$_} = $options->{$_} if defined $options->{$_};
- }
- if (defined $options->{'state'}) {
- $query->{'where'}->{'+jub'}->{'-or'}->[1]->{'state'} = $options->{'state'};
- }
-
- if ($self->api_name =~ /by_user_id/) {
- $query->{'where'}->{'usr'} = $search_value;
- } else {
- $query->{'where'}->{'+au'} = { 'home_ou' => $search_value };
- }
-
- my $pertinent_ids = $e->json_query($query);
-
- my %perm_test = ();
- for my $id_blob (@$pertinent_ids) {
- if ($rid != $id_blob->{usr_id}) {
- if (!defined $perm_test{ $id_blob->{home_ou} }) {
- $perm_test{ $id_blob->{home_ou} } = $e->allowed( ['user_request.view'], $id_blob->{home_ou} );
- }
- if (!$perm_test{ $id_blob->{home_ou} }) {
- next; # failed test
- }
- }
- my $aur_obj = $e->retrieve_acq_user_request([
- $id_blob->{id},
- {flesh => 1, flesh_fields => { "aur" => [ 'lineitem' ] } }
- ]);
- if (! $aur_obj) { next; }
-
- if ($aur_obj->lineitem()) {
- $aur_obj->lineitem()->clear_marc();
- }
- $conn->respond($aur_obj);
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method (
- method => 'update_user_request',
- api_name => 'open-ils.acq.user_request.cancel.batch',
- stream => 1,
- signature => {
- desc => 'If given a cancel reason, will update the request with that reason, otherwise, this will delete the request altogether. The ' .
- 'intention is for staff interfaces or processes to provide cancel reasons, and for patron interfaces to just delete the requests.' ,
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'ID or array of IDs for the user requests to cancel' },
- { desc => 'Cancel Reason ID (optional)', type => 'string' }
- ],
- return => {
- desc => 'progress object, event on error',
- }
- }
-);
-__PACKAGE__->register_method (
- method => 'update_user_request',
- api_name => 'open-ils.acq.user_request.set_no_hold.batch',
- stream => 1,
- signature => {
- desc => 'Remove the hold from a user request or set of requests',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'ID or array of IDs for the user requests to modify' }
- ],
- return => {
- desc => 'progress object, event on error',
- }
- }
-);
-
-sub update_user_request {
- my($self, $conn, $auth, $aur_ids, $cancel_reason) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $rid = $e->requestor->id;
-
- my $x = 1;
- my %perm_test = ();
- for my $id (@$aur_ids) {
-
- my $aur_obj = $e->retrieve_acq_user_request([
- $id,
- { flesh => 1,
- flesh_fields => { "aur" => ['lineitem', 'usr'] }
- }
- ]) or return $e->die_event;
-
- my $context_org = $aur_obj->usr()->home_ou();
- $aur_obj->usr( $aur_obj->usr()->id() );
-
- if ($rid != $aur_obj->usr) {
- if (!defined $perm_test{ $context_org }) {
- $perm_test{ $context_org } = $e->allowed( ['user_request.update'], $context_org );
- }
- if (!$perm_test{ $context_org }) {
- next; # failed test
- }
- }
-
- if($self->api_name =~ /set_no_hold/) {
- if ($U->is_true($aur_obj->hold)) {
- $aur_obj->hold(0);
- $e->update_acq_user_request($aur_obj) or return $e->die_event;
- }
- }
-
- if($self->api_name =~ /cancel/) {
- if ( $cancel_reason ) {
- $aur_obj->cancel_reason( $cancel_reason );
- $e->update_acq_user_request($aur_obj) or return $e->die_event;
- create_user_request_events( $e, [ $aur_obj ], 'aur.rejected' );
- } else {
- $e->delete_acq_user_request($aur_obj);
- }
- }
-
- $conn->respond({maximum => scalar(@$aur_ids), progress => $x++});
- }
-
- $e->commit;
- return {complete => 1};
-}
-
-__PACKAGE__->register_method (
- method => 'new_user_request',
- api_name => 'open-ils.acq.user_request.create',
- signature => {
- desc => 'Create a new user request object in the DB',
- param => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User request data hash. Hash keys match the fields for the "aur" object', type => 'object' }
- ],
- return => {
- desc => 'The created user request object, or event on error'
- }
- }
-);
-
-sub new_user_request {
- my($self, $conn, $auth, $form_data) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $rid = $e->requestor->id;
- my $target_user_fleshed;
- if (! defined $$form_data{'usr'}) {
- $$form_data{'usr'} = $rid;
- }
- if ($$form_data{'usr'} != $rid) {
- # See if the requestor can place the request on behalf of a different user.
- $target_user_fleshed = $e->retrieve_actor_user($$form_data{'usr'}) or return $e->die_event;
- $e->allowed('user_request.create', $target_user_fleshed->home_ou) or return $e->die_event;
- } else {
- $target_user_fleshed = $e->requestor;
- $e->allowed('CREATE_PURCHASE_REQUEST') or return $e->die_event;
- }
- if (! defined $$form_data{'pickup_lib'}) {
- if ($target_user_fleshed->ws_ou) {
- $$form_data{'pickup_lib'} = $target_user_fleshed->ws_ou;
- } else {
- $$form_data{'pickup_lib'} = $target_user_fleshed->home_ou;
- }
- }
- if (! defined $$form_data{'request_type'}) {
- $$form_data{'request_type'} = 1; # Books
- }
- my $aur_obj = new Fieldmapper::acq::user_request;
- $aur_obj->isnew(1);
- $aur_obj->usr( $$form_data{'usr'} );
- $aur_obj->request_date( 'now' );
- for my $field ( keys %$form_data ) {
- if (defined $$form_data{$field} and $field !~ /^(id|lineitem|eg_bib|request_date|cancel_reason)$/) {
- $aur_obj->$field( $$form_data{$field} );
- }
- }
-
- $aur_obj = $e->create_acq_user_request($aur_obj) or return $e->die_event;
-
- $e->commit and create_user_request_events( $e, [ $aur_obj ], 'aur.created' );
-
- return $aur_obj;
-}
-
-sub create_user_request_events {
- my($e, $user_reqs, $hook) = @_;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->connect;
-
- my %cached_usr_home_ou = ();
- for my $user_req (@$user_reqs) {
- my $home_ou = $cached_usr_home_ou{$user_req->usr};
- if (! $home_ou) {
- my $user = $e->retrieve_actor_user($user_req->usr) or return $e->die_event;
- $home_ou = $user->home_ou;
- $cached_usr_home_ou{$user_req->usr} = $home_ou;
- }
- my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $home_ou);
- $req->recv;
- }
-
- $ses->disconnect;
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "po_note_CUD_batch",
- api_name => "open-ils.acq.po_note.cud.batch",
- stream => 1,
- signature => {
- desc => q/Manage purchase order notes/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "List of po_notes to manage", type => "array"},
- ],
- return => {desc => "Stream of successfully managed objects"}
- }
-);
-
-sub po_note_CUD_batch {
- my ($self, $conn, $auth, $notes) = @_;
-
- my $e = new_editor("xact"=> 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
- # XXX perms
-
- my $total = @$notes;
- my $count = 0;
-
- foreach my $note (@$notes) {
-
- $note->editor($e->requestor->id);
- $note->edit_time("now");
-
- if ($note->isnew) {
- $note->creator($e->requestor->id);
- $note = $e->create_acq_po_note($note) or return $e->die_event;
- } elsif ($note->isdeleted) {
- $e->delete_acq_po_note($note) or return $e->die_event;
- } elsif ($note->ischanged) {
- $e->update_acq_po_note($note) or return $e->die_event;
- }
-
- unless ($note->isdeleted) {
- $note = $e->retrieve_acq_po_note($note->id) or
- return $e->die_event;
- }
-
- $conn->respond(
- {"maximum" => $total, "progress" => ++$count, "note" => $note}
- );
- }
-
- $e->commit and $conn->respond_complete or return $e->die_event;
-}
-
-
-# retrieves a lineitem, fleshes its PO and PL, checks perms
-sub fetch_and_check_li {
- my $e = shift;
- my $li_id = shift;
- my $perm_mode = shift || 'read';
-
- my $li = $e->retrieve_acq_lineitem([
- $li_id,
- { flesh => 1,
- flesh_fields => {jub => ['purchase_order', 'picklist']}
- }
- ]) or return $e->die_event;
-
- if(my $po = $li->purchase_order) {
- my $perms = ($perm_mode eq 'read') ? 'VIEW_PURCHASE_ORDER' : 'CREATE_PURCHASE_ORDER';
- return ($li, $e->die_event) unless $e->allowed($perms, $po->ordering_agency);
-
- } elsif(my $pl = $li->picklist) {
- my $perms = ($perm_mode eq 'read') ? 'VIEW_PICKLIST' : 'CREATE_PICKLIST';
- return ($li, $e->die_event) unless $e->allowed($perms, $pl->org_unit);
- }
-
- return ($li);
-}
-
-
-__PACKAGE__->register_method(
- method => "clone_distrib_form",
- api_name => "open-ils.acq.distribution_formula.clone",
- stream => 1,
- signature => {
- desc => q/Clone a distribution formula/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Original formula ID", type => 'integer'},
- {desc => "Name of new formula", type => 'string'},
- ],
- return => {desc => "ID of newly created formula"}
- }
-);
-
-sub clone_distrib_form {
- my($self, $client, $auth, $form_id, $new_name) = @_;
-
- my $e = new_editor("xact"=> 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $old_form = $e->retrieve_acq_distribution_formula($form_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('ADMIN_ACQ_DISTRIB_FORMULA', $old_form->owner);
-
- my $new_form = Fieldmapper::acq::distribution_formula->new;
-
- $new_form->owner($old_form->owner);
- $new_form->name($new_name);
- $e->create_acq_distribution_formula($new_form) or return $e->die_event;
-
- my $entries = $e->search_acq_distribution_formula_entry({formula => $form_id});
- for my $entry (@$entries) {
- my $new_entry = Fieldmapper::acq::distribution_formula_entry->new;
- $new_entry->$_($entry->$_()) for $entry->real_fields;
- $new_entry->formula($new_form->id);
- $new_entry->clear_id;
- $e->create_acq_distribution_formula_entry($new_entry) or return $e->die_event;
- }
-
- $e->commit;
- return $new_form->id;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Acq::Picklist;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::EX q/:try/;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Const qw/:const/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Event;
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils::Cache;
-use MARC::Record;
-use MARC::Batch;
-use MARC::File::XML;
-use MIME::Base64;
-use Digest::MD5 qw/md5_hex/;
-use OpenILS::Application::Acq::Financials;
-use DateTime;
-
-my $U = 'OpenILS::Application::AppUtils';
-
-
-__PACKAGE__->register_method(
- method => 'create_picklist',
- api_name => 'open-ils.acq.picklist.create',
- signature => {
- desc => 'Creates a new picklist',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist object to create', type => 'object'}
- ],
- return => {desc => 'The ID of the new picklist'}
- }
-);
-
-sub create_picklist {
- my($self, $conn, $auth, $picklist) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- $picklist->creator($e->requestor->id);
- $picklist->editor($e->requestor->id);
- $picklist->org_unit($e->requestor->ws_ou) unless $picklist->org_unit;
- return $e->die_event unless $e->allowed('CREATE_PICKLIST', $picklist->org_unit);
- return OpenILS::Event->new('BAD_PARAMS')
- unless $e->requestor->id == $picklist->owner;
- $e->create_acq_picklist($picklist) or return $e->die_event;
- $e->commit;
- return $picklist->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'update_picklist',
- api_name => 'open-ils.acq.picklist.update',
- signature => {
- desc => 'Updates a new picklist',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist object to update', type => 'object'}
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub update_picklist {
- my($self, $conn, $auth, $picklist) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- # don't let them change the owner
- my $o_picklist = $e->retrieve_acq_picklist($picklist->id)
- or return $e->die_event;
- if($o_picklist->owner != $e->requestor->id) {
- return $e->die_event unless
- $e->allowed('UPDATE_PICKLIST', $o_picklist->org_unit);
- }
- return OpenILS::Event->new('BAD_PARAMS') unless $o_picklist->org_unit == $picklist->org_unit;
-
- $picklist->edit_time('now');
- $picklist->editor($e->requestor->id);
- $e->update_acq_picklist($picklist) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_picklist',
- api_name => 'open-ils.acq.picklist.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a picklist',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist ID to retrieve', type => 'number'},
- {desc => 'Options hash, including "flesh_lineitem_count" to get the count of attached entries', type => 'hash'},
- ],
- return => {desc => 'Picklist object on success, Event on error'}
- }
-);
-
-sub retrieve_picklist {
- my($self, $conn, $auth, $picklist_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- return retrieve_picklist_impl($e, $picklist_id, $options);
-}
-
-sub retrieve_picklist_impl {
- my ($e, $picklist_id, $options) = @_;
- $options ||= {};
-
- my $picklist = $e->retrieve_acq_picklist($picklist_id)
- or return $e->event;
-
- $picklist->entry_count(retrieve_lineitem_count($e, $picklist_id))
- if $$options{flesh_lineitem_count};
-
- if($e->requestor->id != $picklist->owner) {
- return $e->event unless
- $e->allowed('VIEW_PICKLIST', $picklist->org_unit, $picklist);
- }
-
- $picklist->owner($e->retrieve_actor_user($picklist->owner))
- if($$options{flesh_owner});
- $picklist->owner($e->retrieve_actor_user($picklist->owner)->usrname)
- if($$options{flesh_username});
-
- return $picklist;
-}
-
-
-# Returns the number of entries associated with this picklist
-sub retrieve_lineitem_count {
- my($e, $picklist_id) = @_;
- my $count = $e->json_query({
- select => {
- jub => [{transform => 'count', column => 'id', alias => 'count'}]
- },
- from => 'jub',
- where => {picklist => $picklist_id}}
- );
- return $count->[0]->{count};
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_picklist_name',
- api_name => 'open-ils.acq.picklist.name.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a picklist by name. Owner is implied by the caller',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist name to retrieve', type => 'string'},
- ],
- return => {desc => 'Picklist object on success, null on not found'}
- }
-);
-
-sub retrieve_picklist_name {
- my($self, $conn, $auth, $name) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $picklist = $e->search_acq_picklist(
- {name => $name, owner => $e->requestor->id})->[0];
- if($e->requestor->id != $picklist->owner) {
- return $e->event unless
- $e->allowed('VIEW_PICKLIST', $picklist->org_unit, $picklist);
- }
- return $picklist;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_user_picklist',
- api_name => 'open-ils.acq.picklist.user.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves a user\'s picklists',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Options, including "idlist", whch forces the return
- of a list of IDs instead of objects', type => 'hash'},
- ],
- return => {desc => 'Picklist object on success, Event on error'}
- }
-);
-
-sub retrieve_user_picklist {
- my($self, $conn, $auth, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- $options ||= {};
-
- # don't grab the PL with name == "", because that is the designated temporary picklist
- my $list = $e->search_acq_picklist([
- {
- owner => $e->requestor->id,
- name => {'!=' => ''}
- }, {
- order_by => $$options{order_by} || {acqpl => 'edit_time DESC'},
- limit => $$options{limit} || 10,
- offset => $$options{offset} || 0,
- }
- ],
- {idlist=>1}
- );
-
- for my $id (@$list) {
- if($$options{idlist}) {
- $conn->respond($id);
- } else {
- my $pl = $e->retrieve_acq_picklist($id);
- $pl->entry_count(retrieve_lineitem_count($e, $id)) if $$options{flesh_lineitem_count};
- $pl->owner($e->retrieve_actor_user($pl->owner)) if $$options{flesh_owner};
- $pl->owner($e->retrieve_actor_user($pl->owner)->usrname) if $$options{flesh_username};
- $conn->respond($pl);
- }
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_all_user_picklist',
- api_name => 'open-ils.acq.picklist.user.all.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves all of the picklists a user is allowed to see',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Options, including "idlist", whch forces the return
- of a list of IDs instead of objects', type => 'hash'},
- ],
- return => {desc => 'Picklist objects on success, Event on error'}
- }
-);
-
-sub retrieve_all_user_picklist {
- my($self, $conn, $auth, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $my_list = $e->search_acq_picklist(
- {owner=>$e->requestor->id, name=>{'!='=>''}}, {idlist=>1});
-
- my $picklist_ids = $e->objects_allowed('VIEW_PICKLIST', 'acqpl');
- my $p_orgs = $U->user_has_work_perm_at($e, 'VIEW_PICKLIST', {descendants =>1});
- my $picklist_ids_2 = $e->search_acq_picklist(
- {name=>{'!='=>''}, org_unit => $p_orgs}, {idlist=>1});
-
- return undef unless @$my_list or @$picklist_ids or @$picklist_ids_2;
-
- my @list = (@$my_list, @$picklist_ids, @$picklist_ids_2);
- my %dedup;
- $dedup{$_} = 1 for @list;
- @list = keys %dedup;
-
- return \@list if $$options{idlist};
-
- for my $pl (@list) {
- my $picklist = $e->retrieve_acq_picklist($pl) or return $e->event;
- $picklist->entry_count(retrieve_lineitem_count($e, $picklist->id))
- if($$options{flesh_lineitem_count});
- $picklist->owner($e->retrieve_actor_user($picklist->owner))
- if $$options{flesh_owner};
- $picklist->owner($e->retrieve_actor_user($picklist->owner)->usrname)
- if $$options{flesh_username};
- $conn->respond($picklist);
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_pl_lineitem',
- api_name => 'open-ils.acq.lineitem.picklist.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves lineitem objects according to picklist',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Picklist ID whose entries to retrieve', type => 'number'},
- {desc => q/Options, including
- "sort_attr", which defines the attribute to sort on;
- "sort_attr_type", which defines the attribute type sort on;
- "sort_dir", which defines the sort order between "asc" and "desc";
- "limit", retrieval limit;
- "offset", retrieval offset;
- "idlist", return a list of IDs instead of objects
- "flesh_attrs", additionaly return the list of flattened attributes
- "clear_marc", discards the raw MARC data to reduce data size
- "flesh_notes", flesh lineitem notes
- "flesh_cancel_reason", flesh cancel_reason
- /,
- type => 'hash'}
- ],
- return => {desc => 'Array of lineitem objects or IDs, on success, Event on error'}
- }
-);
-
-
-my $PL_ENTRY_JSON_QUERY = {
- select => {jub => ["id"], "acqlia" => ["attr_value"]},
- "from" => {
- "jub" => {
- "acqlia" => {
- "fkey" => "id",
- "field" => "lineitem",
- "type" => "left",
- "filter" => {
- "attr_type" => "lineitem_marc_attr_definition",
- "attr_name" => "author"
- }
- }
- }
- },
- "order_by" => {"acqlia" => {"attr_value" => {"direction"=>"asc"}}},
- "limit" => 10,
- "where" => {"+jub" => {"picklist"=>2}},
- "offset" => 0
-};
-
-sub retrieve_pl_lineitem {
- my($self, $conn, $auth, $picklist_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- # collect the retrieval options
- my $sort_attr = $$options{sort_attr} || 'title';
- my $sort_attr_type = $$options{sort_attr_type} || 'lineitem_marc_attr_definition';
- my $sort_dir = $$options{sort_dir} || 'asc';
- my $limit = $$options{limit} || 10;
- my $offset = $$options{offset} || 0;
-
- $PL_ENTRY_JSON_QUERY->{where}->{'+jub'}->{picklist} = $picklist_id;
- $PL_ENTRY_JSON_QUERY->{from}->{jub}->{acqlia}->{filter}->{attr_name} = $sort_attr;
- $PL_ENTRY_JSON_QUERY->{from}->{jub}->{acqlia}->{filter}->{attr_type} = $sort_attr_type;
- $PL_ENTRY_JSON_QUERY->{order_by}->{acqlia}->{attr_value}->{direction} = $sort_dir;
- $PL_ENTRY_JSON_QUERY->{limit} = $limit;
- $PL_ENTRY_JSON_QUERY->{offset} = $offset;
-
- my $entries = $e->json_query($PL_ENTRY_JSON_QUERY);
-
- my @ids;
- for my $entry (@$entries) {
- push(@ids, $entry->{id}) unless grep { $_ eq $entry->{id} } @ids;
- }
-
- for my $id (@ids) {
- if($$options{idlist}) {
- $conn->respond($id);
- next;
- }
-
- my $entry;
- my $flesh = {};
- if($$options{flesh_attrs} or $$options{flesh_notes} or $$options{flesh_cancel_reason}) {
- $flesh = {flesh => 2, flesh_fields => {jub => []}};
- if($$options{flesh_notes}) {
- push(@{$flesh->{flesh_fields}->{jub}}, 'lineitem_notes');
- $flesh->{flesh_fields}->{acqlin} = ['alert_text'];
- }
- push(@{$flesh->{flesh_fields}->{jub}}, 'attributes') if $$options{flesh_attrs};
- push @{$flesh->{flesh_fields}->{jub}}, 'cancel_reason' if $$options{flesh_cancel_reason};
- }
-
- $entry = $e->retrieve_acq_lineitem([$id, $flesh]);
- my $details = $e->search_acq_lineitem_detail({lineitem => $id}, {idlist=>1});
- $entry->item_count(scalar(@$details));
- $entry->clear_marc if $$options{clear_marc};
- $conn->respond($entry);
- }
-
- return undef;
-}
-
-=head comment
-request open-ils.cstore open-ils.cstore.json_query.atomic {"select":{"jub":[{"transform":"count", "attregate":1, "column":"id","alias":"count"}]}, "from":"jub","where":{"picklist":1}}
-=cut
-
-
-
-__PACKAGE__->register_method(
- method => "record_distribution_formula_application",
- api_name => "open-ils.acq.distribution_formula.record_application",
- signature => {
- desc => "Record the application (which actually happens on the " .
- "client side) of a distribution formula to a PO or a PL",
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Formulae applied", "type" => "array"},
- {desc => "Lineitem ID", "type" => "number"}
- ],
- return => {desc => "acqdfa IDs on success; event on failure"}
- }
-);
-
-sub record_distribution_formula_application {
- my ($self, $conn, $auth, $formulae, $li_id) = @_;
-
- my $e = new_editor("authtoken" => $auth, "xact" => 1);
- return $e->die_event unless $e->checkauth;
-
- # We need this to determine relevant OU for testing permissions...
- my $li = $e->retrieve_acq_lineitem([
- $li_id, {
- "flesh" => 1,
- "flesh_fields" => {"jub" => [qw/purchase_order picklist/]}
- }
- ]) or return $e->die_event;
-
- # ... which we do here.
- my $ou;
- if ($li->purchase_order) {
- $ou = $li->purchase_order->ordering_agency;
- } elsif ($li->picklist) {
- $ou = $li->picklist->org_unit;
- } else {
- $e->rollback;
- return new OpenILS::Event("BAD_PARAMS");
- }
-
- return $e->die_event unless $e->allowed("CREATE_PURCHASE_ORDER", $ou);
-
- # Just deal with it if $formulate is a scalar instead of an array.
- $formulae = [ $formulae ] if not ref $formulae;
-
- my @results = ();
- foreach (@{$formulae}) {
- my $acqdfa = new Fieldmapper::acq::distribution_formula_application;
-
- $acqdfa->creator($e->requestor->id);
- $acqdfa->formula($_);
- $acqdfa->lineitem($li_id);
-
- $acqdfa = $e->create_acq_distribution_formula_application($acqdfa)
- or return $e->die_event;
- push @results, $acqdfa->id;
- }
-
- $e->commit or return $e->die_event;
- \@results;
-}
-
-
-__PACKAGE__->register_method(
- method => 'ranged_distrib_formulas',
- api_name => 'open-ils.acq.distribution_formula.ranged.retrieve',
- stream => 1,
- signature => {
- desc => 'Ranged distribution formulas, fleshed with entries',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => "offset", type => "number"},
- {desc => "limit", type => "number"}
- ],
- return => {desc => 'List of distribution formulas'}
- }
-);
-
-sub ranged_distrib_formulas {
- my ($self, $conn, $auth, $offset, $limit) = @_;
-
- $offset ||= 0;
- $limit ||= 10;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $orgs = $U->user_has_work_perm_at($e, 'CREATE_PICKLIST', {descendants =>1});
-
- my $forms = $e->search_acq_distribution_formula([
- {owner => $orgs},
- {
- flesh => 1,
- flesh_fields => {acqdf => ['entries']},
- order_by => {acqdf => "name"},
- limit => $limit,
- offset => $offset
- }
- ]) or return $e->die_event;
-
- for (@$forms) {
-
- # how many times has this DF been used
- my $count = $e->json_query({
- select => {acqdfa => [{column => 'formula', aggregate => 1, transform => 'count', alias => 'count'}]},
- from => 'acqdfa',
- where => {formula => $_->id}
- })->[0];
-
- $_->use_count($count->{count});
- $conn->respond($_);
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "ranged_distrib_formula_applications",
- api_name => "open-ils.acq.distribution_formula_application.ranged.retrieve",
- stream => 1,
- signature => {
- desc => "Ranged distribution formulas applications, fleshed with formulas and users",
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Lineitem Id", type => "number"}
- ],
- return => {desc => "List of distribution formula applications"}
- }
-);
-
-sub ranged_distrib_formula_applications {
- my ($self, $conn, $auth, $li_id) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->event unless $e->checkauth;
-
- my $li = $e->retrieve_acq_lineitem([
- $li_id, {
- "flesh" => 1,
- "flesh_fields" => {"jub" => [qw/purchase_order picklist/]}
- }
- ]) or return $e->die_event;
-
- if ($li->picklist) {
- return $e->die_event unless $e->allowed(
- "VIEW_PICKLIST", $li->picklist->org_unit
- );
- } elsif ($li->purchase_order) {
- return $e->die_event unless $e->allowed(
- "VIEW_PURCHASE_ORDER", $li->purchase_order->ordering_agency
- );
- } else {
- # For the moment no use cases are forseen for using this
- # method with LIs that don't belong to a PL or a PO.
- $e->disconnect;
- return new OpenILS::Event("BAD_PARAMS", "note" => "Freestanding LI");
- }
-
- my $dfa = $e->search_acq_distribution_formula_application([
- {"lineitem" => $li_id},
- {"flesh" => 1, "flesh_fields" => {"acqdfa" => [qw/formula creator/]}}
- ]);
-
- $conn->respond($_) foreach (@$dfa);
-
- $e->disconnect;
- undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Acq::Provider;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenILS::Event;
-use OpenILS::Const qw/:const/;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::AppUtils;
-
-my $U = 'OpenILS::Application::AppUtils';
-
-__PACKAGE__->register_method(
- method => 'create_provider',
- api_name => 'open-ils.acq.provider.create',
- signature => {
- desc => 'Creates a new provider',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'provider object to create', type => 'object'}
- ],
- return => {desc => 'The ID of the new provider'}
- }
-);
-
-sub create_provider {
- my($self, $conn, $auth, $provider) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
- $e->create_acq_provider($provider) or return $e->die_event;
- $e->commit;
- return $provider->id;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_provider',
- api_name => 'open-ils.acq.provider.retrieve',
- authoritative => 1,
- signature => {
- desc => 'Retrieves a new provider',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'provider ID', type => 'number'}
- ],
- return => {desc => 'The provider object on success, Event on failure'}
- }
-);
-
-sub retrieve_provider {
- my($self, $conn, $auth, $provider_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $provider = $e->retrieve_acq_provider($provider_id) or return $e->event;
- return $e->event unless $e->allowed(
- ['ADMIN_PROVIDER', 'MANAGE_PROVIDER', 'VIEW_PROVIDER'], $provider->owner, $provider);
- return $provider;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_org_providers',
- api_name => 'open-ils.acq.provider.org.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves all the providers associated with an org unit that the requestor has access to see',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'List of org Unit IDs. If no IDs are provided, this method returns the
- full set of funding sources this user has permission to view', type => 'number'},
- {desc => q/Limiting permission. this permission is used find the work-org tree from which
- the list of orgs is generated if no org ids are provided.
- The default is ADMIN_PROVIDER/, type => 'string'},
- ],
- return => {desc => 'The provider objects on success, empty array otherwise'}
- }
-);
-
-sub retrieve_org_providers {
- my($self, $conn, $auth, $org_id_list, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $limit_perm = ($$options{limit_perm}) ? $$options{limit_perm} : 'ADMIN_PROVIDER';
-
- return OpenILS::Event->new('BAD_PARAMS')
- unless $limit_perm =~ /(ADMIN|MANAGE|VIEW)_PROVIDER/;
-
- my $org_ids = ($org_id_list and @$org_id_list) ? $org_id_list :
- $U->user_has_work_perm_at($e, $limit_perm, {descendants =>1});
-
- return [] unless @$org_ids;
- $conn->respond($_) for @{
- $e->search_acq_provider([
- {owner => $org_ids, active => 't'},
- {order_by => {acqpro => 'code'}}
- ])
- };
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_provider_attr_def',
- api_name => 'open-ils.acq.lineitem_provider_attr_definition.provider.retrieve',
- stream => 1,
- signature => {
- desc => 'Retrieves all of the lineitem_provider_attr_definition for a given provider',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Provider ID', type => 'number'}
- ],
- return => {desc => 'Streams a of lineitem_provider_attr_definition objects'}
- }
-);
-
-sub retrieve_provider_attr_def {
- my($self, $conn, $auth, $prov_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $provider = $e->retrieve_acq_provider($prov_id)
- or return $e->event;
- return $e->event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
- for my $id (@{$e->search_acq_lineitem_provider_attr_definition({provider=>$prov_id},{idlist=>1})}) {
- $conn->respond($e->retrieve_acq_lineitem_provider_attr_definition($id));
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'create_provider_attr_def',
- api_name => 'open-ils.acq.lineitem_provider_attr_definition.create',
- signature => {
- desc => 'Retrieves all of the lineitem_provider_attr_definition for a given provider',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Provider ID', type => 'number'}
- ],
- return => {desc => 'Streams a of lineitem_provider_attr_definition objects'}
- }
-);
-
-sub create_provider_attr_def {
- my($self, $conn, $auth, $attr_def) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my $provider = $e->retrieve_acq_provider($attr_def->provider)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
- $e->create_acq_lineitem_provider_attr_definition($attr_def)
- or return $e->die_event;
- $e->commit;
- return $attr_def->id;
-}
-
-__PACKAGE__->register_method(
- method => 'delete_provider_attr_def',
- api_name => 'open-ils.acq.lineitem_provider_attr_definition.delete',
- signature => {
- desc => 'Deletes a lineitem_provider_attr_definition',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'ID', type => 'number'}
- ],
- return => {desc => '1 on success, event on failure'}
- }
-);
-
-sub delete_provider_attr_def {
- my($self, $conn, $auth, $id) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my $attr_def = $e->retrieve_acq_lineitem_provider_attr_definition($id)
- or return $e->die_event;
- my $provider = $e->retrieve_acq_provider($attr_def->provider)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
- $e->delete_acq_lineitem_provider_attr_definition($attr_def)
- or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Acq::Search;
-use base "OpenILS::Application";
-
-use strict;
-use warnings;
-
-use OpenSRF::AppSession;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Event;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Application::Acq::Lineitem;
-use OpenILS::Application::Acq::Financials;
-use OpenILS::Application::Acq::Picklist;
-use OpenILS::Application::Acq::Invoice;
-use OpenILS::Application::Acq::Order;
-
-my %RETRIEVERS = (
- "lineitem" =>
- \&{"OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl"},
- "picklist" =>
- \&{"OpenILS::Application::Acq::Picklist::retrieve_picklist_impl"},
- "purchase_order" => \&{
- "OpenILS::Application::Acq::Financials::retrieve_purchase_order_impl"
- },
- "invoice" => \&{
- "OpenILS::Application::Acq::Invoice::fetch_invoice_impl"
- },
-);
-
-sub F { $Fieldmapper::fieldmap->{"Fieldmapper::" . $_[0]}; }
-
-# This subroutine returns 1 if the argument is a) a scalar OR
-# b) an array of ONLY scalars. Otherwise it returns 0.
-sub check_1d_max {
- my ($o) = @_;
- return 1 unless ref $o;
- if (ref($o) eq "ARRAY") {
- foreach (@$o) { return 0 if ref $_; }
- return 1;
- }
- 0;
-}
-
-# Returns 1 if and only if argument is an array of exactly two scalars.
-sub could_be_range {
- my ($o) = @_;
- if (ref $o eq "ARRAY") {
- return 1 if (scalar(@$o) == 2 && (!ref $o->[0] && !ref $o->[1]));
- }
- 0;
-}
-
-sub castdate {
- my ($value, $gte, $lte) = @_;
-
- my $op = "=";
- $op = ">=" if $gte;
- $op = "<=" if $lte;
-
- +{$op => {"transform" => "date", "value" => $value}};
-}
-
-sub prepare_acqlia_search_and {
- my ($acqlia) = @_;
-
- my @phrases = ();
- foreach my $unit (@{$acqlia}) {
- my $subquery = {
- "select" => {"acqlia" => ["id"]},
- "from" => "acqlia",
- "where" => {"-and" => [{"lineitem" => {"=" => {"+jub" => "id"}}}]}
- };
-
- # castdate not supported for acqlia fields: they're all type text
- my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
- my $point = $subquery->{"where"}->{"-and"};
- my $term_clause;
-
- push @$point, {"definition" => $k};
-
- if ($fuzzy and not ref $v) {
- push @$point, {"attr_value" => {"ilike" => "%" . $v . "%"}};
- } elsif ($between and could_be_range($v)) {
- push @$point, {"attr_value" => {"between" => $v}};
- } elsif (check_1d_max($v)) {
- push @$point, {"attr_value" => $v};
- } else {
- next;
- }
-
- my $operator = $not ? "-not-exists" : "-exists";
- push @phrases, {$operator => $subquery};
- }
- @phrases;
-}
-
-sub prepare_acqlia_search_or {
- my ($acqlia) = @_;
-
- my $point = [];
- my $result = {"+acqlia" => {"-or" => $point}};
-
- foreach my $unit (@$acqlia) {
- # castdate not supported for acqlia fields: they're all type text
- my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
- my $term_clause;
- if ($fuzzy and not ref $v) {
- $term_clause = {
- "-and" => {
- "definition" => $k,
- "attr_value" => {"ilike" => "%" . $v . "%"}
- }
- };
- } elsif ($between and could_be_range($v)) {
- $term_clause = {
- "-and" => {
- "definition" => $k, "attr_value" => {"between" => $v}
- }
- };
- } elsif (check_1d_max($v)) {
- $term_clause = {
- "-and" => {"definition" => $k, "attr_value" => $v}
- };
- } else {
- next;
- }
-
- push @$point, $not ? {"-not" => $term_clause} : $term_clause;
- }
- $result;
-}
-
-sub breakdown_term {
- my ($term) = @_;
-
- my $key = (grep { !/^__/ } keys %$term)[0];
- (
- $key, $term->{$key},
- $term->{"__fuzzy"} ? 1 : 0,
- $term->{"__between"} ? 1 : 0,
- $term->{"__not"} ? 1 : 0,
- $term->{"__castdate"} ? 1 : 0,
- $term->{"__gte"} ? 1 : 0,
- $term->{"__lte"} ? 1 : 0
- );
-}
-
-sub get_fm_links_by_hint {
- my ($hint) = @_;
- foreach my $field (values %{$Fieldmapper::fieldmap}) {
- return $field->{"links"} if $field->{"hint"} eq $hint;
- }
- undef;
-}
-
-sub gen_au_term {
- my ($value, $n) = @_;
- +{
- "-or" => [
- {"+au$n" => {"usrname" => $value}},
- {"+au$n" => {"first_given_name" => $value}},
- {"+au$n" => {"second_given_name" => $value}},
- {"+au$n" => {"family_name" => $value}},
- {"+ac$n" => {"barcode" => $value}}
- ]
- };
-}
-
-# go through the terms hash, find keys that correspond to fields links
-# to actor.usr, and rewrite the search as one that searches not by
-# actor.usr.id but by any of these user properties: card barcode, username,
-# given names and family name.
-sub prepare_au_terms {
- my ($terms, $join_num) = @_;
-
- my @joins = ();
- my $nots = 0;
- $join_num ||= 0;
-
- foreach my $conj (qw/-and -or/) {
- next unless exists $terms->{$conj};
-
- my @new_outer_terms = ();
- HINT_UNIT: foreach my $hint_unit (@{$terms->{$conj}}) {
- my $hint = (keys %$hint_unit)[0];
- (my $plain_hint = $hint) =~ y/+//d;
- if ($hint eq "-not") {
- $hint_unit = $hint_unit->{$hint};
- $nots++;
- redo HINT_UNIT;
- }
-
- if (my $links = get_fm_links_by_hint($plain_hint) and
- $plain_hint ne "acqlia") {
- my @new_terms = ();
- my ($attr, $value) = breakdown_term($hint_unit->{$hint});
- if ($links->{$attr} and
- $links->{$attr}->{"class"} eq "au") {
- push @joins, [$plain_hint, $attr, $join_num];
- my $au_term = gen_au_term($value, $join_num);
- if ($nots > 0) {
- $au_term = {"-not" => $au_term};
- $nots--;
- }
- push @new_outer_terms, $au_term;
- $join_num++;
- delete $hint_unit->{$hint};
- }
- }
- if ($nots > 0) {
- $hint_unit = {"-not" => $hint_unit};
- $nots--;
- }
- push @new_outer_terms, $hint_unit if scalar keys %$hint_unit;
- }
- $terms->{$conj} = [ @new_outer_terms ];
- }
- @joins;
-}
-
-sub prepare_terms {
- my ($terms, $is_and) = @_;
-
- my $conj = $is_and ? "-and" : "-or";
- my $outer_clause = {};
-
- foreach my $class (qw/acqpo acqpl acqinv jub/) {
- next if not exists $terms->{$class};
-
- $outer_clause->{$conj} = [] unless $outer_clause->{$conj};
- foreach my $unit (@{$terms->{$class}}) {
- my ($k, $v, $fuzzy, $between, $not, $castdate, $gte, $lte) =
- breakdown_term($unit);
-
- my $term_clause;
- if ($fuzzy and not ref $v) {
- $term_clause = {$k => {"ilike" => "%" . $v . "%"}};
- } elsif ($between and could_be_range($v)) {
- $term_clause = {$k => {"between" => $v}};
- } elsif (check_1d_max($v)) {
- $v = castdate($v, $gte, $lte) if $castdate;
- $term_clause = {$k => $v};
- } else {
- next;
- }
-
- my $clause = {"+" . $class => $term_clause};
- $clause = {"-not" => $clause} if $not;
- push @{$outer_clause->{$conj}}, $clause;
- }
- }
-
- if ($terms->{"acqlia"}) {
- push @{$outer_clause->{$conj}},
- $is_and ? prepare_acqlia_search_and($terms->{"acqlia"}) :
- prepare_acqlia_search_or($terms->{"acqlia"});
- }
-
- return undef unless scalar keys %$outer_clause;
- $outer_clause;
-}
-
-sub add_au_joins {
- my ($from) = shift;
-
- my $n = 0;
- foreach my $join (@_) {
- my ($hint, $attr, $num) = @$join;
- my $start;
- if ($hint eq "jub") {
- $start = $from->{$hint};
- } elsif ($hint eq "acqinv") {
- $start = $from->{"jub"}->{"acqie"}->{"join"}->{$hint};
- } else {
- $start = $from->{"jub"}->{$hint};
- }
- my $clause = {
- "class" => "au",
- "type" => "left",
- "field" => "id",
- "fkey" => $attr,
- "join" => {
- "ac$num" => {
- "class" => "ac",
- "type" => "left",
- "field" => "id",
- "fkey" => "card"
- }
- }
- };
- if ($hint eq "jub") {
- $start->{"au$num"} = $clause;
- } else {
- $start->{"join"} ||= {};
- $start->{"join"}->{"au$num"} = $clause;
- }
- $n++;
- }
- $n;
-}
-
-__PACKAGE__->register_method(
- method => "unified_search",
- api_name => "open-ils.acq.lineitem.unified_search",
- stream => 1,
- signature => {
- desc => q/Returns lineitems based on flexible search terms./,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "Field/value pairs for AND'ing", type => "object"},
- {desc => "Field/value pairs for OR'ing", type => "object"},
- {desc => "Conjunction between AND pairs and OR pairs " .
- "(can be 'and' or 'or')", type => "string"},
- {desc => "Retrieval options (clear_marc, flesh_notes, etc) " .
- "- XXX detail all the options",
- type => "object"}
- ],
- return => {desc => "A stream of LIs on success, Event on failure"}
- }
-);
-
-__PACKAGE__->register_method(
- method => "unified_search",
- api_name => "open-ils.acq.purchase_order.unified_search",
- stream => 1,
- signature => {
- desc => q/Returns purchase orders based on flexible search terms.
- See open-ils.acq.lineitem.unified_search/,
- return => {desc => "A stream of POs on success, Event on failure"}
- }
-);
-
-__PACKAGE__->register_method(
- method => "unified_search",
- api_name => "open-ils.acq.picklist.unified_search",
- stream => 1,
- signature => {
- desc => q/Returns pick lists based on flexible search terms.
- See open-ils.acq.lineitem.unified_search/,
- return => {desc => "A stream of PLs on success, Event on failure"}
- }
-);
-
-__PACKAGE__->register_method(
- method => "unified_search",
- api_name => "open-ils.acq.invoice.unified_search",
- stream => 1,
- signature => {
- desc => q/Returns invoices lists based on flexible search terms.
- See open-ils.acq.lineitem.unified_search/,
- return => {desc => "A stream of invoices on success, Event on failure"}
- }
-);
-
-sub unified_search {
- my ($self, $conn, $auth, $and_terms, $or_terms, $conj, $options) = @_;
- $options ||= {};
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- # What kind of object are we returning? Important: (\w+) had better be
- # a legit acq classname particle, so don't register any crazy api_names.
- my $ret_type = ($self->api_name =~ /cq.(\w+).un/)[0];
- my $retriever = $RETRIEVERS{$ret_type};
- my $hint = F("acq::$ret_type")->{"hint"};
-
- my $select_clause = {
- $hint => [{"column" => "id", "transform" => "distinct"}]
- };
-
- if ($options->{"order_by"}) {
- # What's the point of this block? When using ORDER BY in conjuction
- # with SELECT DISTINCT, the fields present in ORDER BY have to also
- # be in the SELECT clause. This will take _one_ such field and add
- # it to the SELECT clause as needed.
- my ($order_by, $class, $field);
- unless (
- ($order_by = $options->{"order_by"}->[0]) &&
- ($class = $order_by->{"class"}) =~ /^[\da-z_]+$/ &&
- ($field = $order_by->{"field"}) =~ /^[\da-z_]+$/
- ) {
- $e->disconnect;
- return new OpenILS::Event(
- "BAD_PARAMS", "note" =>
-q/order_by clause must be of the long form, like:
-"order_by": [{"class": "foo", "field": "bar", "direction": "asc"}]/
- );
- } else {
- $select_clause->{$class} ||= [];
- push @{$select_clause->{$class}}, $field;
- }
- }
-
- my $query = {
- "select" => $select_clause,
- "from" => {
- "jub" => {
- "acqpo" => {
- "type" => "full",
- "field" => "id",
- "fkey" => "purchase_order"
- },
- "acqpl" => {
- "type" => "full",
- "field" => "id",
- "fkey" => "picklist"
- },
- "acqie" => {
- "type" => "full",
- "field" => "lineitem",
- "fkey" => "id",
- "join" => {
- "acqinv" => {
- "type" => "full",
- "fkey" => "invoice",
- "field" => "id"
- }
- }
- }
- }
- },
- "order_by" => ($options->{"order_by"} || {$hint => {"id" => {}}}),
- "offset" => ($options->{"offset"} || 0)
- };
-
- $query->{"limit"} = $options->{"limit"} if $options->{"limit"};
-
- # XXX for the future? but it doesn't quite work as is.
-# # Remove anything in temporary picklists from search results.
-# $and_terms ||= {};
-# $and_terms->{"acqpl"} ||= [];
-# push @{$and_terms->{"acqpl"}}, {"name" => "", "__not" => 1};
-
- $and_terms = prepare_terms($and_terms, 1);
- $or_terms = prepare_terms($or_terms, 0) and do {
- $query->{"from"}->{"jub"}->{"acqlia"} = {
- "type" => "left", "field" => "lineitem", "fkey" => "id",
- };
- };
-
- my $offset = add_au_joins($query->{"from"}, prepare_au_terms($and_terms));
- add_au_joins($query->{"from"}, prepare_au_terms($or_terms, $offset));
-
- if ($and_terms and $or_terms) {
- $query->{"where"} = {
- "-" . (lc $conj eq "or" ? "or" : "and") => [$and_terms, $or_terms]
- };
- } elsif ($and_terms) {
- $query->{"where"} = $and_terms;
- } elsif ($or_terms) {
- $query->{"where"} = $or_terms;
- } else {
- $e->disconnect;
- return new OpenILS::Event("BAD_PARAMS", "desc" => "No usable terms");
- }
-
- my $results = $e->json_query($query) or return $e->die_event;
- my @id_list = map { $_->{"id"} } (grep { $_->{"id"} } @$results);
-
- if ($options->{"id_list"}) {
- $conn->respond($_) foreach @id_list;
- } else {
- $conn->respond($retriever->($e, $_, $options)) foreach @id_list;
- }
-
- $e->disconnect;
- undef;
-}
-
-__PACKAGE__->register_method(
- method => "bib_search",
- api_name => "open-ils.acq.biblio.wrapped_search",
- stream => 1,
- signature => {
- desc => q/Returns new lineitems for each matching bib record/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "search string", type => "string"},
- {desc => "search options", type => "object"}
- ],
- return => {desc => "A stream of LIs on success, Event on failure"}
- }
-);
-
-__PACKAGE__->register_method(
- method => "bib_search",
- api_name => "open-ils.acq.biblio.create_by_id",
- stream => 1,
- signature => {
- desc => q/Returns new lineitems for each matching bib record/,
- params => [
- {desc => "Authentication token", type => "string"},
- {desc => "list of bib IDs", type => "array"},
- {desc => "options (for lineitem fleshing)", type => "object"}
- ],
- return => {desc => "A stream of LIs on success, Event on failure"}
- }
-);
-
-# This is very similar to zsearch() in Order.pm
-sub bib_search {
- my ($self, $conn, $auth, $search, $opts) = @_;
-
- my $e = new_editor("authtoken" => $auth, "xact" => 1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("CREATE_PICKLIST");
-
- my $mgr = new OpenILS::Application::Acq::BatchManager(
- "editor" => $e, "conn" => $conn
- );
-
- $opts ||= {};
-
- my $picklist;
- my @li_ids = ();
- if ($self->api_name =~ /create_by_id/) {
- $search = [ sort @$search ]; # for consitency
- my $bibs = $e->search_biblio_record_entry(
- {"id" => $search}, {"order_by" => {"bre" => ["id"]}}
- ) or return $e->die_event;
-
- if ($opts->{"reuse_picklist"}) {
- $picklist = $e->retrieve_acq_picklist($opts->{"reuse_picklist"}) or
- return $e->die_event;
- return $e->die_event unless
- $e->allowed("UPDATE_PICKLIST", $picklist->org_unit);
-
- # If we're reusing an existing picklist, we don't need to
- # create new lineitems for any bib records for which we already
-
- my $already_have = $e->search_acq_lineitem({
- "picklist" => $picklist->id,
- "eg_bib_id" => [ map { $_->id } @$bibs ]
- }) or return $e->die_event;
-
- # So in that case we a) save the lineitem id's of the relevant
- # items that already exist so that we can return those items later,
- # and b) remove the bib id's in question from our list of bib
- # id's to lineitemize.
- if (@$already_have) {
- push @li_ids, $_->id foreach (@$already_have);
- my @new_bibs = ();
- foreach my $bib (@$bibs) {
- push @new_bibs, $bib unless
- grep { $_->eg_bib_id == $bib->id } @$already_have;
- }
- $bibs = [ @new_bibs ];
- }
- } else {
- $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl($mgr, undef)
- or return $e->die_event;
- }
-
- $conn->respond($picklist->id);
-
- push @li_ids, map {
- OpenILS::Application::Acq::Order::create_lineitem(
- $mgr,
- "picklist" => $picklist->id,
- "source_label" => "native-evergreen-catalog",
- "marc" => $_->marc,
- "eg_bib_id" => $_->id
- )->id;
- } (@$bibs);
- } else {
- $opts->{"limit"} ||= 10;
-
- my $ses = create OpenSRF::AppSession("open-ils.search");
- my $req = $ses->request(
- "open-ils.search.biblio.multiclass.query.staff", $opts, $search
- );
-
- my $count = 0;
- while (my $resp = $req->recv("timeout" => 60)) {
- $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl(
- $mgr, undef
- ) unless $count++;
-
- my $result = $resp->content;
- next if not ref $result;
-
- # The result object contains a whole heck of a lot more information
- # than just bib IDs, so maybe we could tell the client something
- # useful (progress meter at least) in the future...
- push @li_ids, map {
- my $bib = $_->[0];
- OpenILS::Application::Acq::Order::create_lineitem(
- $mgr,
- "picklist" => $picklist->id,
- "source_label" => "native-evergreen-catalog",
- "marc" => $e->retrieve_biblio_record_entry($bib)->marc,
- "eg_bib_id" => $bib
- )->id;
- } (@{$result->{"ids"}});
- }
- $ses->disconnect;
- }
-
- $e->commit;
-
- $logger->info("created @li_ids new lineitems for picklist $picklist");
-
- # new editor, but still using transaction to ensure correct retrieval
- # in a replicated setup
- $e = new_editor("authtoken" => $auth, xact => 1) or return $e->die_event;
- return $e->die_event unless $e->checkauth;
- $conn->respond($RETRIEVERS{"lineitem"}->($e, $_, $opts)) foreach @li_ids;
- $e->rollback;
- $e->disconnect;
-
- undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Actor;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use Data::Dumper;
-$Data::Dumper::Indent = 0;
-use OpenILS::Event;
-
-use Digest::MD5 qw(md5_hex);
-
-use OpenSRF::EX qw(:try);
-use OpenILS::Perm;
-
-use OpenILS::Application::AppUtils;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::ModsParser;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::SettingsClient;
-
-use OpenSRF::Utils::Cache;
-
-use OpenSRF::Utils::JSON;
-use DateTime;
-use DateTime::Format::ISO8601;
-use OpenILS::Const qw/:const/;
-
-use OpenILS::Application::Actor::Container;
-use OpenILS::Application::Actor::ClosedDates;
-use OpenILS::Application::Actor::UserGroups;
-use OpenILS::Application::Actor::Friends;
-use OpenILS::Application::Actor::Stage;
-
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Utils::Penalty;
-use List::Util qw/max/;
-
-use UUID::Tiny qw/:std/;
-
-sub initialize {
- OpenILS::Application::Actor::Container->initialize();
- OpenILS::Application::Actor::UserGroups->initialize();
- OpenILS::Application::Actor::ClosedDates->initialize();
-}
-
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-
-sub _d { warn "Patron:\n" . Dumper(shift()); }
-
-my $cache;
-my $set_user_settings;
-my $set_ou_settings;
-
-
-#__PACKAGE__->register_method(
-# method => "allowed_test",
-# api_name => "open-ils.actor.allowed_test",
-#);
-#sub allowed_test {
-# my($self, $conn, $auth, $orgid, $permcode) = @_;
-# my $e = new_editor(authtoken => $auth);
-# return $e->die_event unless $e->checkauth;
-#
-# return {
-# orgid => $orgid,
-# permcode => $permcode,
-# result => $e->allowed($permcode, $orgid)
-# };
-#}
-
-__PACKAGE__->register_method(
- method => "update_user_setting",
- api_name => "open-ils.actor.patron.settings.update",
-);
-sub update_user_setting {
- my($self, $conn, $auth, $user_id, $settings) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- $user_id = $e->requestor->id unless defined $user_id;
-
- unless($e->requestor->id == $user_id) {
- my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
- }
-
- for my $name (keys %$settings) {
- my $val = $$settings{$name};
- my $set = $e->search_actor_user_setting({usr => $user_id, name => $name})->[0];
-
- if(defined $val) {
- $val = OpenSRF::Utils::JSON->perl2JSON($val);
- if($set) {
- $set->value($val);
- $e->update_actor_user_setting($set) or return $e->die_event;
- } else {
- $set = Fieldmapper::actor::user_setting->new;
- $set->usr($user_id);
- $set->name($name);
- $set->value($val);
- $e->create_actor_user_setting($set) or return $e->die_event;
- }
- } elsif($set) {
- $e->delete_actor_user_setting($set) or return $e->die_event;
- }
- }
-
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "set_ou_settings",
- api_name => "open-ils.actor.org_unit.settings.update",
- signature => {
- desc => "Updates the value for a given org unit setting. The permission to update " .
- "an org unit setting is either the UPDATE_ORG_UNIT_SETTING_ALL, or a specific " .
- "permission specified in the update_perm column of the config.org_unit_setting_type " .
- "table's row corresponding to the setting being changed." ,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Org unit ID', type => 'number'},
- {desc => 'Hash of setting name-value pairs', type => 'object'}
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub set_ou_settings {
- my( $self, $client, $auth, $org_id, $settings ) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $all_allowed = $e->allowed("UPDATE_ORG_UNIT_SETTING_ALL", $org_id);
-
- for my $name (keys %$settings) {
- my $val = $$settings{$name};
-
- my $type = $e->retrieve_config_org_unit_setting_type([
- $name,
- {flesh => 1, flesh_fields => {'coust' => ['update_perm']}}
- ]) or return $e->die_event;
- my $set = $e->search_actor_org_unit_setting({org_unit => $org_id, name => $name})->[0];
-
- # If there is no relevant permission, the default assumption will
- # be, "no, the caller cannot change that value."
- return $e->die_event unless ($all_allowed ||
- ($type->update_perm && $e->allowed($type->update_perm->code, $org_id)));
-
- if(defined $val) {
- $val = OpenSRF::Utils::JSON->perl2JSON($val);
- if($set) {
- $set->value($val);
- $e->update_actor_org_unit_setting($set) or return $e->die_event;
- } else {
- $set = Fieldmapper::actor::org_unit_setting->new;
- $set->org_unit($org_id);
- $set->name($name);
- $set->value($val);
- $e->create_actor_org_unit_setting($set) or return $e->die_event;
- }
- } elsif($set) {
- $e->delete_actor_org_unit_setting($set) or return $e->die_event;
- }
- }
-
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "user_settings",
- authoritative => 1,
- api_name => "open-ils.actor.patron.settings.retrieve",
-);
-sub user_settings {
- my( $self, $client, $auth, $user_id, $setting ) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- $user_id = $e->requestor->id unless defined $user_id;
-
- my $patron = $e->retrieve_actor_user($user_id) or return $e->event;
- if($e->requestor->id != $user_id) {
- return $e->event unless $e->allowed('VIEW_USER', $patron->home_ou);
- }
-
- sub get_setting {
- my($e, $user_id, $setting) = @_;
- my $val = $e->search_actor_user_setting({usr => $user_id, name => $setting})->[0];
- return undef unless $val; # XXX this should really return undef, but needs testing
- return OpenSRF::Utils::JSON->JSON2perl($val->value);
- }
-
- if($setting) {
- if(ref $setting eq 'ARRAY') {
- my %settings;
- $settings{$_} = get_setting($e, $user_id, $_) for @$setting;
- return \%settings;
- } else {
- return get_setting($e, $user_id, $setting);
- }
- } else {
- my $s = $e->search_actor_user_setting({usr => $user_id});
- return { map { ( $_->name => OpenSRF::Utils::JSON->JSON2perl($_->value) ) } @$s };
- }
-}
-
-
-__PACKAGE__->register_method(
- method => "ranged_ou_settings",
- api_name => "open-ils.actor.org_unit_setting.values.ranged.retrieve",
- signature => {
- desc => "Retrieves all org unit settings for the given org_id, up to whatever limit " .
- "is implied for retrieving OU settings by the authenticated users' permissions.",
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Org unit ID', type => 'number'},
- ],
- return => {desc => 'A hashref of "ranged" settings, event on error'}
- }
-);
-sub ranged_ou_settings {
- my( $self, $client, $auth, $org_id ) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my %ranged_settings;
- my $org_list = $U->get_org_ancestors($org_id);
- my $settings = $e->search_actor_org_unit_setting({org_unit => $org_list});
- $org_list = [ reverse @$org_list ];
-
- # start at the context org and capture the setting value
- # without clobbering settings we've already captured
- for my $this_org_id (@$org_list) {
-
- my @sets = grep { $_->org_unit == $this_org_id } @$settings;
-
- for my $set (@sets) {
- my $type = $e->retrieve_config_org_unit_setting_type([
- $set->name,
- {flesh => 1, flesh_fields => {coust => ['view_perm']}}
- ]);
-
- # If there is no relevant permission, the default assumption will
- # be, "yes, the caller can have that value."
- if ($type && $type->view_perm) {
- next if not $e->allowed($type->view_perm->code, $org_id);
- }
-
- $ranged_settings{$set->name} = OpenSRF::Utils::JSON->JSON2perl($set->value)
- unless defined $ranged_settings{$set->name};
- }
- }
-
- return \%ranged_settings;
-}
-
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.actor.ou_setting.ancestor_default',
- method => 'ou_ancestor_setting',
- signature => {
- desc => 'Get the org unit setting value associated with the setting name as seen from the specified org unit. ' .
- 'IF AND ONLY IF an authentication token is provided, this method will make sure that the given ' .
- 'user has permission to view that setting, if there is a permission associated with the setting.' ,
- params => [
- { desc => 'Org unit ID', type => 'number' },
- { desc => 'setting name', type => 'string' },
- { desc => 'authtoken (optional)', type => 'string' }
- ],
- return => {desc => 'A value for the org unit setting, or undef'}
- }
-);
-
-# ------------------------------------------------------------------
-# Attempts to find the org setting value for a given org. if not
-# found at the requested org, searches up the org tree until it
-# finds a parent that has the requested setting.
-# when found, returns { org => $id, value => $value }
-# otherwise, returns NULL
-# ------------------------------------------------------------------
-sub ou_ancestor_setting {
- my( $self, $client, $orgid, $name, $auth ) = @_;
- return $U->ou_ancestor_setting($orgid, $name, undef, $auth);
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.actor.ou_setting.ancestor_default.batch',
- method => 'ou_ancestor_setting_batch',
- signature => {
- desc => 'Get org unit setting name => value pairs for a list of names, as seen from the specified org unit. ' .
- 'IF AND ONLY IF an authentication token is provided, this method will make sure that the given ' .
- 'user has permission to view that setting, if there is a permission associated with the setting.' ,
- params => [
- { desc => 'Org unit ID', type => 'number' },
- { desc => 'setting name list', type => 'array' },
- { desc => 'authtoken (optional)', type => 'string' }
- ],
- return => {desc => 'A hash with name => value pairs for the org unit settings'}
- }
-);
-sub ou_ancestor_setting_batch {
- my( $self, $client, $orgid, $name_list, $auth ) = @_;
- my %values;
- $values{$_} = $U->ou_ancestor_setting($orgid, $_, undef, $auth) for @$name_list;
- return \%values;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "update_patron",
- api_name => "open-ils.actor.patron.update",
- signature => {
- desc => q/
- Update an existing user, or create a new one. Related objects,
- like cards, addresses, survey responses, and stat cats,
- can be updated by attaching them to the user object in their
- respective fields. For examples, the billing address object
- may be inserted into the 'billing_address' field, etc. For each
- attached object, indicate if the object should be created,
- updated, or deleted using the built-in 'isnew', 'ischanged',
- and 'isdeleted' fields on the object.
- /,
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Patron data object', type => 'object' }
- ],
- return => {desc => 'A fleshed user object, event on error'}
- }
-);
-
-sub update_patron {
- my( $self, $client, $user_session, $patron ) = @_;
-
- my $session = $apputils->start_db_session();
-
- $logger->info($patron->isnew ? "Creating new patron..." : "Updating Patron: " . $patron->id);
-
- my( $user_obj, $evt ) = $U->checkses($user_session);
- return $evt if $evt;
-
- $evt = check_group_perm($session, $user_obj, $patron);
- return $evt if $evt;
-
-
- # $new_patron is the patron in progress. $patron is the original patron
- # passed in with the method. new_patron will change as the components
- # of patron are added/updated.
-
- my $new_patron;
-
- # unflesh the real items on the patron
- $patron->card( $patron->card->id ) if(ref($patron->card));
- $patron->billing_address( $patron->billing_address->id )
- if(ref($patron->billing_address));
- $patron->mailing_address( $patron->mailing_address->id )
- if(ref($patron->mailing_address));
-
- # create/update the patron first so we can use his id
- if($patron->isnew()) {
- ( $new_patron, $evt ) = _add_patron($session, _clone_patron($patron), $user_obj);
- return $evt if $evt;
- } else { $new_patron = $patron; }
-
- ( $new_patron, $evt ) = _add_update_addresses($session, $patron, $new_patron, $user_obj);
- return $evt if $evt;
-
- ( $new_patron, $evt ) = _add_update_cards($session, $patron, $new_patron, $user_obj);
- return $evt if $evt;
-
- ( $new_patron, $evt ) = _add_survey_responses($session, $patron, $new_patron, $user_obj);
- return $evt if $evt;
-
- # re-update the patron if anything has happened to him during this process
- if($new_patron->ischanged()) {
- ( $new_patron, $evt ) = _update_patron($session, $new_patron, $user_obj);
- return $evt if $evt;
- }
-
- ($new_patron, $evt) = _create_stat_maps($session, $user_session, $patron, $new_patron, $user_obj);
- return $evt if $evt;
-
- ($new_patron, $evt) = _create_perm_maps($session, $user_session, $patron, $new_patron, $user_obj);
- return $evt if $evt;
-
- $apputils->commit_db_session($session);
-
- $evt = apply_invalid_addr_penalty($patron);
- return $evt if $evt;
-
- my $tses = OpenSRF::AppSession->create('open-ils.trigger');
- if($patron->isnew) {
- $tses->request('open-ils.trigger.event.autocreate', 'au.create', $new_patron, $new_patron->home_ou);
- } else {
- $tses->request('open-ils.trigger.event.autocreate', 'au.update', $new_patron, $new_patron->home_ou);
- }
-
- return flesh_user($new_patron->id(), new_editor(requestor => $user_obj, xact => 1));
-}
-
-sub apply_invalid_addr_penalty {
- my $patron = shift;
- my $e = new_editor(xact => 1);
-
- # grab the invalid address penalty if set
- my $penalties = OpenILS::Utils::Penalty->retrieve_usr_penalties($e, $patron->id, $patron->home_ou);
-
- my ($addr_penalty) = grep
- { $_->standing_penalty->name eq 'INVALID_PATRON_ADDRESS' } @$penalties;
-
- # do we enforce invalid address penalty
- my $enforce = $U->ou_ancestor_setting_value(
- $patron->home_ou, 'circ.patron_invalid_address_apply_penalty') || 0;
-
- my $addrs = $e->search_actor_user_address(
- {usr => $patron->id, valid => 'f', id => {'>' => 0}}, {idlist => 1});
- my $addr_count = scalar(@$addrs);
-
- if($addr_count == 0 and $addr_penalty) {
-
- # regardless of any settings, remove the penalty when the user has no invalid addresses
- $e->delete_actor_user_standing_penalty($addr_penalty) or return $e->die_event;
- $e->commit;
-
- } elsif($enforce and $addr_count > 0 and !$addr_penalty) {
-
- my $ptype = $e->retrieve_config_standing_penalty(29) or return $e->die_event;
- my $depth = $ptype->org_depth;
- my $ctx_org = $U->org_unit_ancestor_at_depth($patron->home_ou, $depth) if defined $depth;
- $ctx_org = $patron->home_ou unless defined $ctx_org;
-
- my $penalty = Fieldmapper::actor::user_standing_penalty->new;
- $penalty->usr($patron->id);
- $penalty->org_unit($ctx_org);
- $penalty->standing_penalty(OILS_PENALTY_INVALID_PATRON_ADDRESS);
-
- $e->create_actor_user_standing_penalty($penalty) or return $e->die_event;
- $e->commit;
-
- } else {
- $e->rollback;
- }
-
- return undef;
-}
-
-
-sub flesh_user {
- my $id = shift;
- my $e = shift;
- my $home_ou = shift;
-
- my $fields = [
- "cards",
- "card",
- "standing_penalties",
- "addresses",
- "billing_address",
- "mailing_address",
- "stat_cat_entries"
- ];
- push @$fields, "home_ou" if $home_ou;
- return new_flesh_user($id, $fields, $e );
-}
-
-
-
-
-
-
-# clone and clear stuff that would break the database
-sub _clone_patron {
- my $patron = shift;
-
- my $new_patron = $patron->clone;
- # clear these
- $new_patron->clear_billing_address();
- $new_patron->clear_mailing_address();
- $new_patron->clear_addresses();
- $new_patron->clear_card();
- $new_patron->clear_cards();
- $new_patron->clear_id();
- $new_patron->clear_isnew();
- $new_patron->clear_ischanged();
- $new_patron->clear_isdeleted();
- $new_patron->clear_stat_cat_entries();
- $new_patron->clear_permissions();
- $new_patron->clear_standing_penalties();
-
- return $new_patron;
-}
-
-
-sub _add_patron {
-
- my $session = shift;
- my $patron = shift;
- my $user_obj = shift;
-
- my $evt = $U->check_perms($user_obj->id, $patron->home_ou, 'CREATE_USER');
- return (undef, $evt) if $evt;
-
- my $ex = $session->request(
- 'open-ils.storage.direct.actor.user.search.usrname', $patron->usrname())->gather(1);
- if( $ex and @$ex ) {
- return (undef, OpenILS::Event->new('USERNAME_EXISTS'));
- }
-
- $logger->info("Creating new user in the DB with username: ".$patron->usrname());
-
- my $id = $session->request(
- "open-ils.storage.direct.actor.user.create", $patron)->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($patron)) unless $id;
-
- $logger->info("Successfully created new user [$id] in DB");
-
- return ( $session->request(
- "open-ils.storage.direct.actor.user.retrieve", $id)->gather(1), undef );
-}
-
-
-sub check_group_perm {
- my( $session, $requestor, $patron ) = @_;
- my $evt;
-
- # first let's see if the requestor has
- # priveleges to update this user in any way
- if( ! $patron->isnew ) {
- my $p = $session->request(
- 'open-ils.storage.direct.actor.user.retrieve', $patron->id )->gather(1);
-
- # If we are the requestor (trying to update our own account)
- # and we are not trying to change our profile, we're good
- if( $p->id == $requestor->id and
- $p->profile == $patron->profile ) {
- return undef;
- }
-
-
- $evt = group_perm_failed($session, $requestor, $p);
- return $evt if $evt;
- }
-
- # They are allowed to edit this patron.. can they put the
- # patron into the group requested?
- $evt = group_perm_failed($session, $requestor, $patron);
- return $evt if $evt;
- return undef;
-}
-
-
-sub group_perm_failed {
- my( $session, $requestor, $patron ) = @_;
-
- my $perm;
- my $grp;
- my $grpid = $patron->profile;
-
- do {
-
- $logger->debug("user update looking for group perm for group $grpid");
- $grp = $session->request(
- 'open-ils.storage.direct.permission.grp_tree.retrieve', $grpid )->gather(1);
- return OpenILS::Event->new('PERMISSION_GRP_TREE_NOT_FOUND') unless $grp;
-
- } while( !($perm = $grp->application_perm) and ($grpid = $grp->parent) );
-
- $logger->info("user update checking perm $perm on user ".
- $requestor->id." for update/create on user username=".$patron->usrname);
-
- my $evt = $U->check_perms($requestor->id, $patron->home_ou, $perm);
- return $evt if $evt;
- return undef;
-}
-
-
-
-sub _update_patron {
- my( $session, $patron, $user_obj, $noperm) = @_;
-
- $logger->info("Updating patron ".$patron->id." in DB");
-
- my $evt;
-
- if(!$noperm) {
- $evt = $U->check_perms($user_obj->id, $patron->home_ou, 'UPDATE_USER');
- return (undef, $evt) if $evt;
- }
-
- # update the password by itself to avoid the password protection magic
- if( $patron->passwd ) {
- my $s = $session->request(
- 'open-ils.storage.direct.actor.user.remote_update',
- {id => $patron->id}, {passwd => $patron->passwd})->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($patron)) unless defined($s);
- $patron->clear_passwd;
- }
-
- if(!$patron->ident_type) {
- $patron->clear_ident_type;
- $patron->clear_ident_value;
- }
-
- $evt = verify_last_xact($session, $patron);
- return (undef, $evt) if $evt;
-
- my $stat = $session->request(
- "open-ils.storage.direct.actor.user.update",$patron )->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($patron)) unless defined($stat);
-
- return ($patron);
-}
-
-sub verify_last_xact {
- my( $session, $patron ) = @_;
- return undef unless $patron->id and $patron->id > 0;
- my $p = $session->request(
- 'open-ils.storage.direct.actor.user.retrieve', $patron->id)->gather(1);
- my $xact = $p->last_xact_id;
- return undef unless $xact;
- $logger->info("user xact = $xact, saving with xact " . $patron->last_xact_id);
- return OpenILS::Event->new('XACT_COLLISION')
- if $xact != $patron->last_xact_id;
- return undef;
-}
-
-
-sub _check_dup_ident {
- my( $session, $patron ) = @_;
-
- return undef unless $patron->ident_value;
-
- my $search = {
- ident_type => $patron->ident_type,
- ident_value => $patron->ident_value,
- };
-
- $logger->debug("patron update searching for dup ident values: " .
- $patron->ident_type . ':' . $patron->ident_value);
-
- $search->{id} = {'!=' => $patron->id} if $patron->id and $patron->id > 0;
-
- my $dups = $session->request(
- 'open-ils.storage.direct.actor.user.search_where.atomic', $search )->gather(1);
-
-
- return OpenILS::Event->new('PATRON_DUP_IDENT1', payload => $patron )
- if $dups and @$dups;
-
- return undef;
-}
-
-
-sub _add_update_addresses {
-
- my $session = shift;
- my $patron = shift;
- my $new_patron = shift;
-
- my $evt;
-
- my $current_id; # id of the address before creation
-
- for my $address (@{$patron->addresses()}) {
-
- next unless ref $address;
- $current_id = $address->id();
-
- if( $patron->billing_address() and
- $patron->billing_address() == $current_id ) {
- $logger->info("setting billing addr to $current_id");
- $new_patron->billing_address($address->id());
- $new_patron->ischanged(1);
- }
-
- if( $patron->mailing_address() and
- $patron->mailing_address() == $current_id ) {
- $new_patron->mailing_address($address->id());
- $logger->info("setting mailing addr to $current_id");
- $new_patron->ischanged(1);
- }
-
-
- if($address->isnew()) {
-
- $address->usr($new_patron->id());
-
- ($address, $evt) = _add_address($session,$address);
- return (undef, $evt) if $evt;
-
- # we need to get the new id
- if( $patron->billing_address() and
- $patron->billing_address() == $current_id ) {
- $new_patron->billing_address($address->id());
- $logger->info("setting billing addr to $current_id");
- $new_patron->ischanged(1);
- }
-
- if( $patron->mailing_address() and
- $patron->mailing_address() == $current_id ) {
- $new_patron->mailing_address($address->id());
- $logger->info("setting mailing addr to $current_id");
- $new_patron->ischanged(1);
- }
-
- } elsif($address->ischanged() ) {
-
- ($address, $evt) = _update_address($session, $address);
- return (undef, $evt) if $evt;
-
- } elsif($address->isdeleted() ) {
-
- if( $address->id() == $new_patron->mailing_address() ) {
- $new_patron->clear_mailing_address();
- ($new_patron, $evt) = _update_patron($session, $new_patron);
- return (undef, $evt) if $evt;
- }
-
- if( $address->id() == $new_patron->billing_address() ) {
- $new_patron->clear_billing_address();
- ($new_patron, $evt) = _update_patron($session, $new_patron);
- return (undef, $evt) if $evt;
- }
-
- $evt = _delete_address($session, $address);
- return (undef, $evt) if $evt;
- }
- }
-
- return ( $new_patron, undef );
-}
-
-
-# adds an address to the db and returns the address with new id
-sub _add_address {
- my($session, $address) = @_;
- $address->clear_id();
-
- $logger->info("Creating new address at street ".$address->street1);
-
- # put the address into the database
- my $id = $session->request(
- "open-ils.storage.direct.actor.user_address.create", $address )->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($address)) unless $id;
-
- $address->id( $id );
- return ($address, undef);
-}
-
-
-sub _update_address {
- my( $session, $address ) = @_;
-
- $logger->info("Updating address ".$address->id." in the DB");
-
- my $stat = $session->request(
- "open-ils.storage.direct.actor.user_address.update", $address )->gather(1);
-
- return (undef, $U->DB_UPDATE_FAILED($address)) unless defined($stat);
- return ($address, undef);
-}
-
-
-
-sub _add_update_cards {
-
- my $session = shift;
- my $patron = shift;
- my $new_patron = shift;
-
- my $evt;
-
- my $virtual_id; #id of the card before creation
- for my $card (@{$patron->cards()}) {
-
- $card->usr($new_patron->id());
-
- if(ref($card) and $card->isnew()) {
-
- $virtual_id = $card->id();
- ( $card, $evt ) = _add_card($session,$card);
- return (undef, $evt) if $evt;
-
- #if(ref($patron->card)) { $patron->card($patron->card->id); }
- if($patron->card() == $virtual_id) {
- $new_patron->card($card->id());
- $new_patron->ischanged(1);
- }
-
- } elsif( ref($card) and $card->ischanged() ) {
- $evt = _update_card($session, $card);
- return (undef, $evt) if $evt;
- }
- }
-
- return ( $new_patron, undef );
-}
-
-
-# adds an card to the db and returns the card with new id
-sub _add_card {
- my( $session, $card ) = @_;
- $card->clear_id();
-
- $logger->info("Adding new patron card ".$card->barcode);
-
- my $id = $session->request(
- "open-ils.storage.direct.actor.card.create", $card )->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($card)) unless $id;
- $logger->info("Successfully created patron card $id");
-
- $card->id($id);
- return ( $card, undef );
-}
-
-
-# returns event on error. returns undef otherwise
-sub _update_card {
- my( $session, $card ) = @_;
- $logger->info("Updating patron card ".$card->id);
-
- my $stat = $session->request(
- "open-ils.storage.direct.actor.card.update", $card )->gather(1);
- return $U->DB_UPDATE_FAILED($card) unless defined($stat);
- return undef;
-}
-
-
-
-
-# returns event on error. returns undef otherwise
-sub _delete_address {
- my( $session, $address ) = @_;
-
- $logger->info("Deleting address ".$address->id." from DB");
-
- my $stat = $session->request(
- "open-ils.storage.direct.actor.user_address.delete", $address )->gather(1);
-
- return $U->DB_UPDATE_FAILED($address) unless defined($stat);
- return undef;
-}
-
-
-
-sub _add_survey_responses {
- my ($session, $patron, $new_patron) = @_;
-
- $logger->info( "Updating survey responses for patron ".$new_patron->id );
-
- my $responses = $patron->survey_responses;
-
- if($responses) {
-
- $_->usr($new_patron->id) for (@$responses);
-
- my $evt = $U->simplereq( "open-ils.circ",
- "open-ils.circ.survey.submit.user_id", $responses );
-
- return (undef, $evt) if defined($U->event_code($evt));
-
- }
-
- return ( $new_patron, undef );
-}
-
-
-sub _create_stat_maps {
-
- my($session, $user_session, $patron, $new_patron) = @_;
-
- my $maps = $patron->stat_cat_entries();
-
- for my $map (@$maps) {
-
- my $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.update";
-
- if ($map->isdeleted()) {
- $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.delete";
-
- } elsif ($map->isnew()) {
- $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.create";
- $map->clear_id;
- }
-
-
- $map->target_usr($new_patron->id);
-
- #warn "
- $logger->info("Updating stat entry with method $method and map $map");
-
- my $stat = $session->request($method, $map)->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($map)) unless defined($stat);
-
- }
-
- return ($new_patron, undef);
-}
-
-sub _create_perm_maps {
-
- my($session, $user_session, $patron, $new_patron) = @_;
-
- my $maps = $patron->permissions;
-
- for my $map (@$maps) {
-
- my $method = "open-ils.storage.direct.permission.usr_perm_map.update";
- if ($map->isdeleted()) {
- $method = "open-ils.storage.direct.permission.usr_perm_map.delete";
- } elsif ($map->isnew()) {
- $method = "open-ils.storage.direct.permission.usr_perm_map.create";
- $map->clear_id;
- }
-
-
- $map->usr($new_patron->id);
-
- #warn( "Updating permissions with method $method and session $user_session and map $map" );
- $logger->info( "Updating permissions with method $method and map $map" );
-
- my $stat = $session->request($method, $map)->gather(1);
- return (undef, $U->DB_UPDATE_FAILED($map)) unless defined($stat);
-
- }
-
- return ($new_patron, undef);
-}
-
-
-__PACKAGE__->register_method(
- method => "set_user_work_ous",
- api_name => "open-ils.actor.user.work_ous.update",
-);
-
-sub set_user_work_ous {
- my $self = shift;
- my $client = shift;
- my $ses = shift;
- my $maps = shift;
-
- my( $requestor, $evt ) = $apputils->checksesperm( $ses, 'ASSIGN_WORK_ORG_UNIT' );
- return $evt if $evt;
-
- my $session = $apputils->start_db_session();
-
- for my $map (@$maps) {
-
- my $method = "open-ils.storage.direct.permission.usr_work_ou_map.update";
- if ($map->isdeleted()) {
- $method = "open-ils.storage.direct.permission.usr_work_ou_map.delete";
- } elsif ($map->isnew()) {
- $method = "open-ils.storage.direct.permission.usr_work_ou_map.create";
- $map->clear_id;
- }
-
- #warn( "Updating permissions with method $method and session $ses and map $map" );
- $logger->info( "Updating work_ou map with method $method and map $map" );
-
- my $stat = $session->request($method, $map)->gather(1);
- $logger->warn( "update failed: ".$U->DB_UPDATE_FAILED($map) ) unless defined($stat);
-
- }
-
- $apputils->commit_db_session($session);
-
- return scalar(@$maps);
-}
-
-
-__PACKAGE__->register_method(
- method => "set_user_perms",
- api_name => "open-ils.actor.user.permissions.update",
-);
-
-sub set_user_perms {
- my $self = shift;
- my $client = shift;
- my $ses = shift;
- my $maps = shift;
-
- my $session = $apputils->start_db_session();
-
- my( $user_obj, $evt ) = $U->checkses($ses);
- return $evt if $evt;
-
- my $perms = $session->request('open-ils.storage.permission.user_perms.atomic', $user_obj->id)->gather(1);
-
- my $all = undef;
- $all = 1 if ($U->is_true($user_obj->super_user()));
- $all = 1 unless ($U->check_perms($user_obj->id, $user_obj->home_ou, 'EVERYTHING'));
-
- for my $map (@$maps) {
-
- my $method = "open-ils.storage.direct.permission.usr_perm_map.update";
- if ($map->isdeleted()) {
- $method = "open-ils.storage.direct.permission.usr_perm_map.delete";
- } elsif ($map->isnew()) {
- $method = "open-ils.storage.direct.permission.usr_perm_map.create";
- $map->clear_id;
- }
-
- next if (!$all and !grep { $_->perm eq $map->perm and $U->is_true($_->grantable) and $_->depth <= $map->depth } @$perms);
- #warn( "Updating permissions with method $method and session $ses and map $map" );
- $logger->info( "Updating permissions with method $method and map $map" );
-
- my $stat = $session->request($method, $map)->gather(1);
- $logger->warn( "update failed: ".$U->DB_UPDATE_FAILED($map) ) unless defined($stat);
-
- }
-
- $apputils->commit_db_session($session);
-
- return scalar(@$maps);
-}
-
-
-__PACKAGE__->register_method(
- method => "user_retrieve_by_barcode",
- authoritative => 1,
- api_name => "open-ils.actor.user.fleshed.retrieve_by_barcode",);
-
-sub user_retrieve_by_barcode {
- my($self, $client, $auth, $barcode, $flesh_home_ou) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $card = $e->search_actor_card({barcode => $barcode})->[0]
- or return $e->event;
-
- my $user = flesh_user($card->usr, $e, $flesh_home_ou);
- return $e->event unless $e->allowed(
- "VIEW_USER", $flesh_home_ou ? $user->home_ou->id : $user->home_ou
- );
- return $user;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "get_user_by_id",
- authoritative => 1,
- api_name => "open-ils.actor.user.retrieve",
-);
-
-sub get_user_by_id {
- my ($self, $client, $auth, $id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $user = $e->retrieve_actor_user($id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- return $user;
-}
-
-
-__PACKAGE__->register_method(
- method => "get_org_types",
- api_name => "open-ils.actor.org_types.retrieve",
-);
-sub get_org_types {
- return $U->get_org_types();
-}
-
-
-__PACKAGE__->register_method(
- method => "get_user_ident_types",
- api_name => "open-ils.actor.user.ident_types.retrieve",
-);
-my $ident_types;
-sub get_user_ident_types {
- return $ident_types if $ident_types;
- return $ident_types =
- new_editor()->retrieve_all_config_identification_type();
-}
-
-
-__PACKAGE__->register_method(
- method => "get_org_unit",
- api_name => "open-ils.actor.org_unit.retrieve",
-);
-
-sub get_org_unit {
- my( $self, $client, $user_session, $org_id ) = @_;
- my $e = new_editor(authtoken => $user_session);
- if(!$org_id) {
- return $e->event unless $e->checkauth;
- $org_id = $e->requestor->ws_ou;
- }
- my $o = $e->retrieve_actor_org_unit($org_id)
- or return $e->event;
- return $o;
-}
-
-__PACKAGE__->register_method(
- method => "search_org_unit",
- api_name => "open-ils.actor.org_unit_list.search",
-);
-
-sub search_org_unit {
-
- my( $self, $client, $field, $value ) = @_;
-
- my $list = OpenILS::Application::AppUtils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.actor.org_unit.search.atomic",
- { $field => $value } );
-
- return $list;
-}
-
-
-# build the org tree
-
-__PACKAGE__->register_method(
- method => "get_org_tree",
- api_name => "open-ils.actor.org_tree.retrieve",
- argc => 0,
- note => "Returns the entire org tree structure",
-);
-
-sub get_org_tree {
- my $self = shift;
- my $client = shift;
- return $U->get_org_tree($client->session->session_locale);
-}
-
-
-__PACKAGE__->register_method(
- method => "get_org_descendants",
- api_name => "open-ils.actor.org_tree.descendants.retrieve"
-);
-
-# depth is optional. org_unit is the id
-sub get_org_descendants {
- my( $self, $client, $org_unit, $depth ) = @_;
-
- if(ref $org_unit eq 'ARRAY') {
- $depth ||= [];
- my @trees;
- for my $i (0..scalar(@$org_unit)-1) {
- my $list = $U->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.actor.org_unit.descendants.atomic",
- $org_unit->[$i], $depth->[$i] );
- push(@trees, $U->build_org_tree($list));
- }
- return \@trees;
-
- } else {
- my $orglist = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.actor.org_unit.descendants.atomic",
- $org_unit, $depth );
- return $U->build_org_tree($orglist);
- }
-}
-
-
-__PACKAGE__->register_method(
- method => "get_org_ancestors",
- api_name => "open-ils.actor.org_tree.ancestors.retrieve"
-);
-
-# depth is optional. org_unit is the id
-sub get_org_ancestors {
- my( $self, $client, $org_unit, $depth ) = @_;
- my $orglist = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.actor.org_unit.ancestors.atomic",
- $org_unit, $depth );
- return $U->build_org_tree($orglist);
-}
-
-
-__PACKAGE__->register_method(
- method => "get_standings",
- api_name => "open-ils.actor.standings.retrieve"
-);
-
-my $user_standings;
-sub get_standings {
- return $user_standings if $user_standings;
- return $user_standings =
- $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.config.standing.search.atomic",
- { id => { "!=" => undef } }
- );
-}
-
-
-__PACKAGE__->register_method(
- method => "get_my_org_path",
- api_name => "open-ils.actor.org_unit.full_path.retrieve"
-);
-
-sub get_my_org_path {
- my( $self, $client, $auth, $org_id ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $org_id = $e->requestor->ws_ou unless defined $org_id;
-
- return $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.actor.org_unit.full_path.atomic",
- $org_id );
-}
-
-
-__PACKAGE__->register_method(
- method => "patron_adv_search",
- api_name => "open-ils.actor.patron.search.advanced"
-);
-sub patron_adv_search {
- my( $self, $client, $auth, $search_hash,
- $search_limit, $search_sort, $include_inactive, $search_depth ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER');
- return $U->storagereq(
- "open-ils.storage.actor.user.crazy_search", $search_hash,
- $search_limit, $search_sort, $include_inactive, $e->requestor->ws_ou, $search_depth);
-}
-
-
-__PACKAGE__->register_method(
- method => "update_passwd",
- api_name => "open-ils.actor.user.password.update",
- signature => {
- desc => "Update the operator's password",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'New password', type => 'string' },
- { desc => 'Current password', type => 'string' }
- ],
- return => {desc => '1 on success, Event on error or incorrect current password'}
- }
-);
-
-__PACKAGE__->register_method(
- method => "update_passwd",
- api_name => "open-ils.actor.user.username.update",
- signature => {
- desc => "Update the operator's username",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'New username', type => 'string' }
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-__PACKAGE__->register_method(
- method => "update_passwd",
- api_name => "open-ils.actor.user.email.update",
- signature => {
- desc => "Update the operator's email address",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'New email address', type => 'string' }
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-
-sub update_passwd {
- my( $self, $conn, $auth, $new_val, $orig_pw ) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- my $db_user = $e->retrieve_actor_user($e->requestor->id)
- or return $e->die_event;
- my $api = $self->api_name;
-
- if( $api =~ /password/o ) {
- # make sure the original password matches the in-database password
- if (md5_hex($orig_pw) ne $db_user->passwd) {
- $e->rollback;
- return new OpenILS::Event('INCORRECT_PASSWORD');
- }
- $db_user->passwd($new_val);
-
- } else {
-
- # if we don't clear the password, the user will be updated with
- # a hashed version of the hashed version of their password
- $db_user->clear_passwd;
-
- if( $api =~ /username/o ) {
-
- # make sure no one else has this username
- my $exist = $e->search_actor_user({usrname=>$new_val},{idlist=>1});
- if (@$exist) {
- $e->rollback;
- return new OpenILS::Event('USERNAME_EXISTS');
- }
- $db_user->usrname($new_val);
-
- } elsif( $api =~ /email/o ) {
- $db_user->email($new_val);
- }
- }
-
- $e->update_actor_user($db_user) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "check_user_perms",
- api_name => "open-ils.actor.user.perm.check",
- notes => <<" NOTES");
- Takes a login session, user id, an org id, and an array of perm type strings. For each
- perm type, if the user does *not* have the given permission it is added
- to a list which is returned from the method. If all permissions
- are allowed, an empty list is returned
- if the logged in user does not match 'user_id', then the logged in user must
- have VIEW_PERMISSION priveleges.
- NOTES
-
-sub check_user_perms {
- my( $self, $client, $login_session, $user_id, $org_id, $perm_types ) = @_;
-
- my( $staff, $evt ) = $apputils->checkses($login_session);
- return $evt if $evt;
-
- if($staff->id ne $user_id) {
- if( $evt = $apputils->check_perms(
- $staff->id, $org_id, 'VIEW_PERMISSION') ) {
- return $evt;
- }
- }
-
- my @not_allowed;
- for my $perm (@$perm_types) {
- if($apputils->check_perms($user_id, $org_id, $perm)) {
- push @not_allowed, $perm;
- }
- }
-
- return \@not_allowed
-}
-
-__PACKAGE__->register_method(
- method => "check_user_perms2",
- api_name => "open-ils.actor.user.perm.check.multi_org",
- notes => q/
- Checks the permissions on a list of perms and orgs for a user
- @param authtoken The login session key
- @param user_id The id of the user to check
- @param orgs The array of org ids
- @param perms The array of permission names
- @return An array of [ orgId, permissionName ] arrays that FAILED the check
- if the logged in user does not match 'user_id', then the logged in user must
- have VIEW_PERMISSION priveleges.
- /);
-
-sub check_user_perms2 {
- my( $self, $client, $authtoken, $user_id, $orgs, $perms ) = @_;
-
- my( $staff, $target, $evt ) = $apputils->checkses_requestor(
- $authtoken, $user_id, 'VIEW_PERMISSION' );
- return $evt if $evt;
-
- my @not_allowed;
- for my $org (@$orgs) {
- for my $perm (@$perms) {
- if($apputils->check_perms($user_id, $org, $perm)) {
- push @not_allowed, [ $org, $perm ];
- }
- }
- }
-
- return \@not_allowed
-}
-
-
-__PACKAGE__->register_method(
- method => 'check_user_perms3',
- api_name => 'open-ils.actor.user.perm.highest_org',
- notes => q/
- Returns the highest org unit id at which a user has a given permission
- If the requestor does not match the target user, the requestor must have
- 'VIEW_PERMISSION' rights at the home org unit of the target user
- @param authtoken The login session key
- @param userid The id of the user in question
- @param perm The permission to check
- @return The org unit highest in the org tree within which the user has
- the requested permission
- /);
-
-sub check_user_perms3 {
- my($self, $client, $authtoken, $user_id, $perm) = @_;
- my $e = new_editor(authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- my $tree = $U->get_org_tree();
-
- unless($e->requestor->id == $user_id) {
- my $user = $e->retrieve_actor_user($user_id)
- or return $e->event;
- return $e->event unless $e->allowed('VIEW_PERMISSION', $user->home_ou);
- return $U->find_highest_perm_org($perm, $user_id, $user->home_ou, $tree );
- }
-
- return $U->find_highest_perm_org($perm, $user_id, $e->requestor->ws_ou, $tree);
-}
-
-__PACKAGE__->register_method(
- method => 'user_has_work_perm_at',
- api_name => 'open-ils.actor.user.has_work_perm_at',
- authoritative => 1,
- signature => {
- desc => q/
- Returns a set of org unit IDs which represent the highest orgs in
- the org tree where the user has the requested permission. The
- purpose of this method is to return the smallest set of org units
- which represent the full expanse of the user's ability to perform
- the requested action. The user whose perms this method should
- check is implied by the authtoken. /,
- params => [
- {desc => 'authtoken', type => 'string'},
- {desc => 'permission name', type => 'string'},
- {desc => q/user id, optional. If present, check perms for
- this user instead of the logged in user/, type => 'number'},
- ],
- return => {desc => 'An array of org IDs'}
- }
-);
-
-sub user_has_work_perm_at {
- my($self, $conn, $auth, $perm, $user_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- if(defined $user_id) {
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_PERMISSION', $user->home_ou);
- }
- return $U->user_has_work_perm_at($e, $perm, undef, $user_id);
-}
-
-__PACKAGE__->register_method(
- method => 'user_has_work_perm_at_batch',
- api_name => 'open-ils.actor.user.has_work_perm_at.batch',
- authoritative => 1,
-);
-
-sub user_has_work_perm_at_batch {
- my($self, $conn, $auth, $perms, $user_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- if(defined $user_id) {
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_PERMISSION', $user->home_ou);
- }
- my $map = {};
- $map->{$_} = $U->user_has_work_perm_at($e, $_) for @$perms;
- return $map;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'check_user_perms4',
- api_name => 'open-ils.actor.user.perm.highest_org.batch',
- notes => q/
- Returns the highest org unit id at which a user has a given permission
- If the requestor does not match the target user, the requestor must have
- 'VIEW_PERMISSION' rights at the home org unit of the target user
- @param authtoken The login session key
- @param userid The id of the user in question
- @param perms An array of perm names to check
- @return An array of orgId's representing the org unit
- highest in the org tree within which the user has the requested permission
- The arrah of orgId's has matches the order of the perms array
- /);
-
-sub check_user_perms4 {
- my( $self, $client, $authtoken, $userid, $perms ) = @_;
-
- my( $staff, $target, $org, $evt );
-
- ( $staff, $target, $evt ) = $apputils->checkses_requestor(
- $authtoken, $userid, 'VIEW_PERMISSION' );
- return $evt if $evt;
-
- my @arr;
- return [] unless ref($perms);
- my $tree = $U->get_org_tree();
-
- for my $p (@$perms) {
- push( @arr, $U->find_highest_perm_org( $p, $userid, $target->home_ou, $tree ) );
- }
- return \@arr;
-}
-
-
-__PACKAGE__->register_method(
- method => "user_fines_summary",
- api_name => "open-ils.actor.user.fines.summary",
- authoritative => 1,
- signature => {
- desc => 'Returns a short summary of the users total open fines, ' .
- 'excluding voided fines Params are login_session, user_id' ,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'User ID', type => 'string'} # number?
- ],
- return => {
- desc => "a 'mous' object, event on error",
- }
- }
-);
-
-sub user_fines_summary {
- my( $self, $client, $auth, $user_id ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- if( $user_id ne $e->requestor->id ) {
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless
- $e->allowed('VIEW_USER_FINES_SUMMARY', $user->home_ou);
- }
-
- return $e->search_money_open_user_summary({usr => $user_id})->[0];
-}
-
-
-__PACKAGE__->register_method(
- method => "user_opac_vitals",
- api_name => "open-ils.actor.user.opac.vital_stats",
- argc => 1,
- authoritative => 1,
- signature => {
- desc => 'Returns a short summary of the users vital stats, including ' .
- 'identification information, accumulated balance, number of holds, ' .
- 'and current open circulation stats' ,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Optional User ID, for use in the staff client', type => 'number'} # number?
- ],
- return => {
- desc => "An object with four properties: user, fines, checkouts and holds."
- }
- }
-);
-
-sub user_opac_vitals {
- my( $self, $client, $auth, $user_id ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- $user_id ||= $e->requestor->id;
-
- my $user = $e->retrieve_actor_user( $user_id );
-
- my ($fines) = $self
- ->method_lookup('open-ils.actor.user.fines.summary')
- ->run($auth => $user_id);
- return $fines if (defined($U->event_code($fines)));
-
- if (!$fines) {
- $fines = new Fieldmapper::money::open_user_summary ();
- $fines->balance_owed(0.00);
- $fines->total_owed(0.00);
- $fines->total_paid(0.00);
- $fines->usr($user_id);
- }
-
- my ($holds) = $self
- ->method_lookup('open-ils.actor.user.hold_requests.count')
- ->run($auth => $user_id);
- return $holds if (defined($U->event_code($holds)));
-
- my ($out) = $self
- ->method_lookup('open-ils.actor.user.checked_out.count')
- ->run($auth => $user_id);
- return $out if (defined($U->event_code($out)));
-
- return {
- user => {
- first_given_name => $user->first_given_name,
- second_given_name => $user->second_given_name,
- family_name => $user->family_name,
- alias => $user->alias,
- usrname => $user->usrname
- },
- fines => $fines->to_bare_hash,
- checkouts => $out,
- holds => $holds
- };
-}
-
-
-##### a small consolidation of related method registrations
-my $common_params = [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User ID', type => 'string' },
- { desc => 'Transactions type (optional, defaults to all)', type => 'string' },
- { desc => 'Options hash. May contain limit and offset for paged results.', type => 'object' },
-];
-my %methods = (
- 'open-ils.actor.user.transactions' => '',
- 'open-ils.actor.user.transactions.fleshed' => '',
- 'open-ils.actor.user.transactions.have_charge' => ' that have an initial charge',
- 'open-ils.actor.user.transactions.have_charge.fleshed' => ' that have an initial charge',
- 'open-ils.actor.user.transactions.have_balance' => ' that have an outstanding balance',
- 'open-ils.actor.user.transactions.have_balance.fleshed' => ' that have an outstanding balance',
-);
-
-foreach (keys %methods) {
- my %args = (
- method => "user_transactions",
- api_name => $_,
- signature => {
- desc => 'For a given user, retrieve a list of '
- . (/\.fleshed/ ? 'fleshed ' : '')
- . 'transactions' . $methods{$_}
- . ' optionally limited to transactions of a given type.',
- params => $common_params,
- return => {
- desc => "List of objects, or event on error. Each object is a hash containing: transaction, circ, record. "
- . 'These represent the relevant (mbts) transaction, attached circulation and title pointed to in the circ, respectively.',
- }
- }
- );
- /\.have_balance/ and $args{authoritative} = 1; # FIXME: I don't know why have_charge isn't authoritative
- __PACKAGE__->register_method(%args);
-}
-
-# Now for the counts
-%methods = (
- 'open-ils.actor.user.transactions.count' => '',
- 'open-ils.actor.user.transactions.have_charge.count' => ' that have an initial charge',
- 'open-ils.actor.user.transactions.have_balance.count' => ' that have an outstanding balance',
-);
-
-foreach (keys %methods) {
- my %args = (
- method => "user_transactions",
- api_name => $_,
- signature => {
- desc => 'For a given user, retrieve a count of open '
- . 'transactions' . $methods{$_}
- . ' optionally limited to transactions of a given type.',
- params => $common_params,
- return => { desc => "Integer count of transactions, or event on error" }
- }
- );
- /\.have_balance/ and $args{authoritative} = 1; # FIXME: I don't know why have_charge isn't authoritative
- __PACKAGE__->register_method(%args);
-}
-
-__PACKAGE__->register_method(
- method => "user_transactions",
- api_name => "open-ils.actor.user.transactions.have_balance.total",
- authoritative => 1,
- signature => {
- desc => 'For a given user, retrieve the total balance owed for open transactions,'
- . ' optionally limited to transactions of a given type.',
- params => $common_params,
- return => { desc => "Decimal balance value, or event on error" }
- }
-);
-
-
-sub user_transactions {
- my( $self, $client, $login_session, $user_id, $type, $options ) = @_;
- $options ||= {};
-
- my( $user_obj, $target, $evt ) = $apputils->checkses_requestor(
- $login_session, $user_id, 'VIEW_USER_TRANSACTIONS' );
- return $evt if $evt;
-
- my $api = $self->api_name();
-
- my $filter = ($api =~ /have_balance/o) ?
- { 'balance_owed' => { '<>' => 0 } }:
- { 'total_owed' => { '>' => 0 } };
-
- my ($trans) = $self->method_lookup(
- 'open-ils.actor.user.transactions.history.still_open')
- ->run( $login_session, $user_id, $type, $filter, $options );
-
- if($api =~ /total/o) {
- my $total = 0.0;
- for my $t (@$trans) {
- $total += $t->balance_owed;
- }
-
- $logger->debug("Total balance owed by user $user_id: $total");
- return $total;
- }
-
- ($api =~ /count/o ) and return scalar @$trans;
- ($api !~ /fleshed/o) and return $trans;
-
- my @resp;
- for my $t (@$trans) {
-
- if( $t->xact_type ne 'circulation' ) {
- push @resp, {transaction => $t};
- next;
- }
-
- my $circ = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.action.circulation.retrieve",
- $t->id );
-
- next unless $circ;
-
- my $title = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.fleshed.biblio.record_entry.retrieve_by_copy",
- $circ->target_copy );
-
- next unless $title;
-
- my $u = OpenILS::Utils::ModsParser->new();
- $u->start_mods_batch($title->marc());
- my $mods = $u->finish_mods_batch();
- $mods->doc_id($title->id) if $mods;
-
- push @resp, {transaction => $t, circ => $circ, record => $mods };
-
- }
-
- return \@resp;
-}
-
-
-__PACKAGE__->register_method(
- method => "user_transaction_retrieve",
- api_name => "open-ils.actor.user.transaction.fleshed.retrieve",
- argc => 1,
- notes => "Returns a fleshed transaction record"
-);
-
-__PACKAGE__->register_method(
- method => "user_transaction_retrieve",
- api_name => "open-ils.actor.user.transaction.retrieve",
- argc => 1,
- notes => "Returns a transaction record"
-);
-
-sub user_transaction_retrieve {
- my( $self, $client, $login_session, $bill_id ) = @_;
-
- # I think I'm deprecated... make sure. phasefx says, "No, I'll use you :)
-
- my $trans = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.money.billable_transaction_summary.retrieve",
- $bill_id
- );
-
- my( $user_obj, $target, $evt ) = $apputils->checkses_requestor(
- $login_session, $trans->usr, 'VIEW_USER_TRANSACTIONS' );
- return $evt if $evt;
-
- my $api = $self->api_name();
- if($api !~ /fleshed/o) { return $trans; }
-
- if( $trans->xact_type ne 'circulation' ) {
- $logger->debug("Returning non-circ transaction");
- return {transaction => $trans};
- }
-
- my $circ = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.action.circulation.retrieve",
- $trans->id );
-
- return {transaction => $trans} unless $circ;
- $logger->debug("Found the circ transaction");
-
- my $title = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.fleshed.biblio.record_entry.retrieve_by_copy",
- $circ->target_copy );
-
- return {transaction => $trans, circ => $circ } unless $title;
- $logger->debug("Found the circ title");
-
- my $mods;
- my $copy = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.asset.copy.retrieve",
- $circ->target_copy );
-
- try {
- my $u = OpenILS::Utils::ModsParser->new();
- $u->start_mods_batch($title->marc());
- $mods = $u->finish_mods_batch();
- } otherwise {
- if ($title->id == OILS_PRECAT_RECORD) {
- $mods = new Fieldmapper::metabib::virtual_record;
- $mods->doc_id(OILS_PRECAT_RECORD);
- $mods->title($copy->dummy_title);
- $mods->author($copy->dummy_author);
- }
- };
-
- $logger->debug("MODSized the circ title");
-
- return {transaction => $trans, circ => $circ, record => $mods, copy => $copy };
-}
-
-
-__PACKAGE__->register_method(
- method => "hold_request_count",
- api_name => "open-ils.actor.user.hold_requests.count",
- authoritative => 1,
- argc => 1,
- notes => 'Returns hold ready/total counts'
-);
-
-sub hold_request_count {
- my( $self, $client, $login_session, $userid ) = @_;
-
- my( $user_obj, $target, $evt ) = $apputils->checkses_requestor(
- $login_session, $userid, 'VIEW_HOLD' );
- return $evt if $evt;
-
-
- my $holds = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.action.hold_request.search.atomic",
- {
- usr => $userid,
- fulfillment_time => {"=" => undef },
- cancel_time => undef,
- }
- );
-
- my @ready;
- for my $h (@$holds) {
- next unless $h->capture_time and $h->current_copy;
-
- my $copy = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.asset.copy.retrieve",
- $h->current_copy
- );
-
- if ($copy and $copy->status == 8) {
- push @ready, $h;
- }
- }
-
- return { total => scalar(@$holds), ready => scalar(@ready) };
-}
-
-__PACKAGE__->register_method(
- method => "checked_out",
- api_name => "open-ils.actor.user.checked_out",
- authoritative => 1,
- argc => 2,
- signature => {
- desc => "For a given user, returns a structure of circulations objects sorted by out, overdue, lost, claims_returned, long_overdue. "
- . "A list of IDs are returned of each type. Circs marked lost, long_overdue, and claims_returned will not be 'finished' "
- . "(i.e., outstanding balance or some other pending action on the circ). "
- . "The .count method also includes a 'total' field which sums all open circs.",
- params => [
- { desc => 'Authentication Token', type => 'string'},
- { desc => 'User ID', type => 'string'},
- ],
- return => {
- desc => 'Returns event on error, or an object with ID lists, like: '
- . '{"out":[12552,451232], "claims_returned":[], "long_overdue":[23421] "overdue":[], "lost":[]}'
- },
- }
-);
-
-__PACKAGE__->register_method(
- method => "checked_out",
- api_name => "open-ils.actor.user.checked_out.count",
- authoritative => 1,
- argc => 2,
- signature => q/@see open-ils.actor.user.checked_out/
-);
-
-sub checked_out {
- my( $self, $conn, $auth, $userid ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- if( $userid ne $e->requestor->id ) {
- my $user = $e->retrieve_actor_user($userid) or return $e->event;
- unless($e->allowed('VIEW_CIRCULATIONS', $user->home_ou)) {
-
- # see if there is a friend link allowing circ.view perms
- my $allowed = OpenILS::Application::Actor::Friends->friend_perm_allowed(
- $e, $userid, $e->requestor->id, 'circ.view');
- return $e->event unless $allowed;
- }
- }
-
- my $count = $self->api_name =~ /count/;
- return _checked_out( $count, $e, $userid );
-}
-
-sub _checked_out {
- my( $iscount, $e, $userid ) = @_;
-
- my %result = (
- out => [],
- overdue => [],
- lost => [],
- claims_returned => [],
- long_overdue => []
- );
- my $meth = 'retrieve_action_open_circ_';
-
- if ($iscount) {
- $meth .= 'count';
- %result = (
- out => 0,
- overdue => 0,
- lost => 0,
- claims_returned => 0,
- long_overdue => 0
- );
- } else {
- $meth .= 'list';
- }
-
- my $data = $e->$meth($userid);
-
- if ($data) {
- if ($iscount) {
- $result{$_} += $data->$_() for (keys %result);
- $result{total} += $data->$_() for (keys %result);
- } else {
- for my $k (keys %result) {
- $result{$k} = [ grep { $_ > 0 } split( ',', $data->$k()) ];
- }
- }
- }
-
- return \%result;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "checked_in_with_fines",
- api_name => "open-ils.actor.user.checked_in_with_fines",
- authoritative => 1,
- argc => 2,
- signature => q/@see open-ils.actor.user.checked_out/
-);
-
-sub checked_in_with_fines {
- my( $self, $conn, $auth, $userid ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- if( $userid ne $e->requestor->id ) {
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
- }
-
- # money is owed on these items and they are checked in
- my $open = $e->search_action_circulation(
- {
- usr => $userid,
- xact_finish => undef,
- checkin_time => { "!=" => undef },
- }
- );
-
-
- my( @lost, @cr, @lo );
- for my $c (@$open) {
- push( @lost, $c->id ) if $c->stop_fines eq 'LOST';
- push( @cr, $c->id ) if $c->stop_fines eq 'CLAIMSRETURNED';
- push( @lo, $c->id ) if $c->stop_fines eq 'LONGOVERDUE';
- }
-
- return {
- lost => \@lost,
- claims_returned => \@cr,
- long_overdue => \@lo
- };
-}
-
-
-sub _sigmaker {
- my ($api, $desc, $auth) = @_;
- $desc = $desc ? (" " . $desc) : '';
- my $ids = ($api =~ /ids$/) ? 1 : 0;
- my @sig = (
- argc => 1,
- method => "user_transaction_history",
- api_name => "open-ils.actor.user.transactions.$api",
- signature => {
- desc => "For a given User ID, returns a list of billable transaction" .
- ($ids ? " id" : '') .
- "s$desc, optionally filtered by type and/or fields in money.billable_xact_summary. " .
- "The VIEW_USER_TRANSACTIONS permission is required to view another user's transactions",
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'User ID', type => 'number'},
- {desc => 'Transaction type (optional)', type => 'number'},
- {desc => 'Hash of Billable Transaction Summary filters (optional)', type => 'object'}
- ],
- return => {
- desc => 'List of transaction' . ($ids ? " id" : '') . 's, Event on error'
- },
- }
- );
- $auth and push @sig, (authoritative => 1);
- return @sig;
-}
-
-my %hist_methods = (
- 'history' => '',
- 'history.have_charge' => 'that have an initial charge',
- 'history.still_open' => 'that are not finished',
-);
-my %auth_hist_methods = (
- 'history.have_balance' => 'that have a balance',
- 'history.have_bill' => 'that have billings',
- 'history.have_bill_or_payment' => 'that have non-zero-sum billings or at least 1 payment',
-);
-foreach (keys %hist_methods) {
- __PACKAGE__->register_method(_sigmaker($_, $hist_methods{$_}));
- __PACKAGE__->register_method(_sigmaker("$_.ids", $hist_methods{$_}));
-}
-foreach (keys %auth_hist_methods) {
- __PACKAGE__->register_method(_sigmaker($_, $auth_hist_methods{$_}, 1));
- __PACKAGE__->register_method(_sigmaker("$_.ids", $auth_hist_methods{$_}, 1));
-}
-
-sub user_transaction_history {
- my( $self, $conn, $auth, $userid, $type, $filter, $options ) = @_;
- $filter ||= {};
- $options ||= {};
-
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- if ($e->requestor->id ne $userid) {
- return $e->die_event unless $e->allowed('VIEW_USER_TRANSACTIONS');
- }
-
- my $api = $self->api_name;
- my @xact_finish = (xact_finish => undef ) if ($api =~ /history\.still_open$/); # What about history.still_open.ids?
-
- if(defined($type)) {
- $filter->{'xact_type'} = $type;
- }
-
- if($api =~ /have_bill_or_payment/o) {
-
- # transactions that have a non-zero sum across all billings or at least 1 payment
- $filter->{'-or'} = {
- 'balance_owed' => { '<>' => 0 },
- 'last_payment_ts' => { '<>' => undef }
- };
-
- } elsif( $api =~ /have_balance/o) {
-
- # transactions that have a non-zero overall balance
- $filter->{'balance_owed'} = { '<>' => 0 };
-
- } elsif( $api =~ /have_charge/o) {
-
- # transactions that have at least 1 billing, regardless of whether it was voided
- $filter->{'last_billing_ts'} = { '<>' => undef };
-
- } elsif( $api =~ /have_bill/o) { # needs to be an elsif, or we double-match have_bill_or_payment!
-
- # transactions that have non-zero sum across all billings. This will exclude
- # xacts where all billings have been voided
- $filter->{'total_owed'} = { '<>' => 0 };
- }
-
- my $options_clause = { order_by => { mbt => 'xact_start DESC' } };
- $options_clause->{'limit'} = $options->{'limit'} if $options->{'limit'};
- $options_clause->{'offset'} = $options->{'offset'} if $options->{'offset'};
-
- my $mbts = $e->search_money_billable_transaction_summary(
- [
- { usr => $userid, @xact_finish, %$filter },
- $options_clause
- ]
- );
-
- if ($api =~ /\.ids/) {
- return [map {$_->id} @$mbts];
- } else {
- return $mbts;
- }
-}
-
-
-
-__PACKAGE__->register_method(
- method => "user_perms",
- api_name => "open-ils.actor.permissions.user_perms.retrieve",
- argc => 1,
- notes => "Returns a list of permissions"
-);
-
-sub user_perms {
- my( $self, $client, $authtoken, $user ) = @_;
-
- my( $staff, $evt ) = $apputils->checkses($authtoken);
- return $evt if $evt;
-
- $user ||= $staff->id;
-
- if( $user != $staff->id and $evt = $apputils->check_perms( $staff->id, $staff->home_ou, 'VIEW_PERMISSION') ) {
- return $evt;
- }
-
- return $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.permission.user_perms.atomic",
- $user);
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_perms",
- api_name => "open-ils.actor.permissions.retrieve",
- notes => "Returns a list of permissions"
-);
-sub retrieve_perms {
- my( $self, $client ) = @_;
- return $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.permission.perm_list.search.atomic",
- { id => { '!=' => undef } }
- );
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_groups",
- api_name => "open-ils.actor.groups.retrieve",
- notes => "Returns a list of user groups"
-);
-sub retrieve_groups {
- my( $self, $client ) = @_;
- return new_editor()->retrieve_all_permission_grp_tree();
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_org_address",
- api_name => "open-ils.actor.org_unit.address.retrieve",
- notes => <<' NOTES');
- Returns an org_unit address by ID
- @param An org_address ID
- NOTES
-sub retrieve_org_address {
- my( $self, $client, $id ) = @_;
- return $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.actor.org_address.retrieve",
- $id
- );
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_groups_tree",
- api_name => "open-ils.actor.groups.tree.retrieve",
- notes => "Returns a list of user groups"
-);
-
-sub retrieve_groups_tree {
- my( $self, $client ) = @_;
- return new_editor()->search_permission_grp_tree(
- [
- { parent => undef},
- {
- flesh => -1,
- flesh_fields => { pgt => ["children"] },
- order_by => { pgt => 'name'}
- }
- ]
- )->[0];
-}
-
-
-__PACKAGE__->register_method(
- method => "add_user_to_groups",
- api_name => "open-ils.actor.user.set_groups",
- notes => "Adds a user to one or more permission groups"
-);
-
-sub add_user_to_groups {
- my( $self, $client, $authtoken, $userid, $groups ) = @_;
-
- my( $requestor, $target, $evt ) = $apputils->checkses_requestor(
- $authtoken, $userid, 'CREATE_USER_GROUP_LINK' );
- return $evt if $evt;
-
- ( $requestor, $target, $evt ) = $apputils->checkses_requestor(
- $authtoken, $userid, 'REMOVE_USER_GROUP_LINK' );
- return $evt if $evt;
-
- $apputils->simplereq(
- 'open-ils.storage',
- 'open-ils.storage.direct.permission.usr_grp_map.mass_delete', { usr => $userid } );
-
- for my $group (@$groups) {
- my $link = Fieldmapper::permission::usr_grp_map->new;
- $link->grp($group);
- $link->usr($userid);
-
- my $id = $apputils->simplereq(
- 'open-ils.storage',
- 'open-ils.storage.direct.permission.usr_grp_map.create', $link );
- }
-
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "get_user_perm_groups",
- api_name => "open-ils.actor.user.get_groups",
- notes => "Retrieve a user's permission groups."
-);
-
-
-sub get_user_perm_groups {
- my( $self, $client, $authtoken, $userid ) = @_;
-
- my( $requestor, $target, $evt ) = $apputils->checkses_requestor(
- $authtoken, $userid, 'VIEW_PERM_GROUPS' );
- return $evt if $evt;
-
- return $apputils->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.permission.usr_grp_map.search.atomic', { usr => $userid } );
-}
-
-
-__PACKAGE__->register_method(
- method => "get_user_work_ous",
- api_name => "open-ils.actor.user.get_work_ous",
- notes => "Retrieve a user's work org units."
-);
-
-__PACKAGE__->register_method(
- method => "get_user_work_ous",
- api_name => "open-ils.actor.user.get_work_ous.ids",
- notes => "Retrieve a user's work org units."
-);
-
-sub get_user_work_ous {
- my( $self, $client, $auth, $userid ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $userid ||= $e->requestor->id;
-
- if($e->requestor->id != $userid) {
- my $user = $e->retrieve_actor_user($userid)
- or return $e->event;
- return $e->event unless $e->allowed('ASSIGN_WORK_ORG_UNIT', $user->home_ou);
- }
-
- return $e->search_permission_usr_work_ou_map({usr => $userid})
- unless $self->api_name =~ /.ids$/;
-
- # client just wants a list of org IDs
- return $U->get_user_work_ou_ids($e, $userid);
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'register_workstation',
- api_name => 'open-ils.actor.workstation.register.override',
- signature => q/@see open-ils.actor.workstation.register/
-);
-
-__PACKAGE__->register_method(
- method => 'register_workstation',
- api_name => 'open-ils.actor.workstation.register',
- signature => q/
- Registers a new workstion in the system
- @param authtoken The login session key
- @param name The name of the workstation id
- @param owner The org unit that owns this workstation
- @return The workstation id on success, WORKSTATION_NAME_EXISTS
- if the name is already in use.
- /
-);
-
-sub register_workstation {
- my( $self, $conn, $authtoken, $name, $owner ) = @_;
-
- my $e = new_editor(authtoken=>$authtoken, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('REGISTER_WORKSTATION', $owner);
- my $existing = $e->search_actor_workstation({name => $name})->[0];
-
- if( $existing ) {
-
- if( $self->api_name =~ /override/o ) {
- # workstation with the given name exists.
-
- if($owner ne $existing->owning_lib) {
- # if necessary, update the owning_lib of the workstation
-
- $logger->info("changing owning lib of workstation ".$existing->id.
- " from ".$existing->owning_lib." to $owner");
- return $e->die_event unless
- $e->allowed('UPDATE_WORKSTATION', $existing->owning_lib);
-
- return $e->die_event unless $e->allowed('UPDATE_WORKSTATION', $owner);
-
- $existing->owning_lib($owner);
- return $e->die_event unless $e->update_actor_workstation($existing);
-
- $e->commit;
-
- } else {
- $logger->info(
- "attempt to register an existing workstation. returning existing ID");
- }
-
- return $existing->id;
-
- } else {
- return OpenILS::Event->new('WORKSTATION_NAME_EXISTS')
- }
- }
-
- my $ws = Fieldmapper::actor::workstation->new;
- $ws->owning_lib($owner);
- $ws->name($name);
- $e->create_actor_workstation($ws) or return $e->die_event;
- $e->commit;
- return $ws->id; # note: editor sets the id on the new object for us
-}
-
-__PACKAGE__->register_method(
- method => 'workstation_list',
- api_name => 'open-ils.actor.workstation.list',
- signature => q/
- Returns a list of workstations registered at the given location
- @param authtoken The login session key
- @param ids A list of org_unit.id's for the workstation owners
- /
-);
-
-sub workstation_list {
- my( $self, $conn, $authtoken, @orgs ) = @_;
-
- my $e = new_editor(authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
- my %results;
-
- for my $o (@orgs) {
- return $e->event
- unless $e->allowed('REGISTER_WORKSTATION', $o);
- $results{$o} = $e->search_actor_workstation({owning_lib=>$o});
- }
- return \%results;
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_patron_note',
- api_name => 'open-ils.actor.note.retrieve.all',
- authoritative => 1,
- signature => q/
- Returns a list of notes for a given user
- Requestor must have VIEW_USER permission if pub==false and
- @param authtoken The login session key
- @param args Hash of params including
- patronid : the patron's id
- pub : true if retrieving only public notes
- /
-);
-
-sub fetch_patron_note {
- my( $self, $conn, $authtoken, $args ) = @_;
- my $patronid = $$args{patronid};
-
- my($reqr, $evt) = $U->checkses($authtoken);
- return $evt if $evt;
-
- my $patron;
- ($patron, $evt) = $U->fetch_user($patronid);
- return $evt if $evt;
-
- if($$args{pub}) {
- if( $patronid ne $reqr->id ) {
- $evt = $U->check_perms($reqr->id, $patron->home_ou, 'VIEW_USER');
- return $evt if $evt;
- }
- return $U->cstorereq(
- 'open-ils.cstore.direct.actor.usr_note.search.atomic',
- { usr => $patronid, pub => 't' } );
- }
-
- $evt = $U->check_perms($reqr->id, $patron->home_ou, 'VIEW_USER');
- return $evt if $evt;
-
- return $U->cstorereq(
- 'open-ils.cstore.direct.actor.usr_note.search.atomic', { usr => $patronid } );
-}
-
-__PACKAGE__->register_method(
- method => 'create_user_note',
- api_name => 'open-ils.actor.note.create',
- signature => q/
- Creates a new note for the given user
- @param authtoken The login session key
- @param note The note object
- /
-);
-sub create_user_note {
- my( $self, $conn, $authtoken, $note ) = @_;
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
-
- my $user = $e->retrieve_actor_user($note->usr)
- or return $e->die_event;
-
- return $e->die_event unless
- $e->allowed('UPDATE_USER',$user->home_ou);
-
- $note->creator($e->requestor->id);
- $e->create_actor_usr_note($note) or return $e->die_event;
- $e->commit;
- return $note->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_user_note',
- api_name => 'open-ils.actor.note.delete',
- signature => q/
- Deletes a note for the given user
- @param authtoken The login session key
- @param noteid The note id
- /
-);
-sub delete_user_note {
- my( $self, $conn, $authtoken, $noteid ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
- my $note = $e->retrieve_actor_usr_note($noteid)
- or return $e->die_event;
- my $user = $e->retrieve_actor_user($note->usr)
- or return $e->die_event;
- return $e->die_event unless
- $e->allowed('UPDATE_USER', $user->home_ou);
-
- $e->delete_actor_usr_note($note) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'update_user_note',
- api_name => 'open-ils.actor.note.update',
- signature => q/
- @param authtoken The login session key
- @param note The note
- /
-);
-
-sub update_user_note {
- my( $self, $conn, $auth, $note ) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my $patron = $e->retrieve_actor_user($note->usr)
- or return $e->die_event;
- return $e->die_event unless
- $e->allowed('UPDATE_USER', $patron->home_ou);
- $e->update_actor_user_note($note)
- or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'create_closed_date',
- api_name => 'open-ils.actor.org_unit.closed_date.create',
- signature => q/
- Creates a new closing entry for the given org_unit
- @param authtoken The login session key
- @param note The closed_date object
- /
-);
-sub create_closed_date {
- my( $self, $conn, $authtoken, $cd ) = @_;
-
- my( $user, $evt ) = $U->checkses($authtoken);
- return $evt if $evt;
-
- $evt = $U->check_perms($user->id, $cd->org_unit, 'CREATE_CLOSEING');
- return $evt if $evt;
-
- $logger->activity("user ".$user->id." creating library closing for ".$cd->org_unit);
-
- my $id = $U->storagereq(
- 'open-ils.storage.direct.actor.org_unit.closed_date.create', $cd );
- return $U->DB_UPDATE_FAILED($cd) unless $id;
- return $id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_closed_date',
- api_name => 'open-ils.actor.org_unit.closed_date.delete',
- signature => q/
- Deletes a closing entry for the given org_unit
- @param authtoken The login session key
- @param noteid The close_date id
- /
-);
-sub delete_closed_date {
- my( $self, $conn, $authtoken, $cd ) = @_;
-
- my( $user, $evt ) = $U->checkses($authtoken);
- return $evt if $evt;
-
- my $cd_obj;
- ($cd_obj, $evt) = fetch_closed_date($cd);
- return $evt if $evt;
-
- $evt = $U->check_perms($user->id, $cd->org_unit, 'DELETE_CLOSEING');
- return $evt if $evt;
-
- $logger->activity("user ".$user->id." deleting library closing for ".$cd->org_unit);
-
- my $stat = $U->storagereq(
- 'open-ils.storage.direct.actor.org_unit.closed_date.delete', $cd );
- return $U->DB_UPDATE_FAILED($cd) unless $stat;
- return $stat;
-}
-
-
-__PACKAGE__->register_method(
- method => 'usrname_exists',
- api_name => 'open-ils.actor.username.exists',
- signature => {
- desc => 'Check if a username is already taken (by an undeleted patron)',
- param => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Username', type => 'string'}
- ],
- return => {
- desc => 'id of existing user if username exists, undef otherwise. Event on error'
- },
- }
-);
-
-sub usrname_exists {
- my( $self, $conn, $auth, $usrname ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $a = $e->search_actor_user({usrname => $usrname, deleted=>'f'}, {idlist=>1});
- return $$a[0] if $a and @$a;
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'barcode_exists',
- api_name => 'open-ils.actor.barcode.exists',
- authoritative => 1,
- signature => 'Returns 1 if the requested barcode exists, returns 0 otherwise'
-);
-
-sub barcode_exists {
- my( $self, $conn, $auth, $barcode ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $card = $e->search_actor_card({barcode => $barcode});
- if (@$card) {
- return 1;
- } else {
- return 0;
- }
- #return undef unless @$card;
- #return $card->[0]->usr;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_net_levels',
- api_name => 'open-ils.actor.net_access_level.retrieve.all',
-);
-
-sub retrieve_net_levels {
- my( $self, $conn, $auth ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->retrieve_all_config_net_access_level();
-}
-
-# Retain the old typo API name just in case
-__PACKAGE__->register_method(
- method => 'fetch_org_by_shortname',
- api_name => 'open-ils.actor.org_unit.retrieve_by_shorname',
-);
-__PACKAGE__->register_method(
- method => 'fetch_org_by_shortname',
- api_name => 'open-ils.actor.org_unit.retrieve_by_shortname',
-);
-sub fetch_org_by_shortname {
- my( $self, $conn, $sname ) = @_;
- my $e = new_editor();
- my $org = $e->search_actor_org_unit({ shortname => uc($sname)})->[0];
- return $e->event unless $org;
- return $org;
-}
-
-
-__PACKAGE__->register_method(
- method => 'session_home_lib',
- api_name => 'open-ils.actor.session.home_lib',
-);
-
-sub session_home_lib {
- my( $self, $conn, $auth ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return undef unless $e->checkauth;
- my $org = $e->retrieve_actor_org_unit($e->requestor->home_ou);
- return $org->shortname;
-}
-
-__PACKAGE__->register_method(
- method => 'session_safe_token',
- api_name => 'open-ils.actor.session.safe_token',
- signature => q/
- Returns a hashed session ID that is safe for export to the world.
- This safe token will expire after 1 hour of non-use.
- @param auth Active authentication token
- /
-);
-
-sub session_safe_token {
- my( $self, $conn, $auth ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return undef unless $e->checkauth;
-
- my $safe_token = md5_hex($auth);
-
- $cache ||= OpenSRF::Utils::Cache->new("global", 0);
-
- # Add more like the following if needed...
- $cache->put_cache(
- "safe-token-home_lib-shortname-$safe_token",
- $e->retrieve_actor_org_unit(
- $e->requestor->home_ou
- )->shortname,
- 60 * 60
- );
-
- return $safe_token;
-}
-
-
-__PACKAGE__->register_method(
- method => 'safe_token_home_lib',
- api_name => 'open-ils.actor.safe_token.home_lib.shortname',
- signature => q/
- Returns the home library shortname from the session
- asscociated with a safe token from generated by
- open-ils.actor.session.safe_token.
- @param safe_token Active safe token
- /
-);
-
-sub safe_token_home_lib {
- my( $self, $conn, $safe_token ) = @_;
-
- $cache ||= OpenSRF::Utils::Cache->new("global", 0);
- return $cache->get_cache( 'safe-token-home_lib-shortname-'. $safe_token );
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'slim_tree',
- api_name => "open-ils.actor.org_tree.slim_hash.retrieve",
-);
-sub slim_tree {
- my $tree = new_editor()->search_actor_org_unit(
- [
- {"parent_ou" => undef },
- {
- flesh => -1,
- flesh_fields => { aou => ['children'] },
- order_by => { aou => 'name'},
- select => { aou => ["id","shortname", "name"]},
- }
- ]
- )->[0];
-
- return trim_tree($tree);
-}
-
-
-sub trim_tree {
- my $tree = shift;
- return undef unless $tree;
- my $htree = {
- code => $tree->shortname,
- name => $tree->name,
- };
- if( $tree->children and @{$tree->children} ) {
- $htree->{children} = [];
- for my $c (@{$tree->children}) {
- push( @{$htree->{children}}, trim_tree($c) );
- }
- }
-
- return $htree;
-}
-
-
-__PACKAGE__->register_method(
- method => "update_penalties",
- api_name => "open-ils.actor.user.penalties.update"
-);
-
-sub update_penalties {
- my($self, $conn, $auth, $user_id) = @_;
- my $e = new_editor(authtoken=>$auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
- my $evt = OpenILS::Utils::Penalty->calculate_penalties($e, $user_id, $e->requestor->ws_ou);
- return $evt if $evt;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "apply_penalty",
- api_name => "open-ils.actor.user.penalty.apply"
-);
-
-sub apply_penalty {
- my($self, $conn, $auth, $penalty) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $user = $e->retrieve_actor_user($penalty->usr) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
-
- my $ptype = $e->retrieve_config_standing_penalty($penalty->standing_penalty) or return $e->die_event;
-
- my $ctx_org =
- (defined $ptype->org_depth) ?
- $U->org_unit_ancestor_at_depth($penalty->org_unit, $ptype->org_depth) :
- $penalty->org_unit;
-
- $penalty->org_unit($ctx_org);
- $penalty->staff($e->requestor->id);
- $e->create_actor_user_standing_penalty($penalty) or return $e->die_event;
-
- $e->commit;
- return $penalty->id;
-}
-
-__PACKAGE__->register_method(
- method => "remove_penalty",
- api_name => "open-ils.actor.user.penalty.remove"
-);
-
-sub remove_penalty {
- my($self, $conn, $auth, $penalty) = @_;
- my $e = new_editor(authtoken=>$auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- my $user = $e->retrieve_actor_user($penalty->usr) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
-
- $e->delete_actor_user_standing_penalty($penalty) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "update_penalty_note",
- api_name => "open-ils.actor.user.penalty.note.update"
-);
-
-sub update_penalty_note {
- my($self, $conn, $auth, $penalty_ids, $note) = @_;
- my $e = new_editor(authtoken=>$auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- for my $penalty_id (@$penalty_ids) {
- my $penalty = $e->search_actor_user_standing_penalty( { id => $penalty_id } )->[0];
- if (! $penalty ) { return $e->die_event; }
- my $user = $e->retrieve_actor_user($penalty->usr) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
-
- $penalty->note( $note ); $penalty->ischanged( 1 );
-
- $e->update_actor_user_standing_penalty($penalty) or return $e->die_event;
- }
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "ranged_penalty_thresholds",
- api_name => "open-ils.actor.grp_penalty_threshold.ranged.retrieve",
- stream => 1
-);
-
-sub ranged_penalty_thresholds {
- my($self, $conn, $auth, $context_org) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_GROUP_PENALTY_THRESHOLD', $context_org);
- my $list = $e->search_permission_grp_penalty_threshold([
- {org_unit => $U->get_org_ancestors($context_org)},
- {order_by => {pgpt => 'id'}}
- ]);
- $conn->respond($_) for @$list;
- return undef;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "user_retrieve_fleshed_by_id",
- authoritative => 1,
- api_name => "open-ils.actor.user.fleshed.retrieve",
-);
-
-sub user_retrieve_fleshed_by_id {
- my( $self, $client, $auth, $user_id, $fields ) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- if( $e->requestor->id != $user_id ) {
- return $e->event unless $e->allowed('VIEW_USER');
- }
-
- $fields ||= [
- "cards",
- "card",
- "standing_penalties",
- "addresses",
- "billing_address",
- "mailing_address",
- "stat_cat_entries" ];
- return new_flesh_user($user_id, $fields, $e);
-}
-
-
-sub new_flesh_user {
-
- my $id = shift;
- my $fields = shift || [];
- my $e = shift;
-
- my $fetch_penalties = 0;
- if(grep {$_ eq 'standing_penalties'} @$fields) {
- $fields = [grep {$_ ne 'standing_penalties'} @$fields];
- $fetch_penalties = 1;
- }
-
- my $user = $e->retrieve_actor_user(
- [
- $id,
- {
- "flesh" => 1,
- "flesh_fields" => { "au" => $fields }
- }
- ]
- ) or return $e->die_event;
-
-
- if( grep { $_ eq 'addresses' } @$fields ) {
-
- $user->addresses([]) unless @{$user->addresses};
- # don't expose "replaced" addresses by default
- $user->addresses([grep {$_->id >= 0} @{$user->addresses}]);
-
- if( ref $user->billing_address ) {
- unless( grep { $user->billing_address->id == $_->id } @{$user->addresses} ) {
- push( @{$user->addresses}, $user->billing_address );
- }
- }
-
- if( ref $user->mailing_address ) {
- unless( grep { $user->mailing_address->id == $_->id } @{$user->addresses} ) {
- push( @{$user->addresses}, $user->mailing_address );
- }
- }
- }
-
- if($fetch_penalties) {
- # grab the user penalties ranged for this location
- $user->standing_penalties(
- $e->search_actor_user_standing_penalty([
- { usr => $id,
- '-or' => [
- {stop_date => undef},
- {stop_date => {'>' => 'now'}}
- ],
- org_unit => $U->get_org_ancestors($e->requestor->ws_ou)
- },
- { flesh => 1,
- flesh_fields => {ausp => ['standing_penalty']}
- }
- ])
- );
- }
-
- $e->rollback;
- $user->clear_passwd();
- return $user;
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => "user_retrieve_parts",
- api_name => "open-ils.actor.user.retrieve.parts",
-);
-
-sub user_retrieve_parts {
- my( $self, $client, $auth, $user_id, $fields ) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- $user_id ||= $e->requestor->id;
- if( $e->requestor->id != $user_id ) {
- return $e->event unless $e->allowed('VIEW_USER');
- }
- my @resp;
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- push(@resp, $user->$_()) for(@$fields);
- return \@resp;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'user_opt_in_enabled',
- api_name => 'open-ils.actor.user.org_unit_opt_in.enabled',
- signature => '@return 1 if user opt-in is globally enabled, 0 otherwise.'
-);
-
-sub user_opt_in_enabled {
- my($self, $conn) = @_;
- my $sc = OpenSRF::Utils::SettingsClient->new;
- return 1 if lc($sc->config_value(share => user => 'opt_in')) eq 'true';
- return 0;
-}
-
-
-__PACKAGE__->register_method(
- method => 'user_opt_in_at_org',
- api_name => 'open-ils.actor.user.org_unit_opt_in.check',
- signature => q/
- @param $auth The auth token
- @param user_id The ID of the user to test
- @return 1 if the user has opted in at the specified org,
- event on error, and 0 otherwise. /
-);
-sub user_opt_in_at_org {
- my($self, $conn, $auth, $user_id) = @_;
-
- # see if we even need to enforce the opt-in value
- return 1 unless user_opt_in_enabled($self);
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- my $org_id = $e->requestor->ws_ou;
-
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
-
- # user is automatically opted-in at the home org
- return 1 if $user->home_ou eq $org_id;
-
- my $vals = $e->search_actor_usr_org_unit_opt_in(
- {org_unit=>$org_id, usr=>$user_id},{idlist=>1});
-
- return 1 if @$vals;
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => 'create_user_opt_in_at_org',
- api_name => 'open-ils.actor.user.org_unit_opt_in.create',
- signature => q/
- @param $auth The auth token
- @param user_id The ID of the user to test
- @return The ID of the newly created object, event on error./
-);
-
-sub create_user_opt_in_at_org {
- my($self, $conn, $auth, $user_id) = @_;
-
- my $e = new_editor(authtoken => $auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my $org_id = $e->requestor->ws_ou;
-
- my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
-
- my $opt_in = Fieldmapper::actor::usr_org_unit_opt_in->new;
-
- $opt_in->org_unit($org_id);
- $opt_in->usr($user_id);
- $opt_in->staff($e->requestor->id);
- $opt_in->opt_in_ts('now');
- $opt_in->opt_in_ws($e->requestor->wsid);
-
- $opt_in = $e->create_actor_usr_org_unit_opt_in($opt_in)
- or return $e->die_event;
-
- $e->commit;
-
- return $opt_in->id;
-}
-
-
-__PACKAGE__->register_method (
- method => 'retrieve_org_hours',
- api_name => 'open-ils.actor.org_unit.hours_of_operation.retrieve',
- signature => q/
- Returns the hours of operation for a specified org unit
- @param authtoken The login session key
- @param org_id The org_unit ID
- /
-);
-
-sub retrieve_org_hours {
- my($self, $conn, $auth, $org_id) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- $org_id ||= $e->requestor->ws_ou;
- return $e->retrieve_actor_org_unit_hours_of_operation($org_id);
-}
-
-
-__PACKAGE__->register_method (
- method => 'verify_user_password',
- api_name => 'open-ils.actor.verify_user_password',
- signature => q/
- Given a barcode or username and the MD5 encoded password,
- returns 1 if the password is correct. Returns 0 otherwise.
- /
-);
-
-sub verify_user_password {
- my($self, $conn, $auth, $barcode, $username, $password) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $user;
- my $user_by_barcode;
- my $user_by_username;
- if($barcode) {
- my $card = $e->search_actor_card([
- {barcode => $barcode},
- {flesh => 1, flesh_fields => {ac => ['usr']}}])->[0] or return 0;
- $user_by_barcode = $card->usr;
- $user = $user_by_barcode;
- }
- if ($username) {
- $user_by_username = $e->search_actor_user({usrname => $username})->[0] or return 0;
- $user = $user_by_username;
- }
- return 0 if (!$user);
- return 0 if ($user_by_username && $user_by_barcode && $user_by_username->id != $user_by_barcode->id);
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- return 1 if $user->passwd eq $password;
- return 0;
-}
-
-__PACKAGE__->register_method (
- method => 'retrieve_usr_id_via_barcode_or_usrname',
- api_name => "open-ils.actor.user.retrieve_id_by_barcode_or_username",
- signature => q/
- Given a barcode or username returns the id for the user or
- a failure event.
- /
-);
-
-sub retrieve_usr_id_via_barcode_or_usrname {
- my($self, $conn, $auth, $barcode, $username) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $id_as_barcode= OpenSRF::Utils::SettingsClient->new->config_value(apps => 'open-ils.actor' => app_settings => 'id_as_barcode');
- my $user;
- my $user_by_barcode;
- my $user_by_username;
- $logger->info("$id_as_barcode is the ID as BARCODE");
- if($barcode) {
- my $card = $e->search_actor_card([
- {barcode => $barcode},
- {flesh => 1, flesh_fields => {ac => ['usr']}}])->[0];
- if ($id_as_barcode =~ /^t/i) {
- if (!$card) {
- $user = $e->retrieve_actor_user($barcode);
- return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if(!$user);
- }else {
- $user_by_barcode = $card->usr;
- $user = $user_by_barcode;
- }
- }else {
- return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if(!$card);
- $user_by_barcode = $card->usr;
- $user = $user_by_barcode;
- }
- }
-
- if ($username) {
- $user_by_username = $e->search_actor_user({usrname => $username})->[0] or return OpenILS::Event->new( 'ACTOR_USR_NOT_FOUND' );
-
- $user = $user_by_username;
- }
- return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if (!$user);
- return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if ($user_by_username && $user_by_barcode && $user_by_username->id != $user_by_barcode->id);
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- return $user->id;
-}
-
-
-__PACKAGE__->register_method (
- method => 'merge_users',
- api_name => 'open-ils.actor.user.merge',
- signature => {
- desc => q/
- Given a list of source users and destination user, transfer all data from the source
- to the dest user and delete the source user. All user related data is
- transferred, including circulations, holds, bookbags, etc.
- /
- }
-);
-
-sub merge_users {
- my($self, $conn, $auth, $master_id, $user_ids, $options) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- # disallow the merge if any subordinate accounts are in collections
- my $colls = $e->search_money_collections_tracker({usr => $user_ids}, {idlist => 1});
- return OpenILS::Event->new('MERGED_USER_IN_COLLECTIONS', payload => $user_ids) if @$colls;
-
- my $master_user = $e->retrieve_actor_user($master_id) or return $e->die_event;
- my $del_addrs = ($U->ou_ancestor_setting_value(
- $master_user->home_ou, 'circ.user_merge.delete_addresses', $e)) ? 't' : 'f';
- my $del_cards = ($U->ou_ancestor_setting_value(
- $master_user->home_ou, 'circ.user_merge.delete_cards', $e)) ? 't' : 'f';
- my $deactivate_cards = ($U->ou_ancestor_setting_value(
- $master_user->home_ou, 'circ.user_merge.deactivate_cards', $e)) ? 't' : 'f';
-
- for my $src_id (@$user_ids) {
- my $src_user = $e->retrieve_actor_user($src_id) or return $e->die_event;
-
- return $e->die_event unless $e->allowed('MERGE_USERS', $src_user->home_ou);
- if($src_user->home_ou ne $master_user->home_ou) {
- return $e->die_event unless $e->allowed('MERGE_USERS', $master_user->home_ou);
- }
-
- return $e->die_event unless
- $e->json_query({from => [
- 'actor.usr_merge',
- $src_id,
- $master_id,
- $del_addrs,
- $del_cards,
- $deactivate_cards
- ]});
- }
-
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method (
- method => 'approve_user_address',
- api_name => 'open-ils.actor.user.pending_address.approve',
- signature => {
- desc => q/
- /
- }
-);
-
-sub approve_user_address {
- my($self, $conn, $auth, $addr) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- if(ref $addr) {
- # if the caller passes an address object, assume they want to
- # update it first before approving it
- $e->update_actor_user_address($addr) or return $e->die_event;
- } else {
- $addr = $e->retrieve_actor_user_address($addr) or return $e->die_event;
- }
- my $user = $e->retrieve_actor_user($addr->usr);
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
- my $result = $e->json_query({from => ['actor.approve_pending_address', $addr->id]})->[0]
- or return $e->die_event;
- $e->commit;
- return [values %$result]->[0];
-}
-
-
-__PACKAGE__->register_method (
- method => 'retrieve_friends',
- api_name => 'open-ils.actor.friends.retrieve',
- signature => {
- desc => q/
- returns { confirmed: [], pending_out: [], pending_in: []}
- pending_out are users I'm requesting friendship with
- pending_in are users requesting friendship with me
- /
- }
-);
-
-sub retrieve_friends {
- my($self, $conn, $auth, $user_id, $options) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- $user_id ||= $e->requestor->id;
-
- if($user_id != $e->requestor->id) {
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- }
-
- return OpenILS::Application::Actor::Friends->retrieve_friends(
- $e, $user_id, $options);
-}
-
-
-
-__PACKAGE__->register_method (
- method => 'apply_friend_perms',
- api_name => 'open-ils.actor.friends.perms.apply',
- signature => {
- desc => q/
- /
- }
-);
-sub apply_friend_perms {
- my($self, $conn, $auth, $user_id, $delegate_id, @perms) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- if($user_id != $e->requestor->id) {
- my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('VIEW_USER', $user->home_ou);
- }
-
- for my $perm (@perms) {
- my $evt =
- OpenILS::Application::Actor::Friends->apply_friend_perm(
- $e, $user_id, $delegate_id, $perm);
- return $evt if $evt;
- }
-
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method (
- method => 'update_user_pending_address',
- api_name => 'open-ils.actor.user.address.pending.cud'
-);
-
-sub update_user_pending_address {
- my($self, $conn, $auth, $addr) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- if($addr->usr != $e->requestor->id) {
- my $user = $e->retrieve_actor_user($addr->usr) or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
- }
-
- if($addr->isnew) {
- $e->create_actor_user_address($addr) or return $e->die_event;
- } elsif($addr->isdeleted) {
- $e->delete_actor_user_address($addr) or return $e->die_event;
- } else {
- $e->update_actor_user_address($addr) or return $e->die_event;
- }
-
- $e->commit;
- return $addr->id;
-}
-
-
-__PACKAGE__->register_method (
- method => 'user_events',
- api_name => 'open-ils.actor.user.events.circ',
- stream => 1,
-);
-__PACKAGE__->register_method (
- method => 'user_events',
- api_name => 'open-ils.actor.user.events.ahr',
- stream => 1,
-);
-
-sub user_events {
- my($self, $conn, $auth, $user_id, $filters) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- (my $obj_type = $self->api_name) =~ s/.*\.([a-z]+)$/$1/;
- my $user_field = 'usr';
-
- $filters ||= {};
- $filters->{target} = {
- select => { $obj_type => ['id'] },
- from => $obj_type,
- where => {usr => $user_id}
- };
-
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- if($e->requestor->id != $user_id) {
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- }
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- my $req = $ses->request('open-ils.trigger.events_by_target',
- $obj_type, $filters, {atevdef => ['reactor', 'validator']}, 2);
-
- while(my $resp = $req->recv) {
- my $val = $resp->content;
- my $tgt = $val->target;
-
- if($obj_type eq 'circ') {
- $tgt->target_copy($e->retrieve_asset_copy($tgt->target_copy));
-
- } elsif($obj_type eq 'ahr') {
- $tgt->current_copy($e->retrieve_asset_copy($tgt->current_copy))
- if $tgt->current_copy;
- }
-
- $conn->respond($val) if $val;
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method (
- method => 'copy_events',
- api_name => 'open-ils.actor.copy.events.circ',
- stream => 1,
-);
-__PACKAGE__->register_method (
- method => 'copy_events',
- api_name => 'open-ils.actor.copy.events.ahr',
- stream => 1,
-);
-
-sub copy_events {
- my($self, $conn, $auth, $copy_id, $filters) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- (my $obj_type = $self->api_name) =~ s/.*\.([a-z]+)$/$1/;
-
- my $copy = $e->retrieve_asset_copy($copy_id) or return $e->event;
-
- my $copy_field = 'target_copy';
- $copy_field = 'current_copy' if $obj_type eq 'ahr';
-
- $filters ||= {};
- $filters->{target} = {
- select => { $obj_type => ['id'] },
- from => $obj_type,
- where => {$copy_field => $copy_id}
- };
-
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- my $req = $ses->request('open-ils.trigger.events_by_target',
- $obj_type, $filters, {atevdef => ['reactor', 'validator']}, 2);
-
- while(my $resp = $req->recv) {
- my $val = $resp->content;
- my $tgt = $val->target;
-
- my $user = $e->retrieve_actor_user($tgt->usr);
- if($e->requestor->id != $user->id) {
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- }
-
- $tgt->$copy_field($copy);
-
- $tgt->usr($user);
- $conn->respond($val) if $val;
- }
-
- return undef;
-}
-
-
-
-
-__PACKAGE__->register_method (
- method => 'update_events',
- api_name => 'open-ils.actor.user.event.cancel.batch',
- stream => 1,
-);
-__PACKAGE__->register_method (
- method => 'update_events',
- api_name => 'open-ils.actor.user.event.reset.batch',
- stream => 1,
-);
-
-sub update_events {
- my($self, $conn, $auth, $event_ids) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $x = 1;
- for my $id (@$event_ids) {
-
- # do a little dance to determine what user we are ultimately affecting
- my $event = $e->retrieve_action_trigger_event([
- $id,
- { flesh => 2,
- flesh_fields => {atev => ['event_def'], atevdef => ['hook']}
- }
- ]) or return $e->die_event;
-
- my $user_id;
- if($event->event_def->hook->core_type eq 'circ') {
- $user_id = $e->retrieve_action_circulation($event->target)->usr;
- } elsif($event->event_def->hook->core_type eq 'ahr') {
- $user_id = $e->retrieve_action_hold_request($event->target)->usr;
- } else {
- return 0;
- }
-
- my $user = $e->retrieve_actor_user($user_id);
- return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
-
- if($self->api_name =~ /cancel/) {
- $event->state('invalid');
- } elsif($self->api_name =~ /reset/) {
- $event->clear_start_time;
- $event->clear_update_time;
- $event->state('pending');
- }
-
- $e->update_action_trigger_event($event) or return $e->die_event;
- $conn->respond({maximum => scalar(@$event_ids), progress => $x++});
- }
-
- $e->commit;
- return {complete => 1};
-}
-
-
-__PACKAGE__->register_method (
- method => 'really_delete_user',
- api_name => 'open-ils.actor.user.delete',
- signature => q/
- It anonymizes all personally identifiable information in actor.usr. By calling actor.usr_purge_data()
- it also purges related data from other tables, sometimes by transferring it to a designated destination user.
- The usrname field (along with first_given_name and family_name) is updated to id '-PURGED-' now().
- dest_usr_id is only required when deleting a user that performs staff functions.
- /
-);
-
-sub really_delete_user {
- my($self, $conn, $auth, $user_id, $dest_user_id) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
- return $e->die_event unless $e->allowed('DELETE_USER', $user->home_ou);
- my $stat = $e->json_query(
- {from => ['actor.usr_delete', $user_id, $dest_user_id]})->[0]
- or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method (
- method => 'user_payments',
- api_name => 'open-ils.actor.user.payments.retrieve',
- stream => 1,
- signature => q/
- Returns all payments for a given user. Default order is newest payments first.
- @param auth Authentication token
- @param user_id The user ID
- @param filters An optional hash of filters, including limit, offset, and order_by definitions
- /
-);
-
-sub user_payments {
- my($self, $conn, $auth, $user_id, $filters) = @_;
- $filters ||= {};
-
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_USER_TRANSACTIONS', $user->home_ou);
-
- # Find all payments for all transactions for user $user_id
- my $query = {
- select => {mp => ['id']},
- from => 'mp',
- where => {
- xact => {
- in => {
- select => {mbt => ['id']},
- from => 'mbt',
- where => {usr => $user_id}
- }
- }
- },
- order_by => [{ # by default, order newest payments first
- class => 'mp',
- field => 'payment_ts',
- direction => 'desc'
- }]
- };
-
- for (qw/order_by limit offset/) {
- $query->{$_} = $filters->{$_} if defined $filters->{$_};
- }
-
- if(defined $filters->{where}) {
- foreach (keys %{$filters->{where}}) {
- # don't allow the caller to expand the result set to other users
- $query->{where}->{$_} = $filters->{where}->{$_} unless $_ eq 'xact';
- }
- }
-
- my $payment_ids = $e->json_query($query);
- for my $pid (@$payment_ids) {
- my $pay = $e->retrieve_money_payment([
- $pid->{id},
- { flesh => 6,
- flesh_fields => {
- mp => ['xact'],
- mbt => ['summary', 'circulation', 'grocery'],
- circ => ['target_copy'],
- acp => ['call_number'],
- acn => ['record']
- }
- }
- ]);
-
- my $resp = {
- mp => $pay,
- xact_type => $pay->xact->summary->xact_type,
- last_billing_type => $pay->xact->summary->last_billing_type,
- };
-
- if($pay->xact->summary->xact_type eq 'circulation') {
- $resp->{barcode} = $pay->xact->circulation->target_copy->barcode;
- $resp->{title} = $U->record_to_mvr($pay->xact->circulation->target_copy->call_number->record)->title;
- }
-
- $pay->xact($pay->xact->id); # de-flesh
- $conn->respond($resp);
- }
-
- return undef;
-}
-
-
-
-__PACKAGE__->register_method (
- method => 'negative_balance_users',
- api_name => 'open-ils.actor.users.negative_balance',
- stream => 1,
- signature => q/
- Returns all users that have an overall negative balance
- @param auth Authentication token
- @param org_id The context org unit as an ID or list of IDs. This will be the home
- library of the user. If no org_unit is specified, no org unit filter is applied
- /
-);
-
-sub negative_balance_users {
- my($self, $conn, $auth, $org_id) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('VIEW_USER', $org_id);
-
- my $query = {
- select => {
- mous => ['usr', 'balance_owed'],
- au => ['home_ou'],
- mbts => [
- {column => 'last_billing_ts', transform => 'max', aggregate => 1},
- {column => 'last_payment_ts', transform => 'max', aggregate => 1},
- ]
- },
- from => {
- mous => {
- au => {
- fkey => 'usr',
- field => 'id',
- join => {
- mbts => {
- key => 'id',
- field => 'usr'
- }
- }
- }
- }
- },
- where => {'+mous' => {balance_owed => {'<' => 0}}}
- };
-
- $query->{from}->{mous}->{au}->{filter}->{home_ou} = $org_id if $org_id;
-
- my $list = $e->json_query($query, {timeout => 600});
-
- for my $data (@$list) {
- $conn->respond({
- usr => $e->retrieve_actor_user([$data->{usr}, {flesh => 1, flesh_fields => {au => ['card']}}]),
- balance_owed => $data->{balance_owed},
- last_billing_activity => max($data->{last_billing_ts}, $data->{last_payment_ts})
- });
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "request_password_reset",
- api_name => "open-ils.actor.patron.password_reset.request",
- signature => {
- desc => "Generates a UUID token usable with the open-ils.actor.patron.password_reset.commit " .
- "method for changing a user's password. The UUID token is distributed via A/T " .
- "templates (i.e. email to the user).",
- params => [
- { desc => 'user_id_type', type => 'string' },
- { desc => 'user_id', type => 'string' },
- { desc => 'optional (based on library setting) matching email address for authorizing request', type => 'string' },
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-sub request_password_reset {
- my($self, $conn, $user_id_type, $user_id, $email) = @_;
-
- # Check to see if password reset requests are already being throttled:
- # 0. Check cache to see if we're in throttle mode (avoid hitting database)
-
- my $e = new_editor(xact => 1);
- my $user;
-
- # Get the user, if any, depending on the input value
- if ($user_id_type eq 'username') {
- $user = $e->search_actor_user({usrname => $user_id})->[0];
- if (!$user) {
- $e->die_event;
- return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' );
- }
- } elsif ($user_id_type eq 'barcode') {
- my $card = $e->search_actor_card([
- {barcode => $user_id},
- {flesh => 1, flesh_fields => {ac => ['usr']}}])->[0];
- if (!$card) {
- $e->die_event;
- return OpenILS::Event->new('ACTOR_USER_NOT_FOUND');
- }
- $user = $card->usr;
- }
-
- # If the user doesn't have an email address, we can't help them
- if (!$user->email) {
- $e->die_event;
- return OpenILS::Event->new('PATRON_NO_EMAIL_ADDRESS');
- }
-
- my $email_must_match = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_requires_matching_email');
- if ($email_must_match) {
- if ($user->email ne $email) {
- return OpenILS::Event->new('EMAIL_VERIFICATION_FAILED');
- }
- }
-
- _reset_password_request($conn, $e, $user);
-}
-
-# Once we have the user, we can issue the password reset request
-# XXX Add a wrapper method that accepts barcode + email input
-sub _reset_password_request {
- my ($conn, $e, $user) = @_;
-
- # 1. Get throttle threshold and time-to-live from OU_settings
- my $aupr_throttle = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_throttle') || 1000;
- my $aupr_ttl = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_time_to_live') || 24*60*60;
-
- my $threshold_time = DateTime->now(time_zone => 'local')->subtract(seconds => $aupr_ttl)->iso8601();
-
- # 2. Get time of last request and number of active requests (num_active)
- my $active_requests = $e->json_query({
- from => 'aupr',
- select => {
- aupr => [
- {
- column => 'uuid',
- transform => 'COUNT'
- },
- {
- column => 'request_time',
- transform => 'MAX'
- }
- ]
- },
- where => {
- has_been_reset => { '=' => 'f' },
- request_time => { '>' => $threshold_time }
- }
- });
-
- # Guard against no active requests
- if ($active_requests->[0]->{'request_time'}) {
- my $last_request = DateTime::Format::ISO8601->parse_datetime(clense_ISO8601($active_requests->[0]->{'request_time'}));
- my $now = DateTime::Format::ISO8601->new();
-
- # 3. if (num_active > throttle_threshold) and (now - last_request < 1 minute)
- if (($active_requests->[0]->{'usr'} > $aupr_throttle) &&
- ($last_request->add_duration('1 minute') > $now)) {
- $cache->put_cache('open-ils.actor.password.throttle', DateTime::Format::ISO8601->new(), 60);
- $e->die_event;
- return OpenILS::Event->new('PATRON_TOO_MANY_ACTIVE_PASSWORD_RESET_REQUESTS');
- }
- }
-
- # TODO Check to see if the user is in a password-reset-restricted group
-
- # Otherwise, go ahead and try to get the user.
-
- # Check the number of active requests for this user
- $active_requests = $e->json_query({
- from => 'aupr',
- select => {
- aupr => [
- {
- column => 'usr',
- transform => 'COUNT'
- }
- ]
- },
- where => {
- usr => { '=' => $user->id },
- has_been_reset => { '=' => 'f' },
- request_time => { '>' => $threshold_time }
- }
- });
-
- $logger->info("User " . $user->id . " has " . $active_requests->[0]->{'usr'} . " active password reset requests.");
-
- # if less than or equal to per-user threshold, proceed; otherwise, return event
- my $aupr_per_user_limit = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_per_user_limit') || 3;
- if ($active_requests->[0]->{'usr'} > $aupr_per_user_limit) {
- $e->die_event;
- return OpenILS::Event->new('PATRON_TOO_MANY_ACTIVE_PASSWORD_RESET_REQUESTS');
- }
-
- # Create the aupr object and insert into the database
- my $reset_request = Fieldmapper::actor::usr_password_reset->new;
- my $uuid = create_uuid_as_string(UUID_V4);
- $reset_request->uuid($uuid);
- $reset_request->usr($user->id);
-
- my $aupr = $e->create_actor_usr_password_reset($reset_request) or return $e->die_event;
- $e->commit;
-
- # Create an event to notify user of the URL to reset their password
-
- # Can we stuff this in the user_data param for trigger autocreate?
- my $hostname = $U->ou_ancestor_setting_value($user->home_ou, 'lib.hostname') || 'localhost';
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'password.reset_request', $aupr, $user->home_ou);
-
- # Trunk only
- # $U->create_trigger_event('password.reset_request', $aupr, $user->home_ou);
-
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "commit_password_reset",
- api_name => "open-ils.actor.patron.password_reset.commit",
- signature => {
- desc => "Checks a UUID token generated by the open-ils.actor.patron.password_reset.request method for " .
- "validity, and if valid, uses it as authorization for changing the associated user's password " .
- "with the supplied password.",
- params => [
- { desc => 'uuid', type => 'string' },
- { desc => 'password', type => 'string' },
- ],
- return => {desc => '1 on success, Event on error'}
- }
-);
-sub commit_password_reset {
- my($self, $conn, $uuid, $password) = @_;
-
- # Check to see if password reset requests are already being throttled:
- # 0. Check cache to see if we're in throttle mode (avoid hitting database)
- $cache ||= OpenSRF::Utils::Cache->new("global", 0);
- my $throttle = $cache->get_cache('open-ils.actor.password.throttle') || undef;
- if ($throttle) {
- return OpenILS::Event->new('PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST');
- }
-
- my $e = new_editor(xact => 1);
-
- my $aupr = $e->search_actor_usr_password_reset({
- uuid => $uuid,
- has_been_reset => 0
- });
-
- if (!$aupr->[0]) {
- $e->die_event;
- return OpenILS::Event->new('PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST');
- }
- my $user_id = $aupr->[0]->usr;
- my $user = $e->retrieve_actor_user($user_id);
-
- # Ensure we're still within the TTL for the request
- my $aupr_ttl = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_time_to_live') || 24*60*60;
- my $threshold = DateTime::Format::ISO8601->parse_datetime(clense_ISO8601($aupr->[0]->request_time))->add(seconds => $aupr_ttl);
- if ($threshold < DateTime->now(time_zone => 'local')) {
- $e->die_event;
- $logger->info("Password reset request needed to be submitted before $threshold");
- return OpenILS::Event->new('PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST');
- }
-
- # Check complexity of password against OU-defined regex
- my $pw_regex = $U->ou_ancestor_setting_value($user->home_ou, 'global.password_regex');
-
- my $is_strong = 0;
- if ($pw_regex) {
- # Calling JSON2perl on the $pw_regex causes failure, even before the fancy Unicode regex
- # ($pw_regex = OpenSRF::Utils::JSON->JSON2perl($pw_regex)) =~ s/\\u([0-9a-fA-F]{4})/\\x{$1}/gs;
- $is_strong = check_password_strength_custom($password, $pw_regex);
- } else {
- $is_strong = check_password_strength_default($password);
- }
-
- if (!$is_strong) {
- $e->die_event;
- return OpenILS::Event->new('PATRON_PASSWORD_WAS_NOT_STRONG');
- }
-
- # All is well; update the password
- $user->passwd($password);
- $e->update_actor_user($user);
-
- # And flag that this password reset request has been honoured
- $aupr->[0]->has_been_reset('t');
- $e->update_actor_usr_password_reset($aupr->[0]);
- $e->commit;
-
- return 1;
-}
-
-sub check_password_strength_default {
- my $password = shift;
- # Use the default set of checks
- if ( (length($password) < 7) or
- ($password !~ m/.*\d+.*/) or
- ($password !~ m/.*[A-Za-z]+.*/)
- ) {
- return 0;
- }
- return 1;
-}
-
-sub check_password_strength_custom {
- my ($password, $pw_regex) = @_;
-
- $pw_regex = qr/$pw_regex/;
- if ($password !~ /$pw_regex/) {
- return 0;
- }
- return 1;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "event_def_opt_in_settings",
- api_name => "open-ils.actor.event_def.opt_in.settings",
- stream => 1,
- signature => {
- desc => 'Streams the set of "cust" objects that are used as opt-in settings for event definitions',
- params => [
- { desc => 'Authentication token', type => 'string'},
- {
- desc => 'Org Unit ID. (optional). If no org ID is present, the home_ou of the requesting user is used',
- type => 'number'
- },
- ],
- return => {
- desc => q/set of "cust" objects that are used as opt-in settings for event definitions at the specified org unit/,
- type => 'object',
- class => 'cust'
- }
- }
-);
-
-sub event_def_opt_in_settings {
- my($self, $conn, $auth, $org_id) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- if(defined $org_id and $org_id != $e->requestor->home_ou) {
- return $e->event unless
- $e->allowed(['VIEW_USER_SETTING_TYPE', 'ADMIN_USER_SETTING_TYPE'], $org_id);
- } else {
- $org_id = $e->requestor->home_ou;
- }
-
- # find all config.user_setting_type's related to event_defs for the requested org unit
- my $types = $e->json_query({
- select => {cust => ['name']},
- from => {atevdef => 'cust'},
- where => {
- '+atevdef' => {
- owner => $U->get_org_ancestors($org_id), # context org plus parents
- active => 't'
- }
- }
- });
-
- if(@$types) {
- $conn->respond($_) for
- @{$e->search_config_usr_setting_type({name => [map {$_->{name}} @$types]})};
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "user_visible_circs",
- api_name => "open-ils.actor.history.circ.visible",
- stream => 1,
- signature => {
- desc => 'Returns the set of opt-in visible circulations accompanied by circulation chain summaries',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
- { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
- ],
- return => {
- desc => q/An object with 2 fields: circulation and summary.
- circulation is the "circ" object. summary is the related "accs" object/,
- type => 'object',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "user_visible_circs",
- api_name => "open-ils.actor.history.circ.visible.print",
- stream => 1,
- signature => {
- desc => 'Returns printable output for the set of opt-in visible circulations',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
- { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
- ],
- return => {
- desc => q/An action_trigger.event object or error event./,
- type => 'object',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "user_visible_circs",
- api_name => "open-ils.actor.history.circ.visible.email",
- stream => 1,
- signature => {
- desc => 'Emails the set of opt-in visible circulations to the requestor',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
- { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
- ],
- return => {
- desc => q/undef, or event on error/
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "user_visible_circs",
- api_name => "open-ils.actor.history.hold.visible",
- stream => 1,
- signature => {
- desc => 'Returns the set of opt-in visible holds',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
- { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
- ],
- return => {
- desc => q/An object with 1 field: "hold"/,
- type => 'object',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "user_visible_circs",
- api_name => "open-ils.actor.history.hold.visible.print",
- stream => 1,
- signature => {
- desc => 'Returns printable output for the set of opt-in visible holds',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
- { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
- ],
- return => {
- desc => q/An action_trigger.event object or error event./,
- type => 'object',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "user_visible_circs",
- api_name => "open-ils.actor.history.hold.visible.email",
- stream => 1,
- signature => {
- desc => 'Emails the set of opt-in visible holds to the requestor',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
- { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
- ],
- return => {
- desc => q/undef, or event on error/
- }
- }
-);
-
-sub user_visible_circs {
- my($self, $conn, $auth, $user_id, $options) = @_;
-
- my $is_hold = ($self->api_name =~ /hold/);
- my $for_print = ($self->api_name =~ /print/);
- my $for_email = ($self->api_name =~ /email/);
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- $user_id ||= $e->requestor->id;
- $options ||= {};
- $options->{limit} ||= 50;
- $options->{offset} ||= 0;
-
- if($user_id != $e->requestor->id) {
- my $perm = ($is_hold) ? 'VIEW_HOLD' : 'VIEW_CIRCULATIONS';
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed($perm, $user->home_ou);
- }
-
- my $db_func = ($is_hold) ? 'action.usr_visible_holds' : 'action.usr_visible_circs';
-
- my $data = $e->json_query({
- from => [$db_func, $user_id],
- limit => $$options{limit},
- offset => $$options{offset}
-
- # TODO: I only want IDs. code below didn't get me there
- # {"select":{"au":[{"column":"id", "result_field":"id",
- # "transform":"action.usr_visible_circs"}]}, "where":{"id":10}, "from":"au"}
- },{
- substream => 1
- });
-
- return undef unless @$data;
-
- if ($for_print) {
-
- # collect the batch of objects
-
- if($is_hold) {
-
- my $hold_list = $e->search_action_hold_request({id => [map { $_->{id} } @$data]});
- return $U->fire_object_event(undef, 'ahr.format.history.print', $hold_list, $$hold_list[0]->request_lib);
-
- } else {
-
- my $circ_list = $e->search_action_circulation({id => [map { $_->{id} } @$data]});
- return $U->fire_object_event(undef, 'circ.format.history.print', $circ_list, $$circ_list[0]->circ_lib);
- }
-
- } elsif ($for_email) {
-
- $conn->respond_complete(1) if $for_email; # no sense in waiting
-
- foreach (@$data) {
-
- my $id = $_->{id};
-
- if($is_hold) {
-
- my $hold = $e->retrieve_action_hold_request($id);
- $U->create_events_for_hook('ahr.format.history.email', $hold, $hold->request_lib, undef, undef, 1);
- # events will be fired from action_trigger_runner
-
- } else {
-
- my $circ = $e->retrieve_action_circulation($id);
- $U->create_events_for_hook('circ.format.history.email', $circ, $circ->circ_lib, undef, undef, 1);
- # events will be fired from action_trigger_runner
- }
- }
-
- } else { # just give me the data please
-
- foreach (@$data) {
-
- my $id = $_->{id};
-
- if($is_hold) {
-
- my $hold = $e->retrieve_action_hold_request($id);
- $conn->respond({hold => $hold});
-
- } else {
-
- my $circ = $e->retrieve_action_circulation($id);
- $conn->respond({
- circ => $circ,
- summary => $U->create_circ_chain_summary($e, $id)
- });
- }
- }
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "user_saved_search_cud",
- api_name => "open-ils.actor.user.saved_search.cud",
- stream => 1,
- signature => {
- desc => 'Create/Update/Delete Access to user saved searches',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Saved Search Object', type => 'object', class => 'auss' }
- ],
- return => {
- desc => q/The retrieved or updated saved search object, or id of a deleted object; Event on error/,
- class => 'auss'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "user_saved_search_cud",
- api_name => "open-ils.actor.user.saved_search.retrieve",
- stream => 1,
- signature => {
- desc => 'Retrieve a saved search object',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Saved Search ID', type => 'number' }
- ],
- return => {
- desc => q/The saved search object, Event on error/,
- class => 'auss'
- }
- }
-);
-
-sub user_saved_search_cud {
- my( $self, $client, $auth, $search ) = @_;
- my $e = new_editor( authtoken=>$auth );
- return $e->die_event unless $e->checkauth;
-
- my $o_search; # prior version of the object, if any
- my $res; # to be returned
-
- # branch on the operation type
-
- if( $self->api_name =~ /retrieve/ ) { # Retrieve
-
- # Get the old version, to check ownership
- $o_search = $e->retrieve_actor_usr_saved_search( $search )
- or return $e->die_event;
-
- # You can't read somebody else's search
- return OpenILS::Event->new('BAD_PARAMS')
- unless $o_search->owner == $e->requestor->id;
-
- $res = $o_search;
-
- } else {
-
- $e->xact_begin; # start an editor transaction
-
- if( $search->isnew ) { # Create
-
- # You can't create a search for somebody else
- return OpenILS::Event->new('BAD_PARAMS')
- unless $search->owner == $e->requestor->id;
-
- $e->create_actor_usr_saved_search( $search )
- or return $e->die_event;
-
- $res = $search->id;
-
- } elsif( $search->ischanged ) { # Update
-
- # You can't change ownership of a search
- return OpenILS::Event->new('BAD_PARAMS')
- unless $search->owner == $e->requestor->id;
-
- # Get the old version, to check ownership
- $o_search = $e->retrieve_actor_usr_saved_search( $search->id )
- or return $e->die_event;
-
- # You can't update somebody else's search
- return OpenILS::Event->new('BAD_PARAMS')
- unless $o_search->owner == $e->requestor->id;
-
- # Do the update
- $e->update_actor_usr_saved_search( $search )
- or return $e->die_event;
-
- $res = $search;
-
- } elsif( $search->isdeleted ) { # Delete
-
- # Get the old version, to check ownership
- $o_search = $e->retrieve_actor_usr_saved_search( $search->id )
- or return $e->die_event;
-
- # You can't delete somebody else's search
- return OpenILS::Event->new('BAD_PARAMS')
- unless $o_search->owner == $e->requestor->id;
-
- # Do the delete
- $e->delete_actor_usr_saved_search( $o_search )
- or return $e->die_event;
-
- $res = $search->id;
- }
-
- $e->commit;
- }
-
- return $res;
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Actor::ClosedDates;
-use base 'OpenILS::Application';
-use strict; use warnings;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::Editor q/:funcs/;
-
-sub initialize { return 1; }
-
-__PACKAGE__->register_method(
- method => 'fetch_dates',
- api_name => 'open-ils.actor.org_unit.closed.retrieve.all',
- signature => q/
- Retrieves a list of closed date object IDs
- /
-);
-
-sub fetch_dates {
- my( $self, $conn, $auth, $args ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $org = $$args{orgid} || $e->requestor->ws_ou;
- my @date = localtime;
- my $start = $$args{start_date} || #default to today
- ($date[5] + 1900) .'-'. ($date[4] + 1) .'-'. $date[3];
- my $end = $$args{end_date} || '3000-01-01'; # Y3K, here I come..
-
- my $dates = $e->search_actor_org_unit_closed_date(
- {
- close_start => { ">=" => $start },
- close_end => { "<=" => $end },
- org_unit => $org,
- }, { idlist => $$args{idlist} } ) or return $e->event;
-
- if(!$$args{idlist} and @$dates) {
- $dates = [ sort { $a->close_start cmp $b->close_start } @$dates ];
- }
-
- return $dates;
-}
-
-__PACKAGE__->register_method(
- method => 'fetch_date',
- api_name => 'open-ils.actor.org_unit.closed.retrieve',
- signature => q/
- Retrieves a single date object
- /
-);
-
-sub fetch_date {
- my( $self, $conn, $auth, $id ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $date = $e->retrieve_actor_org_unit_closed_date($id) or return $e->event;
- return $date;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_date',
- api_name => 'open-ils.actor.org_unit.closed.delete',
- signature => q/
- Removes a single date object
- /
-);
-
-sub delete_date {
- my( $self, $conn, $auth, $id ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $date = $e->retrieve_actor_org_unit_closed_date($id) or return $e->event;
- return $e->event unless $e->allowed( # rely on the editor perm eventually
- 'actor.org_unit.closed_date.delete', $date->org_unit);
- $e->delete_actor_org_unit_closed_date($date) or return $e->event;
- return 1;
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => 'create_date',
- api_name => 'open-ils.actor.org_unit.closed.create',
- signature => q/
- Creates a new org closed data
- /
-);
-
-sub create_date {
- my( $self, $conn, $auth, $date ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact =>1);
- return $e->event unless $e->checkauth;
-
- return $e->event unless $e->allowed( # rely on the editor perm eventually
- 'actor.org_unit.closed_date.create', $date->org_unit);
-
- $e->create_actor_org_unit_closed_date($date) or return $e->event;
-
- my $newobj = $e->retrieve_actor_org_unit_closed_date($date->id)
- or return $e->event;
-
- $e->commit;
- return $newobj;
-}
-
-
-__PACKAGE__->register_method(
- method => 'edit_date',
- api_name => 'open-ils.actor.org_unit.closed.update',
- signature => q/
- Updates a closed date object
- /
-);
-
-sub edit_date {
- my( $self, $conn, $auth, $date ) = @_;
- my $e = new_editor(authtoken=>$auth, xact =>1);
- return $e->event unless $e->checkauth;
-
- # First make sure they have the right to update the selected date object
- my $odate = $e->retrieve_actor_org_unit_closed_date($date->id)
- or return $e->event;
-
- return $e->event unless $e->allowed( # rely on the editor perm eventually
- 'actor.org_unit.closed_date.update', $odate->org_unit);
-
- $e->update_actor_org_unit_closed_date($date) or return $e->event;
-
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'closed_dates_overlap',
- api_name => 'open-ils.actor.org_unit.closed_date.overlap',
- signature => q/
- Returns an object with 'start' and 'end' fields
- start is the first day the org is open going backwards from
- 'date'. end is the next day the org is open going
- forward from 'date'.
- @param orgid The org unit in question
- @param date The date to search
- /
-);
-sub closed_dates_overlap {
- my( $self, $conn, $auth, $orgid, $date ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->request(
- 'open-ils.storage.actor.org_unit.closed_date.overlap', $orgid, $date );
-}
-
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Actor::Container;
-use base 'OpenILS::Application';
-use strict; use warnings;
-use OpenILS::Application::AppUtils;
-use OpenILS::Perm;
-use Data::Dumper;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Cache;
-use Digest::MD5 qw(md5_hex);
-use OpenSRF::Utils::JSON;
-
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-my $logger = "OpenSRF::Utils::Logger";
-
-sub initialize { return 1; }
-
-my $svc = 'open-ils.cstore';
-my $meth = 'open-ils.cstore.direct.container';
-my %types;
-my %ctypes;
-$types{'biblio'} = "$meth.biblio_record_entry_bucket";
-$types{'callnumber'} = "$meth.call_number_bucket";
-$types{'copy'} = "$meth.copy_bucket";
-$types{'user'} = "$meth.user_bucket";
-$ctypes{'biblio'} = "container_biblio_record_entry_bucket";
-$ctypes{'callnumber'} = "container_call_number_bucket";
-$ctypes{'copy'} = "container_copy_bucket";
-$ctypes{'user'} = "container_user_bucket";
-my $event;
-
-sub _sort_buckets {
- my $buckets = shift;
- return $buckets unless ($buckets && $buckets->[0]);
- return [ sort { $a->name cmp $b->name } @$buckets ];
-}
-
-__PACKAGE__->register_method(
- method => "bucket_retrieve_all",
- api_name => "open-ils.actor.container.all.retrieve_by_user",
- authoritative => 1,
- notes => <<" NOTES");
- Retrieves all un-fleshed buckets assigned to given user
- PARAMS(authtoken, bucketOwnerId)
- If requestor ID is different than bucketOwnerId, requestor must have
- VIEW_CONTAINER permissions.
- NOTES
-
-sub bucket_retrieve_all {
- my($self, $client, $auth, $user_id) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- if($e->requestor->id ne $user_id) {
- return $e->event unless $e->allowed('VIEW_CONTAINER');
- }
-
- my %buckets;
- for my $type (keys %ctypes) {
- my $meth = "search_" . $ctypes{$type};
- $buckets{$type} = $e->$meth({owner => $user_id});
- }
-
- return \%buckets;
-}
-
-__PACKAGE__->register_method(
- method => "bucket_flesh",
- api_name => "open-ils.actor.container.flesh",
- authoritative => 1,
- argc => 3,
-);
-
-__PACKAGE__->register_method(
- method => "bucket_flesh_pub",
- api_name => "open-ils.actor.container.public.flesh",
- argc => 3,
-);
-
-sub bucket_flesh {
- my($self, $conn, $auth, $class, $bucket_id) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return _bucket_flesh($self, $conn, $e, $class, $bucket_id);
-}
-
-sub bucket_flesh_pub {
- my($self, $conn, $class, $bucket_id) = @_;
- my $e = new_editor();
- return _bucket_flesh($self, $conn, $e, $class, $bucket_id);
-}
-
-sub _bucket_flesh {
- my($self, $conn, $e, $class, $bucket_id) = @_;
- my $meth = 'retrieve_' . $ctypes{$class};
- my $bkt = $e->$meth($bucket_id) or return $e->event;
-
- unless($U->is_true($bkt->pub)) {
- return undef if $self->api_name =~ /public/;
- unless($bkt->owner eq $e->requestor->id) {
- my $owner = $e->retrieve_actor_user($bkt->owner)
- or return $e->die_event;
- return $e->event unless $e->allowed('VIEW_CONTAINER', $owner->home_ou);
- }
- }
-
- my $fmclass = $bkt->class_name . "i";
- $meth = 'search_' . $ctypes{$class} . '_item';
- $bkt->items(
- $e->$meth(
- {bucket => $bucket_id},
- { order_by => {$fmclass => "pos"},
- flesh => 1,
- flesh_fields => {$fmclass => ['notes']}
- }
- )
- );
-
- return $bkt;
-}
-
-
-__PACKAGE__->register_method(
- method => "item_note_cud",
- api_name => "open-ils.actor.container.item_note.cud",
-);
-
-
-sub item_note_cud {
- my($self, $conn, $auth, $class, $note) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $meth = 'retrieve_' . $ctypes{$class};
- my $nclass = $note->class_name;
- (my $iclass = $nclass) =~ s/n$//og;
-
- my $db_note = $e->$meth($note->id, {
- flesh => 2,
- flesh_fields => {
- $nclass => ['item'],
- $iclass => ['bucket']
- }
- });
-
- if($db_note->item->bucket->owner ne $e->requestor->id) {
- return $e->die_event unless
- $e->allowed('UPDATE_CONTAINER', $db_note->item->bucket);
- }
-
- $meth = 'create_' . $ctypes{$class} if $note->isnew;
- $meth = 'update_' . $ctypes{$class} if $note->ischanged;
- $meth = 'delete_' . $ctypes{$class} if $note->isdeleted;
- return $e->die_event unless $e->$meth($note);
- $e->commit;
-}
-
-
-__PACKAGE__->register_method(
- method => "bucket_retrieve_class",
- api_name => "open-ils.actor.container.retrieve_by_class",
- argc => 3,
- notes => <<" NOTES");
- Retrieves all un-fleshed buckets by class assigned to given user
- PARAMS(authtoken, bucketOwnerId, class [, type])
- class can be one of "biblio", "callnumber", "copy", "user"
- The optional "type" parameter allows you to limit the search by
- bucket type.
- If bucketOwnerId is not defined, the authtoken is used as the
- bucket owner.
- If requestor ID is different than bucketOwnerId, requestor must have
- VIEW_CONTAINER permissions.
- NOTES
-
-sub bucket_retrieve_class {
- my( $self, $client, $authtoken, $userid, $class, $type ) = @_;
-
- my( $staff, $user, $evt ) =
- $apputils->checkses_requestor( $authtoken, $userid, 'VIEW_CONTAINER' );
- return $evt if $evt;
-
- $logger->debug("User " . $staff->id .
- " retrieving buckets for user $userid [class=$class, type=$type]");
-
- my $meth = $types{$class} . ".search.atomic";
- my $buckets;
-
- if( $type ) {
- $buckets = $apputils->simplereq( $svc,
- $meth, { owner => $userid, btype => $type } );
- } else {
- $logger->debug("Grabbing buckets by class $class: $svc : $meth : {owner => $userid}");
- $buckets = $apputils->simplereq( $svc, $meth, { owner => $userid } );
- }
-
- return _sort_buckets($buckets);
-}
-
-__PACKAGE__->register_method(
- method => "bucket_create",
- api_name => "open-ils.actor.container.create",
- notes => <<" NOTES");
- Creates a new bucket object. If requestor is different from
- bucketOwner, requestor needs CREATE_CONTAINER permissions
- PARAMS(authtoken, bucketObject);
- Returns the new bucket object
- NOTES
-
-sub bucket_create {
- my( $self, $client, $authtoken, $class, $bucket ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- if( $bucket->owner ne $e->requestor->id ) {
- return $e->event unless
- $e->allowed('CREATE_CONTAINER');
-
- } else {
- return $e->event unless
- $e->allowed('CREATE_MY_CONTAINER');
- }
-
- $bucket->clear_id;
-
- my $evt = OpenILS::Event->new('CONTAINER_EXISTS',
- payload => [$class, $bucket->owner, $bucket->btype, $bucket->name]);
- my $search = {name => $bucket->name, owner => $bucket->owner, btype => $bucket->btype};
-
- my $obj;
- if( $class eq 'copy' ) {
- return $evt if $e->search_container_copy_bucket($search)->[0];
- return $e->event unless
- $obj = $e->create_container_copy_bucket($bucket);
- }
-
- if( $class eq 'callnumber' ) {
- return $evt if $e->search_container_call_number_bucket($search)->[0];
- return $e->event unless
- $obj = $e->create_container_call_number_bucket($bucket);
- }
-
- if( $class eq 'biblio' ) {
- return $evt if $e->search_container_biblio_record_entry_bucket($search)->[0];
- return $e->event unless
- $obj = $e->create_container_biblio_record_entry_bucket($bucket);
- }
-
- if( $class eq 'user') {
- return $evt if $e->search_container_user_bucket($search)->[0];
- return $e->event unless
- $obj = $e->create_container_user_bucket($bucket);
- }
-
- $e->commit;
- return $obj->id;
-}
-
-
-__PACKAGE__->register_method(
- method => "item_create",
- api_name => "open-ils.actor.container.item.create",
- signature => {
- desc => q/
- Adds one or more items to an existing container
- /,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Container class. Can be "copy", "callnumber", "biblio", or "user"', type => 'string'},
- {desc => 'Item or items. Can either be a single container item object, or an array of them', type => 'object'},
- ],
- return => {
- desc => 'The ID of the newly created item(s). In batch context, an array of IDs is returned'
- }
- }
-);
-
-
-sub item_create {
- my( $self, $client, $authtoken, $class, $item ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
- my $items = (ref $item eq 'ARRAY') ? $item : [$item];
-
- my ( $bucket, $evt ) = $apputils->fetch_container_e($e, $item->bucket, $class);
- return $evt if $evt;
-
- if( $bucket->owner ne $e->requestor->id ) {
- return $e->die_event unless
- $e->allowed('CREATE_CONTAINER_ITEM');
-
- } else {
-# return $e->event unless
-# $e->allowed('CREATE_CONTAINER_ITEM'); # new perm here?
- }
-
- for my $one_item (@$items) {
-
- $one_item->clear_id;
-
- my $stat;
- if( $class eq 'copy' ) {
- return $e->die_event unless
- $stat = $e->create_container_copy_bucket_item($one_item);
- }
-
- if( $class eq 'callnumber' ) {
- return $e->die_event unless
- $stat = $e->create_container_call_number_bucket_item($one_item);
- }
-
- if( $class eq 'biblio' ) {
- return $e->die_event unless
- $stat = $e->create_container_biblio_record_entry_bucket_item($one_item);
- }
-
- if( $class eq 'user') {
- return $e->die_event unless
- $stat = $e->create_container_user_bucket_item($one_item);
- }
- }
-
- $e->commit;
-
- # CStoreEeditor inserts the id (pkey) on newly created objects
- return [ map { $_->id } @$items ] if ref $item eq 'ARRAY';
- return $item->id;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "item_delete",
- api_name => "open-ils.actor.container.item.delete",
- notes => <<" NOTES");
- PARAMS(authtoken, class, itemId)
- NOTES
-
-sub item_delete {
- my( $self, $client, $authtoken, $class, $itemid ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- my $ret = __item_delete($e, $class, $itemid);
- $e->commit unless $U->event_code($ret);
- return $ret;
-}
-
-sub __item_delete {
- my( $e, $class, $itemid ) = @_;
- my( $bucket, $item, $evt);
-
- ( $item, $evt ) = $U->fetch_container_item_e( $e, $itemid, $class );
- return $evt if $evt;
-
- ( $bucket, $evt ) = $U->fetch_container_e($e, $item->bucket, $class);
- return $evt if $evt;
-
- if( $bucket->owner ne $e->requestor->id ) {
- my $owner = $e->retrieve_actor_user($bucket->owner)
- or return $e->die_event;
- return $e->event unless $e->allowed('DELETE_CONTAINER_ITEM', $owner->home_ou);
- }
-
- my $stat;
- if( $class eq 'copy' ) {
- for my $note (@{$e->search_container_copy_bucket_item_note({item => $item->id})}) {
- return $e->event unless
- $e->delete_container_copy_bucket_item_note($note);
- }
- return $e->event unless
- $stat = $e->delete_container_copy_bucket_item($item);
- }
-
- if( $class eq 'callnumber' ) {
- for my $note (@{$e->search_container_call_number_bucket_item_note({item => $item->id})}) {
- return $e->event unless
- $e->delete_container_call_number_bucket_item_note($note);
- }
- return $e->event unless
- $stat = $e->delete_container_call_number_bucket_item($item);
- }
-
- if( $class eq 'biblio' ) {
- for my $note (@{$e->search_container_biblio_record_entry_bucket_item_note({item => $item->id})}) {
- return $e->event unless
- $e->delete_container_biblio_record_entry_bucket_item_note($note);
- }
- return $e->event unless
- $stat = $e->delete_container_biblio_record_entry_bucket_item($item);
- }
-
- if( $class eq 'user') {
- for my $note (@{$e->search_container_user_bucket_item_note({item => $item->id})}) {
- return $e->event unless
- $e->delete_container_user_bucket_item_note($note);
- }
- return $e->event unless
- $stat = $e->delete_container_user_bucket_item($item);
- }
-
- return $stat;
-}
-
-
-__PACKAGE__->register_method(
- method => 'full_delete',
- api_name => 'open-ils.actor.container.full_delete',
- notes => "Complety removes a container including all attached items",
-);
-
-sub full_delete {
- my( $self, $client, $authtoken, $class, $containerId ) = @_;
- my( $container, $evt);
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- ( $container, $evt ) = $apputils->fetch_container_e($e, $containerId, $class);
- return $evt if $evt;
-
- if( $container->owner ne $e->requestor->id ) {
- my $owner = $e->retrieve_actor_user($container->owner)
- or return $e->die_event;
- return $e->event unless $e->allowed('DELETE_CONTAINER', $owner->home_ou);
- }
-
- my $items;
-
- my @s = ({bucket => $containerId}, {idlist=>1});
-
- if( $class eq 'copy' ) {
- $items = $e->search_container_copy_bucket_item(@s);
- }
-
- if( $class eq 'callnumber' ) {
- $items = $e->search_container_call_number_bucket_item(@s);
- }
-
- if( $class eq 'biblio' ) {
- $items = $e->search_container_biblio_record_entry_bucket_item(@s);
- }
-
- if( $class eq 'user') {
- $items = $e->search_container_user_bucket_item(@s);
- }
-
- __item_delete($e, $class, $_) for @$items;
-
- my $stat;
- if( $class eq 'copy' ) {
- return $e->event unless
- $stat = $e->delete_container_copy_bucket($container);
- }
-
- if( $class eq 'callnumber' ) {
- return $e->event unless
- $stat = $e->delete_container_call_number_bucket($container);
- }
-
- if( $class eq 'biblio' ) {
- return $e->event unless
- $stat = $e->delete_container_biblio_record_entry_bucket($container);
- }
-
- if( $class eq 'user') {
- return $e->event unless
- $stat = $e->delete_container_user_bucket($container);
- }
-
- $e->commit;
- return $stat;
-}
-
-__PACKAGE__->register_method(
- method => 'container_update',
- api_name => 'open-ils.actor.container.update',
- signature => q/
- Updates the given container item.
- @param authtoken The login session key
- @param class The container class
- @param container The container item
- @return true on success, 0 on no update, Event on error
- /
-);
-
-sub container_update {
- my( $self, $conn, $authtoken, $class, $container ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- my ( $dbcontainer, $evt ) = $U->fetch_container_e($e, $container->id, $class);
- return $evt if $evt;
-
- if( $e->requestor->id ne $container->owner ) {
- return $e->event unless $e->allowed('UPDATE_CONTAINER');
- }
-
- my $stat;
- if( $class eq 'copy' ) {
- return $e->event unless
- $stat = $e->update_container_copy_bucket($container);
- }
-
- if( $class eq 'callnumber' ) {
- return $e->event unless
- $stat = $e->update_container_call_number_bucket($container);
- }
-
- if( $class eq 'biblio' ) {
- return $e->event unless
- $stat = $e->update_container_biblio_record_entry_bucket($container);
- }
-
- if( $class eq 'user') {
- return $e->event unless
- $stat = $e->update_container_user_bucket($container);
- }
-
- $e->commit;
- return $stat;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "anon_cache",
- api_name => "open-ils.actor.anon_cache.set_value",
- signature => {
- desc => q/
- Sets a value in the anon web cache. If the session key is
- undefined, one will be automatically generated.
- /,
- params => [
- {desc => 'Session key', type => 'string'},
- {
- desc => q/Field name. The name of the field in this cache session whose value to set/,
- type => 'string'
- },
- {
- desc => q/The cached value. This can be any type of object (hash, array, string, etc.)/,
- type => 'any'
- },
- ],
- return => {
- desc => 'session key on success, undef on error',
- type => 'string'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "anon_cache",
- api_name => "open-ils.actor.anon_cache.get_value",
- signature => {
- desc => q/
- Returns the cached data at the specified field within the specified cache session.
- /,
- params => [
- {desc => 'Session key', type => 'string'},
- {
- desc => q/Field name. The name of the field in this cache session whose value to set/,
- type => 'string'
- },
- ],
- return => {
- desc => 'cached value on success, undef on error',
- type => 'any'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "anon_cache",
- api_name => "open-ils.actor.anon_cache.delete_session",
- signature => {
- desc => q/
- Deletes a cache session.
- /,
- params => [
- {desc => 'Session key', type => 'string'},
- ],
- return => {
- desc => 'Session key',
- type => 'string'
- }
- }
-);
-
-sub anon_cache {
- my($self, $conn, $ses_key, $field_key, $value) = @_;
-
- my $sc = OpenSRF::Utils::SettingsClient->new;
- my $cache = OpenSRF::Utils::Cache->new('anon');
- my $cache_timeout = $sc->config_value(cache => anon => 'max_cache_time') || 1800; # 30 minutes
- my $cache_size = $sc->config_value(cache => anon => 'max_cache_size') || 102400; # 100k
-
- if($self->api_name =~ /delete_session/) {
-
- return $cache->delete_cache($ses_key);
-
- } elsif( $self->api_name =~ /set_value/ ) {
-
- $ses_key = md5_hex(time . rand($$)) unless $ses_key;
- my $blob = $cache->get_cache($ses_key) || {};
- $blob->{$field_key} = $value;
- return undef if
- length(OpenSRF::Utils::JSON->perl2JSON($blob)) > $cache_size; # bytes, characters, whatever ;)
- $cache->put_cache($ses_key, $blob, $cache_timeout);
- return $ses_key;
-
- } else {
-
- my $blob = $cache->get_cache($ses_key) or return undef;
- return $blob if (!defined($field_key));
- return $blob->{$field_key};
- }
-}
-
-
-
-1;
-
-
+++ /dev/null
-package OpenILS::Application::Actor::Friends;
-use strict; use warnings;
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger q/$logger/;
-use OpenILS::Utils::Fieldmapper;
-my $U = "OpenILS::Application::AppUtils";
-
-# ----------------------------------------------------------------
-# Shared Friend utilities. Thar be no methods published here...
-# ----------------------------------------------------------------
-
-# export these fields for friend display
-my @expose_user_fields = qw/id usrname first_given_name second_given_name family_name alias/;
-
-my $out_links_query = {
- select => {cubi => ['target_user']},
- from => {
- cub => {
- cubi => {field => 'bucket', fkey => 'id'}
- }
- },
- where => {
- '+cub' => {btype => 'folks', owner => undef}
- }
-};
-
-my $in_links_query = {
- select => {cub => ['owner'] },
- from => {
- cub => {
- cubi => {field => 'bucket', fkey => 'id'}
- }
- },
- where => {
- '+cubi' => {target_user => undef},
- '+cub' => {btype => 'folks'}
- }
-};
-
-my $perm_check_query = {
- select => {cub => ['btype'] },
- from => {
- cub => {
- cubi => {field => 'bucket', fkey => 'id'}
- }
- },
-};
-
-sub retrieve_friends {
- my($self, $e, $user_id, $options) = @_;
- $options ||= {};
-
- # users I have links to
- $out_links_query->{where}->{'+cub'}->{owner} = $user_id;
- my @out_linked = map {$_->{target_user}} @{$e->json_query($out_links_query)};
-
- # users who link to me
- $in_links_query->{where}->{'+cubi'}->{target_user} = $user_id;
- my @in_linked = map {$_->{owner}} @{$e->json_query($in_links_query)};
-
- # determine which users are confirmed, pending outbound
- # requests, and pending inbound requests
- my @confirmed;
- my @pending_out;
- my @pending_in;
-
- for my $out_link (@out_linked) {
- if(grep {$_ == $out_link} @in_linked) {
- push(@confirmed, $out_link);
- } else {
- push(@pending_out, $out_link);
- }
- }
-
- for my $in_link (@in_linked) {
- push(@pending_in, $in_link)
- unless grep {$_ == $in_link} @confirmed;
- }
-
- if($$options{confirmed_only}) {
- return {
- confirmed => $self->load_linked_user_perms($e, $user_id, @confirmed),
- };
- } else {
- return {
- confirmed => $self->load_linked_user_perms($e, $user_id, @confirmed),
- pending_out => $self->load_linked_user_perms($e, $user_id, @pending_out),
- pending_in => $self->load_linked_user_perms($e, $user_id, @pending_in)
- };
- }
-}
-
-# given a base user and set of linked users, returns the trimmed linked user
-# records, plus the perms (by name) each user has been granted
-sub load_linked_user_perms {
- my($self, $e, $user_id, @users) = @_;
- my $items = [];
-
- # use this query to retrieve trimmed linked user objects
- my $user_select =
- {select => {au => \@expose_user_fields}, from => 'au', where => undef};
-
- for my $d_user (@users) {
-
- # fetch all of the bucket items linked from base user to
- # delegate user with the folks: prefix on the bucket type
- $perm_check_query->{where} = {
- '+cubi' => {target_user => $d_user},
- '+cub' => {btype => {like => 'folks:%'}, owner => $user_id}
- };
-
- my $perms_granted = [
- map {substr($_->{btype}, 6)} @{$e->json_query($perm_check_query)}];
-
- # fetch all of the bucket items linked from the delegate user
- # to the base user with the folks: prefix on the bucket type
- $perm_check_query->{where} = {
- '+cubi' => {target_user => $user_id},
- '+cub' => {btype => {like => 'folks:%'}, owner => $d_user}
- };
-
- my $perms_received = [
- map {substr($_->{btype}, 6)} @{$e->json_query($perm_check_query)}];
-
- $user_select->{where} = {id => $d_user};
- push(@$items, {
- user => $e->json_query($user_select)->[0],
- perms_granted => $perms_granted,
- perms_received => $perms_received
- }
- );
- }
- return $items;
-}
-
-
-my $direct_links_query = {
- select => {cub => ['id'] },
- from => {
- cub => {
- cubi => {field => 'bucket', fkey => 'id'}
- }
- },
- where => {
- '+cubi' => {target_user => undef},
- '+cub' => {btype => 'folks', owner => undef}
- },
- limit => 1
-};
-
-sub confirmed_friends {
- my($self, $e, $user1_id, $user2_id) = @_;
-
- $direct_links_query->{where}->{'+cub'}->{owner} = $user1_id;
- $direct_links_query->{where}->{'+cubi'}->{target_user} = $user2_id;
-
- if($e->json_query($direct_links_query)->[0]) {
-
- $direct_links_query->{where}->{'+cub'}->{owner} = $user2_id;
- $direct_links_query->{where}->{'+cubi'}->{target_user} = $user1_id;
- return 1 if $e->json_query($direct_links_query)->[0];
- }
-
- return 0;
-}
-
-
-
-# returns 1 if delegate_user is allowed to perform 'perm' for base_user
-sub friend_perm_allowed {
- my($self, $e, $base_user_id, $delegate_user_id, $perm) = @_;
- return 0 unless $self->confirmed_friends($e, $base_user_id, $delegate_user_id);
- $perm_check_query->{where} = {
- '+cubi' => {target_user => $delegate_user_id},
- '+cub' => {btype => "folks:$perm", owner => $base_user_id}
- };
- return 1 if $e->json_query($perm_check_query)->[0];
- return 0;
-}
-
-sub apply_friend_perm {
- my($self, $e, $base_user_id, $delegate_user_id, $perm) = @_;
-
- my $bucket = $e->search_container_user_bucket(
- {owner => $base_user_id, btype => "folks:$perm"})->[0];
-
- if($bucket) {
- # is the permission already set?
- return undef if $e->search_container_user_bucket_item(
- {bucket => $bucket->id, target_user => $delegate_user_id})->[0];
-
- } else {
- # make sure the perm-specific bucket exists for this user
- $bucket = Fieldmapper::container::user_bucket->new;
- $bucket->owner($base_user_id);
- $bucket->btype("folks:$perm");
- $bucket->name("folks:$perm");
- $e->create_container_user_bucket($bucket) or return $e->die_event;
- }
-
- my $item = Fieldmapper::container::user_bucket_item->new;
- $item->bucket($bucket->id);
- $item->target_user($delegate_user_id);
- $e->create_container_user_bucket_item($item) or return $e->die_event;
- return undef;
-}
-
-23;
+++ /dev/null
-package OpenILS::Application::Actor::Stage;
-use strict; use warnings;
-use base 'OpenILS::Application';
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger q/$logger/;
-use OpenILS::Utils::Fieldmapper;
-my $U = "OpenILS::Application::AppUtils";
-
-
-__PACKAGE__->register_method (
- method => 'create_user_stage',
- api_name => 'open-ils.actor.user.stage.create',
- signature => {
- desc => q/
- Creates a new pending user account including addresses and statcats.
- Users are added to staging tables pending staff review.
- /,
- params => [
- {desc => 'user', type => 'object', class => 'stgu'},
- {desc => 'Mailing address. Optional', type => 'object', class => 'stgma'},
- {desc => 'Billing address. Optional', type => 'object', class => 'stgba'},
- {desc => 'Statcats. Optional. This is an array of "stgsc" objects', type => 'array'},
- ],
- return => {
- desc => 'username on success, Event on error',
- type => ''
- }
-
- }
-);
-
-sub create_user_stage {
- my($self, $conn, $user, $mail_addr, $bill_addr, $statcats) = @_; # more?
-
- return 0 unless $U->ou_ancestor_setting_value('opac.allow_pending_user');
- return OpenILS::Event->new('BAD_PARAMS') unless $user;
-
- my $e = new_editor(xact => 1);
-
- my $uname = $U->create_uuid_string;
- $user->usrname($uname);
-
- $e->create_staging_user_stage($user) or return $e->die_event;
-
- if($mail_addr) {
- $mail_addr->usrname($uname);
- $e->create_staging_mailing_address_stage($mail_addr) or return $e->die_event;
- }
-
- if($bill_addr) {
- $bill_addr->usrname($uname);
- $e->create_staging_billing_address_stage($bill_addr) or return $e->die_event;
- }
-
- if($statcats) {
- foreach (@$statcats) {
- $_->usrname($uname);
- $e->create_staging_statcat_stage($_) or return $e->die_event;
- }
- }
-
- $e->commit;
- $conn->respond_complete($uname);
-
- $U->create_events_for_hook('stgu.create', $user, $user->home_ou);
- return undef;
-}
-
-__PACKAGE__->register_method (
- method => 'user_stage_by_org',
- api_name => 'open-ils.actor.user.stage.retrieve.by_org',
- stream => 1
-);
-
-sub user_stage_by_org {
- my($self, $conn, $auth, $org_id, $limit, $offset) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- $org_id ||= $e->requestor->ws_ou;
- return $e->event unless $e->allowed('VIEW_USER', $org_id);
-
- $limit ||= 100;
- $offset ||= 0;
-
- my $stage_ids = $e->search_staging_user_stage(
- [
- { home_ou => $org_id, complete => 'f'},
- { limit => $limit,
- offset => $offset,
- order_by => {stgu => 'row_id'}
- }
- ],
- {idlist => 1}
- );
-
- $conn->respond(flesh_user_stage($e, $_)) for @$stage_ids;
- return undef;
-}
-
-sub flesh_user_stage {
- my($e, $row_id) = @_;
- my $user = $e->retrieve_staging_user_stage($row_id) or return undef;
- return {
- user => $user,
- billing_addresses => $e->search_staging_billing_address_stage({usrname => $user->usrname}),
- mailing_addresses => $e->search_staging_mailing_address_stage({usrname => $user->usrname}),
- cards => $e->search_staging_card_stage({usrname => $user->usrname}),
- statcats => $e->search_staging_statcat_stage({usrname => $user->usrname})
- };
-}
-
-
-__PACKAGE__->register_method (
- method => 'user_stage_by_uname',
- api_name => 'open-ils.actor.user.stage.retrieve.by_username',
-);
-
-sub user_stage_by_uname {
- my($self, $conn, $auth, $username) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $user = $e->search_staging_user_stage({
- usrname => $username,
- complete => 'f'
- })->[0] or return $e->event;
-
- return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
- return flesh_user_stage($e, $user->row_id);
-}
-
-
-
-
-__PACKAGE__->register_method (
- method => 'delete_user_stage',
- api_name => 'open-ils.actor.user.stage.delete',
-);
-
-sub delete_user_stage {
- my($self, $conn, $auth, $row_id) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- my $data = flesh_user_stage($e, $row_id) or return $e->die_event;
-
- return $e->die_event unless $e->allowed('UPDATE_USER', $data->{user}->home_ou);
-
- $e->delete_staging_user_stage($data->{user}) or return $e->die_event;
-
- for my $addr (@{$data->{mailing_addresses}}) {
- $e->delete_staging_mailing_address_stage($addr) or return $e->die_event;
- }
-
- for my $addr (@{$data->{billing_addresses}}) {
- $e->delete_staging_billing_address_stage($addr) or return $e->die_event;
- }
-
- for my $card (@{$data->{cards}}) {
- $e->delete_staging_card_stage($card) or return $e->die_event;
- }
-
- for my $statcat (@{$data->{statcats}}) {
- $e->delete_staging_statcat_stage($statcat) or return $e->die_event;
- }
-
- $e->commit;
- return 1;
-}
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Actor::UserGroups;
-use base 'OpenILS::Application';
-use strict; use warnings;
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger q/$logger/;
-use OpenSRF::EX qw(:try);
-my $U = "OpenILS::Application::AppUtils";
-
-sub initialize { return 1; }
-
-
-
-__PACKAGE__->register_method(
- method => 'group_money_summary',
- api_name => 'open-ils.actor.usergroup.members.balance_owed',
- authoritative => 1,
- signature => q/
- /
-);
-
-sub group_money_summary {
- my($self, $conn, $auth, $group_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER');
-
- my $users = $e->search_actor_user({usrgroup => $group_id}, {idlist => 1});
- my @mous;
-
- for my $uid ( @$users ) {
- push @mous, @{$e->json_query(
- {
- select => {mous => ['usr', 'balance_owed']},
- from => 'mous',
- where => { usr => $uid }
- }
- )};
- }
-
- return \@mous;
-}
-
-
-__PACKAGE__->register_method(
- method => 'get_users_from_usergroup',
- api_name => 'open-ils.actor.usergroup.members.retrieve',
- authoritative => 1,
- signature => q/
- Returns a list of ids for users that are in the given usergroup
- /
-);
-
-sub get_users_from_usergroup {
- my( $self, $conn, $auth, $usergroup ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER'); # XXX reley on editor perm
- return $e->search_actor_user({usrgroup => $usergroup}, {idlist => 1});
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'get_leaders_from_usergroup',
- api_name => 'open-ils.actor.usergroup.leaders.retrieve',
- signature => q/
- Returns a list of ids for users that are leaders of the given usergroup
- /
-);
-
-sub get_leaders_from_usergroup {
- my( $self, $conn, $auth, $usergroup ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER'); # XXX reley on editor perm
- my $users = $e->search_actor_user({usrgroup => $usergroup})
- or return $e->event;
-
- my @res;
- for my $u (@$users) {
- push( @res, $u->id ) if $u->master_account;
- }
-
- return \@res;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'get_address_members',
- api_name => 'open-ils.actor.address.members',
- signature => q/
- Returns a list of ids for users that link to the given address
- @param auth
- @param addrid The address id
- /
-);
-
-sub get_address_members {
- my( $self, $conn, $auth, $addrid ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER'); # XXX reley on editor perm
-
- my $ad = $e->retrieve_actor_user_address($addrid) or return $e->event;
- my $ma = $e->search_actor_user({mailing_address => $addrid}, {idlist => 1});
- my $ba = $e->search_actor_user({billing_address => $addrid}, {idlist => 1});
-
- my @list = (@$ma, @$ba, $ad->usr);
- my %dedup = map { $_ => 1 } @list;
- return [ keys %dedup ];
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'reset_group',
- api_name => 'open-ils.actor.usergroup.new',
- signature => q/
- Gives the requested user a new empty usergroup.
- @param auth The auth token
- @param userid The id of the user who needs the new usergroup
- @param leader If true, this user will be marked as the group leader
- /
-);
-
-sub reset_group {
- my( $self, $conn, $auth, $userid, $leader ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('UPDATE_USER'); # XXX reley on editor perm
-
- my $user = $e->retrieve_actor_user($userid) or return $e->die_event;
-
- # ask for a new group id
- my $groupid = $U->storagereq('open-ils.storage.actor.user.group_id.new');
-
- $user->usrgroup($groupid);
- $user->master_account('t') if $leader;
-
- $e->update_actor_user($user) or return $e->die_event;
- $e->commit;
- return $groupid;
-}
-
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::AppUtils;
-# vim:noet:ts=4
-use strict; use warnings;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use OpenSRF::Utils::Cache;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Utils::ModsParser;
-use OpenSRF::EX qw(:try);
-use OpenILS::Event;
-use Data::Dumper;
-use OpenILS::Utils::CStoreEditor;
-use OpenILS::Const qw/:const/;
-use Unicode::Normalize;
-use OpenSRF::Utils::SettingsClient;
-use UUID::Tiny;
-use Encode;
-
-# ---------------------------------------------------------------------------
-# Pile of utilty methods used accross applications.
-# ---------------------------------------------------------------------------
-my $cache_client = "OpenSRF::Utils::Cache";
-
-
-# ---------------------------------------------------------------------------
-# on sucess, returns the created session, on failure throws ERROR exception
-# ---------------------------------------------------------------------------
-sub start_db_session {
-
- my $self = shift;
- my $session = OpenSRF::AppSession->connect( "open-ils.storage" );
- my $trans_req = $session->request( "open-ils.storage.transaction.begin" );
-
- my $trans_resp = $trans_req->recv();
- if(ref($trans_resp) and UNIVERSAL::isa($trans_resp,"Error")) { throw $trans_resp; }
- if( ! $trans_resp->content() ) {
- throw OpenSRF::ERROR
- ("Unable to Begin Transaction with database" );
- }
- $trans_req->finish();
-
- $logger->debug("Setting global storage session to ".
- "session: " . $session->session_id . " : " . $session->app );
-
- return $session;
-}
-
-my $PERM_QUERY = {
- select => {
- au => [ {
- transform => 'permission.usr_has_perm',
- alias => 'has_perm',
- column => 'id',
- params => []
- } ]
- },
- from => 'au',
- where => {},
-};
-
-
-# returns undef if user has all of the perms provided
-# returns the first failed perm on failure
-sub check_user_perms {
- my($self, $user_id, $org_id, @perm_types ) = @_;
- $logger->debug("Checking perms with user : $user_id , org: $org_id, @perm_types");
-
- for my $type (@perm_types) {
- $PERM_QUERY->{select}->{au}->[0]->{params} = [$type, $org_id];
- $PERM_QUERY->{where}->{id} = $user_id;
- return $type unless $self->is_true(OpenILS::Utils::CStoreEditor->new->json_query($PERM_QUERY)->[0]->{has_perm});
- }
- return undef;
-}
-
-# checks the list of user perms. The first one that fails returns a new
-sub check_perms {
- my( $self, $user_id, $org_id, @perm_types ) = @_;
- my $t = $self->check_user_perms( $user_id, $org_id, @perm_types );
- return OpenILS::Event->new('PERM_FAILURE', ilsperm => $t, ilspermloc => $org_id ) if $t;
- return undef;
-}
-
-
-
-# ---------------------------------------------------------------------------
-# commits and destroys the session
-# ---------------------------------------------------------------------------
-sub commit_db_session {
- my( $self, $session ) = @_;
-
- my $req = $session->request( "open-ils.storage.transaction.commit" );
- my $resp = $req->recv();
-
- if(!$resp) {
- throw OpenSRF::EX::ERROR ("Unable to commit db session");
- }
-
- if(UNIVERSAL::isa($resp,"Error")) {
- throw $resp ($resp->stringify);
- }
-
- if(!$resp->content) {
- throw OpenSRF::EX::ERROR ("Unable to commit db session");
- }
-
- $session->finish();
- $session->disconnect();
- $session->kill_me();
-}
-
-sub rollback_db_session {
- my( $self, $session ) = @_;
-
- my $req = $session->request("open-ils.storage.transaction.rollback");
- my $resp = $req->recv();
- if(UNIVERSAL::isa($resp,"Error")) { throw $resp; }
-
- $session->finish();
- $session->disconnect();
- $session->kill_me();
-}
-
-
-# returns undef it the event is not an ILS event
-# returns the event code otherwise
-sub event_code {
- my( $self, $evt ) = @_;
- return $evt->{ilsevent} if( ref($evt) eq 'HASH' and defined($evt->{ilsevent})) ;
- return undef;
-}
-
-# ---------------------------------------------------------------------------
-# Checks to see if a user is logged in. Returns the user record on success,
-# throws an exception on error.
-# ---------------------------------------------------------------------------
-sub check_user_session {
- my( $self, $user_session ) = @_;
-
- my $content = $self->simplereq(
- 'open-ils.auth',
- 'open-ils.auth.session.retrieve', $user_session);
-
- return undef if (!$content) or $self->event_code($content);
- return $content;
-}
-
-# generic simple request returning a scalar value
-sub simplereq {
- my($self, $service, $method, @params) = @_;
- return $self->simple_scalar_request($service, $method, @params);
-}
-
-
-sub simple_scalar_request {
- my($self, $service, $method, @params) = @_;
-
- my $session = OpenSRF::AppSession->create( $service );
-
- my $request = $session->request( $method, @params );
-
- my $val;
- my $err;
- try {
-
- $val = $request->gather(1);
-
- } catch Error with {
- $err = shift;
- };
-
- if( $err ) {
- warn "received error : service=$service : method=$method : params=".Dumper(\@params) . "\n $err";
- throw $err ("Call to $service for method $method \n failed with exception: $err : " );
- }
-
- return $val;
-}
-
-
-
-
-
-my $tree = undef;
-my $orglist = undef;
-my $org_typelist = undef;
-my $org_typelist_hash = {};
-
-sub __get_org_tree {
-
- # can we throw this version away??
-
- my $self = shift;
- if($tree) { return $tree; }
-
- # see if it's in the cache
- $tree = $cache_client->new()->get_cache('_orgtree');
- if($tree) { return $tree; }
-
- if(!$orglist) {
- warn "Retrieving Org Tree\n";
- $orglist = $self->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.actor.org_unit.search.atomic",
- { id => { '!=' => undef } }
- );
- }
-
- if( ! $org_typelist ) {
- warn "Retrieving org types\n";
- $org_typelist = $self->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.actor.org_unit_type.search.atomic",
- { id => { '!=' => undef } }
- );
- $self->build_org_type($org_typelist);
- }
-
- $tree = $self->build_org_tree($orglist,1);
- $cache_client->new()->put_cache('_orgtree', $tree);
- return $tree;
-
-}
-
-my $slimtree = undef;
-sub get_slim_org_tree {
-
- my $self = shift;
- if($slimtree) { return $slimtree; }
-
- # see if it's in the cache
- $slimtree = $cache_client->new()->get_cache('slimorgtree');
- if($slimtree) { return $slimtree; }
-
- if(!$orglist) {
- warn "Retrieving Org Tree\n";
- $orglist = $self->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.actor.org_unit.search.atomic",
- { id => { '!=' => undef } }
- );
- }
-
- $slimtree = $self->build_org_tree($orglist);
- $cache_client->new->put_cache('slimorgtree', $slimtree);
- return $slimtree;
-
-}
-
-
-sub build_org_type {
- my($self, $org_typelist) = @_;
- for my $type (@$org_typelist) {
- $org_typelist_hash->{$type->id()} = $type;
- }
-}
-
-
-
-sub build_org_tree {
-
- my( $self, $orglist, $add_types ) = @_;
-
- return $orglist unless ref $orglist;
- return $$orglist[0] if @$orglist == 1;
-
- my @list = sort {
- $a->ou_type <=> $b->ou_type ||
- $a->name cmp $b->name } @$orglist;
-
- for my $org (@list) {
-
- next unless ($org);
-
- if(!ref($org->ou_type()) and $add_types) {
- $org->ou_type( $org_typelist_hash->{$org->ou_type()});
- }
-
- next if (!defined($org->parent_ou) || $org->parent_ou eq "");
-
- my ($parent) = grep { $_->id == $org->parent_ou } @list;
- next unless $parent;
- $parent->children([]) unless defined($parent->children);
- push( @{$parent->children}, $org );
- }
-
- return $list[0];
-}
-
-sub fetch_closed_date {
- my( $self, $cd ) = @_;
- my $evt;
-
- $logger->debug("Fetching closed_date $cd from cstore");
-
- my $cd_obj = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.actor.org_unit.closed_date.retrieve', $cd );
-
- if(!$cd_obj) {
- $logger->info("closed_date $cd not found in the db");
- $evt = OpenILS::Event->new('ACTOR_USER_NOT_FOUND');
- }
-
- return ($cd_obj, $evt);
-}
-
-sub fetch_user {
- my( $self, $userid ) = @_;
- my( $user, $evt );
-
- $logger->debug("Fetching user $userid from cstore");
-
- $user = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.actor.user.retrieve', $userid );
-
- if(!$user) {
- $logger->info("User $userid not found in the db");
- $evt = OpenILS::Event->new('ACTOR_USER_NOT_FOUND');
- }
-
- return ($user, $evt);
-}
-
-sub checkses {
- my( $self, $session ) = @_;
- my $user = $self->check_user_session($session) or
- return (undef, OpenILS::Event->new('NO_SESSION'));
- return ($user);
-}
-
-
-# verifiese the session and checks the permissions agains the
-# session user and the user's home_ou as the org id
-sub checksesperm {
- my( $self, $session, @perms ) = @_;
- my $user; my $evt; my $e;
- $logger->debug("Checking user session $session and perms @perms");
- ($user, $evt) = $self->checkses($session);
- return (undef, $evt) if $evt;
- $evt = $self->check_perms($user->id, $user->home_ou, @perms);
- return ($user, $evt);
-}
-
-
-sub checkrequestor {
- my( $self, $staffobj, $userid, @perms ) = @_;
- my $user; my $evt;
- $userid = $staffobj->id unless defined $userid;
-
- $logger->debug("checkrequestor(): requestor => " . $staffobj->id . ", target => $userid");
-
- if( $userid ne $staffobj->id ) {
- ($user, $evt) = $self->fetch_user($userid);
- return (undef, $evt) if $evt;
- $evt = $self->check_perms( $staffobj->id, $user->home_ou, @perms );
-
- } else {
- $user = $staffobj;
- }
-
- return ($user, $evt);
-}
-
-sub checkses_requestor {
- my( $self, $authtoken, $targetid, @perms ) = @_;
- my( $requestor, $target, $evt );
-
- ($requestor, $evt) = $self->checkses($authtoken);
- return (undef, undef, $evt) if $evt;
-
- ($target, $evt) = $self->checkrequestor( $requestor, $targetid, @perms );
- return( $requestor, $target, $evt);
-}
-
-sub fetch_copy {
- my( $self, $copyid ) = @_;
- my( $copy, $evt );
-
- $logger->debug("Fetching copy $copyid from cstore");
-
- $copy = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.asset.copy.retrieve', $copyid );
-
- if(!$copy) { $evt = OpenILS::Event->new('ASSET_COPY_NOT_FOUND'); }
-
- return( $copy, $evt );
-}
-
-
-# retrieves a circ object by id
-sub fetch_circulation {
- my( $self, $circid ) = @_;
- my $circ; my $evt;
-
- $logger->debug("Fetching circ $circid from cstore");
-
- $circ = $self->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.action.circulation.retrieve", $circid );
-
- if(!$circ) {
- $evt = OpenILS::Event->new('ACTION_CIRCULATION_NOT_FOUND', circid => $circid );
- }
-
- return ( $circ, $evt );
-}
-
-sub fetch_record_by_copy {
- my( $self, $copyid ) = @_;
- my( $record, $evt );
-
- $logger->debug("Fetching record by copy $copyid from cstore");
-
- $record = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.asset.copy.retrieve', $copyid,
- { flesh => 3,
- flesh_fields => { bre => [ 'fixed_fields' ],
- acn => [ 'record' ],
- acp => [ 'call_number' ],
- }
- }
- );
-
- if(!$record) {
- $evt = OpenILS::Event->new('BIBLIO_RECORD_ENTRY_NOT_FOUND');
- } else {
- $record = $record->call_number->record;
- }
-
- return ($record, $evt);
-}
-
-# turns a record object into an mvr (mods) object
-sub record_to_mvr {
- my( $self, $record ) = @_;
- return undef unless $record and $record->marc;
- my $u = OpenILS::Utils::ModsParser->new();
- $u->start_mods_batch( $record->marc );
- my $mods = $u->finish_mods_batch();
- $mods->doc_id($record->id);
- $mods->tcn($record->tcn_value);
- return $mods;
-}
-
-sub fetch_hold {
- my( $self, $holdid ) = @_;
- my( $hold, $evt );
-
- $logger->debug("Fetching hold $holdid from cstore");
-
- $hold = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.action.hold_request.retrieve', $holdid);
-
- $evt = OpenILS::Event->new('ACTION_HOLD_REQUEST_NOT_FOUND', holdid => $holdid) unless $hold;
-
- return ($hold, $evt);
-}
-
-
-sub fetch_hold_transit_by_hold {
- my( $self, $holdid ) = @_;
- my( $transit, $evt );
-
- $logger->debug("Fetching transit by hold $holdid from cstore");
-
- $transit = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.action.hold_transit_copy.search', { hold => $holdid } );
-
- $evt = OpenILS::Event->new('ACTION_HOLD_TRANSIT_COPY_NOT_FOUND', holdid => $holdid) unless $transit;
-
- return ($transit, $evt );
-}
-
-# fetches the captured, but not fulfilled hold attached to a given copy
-sub fetch_open_hold_by_copy {
- my( $self, $copyid ) = @_;
- $logger->debug("Searching for active hold for copy $copyid");
- my( $hold, $evt );
-
- $hold = $self->cstorereq(
- 'open-ils.cstore.direct.action.hold_request.search',
- {
- current_copy => $copyid ,
- capture_time => { "!=" => undef },
- fulfillment_time => undef,
- cancel_time => undef,
- } );
-
- $evt = OpenILS::Event->new('ACTION_HOLD_REQUEST_NOT_FOUND', copyid => $copyid) unless $hold;
- return ($hold, $evt);
-}
-
-sub fetch_hold_transit {
- my( $self, $transid ) = @_;
- my( $htransit, $evt );
- $logger->debug("Fetching hold transit with hold id $transid");
- $htransit = $self->cstorereq(
- 'open-ils.cstore.direct.action.hold_transit_copy.retrieve', $transid );
- $evt = OpenILS::Event->new('ACTION_HOLD_TRANSIT_COPY_NOT_FOUND', id => $transid) unless $htransit;
- return ($htransit, $evt);
-}
-
-sub fetch_copy_by_barcode {
- my( $self, $barcode ) = @_;
- my( $copy, $evt );
-
- $logger->debug("Fetching copy by barcode $barcode from cstore");
-
- $copy = $self->simplereq( 'open-ils.cstore',
- 'open-ils.cstore.direct.asset.copy.search', { barcode => $barcode, deleted => 'f'} );
- #'open-ils.storage.direct.asset.copy.search.barcode', $barcode );
-
- $evt = OpenILS::Event->new('ASSET_COPY_NOT_FOUND', barcode => $barcode) unless $copy;
-
- return ($copy, $evt);
-}
-
-sub fetch_open_billable_transaction {
- my( $self, $transid ) = @_;
- my( $transaction, $evt );
-
- $logger->debug("Fetching open billable transaction $transid from cstore");
-
- $transaction = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.money.open_billable_transaction_summary.retrieve', $transid);
-
- $evt = OpenILS::Event->new(
- 'MONEY_OPEN_BILLABLE_TRANSACTION_SUMMARY_NOT_FOUND', transid => $transid ) unless $transaction;
-
- return ($transaction, $evt);
-}
-
-
-
-my %buckets;
-$buckets{'biblio'} = 'biblio_record_entry_bucket';
-$buckets{'callnumber'} = 'call_number_bucket';
-$buckets{'copy'} = 'copy_bucket';
-$buckets{'user'} = 'user_bucket';
-
-sub fetch_container {
- my( $self, $id, $type ) = @_;
- my( $bucket, $evt );
-
- $logger->debug("Fetching container $id with type $type");
-
- my $e = 'CONTAINER_CALL_NUMBER_BUCKET_NOT_FOUND';
- $e = 'CONTAINER_BIBLIO_RECORD_ENTRY_BUCKET_NOT_FOUND' if $type eq 'biblio';
- $e = 'CONTAINER_USER_BUCKET_NOT_FOUND' if $type eq 'user';
- $e = 'CONTAINER_COPY_BUCKET_NOT_FOUND' if $type eq 'copy';
-
- my $meth = $buckets{$type};
- $bucket = $self->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.container.$meth.retrieve", $id );
-
- $evt = OpenILS::Event->new(
- $e, container => $id, container_type => $type ) unless $bucket;
-
- return ($bucket, $evt);
-}
-
-
-sub fetch_container_e {
- my( $self, $editor, $id, $type ) = @_;
-
- my( $bucket, $evt );
- $bucket = $editor->retrieve_container_copy_bucket($id) if $type eq 'copy';
- $bucket = $editor->retrieve_container_call_number_bucket($id) if $type eq 'callnumber';
- $bucket = $editor->retrieve_container_biblio_record_entry_bucket($id) if $type eq 'biblio';
- $bucket = $editor->retrieve_container_user_bucket($id) if $type eq 'user';
-
- $evt = $editor->event unless $bucket;
- return ($bucket, $evt);
-}
-
-sub fetch_container_item_e {
- my( $self, $editor, $id, $type ) = @_;
-
- my( $bucket, $evt );
- $bucket = $editor->retrieve_container_copy_bucket_item($id) if $type eq 'copy';
- $bucket = $editor->retrieve_container_call_number_bucket_item($id) if $type eq 'callnumber';
- $bucket = $editor->retrieve_container_biblio_record_entry_bucket_item($id) if $type eq 'biblio';
- $bucket = $editor->retrieve_container_user_bucket_item($id) if $type eq 'user';
-
- $evt = $editor->event unless $bucket;
- return ($bucket, $evt);
-}
-
-
-
-
-
-sub fetch_container_item {
- my( $self, $id, $type ) = @_;
- my( $bucket, $evt );
-
- $logger->debug("Fetching container item $id with type $type");
-
- my $meth = $buckets{$type} . "_item";
-
- $bucket = $self->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.container.$meth.retrieve", $id );
-
-
- my $e = 'CONTAINER_CALL_NUMBER_BUCKET_ITEM_NOT_FOUND';
- $e = 'CONTAINER_BIBLIO_RECORD_ENTRY_BUCKET_ITEM_NOT_FOUND' if $type eq 'biblio';
- $e = 'CONTAINER_USER_BUCKET_ITEM_NOT_FOUND' if $type eq 'user';
- $e = 'CONTAINER_COPY_BUCKET_ITEM_NOT_FOUND' if $type eq 'copy';
-
- $evt = OpenILS::Event->new(
- $e, itemid => $id, container_type => $type ) unless $bucket;
-
- return ($bucket, $evt);
-}
-
-
-sub fetch_patron_standings {
- my $self = shift;
- $logger->debug("Fetching patron standings");
- return $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.standing.search.atomic', { id => { '!=' => undef } });
-}
-
-
-sub fetch_permission_group_tree {
- my $self = shift;
- $logger->debug("Fetching patron profiles");
- return $self->simplereq(
- 'open-ils.actor',
- 'open-ils.actor.groups.tree.retrieve' );
-}
-
-sub fetch_permission_group_descendants {
- my( $self, $profile ) = @_;
- my $group_tree = $self->fetch_permission_group_tree();
- my $start_here;
- my @groups;
-
- # FIXME: okay, so it's not an org tree, but it is compatible
- $self->walk_org_tree($group_tree, sub {
- my $g = shift;
- if ($g->id == $profile) {
- $start_here = $g;
- }
- });
-
- $self->walk_org_tree($start_here, sub {
- my $g = shift;
- push(@groups,$g->id);
- });
-
- return \@groups;
-}
-
-sub fetch_patron_circ_summary {
- my( $self, $userid ) = @_;
- $logger->debug("Fetching patron summary for $userid");
- my $summary = $self->simplereq(
- 'open-ils.storage',
- "open-ils.storage.action.circulation.patron_summary", $userid );
-
- if( $summary ) {
- $summary->[0] ||= 0;
- $summary->[1] ||= 0.0;
- return $summary;
- }
- return undef;
-}
-
-
-sub fetch_copy_statuses {
- my( $self ) = @_;
- $logger->debug("Fetching copy statuses");
- return $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.copy_status.search.atomic', { id => { '!=' => undef } });
-}
-
-sub fetch_copy_location {
- my( $self, $id ) = @_;
- my $evt;
- my $cl = $self->cstorereq(
- 'open-ils.cstore.direct.asset.copy_location.retrieve', $id );
- $evt = OpenILS::Event->new('ASSET_COPY_LOCATION_NOT_FOUND') unless $cl;
- return ($cl, $evt);
-}
-
-sub fetch_copy_locations {
- my $self = shift;
- return $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.asset.copy_location.search.atomic', { id => { '!=' => undef } });
-}
-
-sub fetch_copy_location_by_name {
- my( $self, $name, $org ) = @_;
- my $evt;
- my $cl = $self->cstorereq(
- 'open-ils.cstore.direct.asset.copy_location.search',
- { name => $name, owning_lib => $org } );
- $evt = OpenILS::Event->new('ASSET_COPY_LOCATION_NOT_FOUND') unless $cl;
- return ($cl, $evt);
-}
-
-sub fetch_callnumber {
- my( $self, $id ) = @_;
- my $evt = undef;
-
- my $e = OpenILS::Event->new( 'ASSET_CALL_NUMBER_NOT_FOUND', id => $id );
- return( undef, $e ) unless $id;
-
- $logger->debug("Fetching callnumber $id");
-
- my $cn = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.asset.call_number.retrieve', $id );
- $evt = $e unless $cn;
-
- return ( $cn, $evt );
-}
-
-my %ORG_CACHE; # - these rarely change, so cache them..
-sub fetch_org_unit {
- my( $self, $id ) = @_;
- return undef unless $id;
- return $id if( ref($id) eq 'Fieldmapper::actor::org_unit' );
- return $ORG_CACHE{$id} if $ORG_CACHE{$id};
- $logger->debug("Fetching org unit $id");
- my $evt = undef;
-
- my $org = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.actor.org_unit.retrieve', $id );
- $evt = OpenILS::Event->new( 'ACTOR_ORG_UNIT_NOT_FOUND', id => $id ) unless $org;
- $ORG_CACHE{$id} = $org;
-
- return ($org, $evt);
-}
-
-sub fetch_stat_cat {
- my( $self, $type, $id ) = @_;
- my( $cat, $evt );
- $logger->debug("Fetching $type stat cat: $id");
- $cat = $self->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.$type.stat_cat.retrieve", $id );
-
- my $e = 'ASSET_STAT_CAT_NOT_FOUND';
- $e = 'ACTOR_STAT_CAT_NOT_FOUND' if $type eq 'actor';
-
- $evt = OpenILS::Event->new( $e, id => $id ) unless $cat;
- return ( $cat, $evt );
-}
-
-sub fetch_stat_cat_entry {
- my( $self, $type, $id ) = @_;
- my( $entry, $evt );
- $logger->debug("Fetching $type stat cat entry: $id");
- $entry = $self->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.$type.stat_cat_entry.retrieve", $id );
-
- my $e = 'ASSET_STAT_CAT_ENTRY_NOT_FOUND';
- $e = 'ACTOR_STAT_CAT_ENTRY_NOT_FOUND' if $type eq 'actor';
-
- $evt = OpenILS::Event->new( $e, id => $id ) unless $entry;
- return ( $entry, $evt );
-}
-
-
-sub find_org {
- my( $self, $org_tree, $orgid ) = @_;
- return undef unless $org_tree and defined $orgid;
- return $org_tree if ( $org_tree->id eq $orgid );
- return undef unless ref($org_tree->children);
- for my $c (@{$org_tree->children}) {
- my $o = $self->find_org($c, $orgid);
- return $o if $o;
- }
- return undef;
-}
-
-sub fetch_non_cat_type_by_name_and_org {
- my( $self, $name, $orgId ) = @_;
- $logger->debug("Fetching non cat type $name at org $orgId");
- my $types = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.non_cataloged_type.search.atomic',
- { name => $name, owning_lib => $orgId } );
- return ($types->[0], undef) if($types and @$types);
- return (undef, OpenILS::Event->new('CONFIG_NON_CATALOGED_TYPE_NOT_FOUND') );
-}
-
-sub fetch_non_cat_type {
- my( $self, $id ) = @_;
- $logger->debug("Fetching non cat type $id");
- my( $type, $evt );
- $type = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.non_cataloged_type.retrieve', $id );
- $evt = OpenILS::Event->new('CONFIG_NON_CATALOGED_TYPE_NOT_FOUND') unless $type;
- return ($type, $evt);
-}
-
-sub DB_UPDATE_FAILED {
- my( $self, $payload ) = @_;
- return OpenILS::Event->new('DATABASE_UPDATE_FAILED',
- payload => ($payload) ? $payload : undef );
-}
-
-sub fetch_booking_reservation {
- my( $self, $id ) = @_;
- my( $res, $evt );
-
- $res = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.booking.reservation.retrieve', $id
- );
-
- # simplereq doesn't know how to flesh so ...
- if ($res) {
- $res->usr(
- $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.actor.user.retrieve', $res->usr
- )
- );
-
- $res->target_resource_type(
- $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.booking.resource_type.retrieve', $res->target_resource_type
- )
- );
-
- if ($res->current_resource) {
- $res->current_resource(
- $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.booking.resource.retrieve', $res->current_resource
- )
- );
-
- if ($self->is_true( $res->target_resource_type->catalog_item )) {
- $res->current_resource->catalog_item( $self->fetch_copy_by_barcode( $res->current_resource->barcode ) );
- }
- }
-
- if ($res->target_resource) {
- $res->target_resource(
- $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.booking.resource.retrieve', $res->target_resource
- )
- );
-
- if ($self->is_true( $res->target_resource_type->catalog_item )) {
- $res->target_resource->catalog_item( $self->fetch_copy_by_barcode( $res->target_resource->barcode ) );
- }
- }
-
- } else {
- $evt = OpenILS::Event->new('RESERVATION_NOT_FOUND');
- }
-
- return ($res, $evt);
-}
-
-sub fetch_circ_duration_by_name {
- my( $self, $name ) = @_;
- my( $dur, $evt );
- $dur = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.rules.circ_duration.search.atomic', { name => $name } );
- $dur = $dur->[0];
- $evt = OpenILS::Event->new('CONFIG_RULES_CIRC_DURATION_NOT_FOUND') unless $dur;
- return ($dur, $evt);
-}
-
-sub fetch_recurring_fine_by_name {
- my( $self, $name ) = @_;
- my( $obj, $evt );
- $obj = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.rules.recurring_fine.search.atomic', { name => $name } );
- $obj = $obj->[0];
- $evt = OpenILS::Event->new('CONFIG_RULES_RECURRING_FINE_NOT_FOUND') unless $obj;
- return ($obj, $evt);
-}
-
-sub fetch_max_fine_by_name {
- my( $self, $name ) = @_;
- my( $obj, $evt );
- $obj = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.rules.max_fine.search.atomic', { name => $name } );
- $obj = $obj->[0];
- $evt = OpenILS::Event->new('CONFIG_RULES_MAX_FINE_NOT_FOUND') unless $obj;
- return ($obj, $evt);
-}
-
-sub fetch_hard_due_date_by_name {
- my( $self, $name ) = @_;
- my( $obj, $evt );
- $obj = $self->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.config.hard_due_date.search.atomic', { name => $name } );
- $obj = $obj->[0];
- $evt = OpenILS::Event->new('CONFIG_RULES_HARD_DUE_DATE_NOT_FOUND') unless $obj;
- return ($obj, $evt);
-}
-
-sub storagereq {
- my( $self, $method, @params ) = @_;
- return $self->simplereq(
- 'open-ils.storage', $method, @params );
-}
-
-sub storagereq_xact {
- my($self, $method, @params) = @_;
- my $ses = $self->start_db_session();
- my $val = $ses->request($method, @params)->gather(1);
- $self->rollback_db_session($ses);
- return $val;
-}
-
-sub cstorereq {
- my( $self, $method, @params ) = @_;
- return $self->simplereq(
- 'open-ils.cstore', $method, @params );
-}
-
-sub event_equals {
- my( $self, $e, $name ) = @_;
- if( $e and ref($e) eq 'HASH' and
- defined($e->{textcode}) and $e->{textcode} eq $name ) {
- return 1 ;
- }
- return 0;
-}
-
-sub logmark {
- my( undef, $f, $l ) = caller(0);
- my( undef, undef, undef, $s ) = caller(1);
- $s =~ s/.*:://g;
- $f =~ s/.*\///g;
- $logger->debug("LOGMARK: $f:$l:$s");
-}
-
-# takes a copy id
-sub fetch_open_circulation {
- my( $self, $cid ) = @_;
- $self->logmark;
-
- my $e = OpenILS::Utils::CStoreEditor->new;
- my $circ = $e->search_action_circulation({
- target_copy => $cid,
- stop_fines_time => undef,
- checkin_time => undef
- })->[0];
-
- return ($circ, $e->event);
-}
-
-my $copy_statuses;
-sub copy_status_from_name {
- my( $self, $name ) = @_;
- $copy_statuses = $self->fetch_copy_statuses unless $copy_statuses;
- for my $status (@$copy_statuses) {
- return $status if( $status->name =~ /$name/i );
- }
- return undef;
-}
-
-sub copy_status_to_name {
- my( $self, $sid ) = @_;
- $copy_statuses = $self->fetch_copy_statuses unless $copy_statuses;
- for my $status (@$copy_statuses) {
- return $status->name if( $status->id == $sid );
- }
- return undef;
-}
-
-
-sub copy_status {
- my( $self, $arg ) = @_;
- return $arg if ref $arg;
- $copy_statuses = $self->fetch_copy_statuses unless $copy_statuses;
- my ($stat) = grep { $_->id == $arg } @$copy_statuses;
- return $stat;
-}
-
-sub fetch_open_transit_by_copy {
- my( $self, $copyid ) = @_;
- my($transit, $evt);
- $transit = $self->cstorereq(
- 'open-ils.cstore.direct.action.transit_copy.search',
- { target_copy => $copyid, dest_recv_time => undef });
- $evt = OpenILS::Event->new('ACTION_TRANSIT_COPY_NOT_FOUND') unless $transit;
- return ($transit, $evt);
-}
-
-sub unflesh_copy {
- my( $self, $copy ) = @_;
- return undef unless $copy;
- $copy->status( $copy->status->id ) if ref($copy->status);
- $copy->location( $copy->location->id ) if ref($copy->location);
- $copy->circ_lib( $copy->circ_lib->id ) if ref($copy->circ_lib);
- return $copy;
-}
-
-sub unflesh_reservation {
- my( $self, $reservation ) = @_;
- return undef unless $reservation;
- $reservation->usr( $reservation->usr->id ) if ref($reservation->usr);
- $reservation->target_resource_type( $reservation->target_resource_type->id ) if ref($reservation->target_resource_type);
- $reservation->target_resource( $reservation->target_resource->id ) if ref($reservation->target_resource);
- $reservation->current_resource( $reservation->current_resource->id ) if ref($reservation->current_resource);
- return $reservation;
-}
-
-# un-fleshes a copy and updates it in the DB
-# returns a DB_UPDATE_FAILED event on error
-# returns undef on success
-sub update_copy {
- my( $self, %params ) = @_;
-
- my $copy = $params{copy} || die "update_copy(): copy required";
- my $editor = $params{editor} || die "update_copy(): copy editor required";
- my $session = $params{session};
-
- $logger->debug("Updating copy in the database: " . $copy->id);
-
- $self->unflesh_copy($copy);
- $copy->editor( $editor );
- $copy->edit_date( 'now' );
-
- my $s;
- my $meth = 'open-ils.storage.direct.asset.copy.update';
-
- $s = $session->request( $meth, $copy )->gather(1) if $session;
- $s = $self->storagereq( $meth, $copy ) unless $session;
-
- $logger->debug("Update of copy ".$copy->id." returned: $s");
-
- return $self->DB_UPDATE_FAILED($copy) unless $s;
- return undef;
-}
-
-sub update_reservation {
- my( $self, %params ) = @_;
-
- my $reservation = $params{reservation} || die "update_reservation(): reservation required";
- my $editor = $params{editor} || die "update_reservation(): copy editor required";
- my $session = $params{session};
-
- $logger->debug("Updating copy in the database: " . $reservation->id);
-
- $self->unflesh_reservation($reservation);
-
- my $s;
- my $meth = 'open-ils.cstore.direct.booking.reservation.update';
-
- $s = $session->request( $meth, $reservation )->gather(1) if $session;
- $s = $self->cstorereq( $meth, $reservation ) unless $session;
-
- $logger->debug("Update of copy ".$reservation->id." returned: $s");
-
- return $self->DB_UPDATE_FAILED($reservation) unless $s;
- return undef;
-}
-
-sub fetch_billable_xact {
- my( $self, $id ) = @_;
- my($xact, $evt);
- $logger->debug("Fetching billable transaction %id");
- $xact = $self->cstorereq(
- 'open-ils.cstore.direct.money.billable_transaction.retrieve', $id );
- $evt = OpenILS::Event->new('MONEY_BILLABLE_TRANSACTION_NOT_FOUND') unless $xact;
- return ($xact, $evt);
-}
-
-sub fetch_billable_xact_summary {
- my( $self, $id ) = @_;
- my($xact, $evt);
- $logger->debug("Fetching billable transaction summary %id");
- $xact = $self->cstorereq(
- 'open-ils.cstore.direct.money.billable_transaction_summary.retrieve', $id );
- $evt = OpenILS::Event->new('MONEY_BILLABLE_TRANSACTION_NOT_FOUND') unless $xact;
- return ($xact, $evt);
-}
-
-sub fetch_fleshed_copy {
- my( $self, $id ) = @_;
- my( $copy, $evt );
- $logger->info("Fetching fleshed copy $id");
- $copy = $self->cstorereq(
- "open-ils.cstore.direct.asset.copy.retrieve", $id,
- { flesh => 1,
- flesh_fields => { acp => [ qw/ circ_lib location status stat_cat_entries / ] }
- }
- );
- $evt = OpenILS::Event->new('ASSET_COPY_NOT_FOUND', id => $id) unless $copy;
- return ($copy, $evt);
-}
-
-
-# returns the org that owns the callnumber that the copy
-# is attached to
-sub fetch_copy_owner {
- my( $self, $copyid ) = @_;
- my( $copy, $cn, $evt );
- $logger->debug("Fetching copy owner $copyid");
- ($copy, $evt) = $self->fetch_copy($copyid);
- return (undef,$evt) if $evt;
- ($cn, $evt) = $self->fetch_callnumber($copy->call_number);
- return (undef,$evt) if $evt;
- return ($cn->owning_lib);
-}
-
-sub fetch_copy_note {
- my( $self, $id ) = @_;
- my( $note, $evt );
- $logger->debug("Fetching copy note $id");
- $note = $self->cstorereq(
- 'open-ils.cstore.direct.asset.copy_note.retrieve', $id );
- $evt = OpenILS::Event->new('ASSET_COPY_NOTE_NOT_FOUND', id => $id ) unless $note;
- return ($note, $evt);
-}
-
-sub fetch_call_numbers_by_title {
- my( $self, $titleid ) = @_;
- $logger->info("Fetching call numbers by title $titleid");
- return $self->cstorereq(
- 'open-ils.cstore.direct.asset.call_number.search.atomic',
- { record => $titleid, deleted => 'f' });
- #'open-ils.storage.direct.asset.call_number.search.record.atomic', $titleid);
-}
-
-sub fetch_copies_by_call_number {
- my( $self, $cnid ) = @_;
- $logger->info("Fetching copies by call number $cnid");
- return $self->cstorereq(
- 'open-ils.cstore.direct.asset.copy.search.atomic', { call_number => $cnid, deleted => 'f' } );
- #'open-ils.storage.direct.asset.copy.search.call_number.atomic', $cnid );
-}
-
-sub fetch_user_by_barcode {
- my( $self, $bc ) = @_;
- my $cardid = $self->cstorereq(
- 'open-ils.cstore.direct.actor.card.id_list', { barcode => $bc } );
- return (undef, OpenILS::Event->new('ACTOR_CARD_NOT_FOUND', barcode => $bc)) unless $cardid;
- my $user = $self->cstorereq(
- 'open-ils.cstore.direct.actor.user.search', { card => $cardid } );
- return (undef, OpenILS::Event->new('ACTOR_USER_NOT_FOUND', card => $cardid)) unless $user;
- return ($user);
-
-}
-
-sub fetch_bill {
- my( $self, $billid ) = @_;
- $logger->debug("Fetching billing $billid");
- my $bill = $self->cstorereq(
- 'open-ils.cstore.direct.money.billing.retrieve', $billid );
- my $evt = OpenILS::Event->new('MONEY_BILLING_NOT_FOUND') unless $bill;
- return($bill, $evt);
-}
-
-my $ORG_TREE;
-sub fetch_org_tree {
- my $self = shift;
- return $ORG_TREE if $ORG_TREE;
- return $ORG_TREE = OpenILS::Utils::CStoreEditor->new->search_actor_org_unit(
- [
- {"parent_ou" => undef },
- {
- flesh => -1,
- flesh_fields => { aou => ['children'] },
- order_by => { aou => 'name'}
- }
- ]
- )->[0];
-}
-
-sub walk_org_tree {
- my( $self, $node, $callback ) = @_;
- return unless $node;
- $callback->($node);
- if( $node->children ) {
- $self->walk_org_tree($_, $callback) for @{$node->children};
- }
-}
-
-sub is_true {
- my( $self, $item ) = @_;
- return 1 if $item and $item !~ /^f$/i;
- return 0;
-}
-
-
-sub patientreq {
- my ($self, $client, $service, $method, @params) = @_;
- my ($response, $err);
-
- my $session = create OpenSRF::AppSession($service);
- my $request = $session->request($method, @params);
-
- my $spurt = 10;
- my $give_up = time + 1000;
-
- try {
- while (time < $give_up) {
- $response = $request->recv("timeout" => $spurt);
- last if $request->complete;
-
- $client->status(new OpenSRF::DomainObject::oilsContinueStatus);
- }
- } catch Error with {
- $err = shift;
- };
-
- if ($err) {
- warn "received error : service=$service : method=$method : params=".Dumper(\@params) . "\n $err";
- throw $err ("Call to $service for method $method \n failed with exception: $err : " );
- }
-
- return $response->content;
-}
-
-# This logic now lives in storage
-sub __patron_money_owed {
- my( $self, $patronid ) = @_;
- my $ses = OpenSRF::AppSession->create('open-ils.storage');
- my $req = $ses->request(
- 'open-ils.storage.money.billable_transaction.summary.search',
- { usr => $patronid, xact_finish => undef } );
-
- my $total = 0;
- my $data;
- while( $data = $req->recv ) {
- $data = $data->content;
- $total += $data->balance_owed;
- }
- return $total;
-}
-
-sub patron_money_owed {
- my( $self, $userid ) = @_;
- my $ses = $self->start_db_session();
- my $val = $ses->request(
- 'open-ils.storage.actor.user.total_owed', $userid)->gather(1);
- $self->rollback_db_session($ses);
- return $val;
-}
-
-sub patron_total_items_out {
- my( $self, $userid ) = @_;
- my $ses = $self->start_db_session();
- my $val = $ses->request(
- 'open-ils.storage.actor.user.total_out', $userid)->gather(1);
- $self->rollback_db_session($ses);
- return $val;
-}
-
-
-
-
-#---------------------------------------------------------------------
-# Returns ($summary, $event)
-#---------------------------------------------------------------------
-sub fetch_mbts {
- my $self = shift;
- my $id = shift;
- my $e = shift || OpenILS::Utils::CStoreEditor->new;
- $id = $id->id if ref($id);
-
- my $xact = $e->retrieve_money_billable_transaction_summary($id)
- or return (undef, $e->event);
-
- return ($xact);
-}
-
-
-#---------------------------------------------------------------------
-# Given a list of money.billable_transaction objects, this creates
-# transaction summary objects for each
-#--------------------------------------------------------------------
-sub make_mbts {
- my $self = shift;
- my $e = shift;
- my @xacts = @_;
- return () if (!@xacts);
- return @{$e->search_money_billable_transaction_summary({id => [ map { $_->id } @xacts ]})};
-}
-
-
-sub ou_ancestor_setting_value {
- my($self, $org_id, $name, $e) = @_;
- $e = $e || OpenILS::Utils::CStoreEditor->new;
- my $set = $self->ou_ancestor_setting($org_id, $name, $e);
- return $set->{value} if $set;
- return undef;
-}
-
-
-# If an authentication token is provided AND this org unit setting has a
-# view_perm, then make sure the user referenced by the auth token has
-# that permission. This means that if you call this method without an
-# authtoken param, you can get whatever org unit setting values you want.
-# API users beware.
-#
-# NOTE: If you supply an editor ($e) arg AND an auth token arg, the editor's
-# authtoken is checked, but the $auth arg is NOT checked. To say that another
-# way, be sure NOT to pass an editor argument if you want your token checked.
-# Otherwise the auth arg is just a flag saying "check the editor".
-
-sub ou_ancestor_setting {
- my( $self, $orgid, $name, $e, $auth ) = @_;
- $e = $e || OpenILS::Utils::CStoreEditor->new(
- (defined $auth) ? (authtoken => $auth) : ()
- );
- my $coust = $e->retrieve_config_org_unit_setting_type([
- $name, {flesh => 1, flesh_fields => {coust => ['view_perm']}}
- ]);
-
- if ($auth && $coust && $coust->view_perm) {
- # And you can't have permission if you don't have a valid session.
- return undef if not $e->checkauth;
- # And now that we know you MIGHT have permission, we check it.
- return undef if not $e->allowed($coust->view_perm->code, $orgid);
- }
-
- my $query = {from => ['actor.org_unit_ancestor_setting', $name, $orgid]};
- my $setting = $e->json_query($query)->[0];
- return undef unless $setting;
- return {org => $setting->{org_unit}, value => OpenSRF::Utils::JSON->JSON2perl($setting->{value})};
-}
-
-
-# returns the ISO8601 string representation of the requested epoch in GMT
-sub epoch2ISO8601 {
- my( $self, $epoch ) = @_;
- my ($sec,$min,$hour,$mday,$mon,$year) = gmtime($epoch);
- $year += 1900; $mon += 1;
- my $date = sprintf(
- '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d-00',
- $year, $mon, $mday, $hour, $min, $sec);
- return $date;
-}
-
-sub find_highest_perm_org {
- my ( $self, $perm, $userid, $start_org, $org_tree ) = @_;
- my $org = $self->find_org($org_tree, $start_org );
-
- my $lastid = -1;
- while( $org ) {
- last if ($self->check_perms( $userid, $org->id, $perm )); # perm failed
- $lastid = $org->id;
- $org = $self->find_org( $org_tree, $org->parent_ou() );
- }
-
- return $lastid;
-}
-
-
-# returns the org_unit ID's
-sub user_has_work_perm_at {
- my($self, $e, $perm, $options, $user_id) = @_;
- $options ||= {};
- $user_id = (defined $user_id) ? $user_id : $e->requestor->id;
-
- my $func = 'permission.usr_has_perm_at';
- $func = $func.'_all' if $$options{descendants};
-
- my $orgs = $e->json_query({from => [$func, $user_id, $perm]});
- $orgs = [map { $_->{ (keys %$_)[0] } } @$orgs];
-
- return $orgs unless $$options{objects};
-
- return $e->search_actor_org_unit({id => $orgs});
-}
-
-sub get_user_work_ou_ids {
- my($self, $e, $userid) = @_;
- my $work_orgs = $e->json_query({
- select => {puwoum => ['work_ou']},
- from => 'puwoum',
- where => {usr => $e->requestor->id}});
-
- return [] unless @$work_orgs;
- my @work_orgs;
- push(@work_orgs, $_->{work_ou}) for @$work_orgs;
-
- return \@work_orgs;
-}
-
-
-my $org_types;
-sub get_org_types {
- my($self, $client) = @_;
- return $org_types if $org_types;
- return $org_types = OpenILS::Utils::CStoreEditor->new->retrieve_all_actor_org_unit_type();
-}
-
-sub get_org_tree {
- my $self = shift;
- my $locale = shift || '';
- my $cache = OpenSRF::Utils::Cache->new("global", 0);
- my $tree = $cache->get_cache("orgtree.$locale");
- return $tree if $tree;
-
- my $ses = OpenILS::Utils::CStoreEditor->new;
- $ses->session->session_locale($locale);
- $tree = $ses->search_actor_org_unit(
- [
- {"parent_ou" => undef },
- {
- flesh => -1,
- flesh_fields => { aou => ['children'] },
- order_by => { aou => 'name'}
- }
- ]
- )->[0];
-
- $cache->put_cache("orgtree.$locale", $tree);
- return $tree;
-}
-
-sub get_org_descendants {
- my($self, $org_id, $depth) = @_;
-
- my $select = {
- transform => 'actor.org_unit_descendants',
- column => 'id',
- result_field => 'id',
- };
- $select->{params} = [$depth] if defined $depth;
-
- my $org_list = OpenILS::Utils::CStoreEditor->new->json_query({
- select => {aou => [$select]},
- from => 'aou',
- where => {id => $org_id}
- });
- my @orgs;
- push(@orgs, $_->{id}) for @$org_list;
- return \@orgs;
-}
-
-sub get_org_ancestors {
- my($self, $org_id) = @_;
-
- my $org_list = OpenILS::Utils::CStoreEditor->new->json_query({
- select => {
- aou => [{
- transform => 'actor.org_unit_ancestors',
- column => 'id',
- result_field => 'id',
- params => []
- }],
- },
- from => 'aou',
- where => {id => $org_id}
- });
-
- my @orgs;
- push(@orgs, $_->{id}) for @$org_list;
- return \@orgs;
-}
-
-sub get_org_full_path {
- my($self, $org_id, $depth) = @_;
-
- my $query = {
- select => {
- aou => [{
- transform => 'actor.org_unit_full_path',
- column => 'id',
- result_field => 'id',
- }],
- },
- from => 'aou',
- where => {id => $org_id}
- };
-
- $query->{select}->{aou}->[0]->{params} = [$depth] if defined $depth;
- my $org_list = OpenILS::Utils::CStoreEditor->new->json_query($query);
- return [ map {$_->{id}} @$org_list ];
-}
-
-# returns the ID of the org unit ancestor at the specified depth
-sub org_unit_ancestor_at_depth {
- my($class, $org_id, $depth) = @_;
- my $resp = OpenILS::Utils::CStoreEditor->new->json_query(
- {from => ['actor.org_unit_ancestor_at_depth', $org_id, $depth]})->[0];
- return ($resp) ? $resp->{id} : undef;
-}
-
-# returns the user's configured locale as a string. Defaults to en-US if none is configured.
-sub get_user_locale {
- my($self, $user_id, $e) = @_;
- $e ||= OpenILS::Utils::CStoreEditor->new;
-
- # first, see if the user has an explicit locale set
- my $setting = $e->search_actor_user_setting(
- {usr => $user_id, name => 'global.locale'})->[0];
- return OpenSRF::Utils::JSON->JSON2perl($setting->value) if $setting;
-
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $self->get_org_locale($user->home_ou, $e);
-}
-
-# returns org locale setting
-sub get_org_locale {
- my($self, $org_id, $e) = @_;
- $e ||= OpenILS::Utils::CStoreEditor->new;
-
- my $locale;
- if(defined $org_id) {
- $locale = $self->ou_ancestor_setting_value($org_id, 'global.default_locale', $e);
- return $locale if $locale;
- }
-
- # system-wide default
- my $sclient = OpenSRF::Utils::SettingsClient->new;
- $locale = $sclient->config_value('default_locale');
- return $locale if $locale;
-
- # if nothing else, fallback to locale=cowboy
- return 'en-US';
-}
-
-
-# xml-escape non-ascii characters
-sub entityize {
- my($self, $string, $form) = @_;
- $form ||= "";
-
- # If we're going to convert non-ASCII characters to XML entities,
- # we had better be dealing with a UTF8 string to begin with
- $string = decode_utf8($string);
-
- if ($form eq 'D') {
- $string = NFD($string);
- } else {
- $string = NFC($string);
- }
-
- # Convert raw ampersands to entities
- $string =~ s/&(?!\S+;)/&/gso;
-
- # Convert Unicode characters to entities
- $string =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
-
- return $string;
-}
-
-# x0000-x0008 isn't legal in XML documents
-# XXX Perhaps this should just go into our standard entityize method
-sub strip_ctrl_chars {
- my ($self, $string) = @_;
-
- $string =~ s/([\x{0000}-\x{0008}])//sgoe;
- return $string;
-}
-
-sub get_copy_price {
- my($self, $e, $copy, $volume) = @_;
-
- $copy->price(0) if $copy->price and $copy->price < 0;
-
- return $copy->price if $copy->price and $copy->price > 0;
-
-
- my $owner;
- if(ref $volume) {
- if($volume->id == OILS_PRECAT_CALL_NUMBER) {
- $owner = $copy->circ_lib;
- } else {
- $owner = $volume->owning_lib;
- }
- } else {
- if($copy->call_number == OILS_PRECAT_CALL_NUMBER) {
- $owner = $copy->circ_lib;
- } else {
- $owner = $e->retrieve_asset_call_number($copy->call_number)->owning_lib;
- }
- }
-
- my $default_price = $self->ou_ancestor_setting_value(
- $owner, OILS_SETTING_DEF_ITEM_PRICE, $e) || 0;
-
- return $default_price unless defined $copy->price;
-
- # price is 0. Use the default?
- my $charge_on_0 = $self->ou_ancestor_setting_value(
- $owner, OILS_SETTING_CHARGE_LOST_ON_ZERO, $e) || 0;
-
- return $default_price if $charge_on_0;
- return 0;
-}
-
-# given a transaction ID, this returns the context org_unit for the transaction
-sub xact_org {
- my($self, $xact_id, $e) = @_;
- $e ||= OpenILS::Utils::CStoreEditor->new;
-
- my $loc = $e->json_query({
- "select" => {circ => ["circ_lib"]},
- from => "circ",
- "where" => {id => $xact_id},
- });
-
- return $loc->[0]->{circ_lib} if @$loc;
-
- $loc = $e->json_query({
- "select" => {bresv => ["request_lib"]},
- from => "bresv",
- "where" => {id => $xact_id},
- });
-
- return $loc->[0]->{request_lib} if @$loc;
-
- $loc = $e->json_query({
- "select" => {mg => ["billing_location"]},
- from => "mg",
- "where" => {id => $xact_id},
- });
-
- return $loc->[0]->{billing_location};
-}
-
-
-sub find_event_def_by_hook {
- my($self, $hook, $context_org, $e) = @_;
-
- $e ||= OpenILS::Utils::CStoreEditor->new;
-
- my $orgs = $self->get_org_ancestors($context_org);
-
- # search from the context org up
- for my $org_id (reverse @$orgs) {
-
- my $def = $e->search_action_trigger_event_definition(
- {hook => $hook, owner => $org_id})->[0];
-
- return $def if $def;
- }
-
- return undef;
-}
-
-
-
-# If an event_def ID is not provided, use the hook and context org to find the
-# most appropriate event. create the event, fire it, then return the resulting
-# event with fleshed template_output and error_output
-sub fire_object_event {
- my($self, $event_def, $hook, $object, $context_org, $granularity, $user_data, $client) = @_;
-
- my $e = OpenILS::Utils::CStoreEditor->new;
- my $def;
-
- my $auto_method = "open-ils.trigger.event.autocreate.by_definition";
-
- if($event_def) {
- $def = $e->retrieve_action_trigger_event_definition($event_def)
- or return $e->event;
-
- $auto_method .= '.include_inactive';
-
- } else {
-
- # find the most appropriate event def depending on context org
- $def = $self->find_event_def_by_hook($hook, $context_org, $e)
- or return $e->event;
- }
-
- my $final_resp;
-
- if($def->group_field) {
- # we have a list of objects
- $object = [$object] unless ref $object eq 'ARRAY';
-
- my @event_ids;
- $user_data ||= [];
- for my $i (0..$#$object) {
- my $obj = $$object[$i];
- my $udata = $$user_data[$i];
- my $event_id = $self->simplereq(
- 'open-ils.trigger', $auto_method, $def->id, $obj, $context_org, $udata);
- push(@event_ids, $event_id);
- }
-
- $logger->info("EVENTS = " . OpenSRF::Utils::JSON->perl2JSON(\@event_ids));
-
- my $resp;
- if (not defined $client) {
- $resp = $self->simplereq(
- 'open-ils.trigger',
- 'open-ils.trigger.event_group.fire',
- \@event_ids);
- } else {
- $resp = $self->patientreq(
- $client,
- "open-ils.trigger", "open-ils.trigger.event_group.fire",
- \@event_ids
- );
- }
-
- if($resp and $resp->{events} and @{$resp->{events}}) {
-
- $e->xact_begin;
- $final_resp = $e->retrieve_action_trigger_event([
- $resp->{events}->[0]->id,
- {flesh => 1, flesh_fields => {atev => ['template_output', 'error_output']}}
- ]);
- $e->rollback;
- }
-
- } else {
-
- $object = $$object[0] if ref $object eq 'ARRAY';
-
- my $event_id;
- my $resp;
-
- if (not defined $client) {
- $event_id = $self->simplereq(
- 'open-ils.trigger',
- $auto_method, $def->id, $object, $context_org, $user_data
- );
-
- $resp = $self->simplereq(
- 'open-ils.trigger',
- 'open-ils.trigger.event.fire',
- $event_id
- );
- } else {
- $event_id = $self->patientreq(
- $client,
- 'open-ils.trigger',
- $auto_method, $def->id, $object, $context_org, $user_data
- );
-
- $resp = $self->patientreq(
- $client,
- 'open-ils.trigger',
- 'open-ils.trigger.event.fire',
- $event_id
- );
- }
-
- if($resp and $resp->{event}) {
- $e->xact_begin;
- $final_resp = $e->retrieve_action_trigger_event([
- $resp->{event}->id,
- {flesh => 1, flesh_fields => {atev => ['template_output', 'error_output']}}
- ]);
- $e->rollback;
- }
- }
-
- return $final_resp;
-}
-
-
-sub create_events_for_hook {
- my($self, $hook, $obj, $org_id, $granularity, $user_data, $wait) = @_;
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- my $req = $ses->request('open-ils.trigger.event.autocreate',
- $hook, $obj, $org_id, $granularity, $user_data);
- return undef unless $wait;
- my $resp = $req->recv;
- return $resp->content if $resp;
-}
-
-sub create_uuid_string {
- return create_UUID_as_string();
-}
-
-sub create_circ_chain_summary {
- my($class, $e, $circ_id) = @_;
- my $sum = $e->json_query({from => ['action.summarize_circ_chain', $circ_id]})->[0];
- return undef unless $sum;
- my $obj = Fieldmapper::action::circ_chain_summary->new;
- $obj->$_($sum->{$_}) for keys %$sum;
- return $obj;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Booking;
-
-use strict;
-use warnings;
-
-use POSIX qw/strftime/;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-use OpenSRF::Utils qw/:datetime/;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Application::AppUtils;
-my $U = "OpenILS::Application::AppUtils";
-
-use OpenSRF::Utils::Logger qw/$logger/;
-
-sub prepare_new_brt {
- my ($record_id, $owning_lib, $mvr) = @_;
-
- my $brt = new Fieldmapper::booking::resource_type;
- $brt->isnew(1);
- $brt->name($mvr->title);
- $brt->record($record_id);
- $brt->catalog_item('t');
- $brt->transferable('t');
- $brt->owner($owning_lib);
-
- return $brt;
-}
-
-sub get_existing_brt {
- my ($e, $record_id, $owning_lib, $mvr) = @_;
- my $results = $e->search_booking_resource_type(
- {name => $mvr->title, owner => $owning_lib, record => $record_id}
- );
-
- return $results->[0] if scalar(@$results) > 0;
- return undef;
-}
-
-sub get_mvr {
- return $U->simplereq(
- 'open-ils.search',
- 'open-ils.search.biblio.record.mods_slim.retrieve.authoritative',
- shift # record id
- );
-}
-
-sub get_unique_owning_libs {
- my %hash = ();
- $hash{$_->call_number->owning_lib} = 1 foreach (@_); # @_ are copies
- return keys %hash;
-}
-
-sub fetch_copies_by_ids {
- my ($e, $copy_ids) = @_;
- my $results = $e->search_asset_copy([
- {id => $copy_ids},
- {flesh => 1, flesh_fields => {acp => ['call_number']}}
- ]);
- return $results if ref($results) eq 'ARRAY';
- return [];
-}
-
-sub get_single_record_id {
- my $record_id = undef;
- foreach (@_) { # @_ are copies
- return undef if
- (defined $record_id && $record_id != $_->call_number->record);
- $record_id = $_->call_number->record;
- }
- return $record_id;
-}
-
-# This function generates the correct json_query clause for determining
-# whether two given ranges overlap. Each range is composed of a start
-# and an end point. All four points should be the same type (could be int,
-# date, time, timestamp, or perhaps other types).
-#
-# The first range (or the first two points) should be specified as
-# literal values. The second range (or the last two points) should be
-# specified as the names of columns, the values of which in a given row
-# will constitute the second range in the comparison.
-#
-# ALSO: PostgreSQL includes an OVERLAPS operator which provides the same
-# functionality in a much more concise way, but json_query does not (yet).
-sub json_query_ranges_overlap {
- +{ '-or' => [
- { '-and' => [{$_[2] => {'>=', $_[0]}}, {$_[2] => {'<', $_[1]}}]},
- { '-and' => [{$_[3] => {'>', $_[0]}}, {$_[3] => {'<', $_[1]}}]},
- { '-and' => { $_[3] => {'>', $_[0]}, $_[2] => {'<=', $_[0]}}},
- { '-and' => { $_[3] => {'>', $_[1]}, $_[2] => {'<', $_[1]}}},
- ]};
-}
-
-sub create_brt_and_brsrc {
- my ($self, $conn, $authtoken, $copy_ids) = @_;
- my (@created_brt, @created_brsrc);
- my %brt_table = ();
-
- my $e = new_editor(xact => 1, authtoken => $authtoken);
- return $e->die_event unless $e->checkauth;
-
- my @copies = @{fetch_copies_by_ids($e, $copy_ids)};
- my $record_id = get_single_record_id(@copies) or return $e->die_event;
- my $mvr = get_mvr($record_id) or return $e->die_event;
-
- foreach (get_unique_owning_libs(@copies)) {
- $brt_table{$_} = get_existing_brt($e, $record_id, $_, $mvr) ||
- prepare_new_brt($record_id, $_, $mvr);
- }
-
- while (my ($owning_lib, $brt) = each %brt_table) {
- my $pre_existing = 1;
- if ($brt->isnew) {
- if ($e->allowed('ADMIN_BOOKING_RESOURCE_TYPE', $owning_lib)) {
- $pre_existing = 0;
- return $e->die_event unless (
- # v-- Important: assignment modifies original hash
- $brt = $e->create_booking_resource_type($brt)
- );
- }
- }
- push @created_brt, [$brt->id, $brt->record, $pre_existing];
- }
-
- foreach (@copies) {
- if ($e->allowed(
- 'ADMIN_BOOKING_RESOURCE', $_->call_number->owning_lib
- )) {
- # This block needs to disregard any cstore failures and just
- # return what results it can.
- my $brsrc = new Fieldmapper::booking::resource;
- $brsrc->isnew(1);
- $brsrc->type($brt_table{$_->call_number->owning_lib}->id);
- $brsrc->owner($_->call_number->owning_lib);
- $brsrc->barcode($_->barcode);
-
- $e->set_savepoint("alpha");
- my $pre_existing = 0;
- my $usable_result = undef;
- if (!($usable_result = $e->create_booking_resource($brsrc))) {
- $e->rollback_savepoint("alpha");
- if (($usable_result = $e->search_booking_resource(
- +{ map { ($_, $brsrc->$_()) } qw/type owner barcode/ }
- ))) {
- $usable_result = $usable_result->[0];
- $pre_existing = 1;
- } else {
- # So we failed to create a booking resource for this copy.
- # For now, let's just keep going. If the calling app wants
- # to consider this an error, it can notice the absence
- # of a booking resource for the copy in the returned
- # results.
- $logger->warn(
- "Couldn't create or find brsrc for acp #" . $_->id
- );
- }
- } else {
- $e->release_savepoint("alpha");
- }
-
- if ($usable_result) {
- push @created_brsrc,
- [$usable_result->id, $_->id, $pre_existing];
- }
- }
- }
-
- $e->commit and
- return {brt => \@created_brt, brsrc => \@created_brsrc} or
- return $e->die_event;
-}
-__PACKAGE__->register_method(
- method => "create_brt_and_brsrc",
- api_name => "open-ils.booking.resources.create_from_copies",
- signature => {
- params => [
- {type => 'string', desc => 'Authentication token'},
- {type => 'array', desc => 'Copy IDs'},
- ],
- return => { desc => "A two-element hash. The 'brt' element " .
- "is a list of created booking resource types described by " .
- "3-tuples (id, copy id, was pre-existing). The 'brsrc' " .
- "element is a similar list of created booking resources " .
- "described by (id, record id, was pre-existing) 3-tuples."}
- }
-);
-
-
-sub create_bresv {
- my ($self, $client, $authtoken,
- $target_user_barcode, $datetime_range, $pickup_lib,
- $brt, $brsrc_list, $attr_values) = @_;
-
- $brsrc_list = [ undef ] if not defined $brsrc_list;
- return undef if scalar(@$brsrc_list) < 1; # Empty list not ok.
-
- my $e = new_editor(xact => 1, authtoken => $authtoken);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
-
- my $usr = $U->fetch_user_by_barcode($target_user_barcode);
- return $usr if ref($usr) eq 'HASH' and exists($usr->{"ilsevent"});
-
- my $results = [];
- foreach my $brsrc (@$brsrc_list) {
- my $bresv = new Fieldmapper::booking::reservation;
- $bresv->usr($usr->id);
- $bresv->request_lib($e->requestor->ws_ou);
- $bresv->pickup_lib($pickup_lib);
- $bresv->start_time($datetime_range->[0]);
- $bresv->end_time($datetime_range->[1]);
-
- # A little sanity checking: don't agree to put a reservation on a
- # brsrc and a brt when they don't match. In fact, bomb out of
- # this transaction entirely.
- if ($brsrc) {
- my $brsrc_itself = $e->retrieve_booking_resource([
- $brsrc, {
- "flesh" => 1,
- "flesh_fields" => {"brsrc" => ["type"]}
- }
- ]);
-
- if (not $brsrc_itself) {
- my $ev = new OpenILS::Event(
- "RESERVATION_BAD_PARAMS",
- desc => "brsrc $brsrc doesn't exist"
- );
- $e->disconnect;
- return $ev;
- }
- elsif ($brsrc_itself->type->id != $brt) {
- my $ev = new OpenILS::Event(
- "RESERVATION_BAD_PARAMS",
- desc => "brsrc $brsrc doesn't match given brt $brt"
- );
- $e->disconnect;
- return $ev;
- }
-
- # Also bail if the user is trying to create a reservation at
- # a pickup lib to which our resource won't go.
- if (
- $brsrc_itself->owner != $pickup_lib and
- not $brsrc_itself->type->transferable
- ) {
- my $ev = new OpenILS::Event(
- "RESERVATION_BAD_PARAMS",
- desc => "brsrc $brsrc doesn't belong to $pickup_lib and " .
- "is not transferable"
- );
- $e->disconnect;
- return $ev;
- }
- }
- $bresv->target_resource($brsrc); # undef is ok here
- $bresv->target_resource_type($brt);
-
- ($bresv = $e->create_booking_reservation($bresv)) or
- return $e->die_event;
-
- # We could/should do some sanity checking on this too: namely, on
- # whether the attribute values given actually apply to the relevant
- # brt. Not seeing any grievous side effects of not checking, though.
- my @bravm = ();
- foreach my $value (@$attr_values) {
- my $bravm = new Fieldmapper::booking::reservation_attr_value_map;
- $bravm->reservation($bresv->id);
- $bravm->attr_value($value);
- $bravm = $e->create_booking_reservation_attr_value_map($bravm) or
- return $e->die_event;
- push @bravm, $bravm;
- }
- push @$results, {
- "bresv" => $bresv->id,
- "bravm" => \@bravm,
- };
- }
-
- $e->commit or return $e->die_event;
-
- # Targeting must be tacked on _after_ committing the transaction where the
- # reservations are actually created.
- foreach (@$results) {
- $_->{"targeting"} = $U->storagereq(
- "open-ils.storage.booking.reservation.resource_targeter",
- $_->{"bresv"}
- )->[0];
- }
- return $results;
-}
-__PACKAGE__->register_method(
- method => "create_bresv",
- api_name => "open-ils.booking.reservations.create",
- signature => {
- params => [
- {type => 'string', desc => 'Authentication token'},
- {type => 'string', desc => 'Barcode of user for whom to reserve'},
- {type => 'array', desc => 'Two elements: start and end timestamp'},
- {type => 'int', desc => 'Desired reservation pickup lib'},
- {type => 'int', desc => 'Booking resource type'},
- {type => 'list', desc => 'Booking resource (undef ok; empty not ok)'},
- {type => 'array', desc => 'Attribute values selected'},
- ],
- return => { desc => "A hash containing the new bresv and a list " .
- "of new bravm"}
- }
-);
-
-
-sub resource_list_by_attrs {
- my $self = shift;
- my $client = shift;
- my $auth = shift; # Keep as argument, though not used just now.
- my $filters = shift;
-
- return undef unless ($filters->{type} || $filters->{attribute_values});
-
- my $query = {
- "select" => {brsrc => [qw/id owner/], brt => ["elbow_room"]},
- "from" => {brsrc => {"brt" => {}}},
- "where" => {},
- "distinct" => 1
- };
-
- $query->{where} = {"-and" => []};
- if ($filters->{type}) {
- push @{$query->{where}->{"-and"}}, {"type" => $filters->{type}};
- }
-
- if ($filters->{pickup_lib}) {
- push @{$query->{where}->{"-and"}},
- {"-or" => [
- {"owner" => $filters->{pickup_lib}},
- {"+brt" => {"transferable" => "t"}}
- ]};
- }
-
- if ($filters->{attribute_values}) {
-
- $query->{from}->{brsrc}->{bram} = { field => 'resource' };
-
- $filters->{attribute_values} = [$filters->{attribute_values}]
- if (!ref($filters->{attribute_values}));
-
- $query->{having}->{'+bram'}->{value}->{'@>'} = {
- transform => 'array_accum',
- value => '$_' . $$ . '${' .
- join(',', @{$filters->{attribute_values}}) .
- '}$_' . $$ . '$'
- };
- }
-
- if ($filters->{available}) {
- # If only one timestamp has been provided, make it into a range.
- if (!ref($filters->{available})) {
- $filters->{available} = [($filters->{available}) x 2];
- }
-
- push @{$query->{where}->{"-and"}}, {
- "-or" => [
- {"overbook" => "t"},
- {"-not-exists" => {
- "select" => {"bresv" => ["id"]},
- "from" => "bresv",
- "where" => {"-and" => [
- json_query_ranges_overlap(
- $filters->{available}->[0],
- $filters->{available}->[1],
- "start_time",
- "end_time"
- ),
- {"cancel_time" => undef},
- {"return_time" => undef},
- {"current_resource" => {"=" => {"+brsrc" => "id"}}}
- ]},
- }}
- ]
- };
- }
- if ($filters->{booked}) {
- # If only one timestamp has been provided, make it into a range.
- if (!ref($filters->{booked})) {
- $filters->{booked} = [($filters->{booked}) x 2];
- }
-
- push @{$query->{where}->{"-and"}}, {
- "-exists" => {
- "select" => {"bresv" => ["id"]},
- "from" => "bresv",
- "where" => {"-and" => [
- json_query_ranges_overlap(
- $filters->{booked}->[0],
- $filters->{booked}->[1],
- "start_time",
- "end_time"
- ),
- {"cancel_time" => undef},
- {"current_resource" => { "=" => {"+brsrc" => "id"}}}
- ]},
- }
- };
- # I think that the "booked" case could be done with a JOIN instead of
- # an EXISTS, but I'm leaving it this way for symmetry with the
- # "available" case for now. The available case cannot be done with a
- # join.
- }
-
- my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
- my $rows = $cstore->request(
- "open-ils.cstore.json_query.atomic", $query
- )->gather(1);
- $cstore->disconnect;
-
- return [] if not @$rows;
-
- if ($filters->{"pickup_lib"} && $filters->{"available"}) {
- my @new_rows = ();
- my $general_elbow_room = $U->ou_ancestor_setting_value(
- $filters->{"pickup_lib"},
- "circ.booking_reservation.default_elbow_room"
- ) || '0 seconds';
- my $would_start = $filters->{"available"}->[0];
- my $dt_parser = new DateTime::Format::ISO8601;
-
- $logger->info(
- "general_elbow_room: '$general_elbow_room', " .
- "would_start: '$would_start'"
- );
-
- # Here, elbow_room will double as required transit time padding.
- foreach (@$rows) {
- my $elbow_room = $_->{"elbow_room"} || $general_elbow_room;
- if ($_->{"owner"} != $filters->{"pickup_lib"}) {
- (my $ws = $would_start) =~ s/ /T/;
- push @new_rows, $_ if DateTime->compare(
- $dt_parser->parse_datetime($ws),
- DateTime->now(
- "time_zone" => DateTime::TimeZone->new(
- "name" => "local"
- )
- )->add(seconds => interval_to_seconds($elbow_room))
- ) >= 0;
- } else {
- push @new_rows, $_;
- }
- }
- return [map { $_->{id} } @new_rows];
- } else {
- return [map { $_->{id} } @$rows];
- }
-}
-__PACKAGE__->register_method(
- method => "resource_list_by_attrs",
- api_name => "open-ils.booking.resources.filtered_id_list",
- argc => 2,
- signature=> {
- params => [
- {type => 'string', desc => 'Authentication token (unused for now,' .
- ' but at least pass undef here)'},
- {type => 'object', desc => 'Filter object: see notes for details'},
- ],
- return => { desc => "An array of brsrc ids matching the requested filters." },
- },
- notes => <<'NOTES'
-
-The filter object parameter can contain the following keys:
- * type => The id of a booking resource type (brt)
- * attribute_values => The ids of booking resource type attribute values that the resource must have assigned to it (brav)
- * available => Either:
- A timestamp during which the resources are not reserved. If the resource is overbookable, this is ignored.
- A range of two timestamps which do not overlap any reservations for the resources. If the resource is overbookable, this is ignored.
- * booked => Either:
- A timestamp during which the resources are reserved.
- A range of two timestamps which overlap a reservation of the resources.
-
-Note that at least one of 'type' or 'attribute_values' is required.
-
-NOTES
-);
-
-
-sub reservation_list_by_filters {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $filters = shift;
- my $whole_obj = shift;
-
- return undef unless ($filters->{user} || $filters->{user_barcode} || $filters->{resource} || $filters->{type} || $filters->{attribute_values});
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_TRANSACTION');
-
- my $query = {
- 'select' => { bresv => [ 'id', 'start_time' ] },
- 'from' => { bresv => {} },
- 'where' => {},
- 'order_by' => [{ class => bresv => field => start_time => direction => 'asc' }],
- 'distinct' => 1
- };
-
- if ($filters->{fields}) {
- $query->{where} = $filters->{fields};
- }
-
-
- if ($filters->{user}) {
- $query->{where}->{usr} = $filters->{user};
- }
- elsif ($filters->{user_barcode}) { # just one of user and user_barcode
- my $usr = $U->fetch_user_by_barcode($filters->{user_barcode});
- return $usr if ref($usr) eq 'HASH' and exists($usr->{"ilsevent"});
- $query->{where}->{usr} = $usr->id;
- }
-
-
- if ($filters->{type}) {
- $query->{where}->{target_resource_type} = $filters->{type};
- }
-
- $query->{where}->{"-and"} = [];
- if ($filters->{resource}) {
-# $query->{where}->{target_resource} = $filters->{resource};
- push @{$query->{where}->{"-and"}}, {
- "-or" => {
- "target_resource" => $filters->{resource},
- "current_resource" => $filters->{resource}
- }
- };
- }
-
- if ($filters->{attribute_values}) {
-
- $query->{from}->{bresv}->{bravm} = { field => 'reservation' };
-
- $filters->{attribute_values} = [$filters->{attribute_values}]
- if (!ref($filters->{attribute_values}));
-
- $query->{having}->{'+bravm'}->{attr_value}->{'@>'} = {
- transform => 'array_accum',
- value => '$_' . $$ . '${' .
- join(',', @{$filters->{attribute_values}}) .
- '}$_' . $$ . '$'
- };
- }
-
- if ($filters->{search_start} || $filters->{search_end}) {
- my $or = {};
-
- $or->{start_time} =
- {'between' => [ $filters->{search_start}, $filters->{search_end}]}
- if $filters->{search_start};
-
- $or->{end_time} =
- {'between' =>[$filters->{search_start}, $filters->{search_end}]}
- if $filters->{search_end};
-
- push @{$query->{where}->{"-and"}}, {"-or" => $or};
- }
-
- if (not scalar @{$query->{"where"}->{"-and"}}) {
- delete $query->{"where"}->{"-and"};
- }
-
- my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
- my $ids = [ map { $_->{id} } @{
- $cstore->request(
- 'open-ils.cstore.json_query.atomic', $query
- )->gather(1)
- } ];
- $cstore->disconnect;
-
- if (not $whole_obj or @$ids < 1) {
- $e->disconnect;
- return $ids;
- }
-
- my $bresv_list = $e->search_booking_reservation([
- {"id" => $ids},
- {"flesh" => 1,
- "flesh_fields" => {
- "bresv" =>
- [qw/target_resource current_resource target_resource_type/]
- }
- }]
- );
- $e->disconnect;
- return $bresv_list ? $bresv_list : [];
-}
-__PACKAGE__->register_method(
- method => "reservation_list_by_filters",
- api_name => "open-ils.booking.reservations.filtered_id_list",
- argc => 3,
- signature=> {
- params => [
- {type => 'string', desc => 'Authentication token'},
- {type => "object", desc => "Filter object: see notes for details"},
- {type => "bool", desc => "Return whole object instead of ID? (default false)"}
- ],
- return => { desc => "An array of bresv ids matching the requested filters." },
- },
- notes => <<'NOTES'
-
-The filter object parameter can contain the following keys:
- * user => The id of a user that has requested a bookable item -- filters on bresv.usr
- * barcode => The barcode of a user that has requested a bookable item
- * type => The id of a booking resource type (brt) -- filters on bresv.target_resource_type
- * resource => The id of a booking resource (brsrc) -- filters on bresv.target_resource
- * attribute_values => The ids of booking resource type attribute values that the resource must have assigned to it (brav)
- * search_start => If search_end is not specified, booking interval (start_time to end_time) must contain this timestamp.
- * search_end => If search_start is not specified, booking interval (start_time to end_time) must contain this timestamp.
- * fields => An object containing any combination of bresv search filters in standard cstore/pcrud search format.
-
-Note that at least one of 'user', 'type', 'resource' or 'attribute_values' is required. If both search_start and search_end are specified,
-then the result includes any reservations that overlap with that time range. Any filter fields supplied in 'fields' are overridden
-by the top-level filters ('user', 'type', 'resource').
-
-NOTES
-);
-
-
-sub naive_ts_string {strftime("%F %T", localtime($_[0] || time));}
-sub naive_start_of_day {strftime("%F", localtime($_[0] || time))." 00:00:00";}
-
-# Return a map of bresv or an ilsevent on failure.
-sub get_uncaptured_bresv_for_brsrc {
- my ($e, $o) = @_; # o's keys (all optional): owning_lib, barcode, range
-
- my $from_clause = {
- "bresv" => {
- "brsrc" => {"field" => "id", "fkey" => "current_resource"}
- }
- };
-
- my $query = {
- "select" => {
- "bresv" => [
- "current_resource",
- {
- "column" => "start_time",
- "transform" => "min",
- "aggregate" => 1
- }
- ]
- },
- "from" => $from_clause,
- "where" => {
- "-and" => [
- {"current_resource" => {"!=" => undef}},
- {"capture_time" => undef},
- {"cancel_time" => undef},
- {"return_time" => undef},
- {"pickup_time" => undef}
- ]
- }
- };
- if ($o->{"owning_lib"}) {
- push @{$query->{"where"}->{"-and"}},
- {"+brsrc" => {"owner" => $o->{"owning_lib"}}};
- }
- if ($o->{"range"}) {
- push @{$query->{"where"}->{"-and"}},
- json_query_ranges_overlap(
- $o->{"range"}->[0], $o->{"range"}->[1],
- "start_time", "end_time"
- );
- }
- if ($o->{"barcode"}) {
- push @{$query->{"where"}->{"-and"}},
- {"+brsrc" => {"barcode" => $o->{"barcode"}}};
- }
-
- my $rows = $e->json_query($query);
- my $current_resource_bresv_map = {};
- if (@$rows) {
- my $id_query = {
- "select" => {"bresv" => ["id"]},
- "from" => $from_clause,
- "where" => {
- "-and" => [
- {"current_resource" => "PLACEHOLDER"},
- {"start_time" => "PLACEHOLDER"},
- {"capture_time" => undef},
- {"cancel_time" => undef},
- {"return_time" => undef},
- {"pickup_time" => undef}
- ]
- }
- };
- if ($o->{"owning_lib"}) {
- push @{$id_query->{"where"}->{"-and"}},
- {"+brsrc" => {"owner" => $o->{"owning_lib"}}};
- }
-
- foreach (@$rows) {
- $id_query->{"where"}->{"-and"}->[0]->{"current_resource"} =
- $_->{"current_resource"};
- $id_query->{"where"}->{"-and"}->[1]->{"start_time"} =
- $_->{"start_time"};
-
- my $results = $e->json_query($id_query);
- if ($results && @$results) {
- $current_resource_bresv_map->{$_->{"current_resource"}} =
- [map { $_->{"id"} } @$results];
- }
- }
- }
- return $current_resource_bresv_map;
-}
-
-sub get_pull_list {
- my ($self, $client, $auth, $range, $interval_secs, $owning_lib) = @_;
-
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("RETRIEVE_RESERVATION_PULL_LIST");
- return $e->die_event unless (
- ref($range) eq "ARRAY" or
- ($interval_secs = int($interval_secs)) > 0
- );
-
- $owning_lib = $e->requestor->ws_ou if not $owning_lib;
- $range = [ naive_ts_string(time), naive_ts_string(time + $interval_secs) ]
- if not $range;
-
- my $uncaptured = get_uncaptured_bresv_for_brsrc(
- $e, {"range" => $range, "owning_lib" => $owning_lib}
- );
-
- if (keys(%$uncaptured)) {
- my @all_bresv_ids = map { @{$_} } values %$uncaptured;
- my %bresv_lookup = (
- map { $_->id => $_ } @{
- $e->search_booking_reservation([{"id" => [@all_bresv_ids]}, {
- flesh => 1,
- flesh_fields => { bresv => [
- "usr", "target_resource_type", "current_resource"
- ]}
- }])
- }
- );
- $e->disconnect;
- return [ map {
- my $key = $_;
- my $one = $bresv_lookup{$uncaptured->{$key}->[0]};
- my $result = {
- "current_resource" => $one->current_resource,
- "target_resource_type" => $one->target_resource_type,
- "reservations" => [
- map { $bresv_lookup{$_} } @{$uncaptured->{$key}}
- ]
- };
- foreach (@{$result->{"reservations"}}) { # deflesh
- $_->current_resource($_->current_resource->id);
- $_->target_resource_type($_->target_resource_type->id);
- }
- $result;
- } keys %$uncaptured ];
- } else {
- $e->disconnect;
- return [];
- }
-}
-__PACKAGE__->register_method(
- method => "get_pull_list",
- api_name => "open-ils.booking.reservations.get_pull_list",
- argc => 4,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "array", desc =>
- "range: Date/time range for reservations (opt)"},
- {type => "int", desc =>
- "interval: Seconds from now (instead of range)"},
- {type => "number", desc => "(Optional) Owning library"}
- ],
- return => { desc => "An array of hashes, each containing key/value " .
- "pairs describing resource, resource type, and a list of " .
- "reservations that claim the given resource." }
- }
-);
-
-
-sub could_capture {
- my ($self, $client, $auth, $barcode) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("COPY_CHECKIN");
-
- my $dt_parser = new DateTime::Format::ISO8601;
- my $now = now DateTime; # sic
- my $res = get_uncaptured_bresv_for_brsrc($e, {"barcode" => $barcode});
-
- if ($res and keys %$res) {
- my $id;
- while ((undef, $id) = each %$res) {
- my $bresv = $e->retrieve_booking_reservation([
- $id, {
- "flesh" => 1, "flesh_fields" => {
- "bresv" => [qw(
- usr target_resource_type
- target_resource current_resource
- )]
- }
- }
- ]);
- my $elbow_room = interval_to_seconds(
- $bresv->target_resource_type->elbow_room ||
- $U->ou_ancestor_setting_value(
- $bresv->pickup_lib,
- "circ.booking_reservation.default_elbow_room"
- ) ||
- "0 seconds"
- );
-
- unless ($elbow_room) {
- $client->respond($bresv);
- } else {
- my $start_time = $dt_parser->parse_datetime(
- clense_ISO8601($bresv->start_time)
- );
-
- if ($now >= $start_time->subtract("seconds" => $elbow_room)) {
- $client->respond($bresv);
- } else {
- $logger->info(
- "not within elbow room: $elbow_room, " .
- "else would have returned bresv " . $bresv->id
- );
- }
- }
- }
- }
- $e->disconnect;
- undef;
-}
-__PACKAGE__->register_method(
- method => "could_capture",
- api_name => "open-ils.booking.reservations.could_capture",
- argc => 2,
- streaming=> 1,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "string", desc => "Resource barcode"}
- ],
- return => {desc => "One or zero reservations; event on error."}
- }
-);
-
-
-sub get_copy_fleshed_just_right {
- my ($self, $client, $auth, $barcode) = @_;
-
- return undef if not defined $barcode;
- return {} if ref($barcode) eq "ARRAY" and not @$barcode;
-
- my $e = new_editor(authtoken => $auth);
- my $results = $e->search_asset_copy([
- {"barcode" => $barcode},
- {
- "flesh" => 1,
- "flesh_fields" => {"acp" => [qw/call_number location/]}
- }
- ]);
-
- if (ref($results) eq "ARRAY") {
- $e->disconnect;
- return $results->[0] unless ref $barcode;
- return +{ map { $_->barcode => $_ } @$results };
- } else {
- return $e->die_event;
- }
-}
-__PACKAGE__->register_method(
- method => "get_copy_fleshed_just_right",
- api_name => "open-ils.booking.asset.get_copy_fleshed_just_right",
- argc => 2,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "mixed", desc => "One barcode or an array of them"},
- ],
- return => { desc =>
- "A copy, or a hash of copies keyed by barcode if an array of " .
- "barcodes was given"
- }
- }
-);
-
-
-sub best_bresv_candidate {
- my ($e, $id_list) = @_;
-
- # This will almost always be the case.
- if (@$id_list == 1) {
- $logger->info("best_bresv_candidate (only) " . $id_list->[0]);
- return $id_list->[0];
- }
-
- my @here = ();
- my $this_ou = $e->requestor->ws_ou;
- my $results = $e->json_query({
- "select" => {"brsrc" => ["pickup_lib"], "bresv" => ["id"]},
- "from" => {
- "bresv" => {
- "brsrc" => {"field" => "id", "fkey" => "current_resource"}
- }
- },
- "where" => {
- {"+bresv" => {"id" => $id_list}}
- }
- });
-
- foreach (@$results) {
- push @here, $_->{"id"} if $_->{"pickup_lib"} == $this_ou;
- }
-
- my $result;
- if (@here > 0) {
- $result = @here == 1 ? pop @here : (sort @here)[0];
- } else {
- $result = (sort @$id_list)[0];
- }
- $logger->info(
- "best_bresv_candidate from " . join(",", @$id_list) . ": $result"
- );
- return $result;
-}
-
-
-sub capture_resource_for_reservation {
- my ($self, $client, $auth, $barcode, $no_update_copy) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("COPY_CHECKIN");
-
- my $uncaptured = get_uncaptured_bresv_for_brsrc(
- $e, {"barcode" => $barcode}
- );
-
- if (keys %$uncaptured) {
- # Note this will only capture one reservation at a time, even in
- # cases with overbooking (multiple "soonest" bresv's on a resource).
- my $bresv = best_bresv_candidate(
- $e, $uncaptured->{
- (sort(keys %$uncaptured))[0]
- }
- );
- $e->disconnect;
- return capture_reservation(
- $self, $client, $auth, $bresv, $no_update_copy
- );
- } else {
- return new OpenILS::Event(
- "RESERVATION_NOT_FOUND",
- "desc" => "No capturable reservation found pertaining " .
- "to a resource with barcode $barcode",
- "payload" => {"fail_cause" => "no-reservation", "captured" => 0}
- );
- }
-}
-__PACKAGE__->register_method(
- method => "capture_resource_for_reservation",
- api_name => "open-ils.booking.resources.capture_for_reservation",
- argc => 3,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "string", desc => "Barcode of booked & targeted resource"},
- {type => "number", desc => "(optional) 1 to not update copy"}
- ],
- return => { desc => "An OpenILS event describing the capture outcome" }
- }
-);
-
-
-sub capture_reservation {
- my ($self, $client, $auth, $res_id, $no_update_copy) = @_;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("COPY_CHECKIN");
- my $here = $e->requestor->ws_ou;
-
- my $reservation = $e->retrieve_booking_reservation([
- $res_id, {
- "flesh" => 2, "flesh_fields" => {
- "bresv" => [qw/usr current_resource type/],
- "au" => ["card"],
- "brsrc" => ["type"]
- }
- }
- ]);
-
- return new OpenILS::Event("RESERVATION_NOT_FOUND") unless $reservation;
- return new OpenILS::Event(
- "RESERVATION_CAPTURE_FAILED",
- payload => {"captured" => 0, "fail_cause" => "no-resource"}
- ) unless $reservation->current_resource;
-
- return new OpenILS::Event(
- "RESERVATION_CAPTURE_FAILED",
- "payload" => {"captured" => 0, "fail_cause" => "cancelled"}
- ) if $reservation->cancel_time;
-
- $reservation->capture_staff($e->requestor->id);
- $reservation->capture_time("now");
-
- $e->update_booking_reservation($reservation) or return $e->die_event;
-
- my $ret = {"captured" => 1, "reservation" => $reservation};
-
- my $search_acp_like_this = [
- {
- "barcode" => $reservation->current_resource->barcode,
- "deleted" => "f"
- },
- {"flesh" => 1, "flesh_fields" => {"acp" => ["call_number"]}}
- ];
-
- if ($here != $reservation->pickup_lib) {
- $logger->info("resource isn't at the reservation's pickup lib...");
- return new OpenILS::Event(
- "RESERVATION_CAPTURE_FAILED",
- "payload" => {"captured" => 0, "fail_cause" => "not-transferable"}
- ) unless $U->is_true(
- $reservation->current_resource->type->transferable
- );
-
- # need to transit the item ... is it already in transit?
- my $transit = $e->search_action_reservation_transit_copy(
- {"reservation" => $res_id, "dest_recv_time" => undef}
- )->[0];
-
- if (!$transit) { # not yet in transit
- $transit = new Fieldmapper::action::reservation_transit_copy;
-
- $transit->reservation($reservation->id);
- $transit->target_copy($reservation->current_resource->id);
- $transit->copy_status(15);
- $transit->source_send_time("now");
- $transit->source($here);
- $transit->dest($reservation->pickup_lib);
-
- $e->create_action_reservation_transit_copy($transit);
-
- if ($U->is_true(
- $reservation->current_resource->type->catalog_item
- )) {
- my $copy = $e->search_asset_copy($search_acp_like_this)->[0];
-
- if ($copy) {
- return new OpenILS::Event(
- "OPEN_CIRCULATION_EXISTS",
- "payload" => {"captured" => 0, "copy" => $copy}
- ) if $copy->status == 1 and not $no_update_copy;
-
- $ret->{"mvr"} = get_mvr($copy->call_number->record);
- if ($no_update_copy) {
- $ret->{"new_copy_status"} = 6;
- } else {
- $copy->status(6);
- $e->update_asset_copy($copy) or return $e->die_event;
- }
- }
- }
- }
-
- $ret->{"transit"} = $transit;
- } elsif ($U->is_true($reservation->current_resource->type->catalog_item)) {
- $logger->info("resource is a catalog item...");
- my $copy = $e->search_asset_copy($search_acp_like_this)->[0];
-
- if ($copy) {
- return new OpenILS::Event(
- "OPEN_CIRCULATION_EXISTS",
- "payload" => {"captured" => 0, "copy" => $copy}
- ) if $copy->status == 1 and not $no_update_copy;
-
- $ret->{"mvr"} = get_mvr($copy->call_number->record);
- if ($no_update_copy) {
- $ret->{"new_copy_status"} = 15;
- } else {
- $copy->status(15);
- $e->update_asset_copy($copy) or return $e->die_event;
- }
- }
- }
-
- $e->commit or return $e->die_event;
-
- # XXX I'm not sure whether these last two elements of the payload
- # actually get used anywhere.
- $ret->{"resource"} = $reservation->current_resource;
- $ret->{"type"} = $reservation->current_resource->type;
- return new OpenILS::Event("SUCCESS", "payload" => $ret);
-}
-__PACKAGE__->register_method(
- method => "capture_reservation",
- api_name => "open-ils.booking.reservations.capture",
- argc => 2,
- signature=> {
- params => [
- {type => 'string', desc => 'Authentication token'},
- {type => 'mixed', desc =>
- 'Reservation ID (number) or array of resource barcodes'}
- ],
- return => { desc => "An OpenILS Event object describing the outcome of the capture, with relevant payload." },
- }
-);
-
-
-sub cancel_reservation {
- my ($self, $client, $auth, $id_list) = @_;
-
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- # Should the following permission really be checked as relates to each
- # individual reservation's request_lib? Hrmm...
- return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
-
- my $bresv_list = $e->search_booking_reservation([
- {"id" => $id_list},
- {"flesh" => 1, "flesh_fields" => {"bresv" => [
- "current_resource", "target_resource_type"
- ]}}
- ]);
- return $e->die_event if not $bresv_list;
-
- my @results = ();
- my $circ = OpenSRF::AppSession->connect("open-ils.circ") or
- return $e->die_event;
- foreach my $bresv (@$bresv_list) {
- $bresv->cancel_time("now");
- $e->update_booking_reservation($bresv) or do {
- $circ->disconnect;
- return $e->die_event;
- };
- $e->xact_commit;
- $e->xact_begin;
-
- if (
- $bresv->target_resource_type->catalog_item == "t" &&
- $bresv->current_resource
- ) {
- $logger->info("result of no-op checkin (upon cxl bresv) is " .
- $circ->request(
- "open-ils.circ.checkin", $auth,
- {"barcode" => $bresv->current_resource->barcode,
- "noop" => 1}
- )->gather(1)->{"textcode"});
- }
- push @results, $bresv->id;
- }
-
- $e->disconnect;
- $circ->disconnect;
-
- return \@results;
-}
-__PACKAGE__->register_method(
- method => "cancel_reservation",
- api_name => "open-ils.booking.reservations.cancel",
- argc => 2,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "array", desc => "List of reservation IDs"}
- ],
- return => { desc => "A list of canceled reservation IDs" },
- }
-);
-
-
-sub get_captured_reservations {
- my ($self, $client, $auth, $barcode, $which) = @_;
-
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("VIEW_USER");
- return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
-
- # fetch the patron for our uses in any case...
- my $patron = $U->fetch_user_by_barcode($barcode);
- return $patron if ref($patron) eq "HASH" and exists $patron->{"ilsevent"};
-
- my $bresv_flesh = {
- "flesh" => 1,
- "flesh_fields" => {"bresv" => [
- qw/target_resource_type current_resource/
- ]}
- };
-
- my $dispatch = {
- "patron" => sub {
- return $patron;
- },
- "ready" => sub {
- return $e->search_booking_reservation([
- {
- "usr" => $patron->id,
- "capture_time" => {"!=" => undef},
- "pickup_time" => undef,
- "start_time" => {">=" => naive_start_of_day()},
- "cancel_time" => undef
- },
- $bresv_flesh
- ]) or $e->die_event;
- },
- "out" => sub {
- return $e->search_booking_reservation([
- {
- "usr" => $patron->id,
- "pickup_time" => {"!=" => undef},
- "return_time" => undef,
- "cancel_time" => undef
- },
- $bresv_flesh
- ]) or $e->die_event;
- },
- "in" => sub {
- return $e->search_booking_reservation([
- {
- "usr" => $patron->id,
- "return_time" => {">=" => naive_start_of_day()},
- "cancel_time" => undef
- },
- $bresv_flesh
- ]) or $e->die_event;
- }
- };
-
- my $result = {};
- foreach (@$which) {
- my $f = $dispatch->{$_};
- if ($f) {
- my $r = &{$f}();
- return $r if (ref($r) eq "HASH" and exists $r->{"ilsevent"});
- $result->{$_} = $r;
- }
- }
-
- return $result;
-}
-__PACKAGE__->register_method(
- method => "get_captured_reservations",
- api_name => "open-ils.booking.reservations.get_captured",
- argc => 3,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "string", desc => "Patron barcode"},
- {type => "array", desc => "Parts wanted (patron, ready, out, in?)"}
- ],
- return => { desc => "A hash of parts." } # XXX describe more fully
- }
-);
-
-
-sub get_bresv_by_returnable_resource_barcode {
- my ($self, $client, $auth, $barcode) = @_;
-
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("VIEW_USER");
-# return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
-
- my $rows = $e->json_query({
- "select" => {"bresv" => ["id"]},
- "from" => {
- "bresv" => {
- "brsrc" => {"field" => "id", "fkey" => "current_resource"}
- }
- },
- "where" => {
- "+brsrc" => {"barcode" => $barcode},
- "-and" => {
- "pickup_time" => {"!=" => undef},
- "cancel_time" => undef,
- "return_time" => undef
- }
- }
- }) or return $e->die_event;
-
- if (@$rows < 1) {
- $e->rollback;
- return $rows;
- } else {
- # More than one result might be possible, but we don't want to return
- # more than one at this time.
- my $id = $rows->[0]->{"id"};
- my $resp =$e->retrieve_booking_reservation([
- $id, {
- "flesh" => 2,
- "flesh_fields" => {
- "bresv" => [qw/usr target_resource_type current_resource/],
- "au" => ["card"]
- }
- }
- ]) or $e->die_event;
- $e->rollback;
- return $resp;
- }
-}
-
-__PACKAGE__->register_method(
- method => "get_bresv_by_returnable_resource_barcode",
- api_name => "open-ils.booking.reservations.by_returnable_resource_barcode",
- argc => 2,
- signature=> {
- params => [
- {type => "string", desc => "Authentication token"},
- {type => "string", desc => "Resource barcode"},
- ],
- return => { desc => "A fleshed bresv or an ilsevent on error" }
- }
-);
-
-
-1;
+++ /dev/null
-use strict; use warnings;
-package OpenILS::Application::Cat;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application;
-use OpenILS::Application::Cat::Merge;
-use OpenILS::Application::Cat::Authority;
-use OpenILS::Application::Cat::BibCommon;
-use OpenILS::Application::Cat::AssetCommon;
-use base qw/OpenILS::Application/;
-use Time::HiRes qw(time);
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::JSON;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Event;
-use OpenILS::Const qw/:const/;
-
-use XML::LibXML;
-use Unicode::Normalize;
-use Data::Dumper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Perm;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw($logger);
-use OpenSRF::AppSession;
-
-my $U = "OpenILS::Application::AppUtils";
-my $conf;
-my %marctemplates;
-
-__PACKAGE__->register_method(
- method => "retrieve_marc_template",
- api_name => "open-ils.cat.biblio.marc_template.retrieve",
- notes => <<" NOTES");
- Returns a MARC 'record tree' based on a set of pre-defined templates.
- Templates include : book
- NOTES
-
-sub retrieve_marc_template {
- my( $self, $client, $type ) = @_;
- return $marctemplates{$type} if defined($marctemplates{$type});
- $marctemplates{$type} = _load_marc_template($type);
- return $marctemplates{$type};
-}
-
-__PACKAGE__->register_method(
- method => 'fetch_marc_template_types',
- api_name => 'open-ils.cat.marc_template.types.retrieve'
-);
-
-my $marc_template_files;
-
-sub fetch_marc_template_types {
- my( $self, $conn ) = @_;
- __load_marc_templates();
- return [ keys %$marc_template_files ];
-}
-
-sub __load_marc_templates {
- return if $marc_template_files;
- if(!$conf) { $conf = OpenSRF::Utils::SettingsClient->new; }
-
- $marc_template_files = $conf->config_value(
- "apps", "open-ils.cat","app_settings", "marctemplates" );
-
- $logger->info("Loaded marc templates: " . Dumper($marc_template_files));
-}
-
-sub _load_marc_template {
- my $type = shift;
-
- __load_marc_templates();
-
- my $template = $$marc_template_files{$type};
- open( F, $template ) or
- throw OpenSRF::EX::ERROR ("Unable to open MARC template file: $template : $@");
-
- my @xml = <F>;
- close(F);
- my $xml = join('', @xml);
-
- return XML::LibXML->new->parse_string($xml)->documentElement->toString;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_bib_sources',
- api_name => 'open-ils.cat.bib_sources.retrieve.all');
-
-sub fetch_bib_sources {
- return OpenILS::Application::Cat::BibCommon->fetch_bib_sources();
-}
-
-__PACKAGE__->register_method(
- method => "create_record_xml",
- api_name => "open-ils.cat.biblio.record.xml.create.override",
- signature => q/@see open-ils.cat.biblio.record.xml.create/);
-
-__PACKAGE__->register_method(
- method => "create_record_xml",
- api_name => "open-ils.cat.biblio.record.xml.create",
- signature => q/
- Inserts a new biblio with the given XML
- /
-);
-
-sub create_record_xml {
- my( $self, $client, $login, $xml, $source ) = @_;
-
- my $override = 1 if $self->api_name =~ /override/;
-
- my( $user_obj, $evt ) = $U->checksesperm($login, 'CREATE_MARC');
- return $evt if $evt;
-
- $logger->activity("user ".$user_obj->id." creating new MARC record");
-
- my $meth = $self->method_lookup("open-ils.cat.biblio.record.xml.import");
-
- $meth = $self->method_lookup(
- "open-ils.cat.biblio.record.xml.import.override") if $override;
-
- my ($s) = $meth->run($login, $xml, $source);
- return $s;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "biblio_record_replace_marc",
- api_name => "open-ils.cat.biblio.record.xml.update",
- argc => 3,
- signature => q/
- Updates the XML for a given biblio record.
- This does not change any other aspect of the record entry
- exception the XML, the editor, and the edit date.
- @return The update record object
- /
-);
-
-__PACKAGE__->register_method(
- method => 'biblio_record_replace_marc',
- api_name => 'open-ils.cat.biblio.record.marc.replace',
- signature => q/
- @param auth The authtoken
- @param recid The record whose MARC we're replacing
- @param newxml The new xml to use
- /
-);
-
-__PACKAGE__->register_method(
- method => 'biblio_record_replace_marc',
- api_name => 'open-ils.cat.biblio.record.marc.replace.override',
- signature => q/@see open-ils.cat.biblio.record.marc.replace/
-);
-
-sub biblio_record_replace_marc {
- my( $self, $conn, $auth, $recid, $newxml, $source ) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_MARC', $e->requestor->ws_ou);
-
- my $fix_tcn = $self->api_name =~ /replace/o;
- my $override = $self->api_name =~ /override/o;
-
- my $res = OpenILS::Application::Cat::BibCommon->biblio_record_replace_marc(
- $e, $recid, $newxml, $source, $fix_tcn, $override);
-
- $e->commit unless $U->event_code($res);
-
- #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
- #$ses->request('open-ils.ingest.full.biblio.record', $recid);
-
- return $res;
-}
-
-__PACKAGE__->register_method(
- method => "template_overlay_biblio_record_entry",
- api_name => "open-ils.cat.biblio.record_entry.template_overlay",
- stream => 1,
- signature => q#
- Overlays biblio.record_entry MARC values
- @param auth The authtoken
- @param records The record ids to be updated by the template
- @param template The overlay template
- @return Stream of hashes record id in the key "record" and t or f for the success of the overlay operation in key "success"
- #
-);
-
-sub template_overlay_biblio_record_entry {
- my($self, $conn, $auth, $records, $template) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- $records = [$records] if (!ref($records));
-
- for my $rid ( @$records ) {
- my $rec = $e->retrieve_biblio_record_entry($rid);
- next unless $rec;
-
- unless ($e->allowed('UPDATE_RECORD', $rec->owner, $rec)) {
- $conn->respond({ record => $rid, success => 'f' });
- next;
- }
-
- my $success = $e->json_query(
- { from => [ 'vandelay.template_overlay_bib_record', $template, $rid ] }
- )->[0]->{'vandelay.template_overlay_bib_record'};
-
- $conn->respond({ record => $rid, success => $success });
- }
-
- $e->commit;
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "template_overlay_container",
- api_name => "open-ils.cat.container.template_overlay",
- stream => 1,
- signature => q#
- Overlays biblio.record_entry MARC values
- @param auth The authtoken
- @param container The container, um, containing the records to be updated by the template
- @param template The overlay template, or nothing and the method will look for a negative bib id in the container
- @return Stream of hashes record id in the key "record" and t or f for the success of the overlay operation in key "success"
- #
-);
-
-__PACKAGE__->register_method(
- method => "template_overlay_container",
- api_name => "open-ils.cat.container.template_overlay.background",
- stream => 1,
- signature => q#
- Overlays biblio.record_entry MARC values
- @param auth The authtoken
- @param container The container, um, containing the records to be updated by the template
- @param template The overlay template, or nothing and the method will look for a negative bib id in the container
- @return Cache key to check for status of the container overlay
- #
-);
-
-sub template_overlay_container {
- my($self, $conn, $auth, $container, $template) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $actor = OpenSRF::AppSession->create('open-ils.actor') if ($self->api_name =~ /background$/);
-
- my $items = $e->search_container_biblio_record_entry_bucket_item({ bucket => $container });
-
- my $titem;
- if (!$template) {
- ($titem) = grep { $_->target_biblio_record_entry < 0 } @$items;
- if (!$titem) {
- $e->rollback;
- return undef;
- }
- $items = [grep { $_->target_biblio_record_entry > 0 } @$items];
-
- $template = $e->retrieve_biblio_record_entry( $titem->target_biblio_record_entry )->marc;
- }
-
- my $responses = [];
- my $some_failed = 0;
-
- $self->respond_complete(
- $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses)->gather(1)
- ) if ($actor);
-
- for my $item ( @$items ) {
- my $rec = $e->retrieve_biblio_record_entry($item->target_biblio_record_entry);
- next unless $rec;
-
- my $success = 'f';
- if ($e->allowed('UPDATE_RECORD', $rec->owner, $rec)) {
- $success = $e->json_query(
- { from => [ 'vandelay.template_overlay_bib_record', $template, $rec->id ] }
- )->[0]->{'vandelay.template_overlay_bib_record'};
- }
-
- $some_failed++ if ($success eq 'f');
-
- if ($actor) {
- push @$responses, { record => $rec->id, success => $success };
- $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
- } else {
- $conn->respond({ record => $rec->id, success => $success });
- }
-
- if ($success eq 't') {
- unless ($e->delete_container_biblio_record_entry_bucket_item($item)) {
- $e->rollback;
- if ($actor) {
- push @$responses, { complete => 1, success => 'f' };
- $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
- return undef;
- } else {
- return { complete => 1, success => 'f' };
- }
- }
- }
- }
-
- if ($titem && !$some_failed) {
- return $e->die_event unless ($e->delete_container_biblio_record_entry_bucket_item($titem));
- }
-
- if ($e->commit) {
- if ($actor) {
- push @$responses, { complete => 1, success => 't' };
- $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
- } else {
- return { complete => 1, success => 't' };
- }
- } else {
- if ($actor) {
- push @$responses, { complete => 1, success => 'f' };
- $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
- } else {
- return { complete => 1, success => 'f' };
- }
- }
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "update_biblio_record_entry",
- api_name => "open-ils.cat.biblio.record_entry.update",
- signature => q/
- Updates a biblio.record_entry
- @param auth The authtoken
- @param record The record with updated values
- @return 1 on success, Event on error.
- /
-);
-
-sub update_biblio_record_entry {
- my($self, $conn, $auth, $record) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('UPDATE_RECORD');
- $e->update_biblio_record_entry($record) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "undelete_biblio_record_entry",
- api_name => "open-ils.cat.biblio.record_entry.undelete",
- signature => q/
- Un-deletes a record and sets active=true
- @param auth The authtoken
- @param record The record_id to ressurect
- @return 1 on success, Event on error.
- /
-);
-sub undelete_biblio_record_entry {
- my($self, $conn, $auth, $record_id) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('UPDATE_RECORD');
-
- my $record = $e->retrieve_biblio_record_entry($record_id)
- or return $e->die_event;
- $record->deleted('f');
- $record->active('t');
-
- # Set the leader/05 to indicate that the record has been corrected/revised
- my $marc = $record->marc();
- $marc =~ s{(<leader>.{5}).}{$1c};
- $record->marc($marc);
-
- # no 2 non-deleted records can have the same tcn_value
- my $existing = $e->search_biblio_record_entry(
- { deleted => 'f',
- tcn_value => $record->tcn_value,
- id => {'!=' => $record_id}
- }, {idlist => 1});
- return OpenILS::Event->new('TCN_EXISTS') if @$existing;
-
- $e->update_biblio_record_entry($record) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_record_xml_import",
- api_name => "open-ils.cat.biblio.record.xml.import.override",
- signature => q/@see open-ils.cat.biblio.record.xml.import/);
-
-__PACKAGE__->register_method(
- method => "biblio_record_xml_import",
- api_name => "open-ils.cat.biblio.record.xml.import",
- notes => <<" NOTES");
- Takes a marcxml record and imports the record into the database. In this
- case, the marcxml record is assumed to be a complete record (i.e. valid
- MARC). The title control number is taken from (whichever comes first)
- tags 001, 039[ab], 020a, 022a, 010, 035a and whichever does not already exist
- in the database.
- user_session must have IMPORT_MARC permissions
- NOTES
-
-
-sub biblio_record_xml_import {
- my( $self, $client, $authtoken, $xml, $source, $auto_tcn) = @_;
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('IMPORT_MARC', $e->requestor->ws_ou);
-
- my $override = $self->api_name =~ /override/;
- my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
- $e, $xml, $source, $auto_tcn, $override);
-
- return $record if $U->event_code($record);
-
- $e->commit;
-
- #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
- #$ses->request('open-ils.ingest.full.biblio.record', $record->id);
-
- return $record;
-}
-
-__PACKAGE__->register_method(
- method => "biblio_record_record_metadata",
- api_name => "open-ils.cat.biblio.record.metadata.retrieve",
- authoritative => 1,
- argc => 1, #(session_id, biblio_tree )
- notes => "Walks the tree and commits any changed nodes " .
- "adds any new nodes, and deletes any deleted nodes",
-);
-
-sub biblio_record_record_metadata {
- my( $self, $client, $authtoken, $ids ) = @_;
-
- return [] unless $ids and @$ids;
-
- my $editor = new_editor(authtoken => $authtoken);
- return $editor->event unless $editor->checkauth;
- return $editor->event unless $editor->allowed('VIEW_USER');
-
- my @results;
-
- for(@$ids) {
- return $editor->event unless
- my $rec = $editor->retrieve_biblio_record_entry($_);
- $rec->creator($editor->retrieve_actor_user($rec->creator));
- $rec->editor($editor->retrieve_actor_user($rec->editor));
- $rec->clear_marc; # slim the record down
- push( @results, $rec );
- }
-
- return \@results;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "biblio_record_marc_cn",
- api_name => "open-ils.cat.biblio.record.marc_cn.retrieve",
- argc => 1, #(bib id )
- signature => {
- desc => 'Extracts call number candidates from a bibliographic record',
- params => [
- {desc => 'Record ID', type => 'number'},
- {desc => '(Optional) Classification scheme ID', type => 'number'},
- ]
- },
- return => {desc => 'Hash of candidate call numbers identified by tag' }
-);
-
-sub biblio_record_marc_cn {
- my( $self, $client, $id, $class ) = @_;
-
- my $e = new_editor();
- my $marc = $e->retrieve_biblio_record_entry($id)->marc;
-
- my $doc = XML::LibXML->new->parse_string($marc);
- $doc->documentElement->setNamespace( "http://www.loc.gov/MARC21/slim", "marc", 1 );
-
- my @fields;
- my @res;
- if ($class) {
- @fields = split(/,/, $e->retrieve_asset_call_number_class($class)->field);
- } else {
- @fields = qw/050ab 055ab 060ab 070ab 080ab 082ab 086ab 088ab 090 092 096 098 099/;
- }
-
- # Get field/subfield combos based on acnc value; for example "050ab,055ab"
-
- foreach my $field (@fields) {
- my $tag = substr($field, 0, 3);
- $logger->debug("Tag = $tag");
- my @node = $doc->findnodes("//marc:datafield[\@tag='$tag']");
-
- # Now parse the subfields and build up the subfield XPath
- my @subfields = split(//, substr($field, 3));
-
- # If they give us no subfields to parse, default to just the 'a'
- if (!@subfields) {
- @subfields = ('a');
- }
- my $subxpath;
- foreach my $sf (@subfields) {
- $subxpath .= "\@code='$sf' or ";
- }
- $subxpath = substr($subxpath, 0, -4);
- $logger->debug("subxpath = $subxpath");
-
- # Find the contents of the specified subfields
- foreach my $x (@node) {
- my $cn = $x->findvalue("marc:subfield[$subxpath]");
- push @res, {$tag => $cn} if ($cn);
- }
- }
-
- return \@res;
-}
-
-__PACKAGE__->register_method(
- method => 'autogen_barcodes',
- api_name => "open-ils.cat.item.barcode.autogen",
- signature => {
- desc => 'Returns N generated barcodes following a specified barcode.',
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Barcode which the sequence should follow from', type => 'string'},
- {desc => 'Number of barcodes to generate', type => 'number'},
- {desc => 'Options hash. Currently you can pass in checkdigit : false to disable the use of checkdigits.'}
- ],
- return => {desc => 'Array of generated barcodes'}
- }
-);
-
-sub autogen_barcodes {
- my( $self, $client, $auth, $barcode, $num_of_barcodes, $options ) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('UPDATE_COPY', $e->requestor->ws_ou);
- $options ||= {};
-
- my $barcode_text = '';
- my $barcode_number = 0;
-
- if ($barcode =~ /^(\D+)/) { $barcode_text = $1; }
- if ($barcode =~ /(\d+)$/) { $barcode_number = $1; }
-
- my @res;
- for (my $i = 1; $i <= $num_of_barcodes; $i++) {
- my $calculated_barcode;
-
- # default is to use checkdigits, so looking for an explicit false here
- if (defined $$options{'checkdigit'} && ! $$options{'checkdigit'}) {
- $calculated_barcode = $barcode_number + $i;
- } else {
- if ($barcode_number =~ /^\d{8}$/) {
- $calculated_barcode = add_codabar_checkdigit($barcode_number + $i, 0);
- } elsif ($barcode_number =~ /^\d{9}$/) {
- $calculated_barcode = add_codabar_checkdigit($barcode_number + $i*10, 1); # strip last digit
- } elsif ($barcode_number =~ /^\d{13}$/) {
- $calculated_barcode = add_codabar_checkdigit($barcode_number + $i, 0);
- } elsif ($barcode_number =~ /^\d{14}$/) {
- $calculated_barcode = add_codabar_checkdigit($barcode_number + $i*10, 1); # strip last digit
- } else {
- $calculated_barcode = $barcode_number + $i;
- }
- }
- push @res, $barcode_text . $calculated_barcode;
- }
- return \@res
-}
-
-# Codabar doesn't define a checkdigit algorithm, but this one is typically used by libraries. gmcharlt++
-sub add_codabar_checkdigit {
- my $barcode = shift;
- my $strip_last_digit = shift;
-
- return $barcode if $barcode =~ /\D/;
- $barcode = substr($barcode, 0, length($barcode)-1) if $strip_last_digit;
- my @digits = split //, $barcode;
- my $total = 0;
- for (my $i = 1; $i < length($barcode); $i+=2) { # for a 13/14 digit barcode, would expect 1,3,5,7,9,11
- $total += $digits[$i];
- }
- for (my $i = 0; $i < length($barcode); $i+=2) { # for a 13/14 digit barcode, would expect 0,2,4,6,8,10,12
- $total += (2 * $digits[$i] >= 10) ? (2 * $digits[$i] - 9) : (2 * $digits[$i]);
- }
- my $remainder = $total % 10;
- my $checkdigit = ($remainder == 0) ? $remainder : 10 - $remainder;
- return $barcode . $checkdigit;
-}
-
-__PACKAGE__->register_method(
- method => "orgs_for_title",
- authoritative => 1,
- api_name => "open-ils.cat.actor.org_unit.retrieve_by_title"
-);
-
-sub orgs_for_title {
- my( $self, $client, $record_id ) = @_;
-
- my $vols = $U->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.asset.call_number.search.atomic",
- { record => $record_id, deleted => 'f' });
-
- my $orgs = { map {$_->owning_lib => 1 } @$vols };
- return [ keys %$orgs ];
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_copies",
- authoritative => 1,
- api_name => "open-ils.cat.asset.copy_tree.retrieve");
-
-__PACKAGE__->register_method(
- method => "retrieve_copies",
- api_name => "open-ils.cat.asset.copy_tree.global.retrieve");
-
-# user_session may be null/undef
-sub retrieve_copies {
-
- my( $self, $client, $user_session, $docid, @org_ids ) = @_;
-
- if(ref($org_ids[0])) { @org_ids = @{$org_ids[0]}; }
-
- $docid = "$docid";
-
- # grabbing copy trees should be available for everyone..
- if(!@org_ids and $user_session) {
- my($user_obj, $evt) = OpenILS::Application::AppUtils->checkses($user_session);
- return $evt if $evt;
- @org_ids = ($user_obj->home_ou);
- }
-
- if( $self->api_name =~ /global/ ) {
- return _build_volume_list( { record => $docid, deleted => 'f', label => { '<>' => '##URI##' } } );
-
- } else {
-
- my @all_vols;
- for my $orgid (@org_ids) {
- my $vols = _build_volume_list(
- { record => $docid, owning_lib => $orgid, deleted => 'f', label => { '<>' => '##URI##' } } );
- push( @all_vols, @$vols );
- }
-
- return \@all_vols;
- }
-
- return undef;
-}
-
-
-sub _build_volume_list {
- my $search_hash = shift;
-
- $search_hash->{deleted} = 'f';
- my $e = new_editor();
-
- my $vols = $e->search_asset_call_number([$search_hash, { 'order_by' => {
- 'acn' => 'oils_text_as_bytea(label_sortkey), oils_text_as_bytea(label), id, owning_lib'
- } } ] );
-
- my @volumes;
-
- for my $volume (@$vols) {
-
- my $copies = $e->search_asset_copy(
- { call_number => $volume->id , deleted => 'f' });
-
- $copies = [ sort { $a->barcode cmp $b->barcode } @$copies ];
-
- for my $c (@$copies) {
- if( $c->status == OILS_COPY_STATUS_CHECKED_OUT ) {
- $c->circulations(
- $e->search_action_circulation(
- [
- { target_copy => $c->id },
- {
- order_by => { circ => 'xact_start desc' },
- limit => 1
- }
- ]
- )
- )
- }
- }
-
- $volume->copies($copies);
- push( @volumes, $volume );
- }
-
- #$session->disconnect();
- return \@volumes;
-
-}
-
-
-__PACKAGE__->register_method(
- method => "fleshed_copy_update",
- api_name => "open-ils.cat.asset.copy.fleshed.batch.update",);
-
-__PACKAGE__->register_method(
- method => "fleshed_copy_update",
- api_name => "open-ils.cat.asset.copy.fleshed.batch.update.override",);
-
-
-sub fleshed_copy_update {
- my( $self, $conn, $auth, $copies, $delete_stats ) = @_;
- return 1 unless ref $copies;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
- my $retarget_holds = [];
- $evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
- $editor, $override, undef, $copies, $delete_stats, $retarget_holds, undef);
-
- if( $evt ) {
- $logger->info("fleshed copy update failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
-
- $editor->commit;
- $logger->info("fleshed copy update successfully updated ".scalar(@$copies)." copies");
- reset_hold_list($auth, $retarget_holds);
-
- return 1;
-}
-
-sub reset_hold_list {
- my($auth, $hold_ids) = @_;
- return unless @$hold_ids;
- $logger->info("reseting holds after copy status change: @$hold_ids");
- my $ses = OpenSRF::AppSession->create('open-ils.circ');
- $ses->request('open-ils.circ.hold.reset.batch', $auth, $hold_ids);
-}
-
-
-__PACKAGE__->register_method(
- method => 'in_db_merge',
- api_name => 'open-ils.cat.biblio.records.merge',
- signature => q/
- Merges a group of records
- @param auth The login session key
- @param master The id of the record all other records should be merged into
- @param records Array of records to be merged into the master record
- @return 1 on success, Event on error.
- /
-);
-
-sub in_db_merge {
- my( $self, $conn, $auth, $master, $records ) = @_;
-
- my $editor = new_editor( authtoken => $auth, xact => 1 );
- return $editor->die_event unless $editor->checkauth;
- return $editor->die_event unless $editor->allowed('MERGE_BIB_RECORDS'); # TODO see below about record ownership
-
- my $count = 0;
- for my $source ( @$records ) {
- #XXX we actually /will/ want to check perms for master and sources after record ownership exists
-
- # This stored proc (asset.merge_record_assets(target,source)) has the side effects of
- # moving call_number, title-type (and some volume-type) hold_request and uri-mapping
- # objects from the source record to the target record, so must be called from within
- # a transaction.
-
- $count += $editor->json_query({
- select => {
- bre => [{
- alias => 'count',
- transform => 'asset.merge_record_assets',
- column => 'id',
- params => [$source]
- }]
- },
- from => 'bre',
- where => { id => $master }
- })->[0]->{count}; # count of objects moved, of all types
-
- }
-
- $editor->commit;
- return $count;
-}
-
-__PACKAGE__->register_method(
- method => 'in_db_auth_merge',
- api_name => 'open-ils.cat.authority.records.merge',
- signature => q/
- Merges a group of authority records
- @param auth The login session key
- @param master The id of the record all other records should be merged into
- @param records Array of records to be merged into the master record
- @return 1 on success, Event on error.
- /
-);
-
-sub in_db_auth_merge {
- my( $self, $conn, $auth, $master, $records ) = @_;
-
- my $editor = new_editor( authtoken => $auth, xact => 1 );
- return $editor->die_event unless $editor->checkauth;
- return $editor->die_event unless $editor->allowed('MERGE_AUTH_RECORDS'); # TODO see below about record ownership
-
- my $count = 0;
- for my $source ( @$records ) {
- $count += $editor->json_query({
- select => {
- are => [{
- alias => 'count',
- transform => 'authority.merge_records',
- column => 'id',
- params => [$source]
- }]
- },
- from => 'are',
- where => { id => $master }
- })->[0]->{count}; # count of objects moved, of all types
- }
-
- $editor->commit;
- return $count;
-}
-
-__PACKAGE__->register_method(
- method => "fleshed_volume_update",
- api_name => "open-ils.cat.asset.volume.fleshed.batch.update",);
-
-__PACKAGE__->register_method(
- method => "fleshed_volume_update",
- api_name => "open-ils.cat.asset.volume.fleshed.batch.update.override",);
-
-sub fleshed_volume_update {
- my( $self, $conn, $auth, $volumes, $delete_stats, $options ) = @_;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- $options ||= {};
-
- my $override = ($self->api_name =~ /override/);
- my $editor = new_editor( requestor => $reqr, xact => 1 );
- my $retarget_holds = [];
- my $auto_merge_vols = $options->{auto_merge_vols};
-
- for my $vol (@$volumes) {
- $logger->info("vol-update: investigating volume ".$vol->id);
-
- $vol->editor($reqr->id);
- $vol->edit_date('now');
-
- my $copies = $vol->copies;
- $vol->clear_copies;
-
- $vol->editor($editor->requestor->id);
- $vol->edit_date('now');
-
- if( $vol->isdeleted ) {
-
- $logger->info("vol-update: deleting volume");
- my $cs = $editor->search_asset_copy(
- { call_number => $vol->id, deleted => 'f' } );
- return OpenILS::Event->new(
- 'VOLUME_NOT_EMPTY', payload => $vol->id ) if @$cs;
-
- $vol->deleted('t');
- return $editor->event unless
- $editor->update_asset_call_number($vol);
-
-
- } elsif( $vol->isnew ) {
- $logger->info("vol-update: creating volume");
- $evt = OpenILS::Application::Cat::AssetCommon->create_volume( $override, $editor, $vol );
- return $evt if $evt;
-
- } elsif( $vol->ischanged ) {
- $logger->info("vol-update: update volume");
- my $resp = update_volume($vol, $editor, ($override or $auto_merge_vols));
- return $resp->{evt} if $resp->{evt};
- $vol = $resp->{merge_vol};
- }
-
- # now update any attached copies
- if( $copies and @$copies and !$vol->isdeleted ) {
- $_->call_number($vol->id) for @$copies;
- $evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
- $editor, $override, $vol, $copies, $delete_stats, $retarget_holds, undef);
- return $evt if $evt;
- }
- }
-
- $editor->finish;
- reset_hold_list($auth, $retarget_holds);
- return scalar(@$volumes);
-}
-
-
-sub update_volume {
- my $vol = shift;
- my $editor = shift;
- my $auto_merge = shift;
- my $evt;
- my $merge_vol;
-
- return {evt => $evt}
- if ( $evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($editor, $vol->owning_lib) );
-
- my $vols = $editor->search_asset_call_number({
- owning_lib => $vol->owning_lib,
- record => $vol->record,
- label => $vol->label,
- deleted => 'f',
- id => {'!=' => $vol->id}
- });
-
- if(@$vols) {
-
- if($auto_merge) {
-
- # If the auto-merge option is on, merge our updated volume into the existing
- # volume with the same record + owner + label.
- ($merge_vol, $evt) = OpenILS::Application::Cat::Merge::merge_volumes($editor, [$vol], $vols->[0]);
- return {evt => $evt, merge_vol => $merge_vol};
-
- } else {
- return {evt => OpenILS::Event->new('VOLUME_LABEL_EXISTS', payload => $vol->id)};
- }
- }
-
- return {evt => $editor->die_event} unless $editor->update_asset_call_number($vol);
- return {};
-}
-
-
-
-__PACKAGE__->register_method (
- method => 'delete_bib_record',
- api_name => 'open-ils.cat.biblio.record_entry.delete');
-
-sub delete_bib_record {
- my($self, $conn, $auth, $rec_id) = @_;
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('DELETE_RECORD', $e->requestor->ws_ou);
- my $vols = $e->search_asset_call_number({record=>$rec_id, deleted=>'f'});
- return OpenILS::Event->new('RECORD_NOT_EMPTY', payload=>$rec_id) if @$vols;
- my $evt = OpenILS::Application::Cat::BibCommon->delete_rec($e, $rec_id);
- if($evt) { $e->rollback; return $evt; }
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method (
- method => 'batch_volume_transfer',
- api_name => 'open-ils.cat.asset.volume.batch.transfer',
-);
-
-__PACKAGE__->register_method (
- method => 'batch_volume_transfer',
- api_name => 'open-ils.cat.asset.volume.batch.transfer.override',
-);
-
-
-sub batch_volume_transfer {
- my( $self, $conn, $auth, $args ) = @_;
-
- my $evt;
- my $rec = $$args{docid};
- my $o_lib = $$args{lib};
- my $vol_ids = $$args{volumes};
-
- my $override = 1 if $self->api_name =~ /override/;
-
- $logger->info("merge: transferring volumes to lib=$o_lib and record=$rec");
-
- my $e = new_editor(authtoken => $auth, xact =>1);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('UPDATE_VOLUME', $o_lib);
-
- my $dorg = $e->retrieve_actor_org_unit($o_lib)
- or return $e->event;
-
- my $ou_type = $e->retrieve_actor_org_unit_type($dorg->ou_type)
- or return $e->event;
-
- return $evt if ( $evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($e, $o_lib) );
-
- my $vols = $e->batch_retrieve_asset_call_number($vol_ids);
- my @seen;
-
- my @rec_ids;
-
- for my $vol (@$vols) {
-
- # if we've already looked at this volume, go to the next
- next if !$vol or grep { $vol->id == $_ } @seen;
-
- # grab all of the volumes in the list that have
- # the same label so they can be merged
- my @all = grep { $_->label eq $vol->label } @$vols;
-
- # take note of the fact that we've looked at this set of volumes
- push( @seen, $_->id ) for @all;
- push( @rec_ids, $_->record ) for @all;
-
- # for each volume, see if there are any copies that have a
- # remote circ_lib (circ_lib != vol->owning_lib and != $o_lib ).
- # if so, warn them
- unless( $override ) {
- for my $v (@all) {
-
- $logger->debug("merge: searching for copies with remote circ_lib for volume ".$v->id);
- my $args = {
- call_number => $v->id,
- circ_lib => { "not in" => [ $o_lib, $v->owning_lib ] },
- deleted => 'f'
- };
-
- my $copies = $e->search_asset_copy($args, {idlist=>1});
-
- # if the copy's circ_lib matches the destination lib,
- # that's ok too
- return OpenILS::Event->new('COPY_REMOTE_CIRC_LIB') if @$copies;
- }
- }
-
- # see if there is a volume at the destination lib that
- # already has the requested label
- my $existing_vol = $e->search_asset_call_number(
- {
- label => $vol->label,
- record => $rec,
- owning_lib => $o_lib,
- deleted => 'f'
- }
- )->[0];
-
- if( $existing_vol ) {
-
- if( grep { $_->id == $existing_vol->id } @all ) {
- # this volume is already accounted for in our list of volumes to merge
- $existing_vol = undef;
-
- } else {
- # this volume exists on the destination record/owning_lib and must
- # be used as the destination for merging
- $logger->debug("merge: volume already exists at destination record: ".
- $existing_vol->id.' : '.$existing_vol->label) if $existing_vol;
- }
- }
-
- if( @all > 1 || $existing_vol ) {
- $logger->info("merge: found collisions in volume transfer");
- my @args = ($e, \@all);
- @args = ($e, \@all, $existing_vol) if $existing_vol;
- ($vol, $evt) = OpenILS::Application::Cat::Merge::merge_volumes(@args);
- return $evt if $evt;
- }
-
- if( !$existing_vol ) {
-
- $vol->owning_lib($o_lib);
- $vol->record($rec);
- $vol->editor($e->requestor->id);
- $vol->edit_date('now');
-
- $logger->info("merge: updating volume ".$vol->id);
- $e->update_asset_call_number($vol) or return $e->event;
-
- } else {
- $logger->info("merge: bypassing volume update because existing volume used as target");
- }
-
- # regardless of what volume was used as the destination,
- # update any copies that have moved over to the new lib
- my $copies = $e->search_asset_copy({call_number=>$vol->id, deleted => 'f'});
-
- # update circ lib on the copies - make this a method flag?
- for my $copy (@$copies) {
- next if $copy->circ_lib == $o_lib;
- $logger->info("merge: transfer moving circ lib on copy ".$copy->id);
- $copy->circ_lib($o_lib);
- $copy->editor($e->requestor->id);
- $copy->edit_date('now');
- $e->update_asset_copy($copy) or return $e->event;
- }
-
- # Now see if any empty records need to be deleted after all of this
-
- for(@rec_ids) {
- $logger->debug("merge: seeing if we should delete record $_...");
- $evt = OpenILS::Application::Cat::BibCommon->delete_rec($e, $_)
- if OpenILS::Application::Cat::BibCommon->title_is_empty($e, $_);
- return $evt if $evt;
- }
- }
-
- $logger->info("merge: transfer succeeded");
- $e->commit;
- return 1;
-}
-
-
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.cat.call_number.find_or_create',
- method => 'find_or_create_volume',
-);
-
-sub find_or_create_volume {
- my( $self, $conn, $auth, $label, $record_id, $org_id ) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my ($vol, $evt, $exists) =
- OpenILS::Application::Cat::AssetCommon->find_or_create_volume($e, $label, $record_id, $org_id);
- return $evt if $evt;
- $e->rollback if $exists;
- $e->commit if $vol;
- return $vol->id;
-}
-
-
-__PACKAGE__->register_method(
- method => "create_serial_record_xml",
- api_name => "open-ils.cat.serial.record.xml.create.override",
- signature => q/@see open-ils.cat.serial.record.xml.create/);
-
-__PACKAGE__->register_method(
- method => "create_serial_record_xml",
- api_name => "open-ils.cat.serial.record.xml.create",
- signature => q/
- Inserts a new serial record with the given XML
- /
-);
-
-sub create_serial_record_xml {
- my( $self, $client, $login, $source, $owning_lib, $record_id, $xml ) = @_;
-
- my $override = 1 if $self->api_name =~ /override/; # not currently used
-
- my $e = new_editor(xact=>1, authtoken=>$login);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_MFHD_RECORD', $owning_lib);
-
- # Auto-populate the location field of a placeholder MFHD record with the library name
- my $aou = $e->retrieve_actor_org_unit($owning_lib) or return $e->die_event;
-
- my $mfhd = Fieldmapper::serial::record_entry->new;
-
- $mfhd->source($source) if $source;
- $mfhd->record($record_id);
- $mfhd->creator($e->requestor->id);
- $mfhd->editor($e->requestor->id);
- $mfhd->create_date('now');
- $mfhd->edit_date('now');
- $mfhd->owning_lib($owning_lib);
-
- # If the caller did not pass in MFHD XML, create a placeholder record.
- # The placeholder will only contain the name of the owning library.
- # The goal is to generate common patterns for the caller in the UI that
- # then get passed in here.
- if (!$xml) {
- my $aou_name = $aou->name;
- $xml = <<HERE;
-<record
- xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
- xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
- xmlns="http://www.loc.gov/MARC21/slim">
-<leader>00307ny a22001094 4500</leader>
-<controlfield tag="001">42153</controlfield>
-<controlfield tag="005">20090601182414.0</controlfield>
-<controlfield tag="004">$record_id</controlfield>
-<controlfield tag="008"> 4u####8###l# 4 uueng1 </controlfield>
-<datafield tag="852" ind1=" " ind2=" "> <subfield code="b">$aou_name</subfield></datafield>
-</record>
-HERE
- }
- my $marcxml = XML::LibXML->new->parse_string($xml);
- $marcxml->documentElement->setNamespace("http://www.loc.gov/MARC21/slim", "marc", 1 );
- $marcxml->documentElement->setNamespace("http://www.loc.gov/MARC21/slim");
-
- $mfhd->marc($U->entityize($marcxml->documentElement->toString));
-
- $e->create_serial_record_entry($mfhd) or return $e->die_event;
-
- $e->commit;
- return $mfhd->id;
-}
-
-__PACKAGE__->register_method(
- method => "create_update_asset_copy_template",
- api_name => "open-ils.cat.asset.copy_template.create_or_update"
-);
-
-sub create_update_asset_copy_template {
- my ($self, $client, $authtoken, $act) = @_;
-
- my $e = new_editor("xact" => 1, "authtoken" => $authtoken);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed(
- "ADMIN_ASSET_COPY_TEMPLATE", $act->owning_lib
- );
-
- $act->editor($e->requestor->id);
- $act->edit_date("now");
-
- my $retval;
- if (!$act->id) {
- $act->creator($e->requestor->id);
- $act->create_date("now");
-
- $e->create_asset_copy_template($act) or return $e->die_event;
- $retval = $e->data;
- } else {
- $e->update_asset_copy_template($act) or return $e->die_event;
- $retval = $e->retrieve_asset_copy_template($e->data);
- }
- $e->commit and return $retval;
-}
-
-1;
-
-# vi:et:ts=4:sw=4
+++ /dev/null
-package OpenILS::Application::Cat::AssetCommon;
-use strict; use warnings;
-use OpenILS::Application::Cat::BibCommon;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger qw($logger);
-use OpenILS::Application::Cat::Merge;
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Const qw/:const/;
-use OpenSRF::AppSession;
-use OpenILS::Event;
-use OpenILS::Application::Circ::CircCommon;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-# ---------------------------------------------------------------------------
-# Shared copy mangling code. Do not publish methods from here.
-# ---------------------------------------------------------------------------
-
-sub org_cannot_have_vols {
- my($class, $e, $org_id) = @_;
- my $org = $e->retrieve_actor_org_unit([
- $org_id,
- { flesh => 1,
- flesh_fields => {aou => ['ou_type']}
- }]) or return $e->event;
-
- return OpenILS::Event->new('ORG_CANNOT_HAVE_VOLS')
- unless $U->is_true($org->ou_type->can_have_vols);
-
- return 0;
-}
-
-sub fix_copy_price {
- my $class = shift;
- my $copy = shift;
-
- if(defined $copy->price) {
- my $p = $copy->price || 0;
- $p =~ s/\$//og;
- $copy->price($p);
- }
-
- my $d = $copy->deposit_amount || 0;
- $d =~ s/\$//og;
- $copy->deposit_amount($d);
-}
-
-sub create_copy {
- my($class, $editor, $vol, $copy) = @_;
-
- my $existing = $editor->search_asset_copy(
- { barcode => $copy->barcode, deleted => 'f' } );
-
- return OpenILS::Event->new('ITEM_BARCODE_EXISTS') if @$existing;
-
- # see if the volume this copy references is marked as deleted
- return OpenILS::Event->new('VOLUME_DELETED', vol => $vol->id)
- if $U->is_true($vol->deleted);
-
- my $evt;
- my $org = (ref $copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
- return $evt if ($evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($editor, $org));
-
- $copy->clear_id;
- $copy->editor($editor->requestor->id);
- $copy->creator($editor->requestor->id);
- $copy->create_date('now');
- $copy->call_number($vol->id);
- $class->fix_copy_price($copy);
-
- $editor->create_asset_copy($copy) or return $editor->die_event;
- return undef;
-}
-
-
-# if 'delete_stats' is true, the copy->stat_cat_entries data is
-# treated as the authoritative list for the copy. existing entries
-# that are not in said list will be deleted from the DB
-sub update_copy_stat_entries {
- my($class, $editor, $copy, $delete_stats) = @_;
-
- return undef if $copy->isdeleted;
- return undef unless $copy->ischanged or $copy->isnew;
-
- my $evt;
- my $entries = $copy->stat_cat_entries;
-
- if( $delete_stats ) {
- $entries = ($entries and @$entries) ? $entries : [];
- } else {
- return undef unless ($entries and @$entries);
- }
-
- my $maps = $editor->search_asset_stat_cat_entry_copy_map({owning_copy=>$copy->id});
-
- if(!$copy->isnew) {
- # if there is no stat cat entry on the copy who's id matches the
- # current map's id, remove the map from the database
- for my $map (@$maps) {
- if(! grep { $_->id == $map->stat_cat_entry } @$entries ) {
-
- $logger->info("copy update found stale ".
- "stat cat entry map ".$map->id. " on copy ".$copy->id);
-
- $editor->delete_asset_stat_cat_entry_copy_map($map)
- or return $editor->event;
- }
- }
- }
-
- # go through the stat cat update/create process
- for my $entry (@$entries) {
- next unless $entry;
-
- # if this link already exists in the DB, don't attempt to re-create it
- next if( grep{$_->stat_cat_entry == $entry->id} @$maps );
-
- my $new_map = Fieldmapper::asset::stat_cat_entry_copy_map->new();
-
- my $sc = ref($entry->stat_cat) ? $entry->stat_cat->id : $entry->stat_cat;
-
- $new_map->stat_cat( $sc );
- $new_map->stat_cat_entry( $entry->id );
- $new_map->owning_copy( $copy->id );
-
- $editor->create_asset_stat_cat_entry_copy_map($new_map)
- or return $editor->event;
-
- $logger->info("copy update created new stat cat entry map ".$editor->data);
- }
-
- return undef;
-}
-
-
-sub update_copy {
- my($class, $editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib) = @_;
-
- my $evt;
- my $org = (ref $copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
- return $evt if ( $evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($editor, $org) );
-
- $logger->info("vol-update: updating copy ".$copy->id);
- my $orig_copy = $editor->retrieve_asset_copy($copy->id);
- my $orig_vol = $editor->retrieve_asset_call_number($copy->call_number);
-
- $copy->editor($editor->requestor->id);
- $copy->edit_date('now');
-
- $copy->age_protect( $copy->age_protect->id )
- if ref $copy->age_protect;
-
- $class->fix_copy_price($copy);
- $class->check_hold_retarget($editor, $copy, $orig_copy, $retarget_holds);
-
- return $editor->event unless $editor->update_asset_copy($copy);
- return $class->remove_empty_objects($editor, $override, $orig_vol, $force_delete_empty_bib);
-}
-
-sub check_hold_retarget {
- my($class, $editor, $copy, $orig_copy, $retarget_holds) = @_;
- return unless $retarget_holds;
-
- if( !($copy->isdeleted or $U->is_true($copy->deleted)) ) {
- # see if a status change warrants a retarget
-
- $orig_copy = $editor->retrieve_asset_copy($copy->id) unless $orig_copy;
-
- if($orig_copy->status == $copy->status) {
- # no status change, no retarget
- return;
- }
-
- my $stat = $editor->retrieve_config_copy_status($copy->status);
-
- # new status is holdable, no retarget. Later add logic to find potential
- # holds and retarget those to pick up the newly available copy
- return if $U->is_true($stat->holdable);
- }
-
- my $hold_ids = $editor->search_action_hold_request(
- { current_copy => $copy->id,
- cancel_time => undef,
- fulfillment_time => undef
- }, {idlist => 1}
- );
-
- push(@$retarget_holds, @$hold_ids);
-}
-
-
-# this does the actual work
-sub update_fleshed_copies {
- my($class, $editor, $override, $vol, $copies, $delete_stats, $retarget_holds, $force_delete_empty_bib) = @_;
-
- my $evt;
- my $fetchvol = ($vol) ? 0 : 1;
-
- my %cache;
- $cache{$vol->id} = $vol if $vol;
-
- for my $copy (@$copies) {
-
- my $copyid = $copy->id;
- $logger->info("vol-update: inspecting copy $copyid");
-
- if( !($vol = $cache{$copy->call_number}) ) {
- $vol = $cache{$copy->call_number} =
- $editor->retrieve_asset_call_number($copy->call_number);
- return $editor->event unless $vol;
- }
-
- return $editor->event unless
- $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- $copy->editor($editor->requestor->id);
- $copy->edit_date('now');
-
- $copy->status( $copy->status->id ) if ref($copy->status);
- $copy->location( $copy->location->id ) if ref($copy->location);
- $copy->circ_lib( $copy->circ_lib->id ) if ref($copy->circ_lib);
-
- my $sc_entries = $copy->stat_cat_entries;
- $copy->clear_stat_cat_entries;
-
- if( $copy->isdeleted ) {
- $evt = $class->delete_copy($editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib);
- return $evt if $evt;
-
- } elsif( $copy->isnew ) {
- $evt = $class->create_copy( $editor, $vol, $copy );
- return $evt if $evt;
-
- } elsif( $copy->ischanged ) {
-
- $evt = $class->update_copy( $editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib);
- return $evt if $evt;
- }
-
- $copy->stat_cat_entries( $sc_entries );
- $evt = $class->update_copy_stat_entries($editor, $copy, $delete_stats);
- return $evt if $evt;
- }
-
- $logger->debug("vol-update: done updating copy batch");
-
- return undef;
-}
-
-
-sub delete_copy {
- my($class, $editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib) = @_;
-
- return $editor->event unless
- $editor->allowed('DELETE_COPY', $class->copy_perm_org($vol, $copy));
-
- my $stat = $U->copy_status($copy->status)->id;
-
- unless($override) {
- return OpenILS::Event->new('COPY_DELETE_WARNING', payload => $copy->id )
- if $stat == OILS_COPY_STATUS_CHECKED_OUT or
- $stat == OILS_COPY_STATUS_IN_TRANSIT or
- $stat == OILS_COPY_STATUS_ON_HOLDS_SHELF or
- $stat == OILS_COPY_STATUS_ILL;
- }
-
- $logger->info("vol-update: deleting copy ".$copy->id);
- $copy->deleted('t');
-
- $copy->editor($editor->requestor->id);
- $copy->edit_date('now');
- $editor->update_asset_copy($copy) or return $editor->event;
-
- # Delete any open transits for this copy
- my $transits = $editor->search_action_transit_copy(
- { target_copy=>$copy->id, dest_recv_time => undef } );
-
- for my $t (@$transits) {
- $editor->delete_action_transit_copy($t)
- or return $editor->event;
- }
-
- $class->check_hold_retarget($editor, $copy, undef, $retarget_holds);
-
- return $class->remove_empty_objects($editor, $override, $vol, $force_delete_empty_bib);
-}
-
-
-
-sub create_volume {
- my($class, $override, $editor, $vol) = @_;
- my $evt;
-
- return $evt if ( $evt = $class->org_cannot_have_vols($editor, $vol->owning_lib) );
-
- # see if the record this volume references is marked as deleted
- my $rec = $editor->retrieve_biblio_record_entry($vol->record)
- or return $editor->die_event;
- return OpenILS::Event->new('BIB_RECORD_DELETED', rec => $rec->id)
- if $U->is_true($rec->deleted);
-
- # first lets see if there are any collisions
- my $vols = $editor->search_asset_call_number( {
- owning_lib => $vol->owning_lib,
- record => $vol->record,
- label => $vol->label,
- deleted => 'f'
- }
- );
-
- my $label = undef;
- if(@$vols) {
- # we've found an exising volume
- if($override) {
- $label = $vol->label;
- } else {
- return OpenILS::Event->new(
- 'VOLUME_LABEL_EXISTS', payload => $vol->id);
- }
- }
-
- # create a temp label so we can create the new volume,
- # then de-dup it with the existing volume
- $vol->label( "__SYSTEM_TMP_$$".time) if $label;
-
- $vol->creator($editor->requestor->id);
- $vol->create_date('now');
- $vol->editor($editor->requestor->id);
- $vol->edit_date('now');
- $vol->clear_id;
-
- $editor->create_asset_call_number($vol) or return $editor->die_event;
-
- if($label) {
- # now restore the label and merge into the existing record
- $vol->label($label);
- (undef, $evt) =
- OpenILS::Application::Cat::Merge::merge_volumes($editor, [$vol], $$vols[0]);
- return $evt if $evt;
- }
-
- return undef;
-}
-
-# returns the volume if it exists
-sub volume_exists {
- my($class, $e, $rec_id, $label, $owning_lib) = @_;
- return $e->search_asset_call_number(
- {label => $label, record => $rec_id, owning_lib => $owning_lib, deleted => 'f'})->[0];
-}
-
-sub find_or_create_volume {
- my($class, $e, $label, $record_id, $org_id) = @_;
-
- my $vol;
-
- if($record_id == OILS_PRECAT_RECORD) {
- $vol = $e->retrieve_asset_call_number(OILS_PRECAT_CALL_NUMBER)
- or return (undef, $e->die_event);
-
- } else {
- $vol = $class->volume_exists($e, $record_id, $label, $org_id);
- }
-
- # If the volume exists, return the ID
- return ($vol, undef, 1) if $vol;
-
- # -----------------------------------------------------------------
- # Otherwise, create a new volume with the given attributes
- # -----------------------------------------------------------------
- return (undef, $e->die_event) unless $e->allowed('UPDATE_VOLUME', $org_id);
-
- $vol = Fieldmapper::asset::call_number->new;
- $vol->owning_lib($org_id);
- $vol->label($label);
- $vol->record($record_id);
-
- my $evt = OpenILS::Application::Cat::AssetCommon->create_volume(0, $e, $vol);
- return (undef, $evt) if $evt;
-
- return ($vol);
-}
-
-
-sub create_copy_note {
- my($class, $e, $copy, $title, $value, $pub) = @_;
- my $note = Fieldmapper::asset::copy_note->new;
- $note->owning_copy($copy->id);
- $note->creator($e->requestor->id);
- $note->pub('t');
- $note->value($value);
- $note->title($title);
- $e->create_asset_copy_note($note) or return $e->die_event;
- return undef;
-}
-
-
-sub remove_empty_objects {
- my($class, $editor, $override, $vol, $force_delete_empty_bib) = @_;
-
- my $koe = $U->ou_ancestor_setting_value(
- $editor->requestor->ws_ou, 'cat.bib.keep_on_empty', $editor);
- my $aoe = $U->ou_ancestor_setting_value(
- $editor->requestor->ws_ou, 'cat.bib.alert_on_empty', $editor);
-
- if( OpenILS::Application::Cat::BibCommon->title_is_empty($editor, $vol->record, $vol->id) ) {
-
- # delete this volume if it's not already marked as deleted
- unless( $U->is_true($vol->deleted) || $vol->isdeleted ) {
- $vol->deleted('t');
- $vol->editor($editor->requestor->id);
- $vol->edit_date('now');
- $editor->update_asset_call_number($vol) or return $editor->event;
- }
-
- return OpenILS::Event->new('TITLE_LAST_COPY', payload => $vol->record )
- if $aoe and not $override and not $force_delete_empty_bib;
-
- unless($koe and not $force_delete_empty_bib) {
- # delete the bib record if the keep-on-empty setting is not set (and we're not otherwise forcing things, say through acq settings)
- my $evt = OpenILS::Application::Cat::BibCommon->delete_rec($editor, $vol->record);
- return $evt if $evt;
- }
- }
-
- return undef;
-}
-
-
-sub copy_perm_org {
- my($class, $vol, $copy) = @_;
- my $org = $vol->owning_lib;
- if( $vol->id == OILS_PRECAT_CALL_NUMBER ) {
- $org = ref($copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
- }
- $logger->debug("using copy perm org $org");
- return $org;
-}
-
-
-sub set_item_lost {
- my($class, $e, $copy_id) = @_;
-
- my $copy = $e->retrieve_asset_copy([
- $copy_id,
- {flesh => 1, flesh_fields => {'acp' => ['call_number']}}])
- or return $e->die_event;
-
- my $owning_lib =
- ($copy->call_number->id == OILS_PRECAT_CALL_NUMBER) ?
- $copy->circ_lib : $copy->call_number->owning_lib;
-
- my $circ = $e->search_action_circulation(
- {checkin_time => undef, target_copy => $copy->id} )->[0]
- or return $e->die_event;
-
- $e->allowed('SET_CIRC_LOST', $circ->circ_lib) or return $e->die_event;
-
- return $e->die_event(OpenILS::Event->new('COPY_MARKED_LOST'))
- if $copy->status == OILS_COPY_STATUS_LOST;
-
- # ---------------------------------------------------------------------
- # fetch the related org settings
- my $proc_fee = $U->ou_ancestor_setting_value(
- $owning_lib, OILS_SETTING_LOST_PROCESSING_FEE, $e) || 0;
- my $void_overdue = $U->ou_ancestor_setting_value(
- $owning_lib, OILS_SETTING_VOID_OVERDUE_ON_LOST, $e) || 0;
-
- # ---------------------------------------------------------------------
- # move the copy into LOST status
- $copy->status(OILS_COPY_STATUS_LOST);
- $copy->editor($e->requestor->id);
- $copy->edit_date('now');
- $e->update_asset_copy($copy) or return $e->die_event;
-
- my $price = $U->get_copy_price($e, $copy, $copy->call_number);
-
- if( $price > 0 ) {
- my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
- $e, $price, 3, 'Lost Materials', $circ->id);
- return $evt if $evt;
- }
-
- # ---------------------------------------------------------------------
- # if there is a processing fee, charge that too
- if( $proc_fee > 0 ) {
- my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
- $e, $proc_fee, 4, 'Lost Materials Processing Fee', $circ->id);
- return $evt if $evt;
- }
-
- # ---------------------------------------------------------------------
- # mark the circ as lost and stop the fines
- $circ->stop_fines(OILS_STOP_FINES_LOST);
- $circ->stop_fines_time('now') unless $circ->stop_fines_time;
- $e->update_action_circulation($circ) or return $e->die_event;
-
- # ---------------------------------------------------------------------
- # void all overdue fines on this circ if configured
- if( $void_overdue ) {
- my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ);
- return $evt if $evt;
- }
-
- my $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($e, $circ->id);
- return $evt if $evt;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'lost', $circ, $circ->circ_lib);
-
- return undef;
-}
+++ /dev/null
-package OpenILS::Application::Cat::AuthCommon;
-use strict; use warnings;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger qw($logger);
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Const qw/:const/;
-use OpenSRF::AppSession;
-use OpenILS::Event;
-my $U = 'OpenILS::Application::AppUtils';
-my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
-
-
-# ---------------------------------------------------------------------------
-# Shared authority mangling code. Do not publish methods from here.
-# ---------------------------------------------------------------------------
-
-# generate a MARC XML document from a MARC XML string
-sub marc_xml_to_doc {
- my $xml = shift;
- my $marc_doc = XML::LibXML->new->parse_string($xml);
- $marc_doc->documentElement->setNamespace($MARC_NAMESPACE, 'marc', 1);
- $marc_doc->documentElement->setNamespace($MARC_NAMESPACE);
- return $marc_doc;
-}
-
-
-sub import_authority_record {
- my($class, $e, $marc_xml, $source) = @_;
-
- my $marc_doc = marc_xml_to_doc($marc_xml);
- my $rec = Fieldmapper::authority::record_entry->new;
- $rec->creator($e->requestor->id);
- $rec->editor($e->requestor->id);
- $rec->create_date('now');
- $rec->edit_date('now');
- $rec->marc($U->entityize($marc_doc->documentElement->toString));
-
- $rec = $e->create_authority_record_entry($rec) or return $e->die_event;
-
- # we don't care about the result, just fire off the request
- #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
- #$ses->request('open-ils.ingest.full.authority.record', $recid);
-
- return $rec;
-}
-
-
-sub overlay_authority_record {
- my($class, $e, $rec_id, $marc_xml, $source) = @_;
-
- my $marc_doc = marc_xml_to_doc($marc_xml);
- my $rec = $e->retrieve_authority_record_entry($rec_id) or return $e->die_event;
- $rec->editor($e->requestor->id);
- $rec->edit_date('now');
- $rec->marc($U->entityize($marc_doc->documentElement->toString));
-
- $rec = $e->update_authority_record_entry($rec) or return $e->die_event;
-
- # we don't care about the result, just fire off the request
- #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
- #$ses->request('open-ils.ingest.full.authority.record', $recid);
-
- return $rec;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Cat::Authority;
-use strict; use warnings;
-use base qw/OpenILS::Application/;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::Cat::AuthCommon;
-use OpenSRF::Utils::Logger qw($logger);
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Const qw/:const/;
-use OpenILS::Event;
-my $U = 'OpenILS::Application::AppUtils';
-my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
-
-
-# generate a MARC XML document from a MARC XML string
-sub marc_xml_to_doc {
- my $xml = shift;
- my $marc_doc = XML::LibXML->new->parse_string($xml);
- $marc_doc->documentElement->setNamespace($MARC_NAMESPACE, 'marc', 1);
- $marc_doc->documentElement->setNamespace($MARC_NAMESPACE);
- return $marc_doc;
-}
-
-
-__PACKAGE__->register_method(
- method => 'import_authority_record',
- api_name => 'open-ils.cat.authority.record.import',
-);
-
-sub import_authority_record {
- my($self, $conn, $auth, $marc_xml, $source) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_AUTHORITY_RECORD');
- my $rec = OpenILS::Application::Cat::AuthCommon->import_authority_record($marc_xml, $source);
- $e->commit unless $U->event_code($rec);
- return $rec;
-}
-
-__PACKAGE__->register_method(
- method => 'create_authority_record_from_bib_field',
- api_name => 'open-ils.cat.authority.record.create_from_bib',
- signature => {
- desc => q/Create an authority record entry from a field in a bibliographic record/,
- params => q/
- @param field A hash representing the field to control, consisting of: { tag: string, ind1: string, ind2: string, subfields: [ [code, value] ... ] }
- @param identifier A MARC control number identifier
- @param authtoken A valid authentication token
- @returns The new record object
- /}
-);
-
-__PACKAGE__->register_method(
- method => 'create_authority_record_from_bib_field',
- api_name => 'open-ils.cat.authority.record.create_from_bib.readonly',
- signature => {
- desc => q/Creates MARCXML for an authority record entry from a field in a bibliographic record/,
- params => q/
- @param field A hash representing the field to control, consisting of: { tag: string, ind1: string, ind2: string, subfields: [ [code, value] ... ] }
- @param identifier A MARC control number identifier
- @returns The MARCXML for the authority record
- /}
-);
-
-sub create_authority_record_from_bib_field {
- my($self, $conn, $field, $cni, $auth) = @_;
-
- # Control number identifier should have been passed in
- if (!$cni) {
- $cni = 'UNSET';
- }
-
- # Change the first character of the incoming bib field tag to a '1'
- # for use in our authority record; close enough for now?
- my $tag = $field->{'tag'};
- $tag =~ s/^./1/;
-
- my $ind1 = $field->{ind1} || ' ';
- my $ind2 = $field->{ind2} || ' ';
-
- my $control = qq{<datafield tag="$tag" ind1="$ind1" ind2="$ind2">};
- foreach my $sf (@{$field->{subfields}}) {
- my $code = $sf->[0];
- my $val = $U->entityize($sf->[1]);
- $control .= qq{<subfield code="$code">$val</subfield>};
- }
- $control .= '</datafield>';
-
- # ARN, or "authority record number", used to need to be unique across the database.
- # Of course, we have no idea what's in the database, and if the
- # cat.maintain_control_numbers flag is set to "TRUE" then the 001 will
- # be reset to the record ID anyway.
- my $arn = 'AUTOGEN-' . time();
-
- # Placeholder MARCXML;
- # 001/003 can be be properly filled in via database triggers
- # 005 will be filled in automatically at creation time
- # 008 needs to be set by a cataloguer (could be some OU settings, I suppose)
- # 040 should come from OU settings / OU shortname
- #
- my $marc_xml = <<MARCXML;
-<record xmlns:marc="http://www.loc.gov/MARC21/slim" xmlns="http://www.loc.gov/MARC21/slim"><leader> nz a22 o 4500</leader>
-<controlfield tag="001">$arn</controlfield>
-<controlfield tag="008"> ||||||||||||||||||||||||||||||||||</controlfield>
-<datafield tag="040" ind1=" " ind2=" "><subfield code="a">$cni</subfield><subfield code="c">$cni</subfield></datafield>
-$control
-</record>
-MARCXML
-
- if ($self->api_name =~ m/readonly$/) {
- return $marc_xml;
- } else {
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_AUTHORITY_RECORD');
- my $rec = OpenILS::Application::Cat::AuthCommon->import_authority_record($e, $marc_xml);
- $e->commit unless $U->event_code($rec);
- return $rec;
- }
-}
-
-__PACKAGE__->register_method(
- method => 'overlay_authority_record',
- api_name => 'open-ils.cat.authority.record.overlay',
-);
-
-sub overlay_authority_record {
- my($self, $conn, $auth, $rec_id, $marc_xml, $source) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('UPDATE_AUTHORITY_RECORD');
- my $rec = OpenILS::Application::Cat::AuthCommon->overlay_authority_record($rec_id, $marc_xml, $source);
- $e->commit unless $U->event_code($rec);
- return $rec;
-
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_authority_record',
- api_name => 'open-ils.cat.authority.record.retrieve',
- signature => {
- desc => q/Retrieve an authority record entry/,
- params => [
- {desc => q/hash of options. Options include "clear_marc" which clears
- the MARC xml from the record before it is returned/}
- ]
- }
-);
-sub retrieve_authority_record {
- my($self, $conn, $auth, $rec_id, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $rec = $e->retrieve_authority_record($rec_id) or return $e->event;
- $rec->clear_marc if $$options{clear_marc};
- return $rec;
-}
-
-__PACKAGE__->register_method(
- method => 'batch_retrieve_authority_record',
- api_name => 'open-ils.cat.authority.record.batch.retrieve',
- stream => 1,
- signature => {
- desc => q/Retrieve a set of authority record entry objects/,
- params => [
- {desc => q/hash of options. Options include "clear_marc" which clears
- the MARC xml from the record before it is returned/}
- ]
- }
-);
-sub batch_retrieve_authority_record {
- my($self, $conn, $auth, $rec_id_list, $options) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- for my $rec_id (@$rec_id_list) {
- my $rec = $e->retrieve_authority_record($rec_id) or return $e->event;
- $rec->clear_marc if $$options{clear_marc};
- $conn->respond($rec);
- }
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'count_linked_bibs',
- api_name => 'open-ils.cat.authority.records.count_linked_bibs',
- signature => q/
- Counts the number of bib records linked to each authority record in the input list
- @param records Array of authority records to return counts
- @return A list of hashes containing the authority record ID ("id") and linked bib count ("bibs")
- /
-);
-
-sub count_linked_bibs {
- my( $self, $conn, $records ) = @_;
-
- my $editor = new_editor();
-
- my $link_count;
- my @clean_records;
- for my $auth ( @$records ) {
- # Protection against SQL injection? Might be overkill.
- my $intauth = int($auth);
- if ($intauth) {
- push(@clean_records, $intauth);
- }
- }
- return $link_count if !@clean_records;
-
- $link_count = $editor->json_query({
- "select" => {
- "abl" => [
- {
- "column" => "authority"
- },
- {
- "alias" => "bibs",
- "transform" => "count",
- "column" => "bib",
- "aggregate" => 1
- }
- ]
- },
- "from" => "abl",
- "where" => { "authority" => \@clean_records }
- });
-
- return $link_count;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Cat::BibCommon;
-use strict; use warnings;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger qw($logger);
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Const qw/:const/;
-use OpenSRF::AppSession;
-use OpenILS::Event;
-my $U = 'OpenILS::Application::AppUtils';
-my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
-
-
-# ---------------------------------------------------------------------------
-# Shared bib mangling code. Do not publish methods from here.
-# ---------------------------------------------------------------------------
-
-my $__bib_sources;
-sub bib_source_from_name {
- my $name = shift;
- $logger->debug("searching for bib source: $name");
-
- fetch_bib_sources();
-
- my ($s) = grep { lc($_->source) eq lc($name) } @$__bib_sources;
-
- return $s->id if $s;
- return undef;
-}
-
-sub fetch_bib_sources {
- $__bib_sources = new_editor()->retrieve_all_config_bib_source()
- unless $__bib_sources;
- return $__bib_sources;
-}
-
-
-sub biblio_record_replace_marc {
- my($class, $e, $recid, $newxml, $source, $fixtcn, $override) = @_;
-
- my $rec = $e->retrieve_biblio_record_entry($recid)
- or return $e->die_event;
-
- # See if there is a different record in the database that has our TCN value
- # If we're not updating the TCN, all we care about it the marcdoc
- # XXX should .update even bother with the tcn_info if it's not going to replace it?
- # there is the potential for returning a TCN_EXISTS event, even though no replacement happens
-
- my( $tcn, $tsource, $marcdoc, $evt);
-
- if($fixtcn or $override) {
-
- ($tcn, $tsource, $marcdoc, $evt) =
- _find_tcn_info($e, $newxml, $override, $recid);
-
- return $evt if $evt;
-
- $rec->tcn_value($tcn) if ($tcn);
- $rec->tcn_source($tsource);
-
- } else {
-
- $marcdoc = __make_marc_doc($newxml);
- }
-
-
- $rec->source(bib_source_from_name($source)) if $source;
- $rec->editor($e->requestor->id);
- $rec->edit_date('now');
- $rec->marc( $U->entityize( $marcdoc->documentElement->toString ) );
- $e->update_biblio_record_entry($rec) or return $e->die_event;
-
- return $rec;
-}
-
-sub biblio_record_xml_import {
- my($class, $e, $xml, $source, $auto_tcn, $override) = @_;
-
- my( $evt, $tcn, $tcn_source, $marcdoc );
-
- my $use_id = $e->retrieve_config_global_flag('cat.bib.use_id_for_tcn');
- $use_id = ($use_id and $U->is_true($use_id->enabled));
-
- if( $auto_tcn or $use_id ) {
- # auto_tcn forces a blank TCN value so the DB will have to generate one for us
- $marcdoc = __make_marc_doc($xml);
- } else {
- ( $tcn, $tcn_source, $marcdoc, $evt ) = _find_tcn_info($e, $xml, $override);
- return $evt if $evt;
- }
-
- # Silence warnings when _find_tcn_info() fails
- $tcn ||= '';
- $tcn_source ||= '';
- $logger->info("user ".$e->requestor->id.
- " creating new biblio entry with tcn=$tcn and tcn_source $tcn_source");
-
- my $record = Fieldmapper::biblio::record_entry->new;
-
- $record->source(bib_source_from_name($source)) if $source;
- $record->tcn_source($tcn_source);
- $record->tcn_value($tcn) if ($tcn);
- $record->creator($e->requestor->id);
- $record->editor($e->requestor->id);
- $record->create_date('now');
- $record->edit_date('now');
- $record->marc($U->entityize($marcdoc->documentElement->toString));
-
- $record = $e->create_biblio_record_entry($record) or return $e->die_event;
-
- if($use_id) {
- my $existing = $e->search_biblio_record_entry(
- {
- tcn_value => $record->id,
- deleted => 'f'
- }, {
- idlist => 1
- }
- );
-
- if(@$existing) {
- # leave the auto-generated tcn_value in place
- $logger->warn("Collision using internal ID as tcn_value for record " . $record->id);
- } else {
- $record->tcn_value($record->id);
- $e->update_biblio_record_entry($record) or return $e->die_event;
- }
- }
-
- $logger->info("marc create/import created new record ".$record->id);
- return $record;
-}
-
-sub __make_marc_doc {
- my $xml = shift;
- my $marcxml = XML::LibXML->new->parse_string($xml);
- $marcxml->documentElement->setNamespace($MARC_NAMESPACE, "marc", 1 );
- $marcxml->documentElement->setNamespace($MARC_NAMESPACE);
- __remove_empty_marc_nodes($marcxml);
- return $marcxml;
-}
-
-# remove empty control fields, subfields, and variable data fields, which
-# can creep in via less-than-correct imported MARC records or issues
-# with templates
-sub __remove_empty_marc_nodes {
- my $marcxml = shift;
-
- __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'controlfield');
- __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'subfield');
- __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'datafield');
-}
-
-sub __remove_if_childless {
- my $node = shift;
- my @children = $node->childNodes();
- my $has_nonblank_children = 0;
- # can do this more concisely by requiring XML::LibXML >= 1.70 and using nonBlankChildNodes()
- foreach my $node ($node->childNodes()) {
- if ($node->nodeType != XML::LibXML::XML_TEXT_NODE || $node->nodeValue !~ /^\s*$/) {
- $has_nonblank_children = 1;
- last;
- }
- }
- $node->parentNode->removeChild($node) unless $has_nonblank_children;
-}
-
-sub _find_tcn_info {
- my $editor = shift;
- my $xml = shift;
- my $override = shift;
- my $existing_rec = shift || 0;
-
- # parse the XML
- my $marcxml = __make_marc_doc($xml);
-
- my $xpath = '//marc:controlfield[@tag="001"]';
- my $tcn = $marcxml->documentElement->findvalue($xpath);
- $logger->info("biblio import located 001 (tcn) value of $tcn");
-
- $xpath = '//marc:controlfield[@tag="003"]';
- my $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
-
- if(my $rec = _tcn_exists($editor, $tcn, $tcn_source, $existing_rec) ) {
-
- my $origtcn = $tcn;
- $tcn = find_free_tcn( $marcxml, $editor, $existing_rec );
-
- # if we're overriding, try to find a different TCN to use
- if( $override ) {
-
- # XXX Create ALLOW_ALT_TCN permission check support
-
- $logger->info("tcn value $tcn already exists, attempting to override");
-
- if(!$tcn) {
- return (
- undef,
- undef,
- undef,
- OpenILS::Event->new(
- 'OPEN_TCN_NOT_FOUND',
- payload => $marcxml->toString())
- );
- }
-
- } else {
-
- $logger->warn("tcn value $origtcn already exists in import/create");
-
- # otherwise, return event
- return (
- undef,
- undef,
- undef,
- OpenILS::Event->new(
- 'TCN_EXISTS', payload => {
- dup_record => $rec,
- tcn => $origtcn,
- new_tcn => $tcn
- }
- )
- );
- }
- }
-
- return ($tcn, $tcn_source, $marcxml);
-}
-
-sub find_free_tcn {
-
- my $marcxml = shift;
- my $editor = shift;
- my $existing_rec = shift;
-
- my $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="a"]';
- my ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
-
- if (!$tcn) {
- $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="a"]';
- ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
- }
-
- $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="b"]';
- my ($tcn_source) = $marcxml->documentElement->findvalue($xpath);
- if (!$tcn_source) {
- $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="b"]';
- $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
- }
-
- if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {
- $tcn = undef;
- }
-
-
- if(!$tcn) {
- $xpath = '//marc:datafield[@tag="020"]/marc:subfield[@code="a"]';
- ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
- $tcn_source = "ISBN";
- if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
- }
-
- if(!$tcn) {
- $xpath = '//marc:datafield[@tag="022"]/marc:subfield[@code="a"]';
- ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
- $tcn_source = "ISSN";
- if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
- }
-
- if(!$tcn) {
- $xpath = '//marc:datafield[@tag="010"]';
- ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
- $tcn_source = "LCCN";
- if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
- }
-
- if(!$tcn) {
- $xpath = '//marc:datafield[@tag="035"]/marc:subfield[@code="a"]';
- ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
- $tcn_source = "System Legacy";
- if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
-
- if($tcn) {
- $marcxml->documentElement->removeChild(
- $marcxml->documentElement->findnodes( '//marc:datafield[@tag="035"]' )
- );
- }
- }
-
- return undef unless $tcn;
- return $tcn;
-}
-
-
-
-sub _tcn_exists {
- my $editor = shift;
- my $tcn = shift;
- my $source = shift;
- my $existing_rec = shift || 0;
-
- if(!$tcn) {return 0;}
-
- $logger->debug("tcn_exists search for tcn $tcn and source $source and id $existing_rec");
-
- # XXX why does the source matter?
-# my $req = $session->request(
-# { tcn_value => $tcn, tcn_source => $source, deleted => 'f' } );
-
- my $recs = $editor->search_biblio_record_entry(
- {tcn_value => $tcn, deleted => 'f', id => {'!=' => $existing_rec}}, {idlist =>1});
-
- if(@$recs) {
- $logger->debug("_tcn_exists is true for tcn : $tcn ($source)");
- return $recs->[0];
- }
-
- $logger->debug("_tcn_exists is false for tcn : $tcn ($source)");
- return 0;
-}
-
-
-sub delete_rec {
- my($class, $editor, $rec_id ) = @_;
-
- my $rec = $editor->retrieve_biblio_record_entry($rec_id)
- or return $editor->event;
-
- return undef if $U->is_true($rec->deleted);
-
- $rec->deleted('t');
- $rec->active('f');
- $rec->editor( $editor->requestor->id );
- $rec->edit_date('now');
-
- # Set the leader/05 to indicate that the record has been deleted
- my $marc = $rec->marc();
- $marc =~ s{(<leader>.{5}).}{$1d};
- $rec->marc($marc);
-
- $editor->update_biblio_record_entry($rec) or return $editor->event;
-
- return undef;
-}
-
-
-# ---------------------------------------------------------------------------
-# returns true if the given title (id) has no un-deleted volumes or
-# copies attached. If a context volume is defined, a record
-# is considered empty only if the context volume is the only
-# remaining volume on the record.
-# ---------------------------------------------------------------------------
-sub title_is_empty {
- my($class, $editor, $rid, $vol_id) = @_;
-
- return 0 if $rid == OILS_PRECAT_RECORD;
-
- my $cnlist = $editor->search_asset_call_number(
- { record => $rid, deleted => 'f' }, { idlist => 1 } );
-
- return 1 unless @$cnlist; # no attached volumes
- return 0 if @$cnlist > 1; # multiple attached volumes
- return 0 unless $$cnlist[0] == $vol_id; # attached volume is not the context vol.
-
- # see if the sole remaining context volume has any attached copies
- for my $cn (@$cnlist) {
- my $copylist = $editor->search_asset_copy(
- [
- { call_number => $cn, deleted => 'f' },
- { limit => 1 },
- ], { idlist => 1 });
- return 0 if @$copylist; # false if we find any copies
- }
-
- return 1;
-}
-1;
+++ /dev/null
-use strict; use warnings;
-package OpenILS::Application::Cat::Merge;
-use base qw/OpenILS::Application/;
-use OpenSRF::Application;
-use OpenILS::Application::AppUtils;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Event;
-use OpenSRF::Utils::Logger qw($logger);
-use Data::Dumper;
-my $U = "OpenILS::Application::AppUtils";
-
-my $storage;
-
-
-# removes items from an array and returns the removed items
-# example : my @d = rgrep(sub { $_ =~ /o/ }, \@a);
-# there's surely a smarter way to do this
-sub rgrep {
- my( $sub, $arr ) = @_;
- my @del;
- for( my $i = 0; $i < @$arr; $i++ ) {
- my $a = $$arr[$i];
- local $_ = $a;
- if($sub->()) {
- splice(@$arr, $i--, 1);
- push( @del, $a );
- }
- }
- return @del;
-}
-
-
-
-# takes a master record and a list of
-# sub-records to merge into the master record
-sub merge_records {
- my( $editor, $master, $records ) = @_;
-
- # bib records are global objects, so no org context required.
- return (undef, $editor->die_event)
- unless $editor->allowed('MERGE_BIB_RECORDS');
-
- my $vol;
- my $evt;
-
- my %r = map { $_ => 1 } ($master, @$records); # unique the ids
- my @recs = keys %r;
-
- my $reqr = $editor->requestor;
- $logger->activity("merge: user ".$reqr->id." merging bib records: @recs with master = $master");
-
- # -----------------------------------------------------------
- # collect all of the volumes, merge any with duplicate
- # labels, then move all of the volumes to the master record
- # -----------------------------------------------------------
- my @volumes;
- for (@recs) {
- my $vs = $editor->search_asset_call_number({record => $_, deleted=>'f'});
- push( @volumes, @$vs );
- }
-
- $logger->info("merge: merge recovered ".scalar(@volumes)." total volumes");
-
- my @trimmed;
- # de-duplicate any volumes with the same label and owning_lib
-
- my %seen_vols;
-
- for my $v (@volumes) {
- my $l = $v->label;
- my $o = $v->owning_lib;
-
- if($seen_vols{$v->id}) {
- $logger->debug("merge: skipping ".$v->id." since it's already been merged");
- next;
- }
-
- $seen_vols{$v->id} = 1;
-
- $logger->debug("merge: [".$v->id."] looking for dupes with label $l and owning_lib $o");
-
- my @dups;
- for my $vv (@volumes) {
- if( $vv->label eq $v->label and $vv->owning_lib == $v->owning_lib ) {
- $logger->debug("merge: pushing dupe volume ".$vv->id) if @dups;
- push( @dups, $vv );
- $seen_vols{$vv->id} = 1;
- }
- }
-
- if( @dups == 1 ) {
- $logger->debug("merge: pushing unique volume into trimmed volume set: ".$v->id);
- push( @trimmed, @dups );
-
- } else {
- my($vol, $e) = merge_volumes($editor, \@dups);
- return $e if $e;
- $logger->debug("merge: pushing vol-merged volume into trimmed volume set: ".$vol->id);
- push(@trimmed, $vol);
- }
- }
-
- my $s = 'merge: trimmed volume set contains the following vols: ';
- $s .= 'id = '.$_->id .' : record = '.$_->record.' | ' for @trimmed;
- $logger->debug($s);
-
- # make all the volumes point to the master record
- my $stat;
- for $vol (@trimmed) {
- if( $vol->record ne $master ) {
-
- $logger->debug("merge: moving volume ".
- $vol->id." from record ".$vol->record. " to $master");
-
- $vol->editor( $editor->requestor->id );
- $vol->edit_date('now');
- $vol->record( $master );
- $editor->update_asset_call_number($vol)
- or return $editor->die_event;
- }
- }
-
- # cycle through and delete the non-master records
- for my $rec (@recs) {
-
- my $record = $editor->retrieve_biblio_record_entry($rec)
- or return $editor->die_event;
-
- $logger->debug("merge: seeing if record $rec needs to be deleted or un-deleted");
-
- if( $rec == $master ) {
- # make sure the master record is not deleted
- if( $U->is_true($record->deleted) ) {
- $logger->info("merge: master record is marked as deleted...un-deleting.");
- $record->deleted('f');
- $record->editor($reqr->id);
- $record->edit_date('now');
- $editor->update_biblio_record_entry($record)
- or return $editor->die_event;
- }
-
- } else {
- $logger->info("merge: deleting record $rec");
- $record->deleted('t');
- $record->editor($reqr->id);
- $record->edit_date('now');
- $editor->update_biblio_record_entry($record)
- or return $editor->die_event;
- }
- }
-
- return undef;
-}
-
-
-
-# takes a list of volume objects, picks the volume with most
-# copies and moves all copies attached to the other volumes
-# into said volume. all other volumes are deleted
-sub merge_volumes {
- my( $editor, $volumes, $master ) = @_;
- my %copies;
- my $evt;
-
- return ($$volumes[0]) if !$master and @$volumes == 1;
-
- return ($$volumes[0]) if
- $master and @$volumes == 1
- and $master->id == $$volumes[0]->id;
-
- $logger->debug("merge: fetching copies for volume list of size ".scalar(@$volumes));
-
- # collect all of the copies attached to the selected volumes
- for( @$volumes ) {
- $copies{$_->id} = $editor->search_asset_copy({call_number=>$_->id, deleted=>'f'});
- $logger->debug("merge: found ".scalar(@{$copies{$_->id}})." copies for volume ".$_->id);
- }
-
- my $bigcn;
- if( $master ) {
-
- # the caller has chosen the master record
- $bigcn = $master->id;
- push( @$volumes, $master );
-
- } else {
-
- # find the CN with the most copies and make it the master CN
- my $big = 0;
- for my $cn (keys %copies) {
- my $count = scalar(@{$copies{$cn}});
- if( $count > $big ) {
- $big = $count;
- $bigcn = $cn;
- }
- }
- }
-
- $bigcn = $$volumes[0]->id unless $bigcn;
-
- $logger->info("merge: merge using volume $bigcn as the master");
-
- # now move all of the copies to the new volume
- for my $cn (keys %copies) {
- next if $cn == $bigcn;
- for my $copy (@{$copies{$cn}}) {
- $logger->debug("merge: setting call_number to $bigcn for copy ".$copy->id);
- $copy->call_number($bigcn);
- $copy->editor($editor->requestor->id);
- $copy->edit_date('now');
- $editor->update_asset_copy($copy) or return (undef, $editor->die_event);
- }
- }
-
- for( @$volumes ) {
- next if $_->id == $bigcn;
- $logger->debug("merge: marking call_number as deleted: ".$_->id);
- $_->deleted('t');
- $_->editor($editor->requestor->id);
- $_->edit_date('now');
- $editor->update_asset_call_number($_) or return (undef, $editor->die_event);
- merge_volume_holds($editor, $bigcn, $_->id);
- }
-
- my ($mvol) = grep { $_->id == $bigcn } @$volumes;
- $logger->debug("merge: returning master volume ".$mvol->id);
- return ($mvol);
-}
-
-sub merge_volume_holds {
- my($e, $master_id, $vol_id) = @_;
-
- my $holds = $e->search_action_hold_request(
- { cancel_time => undef,
- fulfillment_time => undef,
- hold_type => 'V',
- target => $vol_id
- }
- );
-
- for my $hold (@$holds) {
-
- $logger->info("Changing hold ".$hold->id.
- " target from ".$hold->target." to $master_id in volume merge");
-
- $hold->target($master_id);
- unless($e->update_action_hold_request($hold)) {
- my $evt = $e->event;
- $logger->error("Error updating hold ". $evt->textcode .":". $evt->desc .":". $evt->stacktrace);
- }
- }
-
- return undef;
-}
-
-
-1;
-
-
+++ /dev/null
-package OpenILS::Application::Circ;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenILS::Application::Circ::Circulate;
-use OpenILS::Application::Circ::Survey;
-use OpenILS::Application::Circ::StatCat;
-use OpenILS::Application::Circ::Holds;
-use OpenILS::Application::Circ::HoldNotify;
-use OpenILS::Application::Circ::CreditCard;
-use OpenILS::Application::Circ::Money;
-use OpenILS::Application::Circ::NonCat;
-use OpenILS::Application::Circ::CopyLocations;
-use OpenILS::Application::Circ::CircCommon;
-
-use DateTime;
-use DateTime::Format::ISO8601;
-
-use OpenILS::Application::AppUtils;
-
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::AppSession;
-use OpenILS::Utils::ModsParser;
-use OpenILS::Event;
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::Editor;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Const qw/:const/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::Cat::AssetCommon;
-
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-
-my $holdcode = "OpenILS::Application::Circ::Holds";
-
-# ------------------------------------------------------------------------
-# Top level Circ package;
-# ------------------------------------------------------------------------
-
-sub initialize {
- my $self = shift;
- OpenILS::Application::Circ::Circulate->initialize();
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_circ',
- authoritative => 1,
- api_name => 'open-ils.circ.retrieve',
- signature => q/
- Retrieve a circ object by id
- @param authtoken Login session key
- @pararm circid The id of the circ object
- /
-);
-sub retrieve_circ {
- my( $s, $c, $a, $i ) = @_;
- my $e = new_editor(authtoken => $a);
- return $e->event unless $e->checkauth;
- my $circ = $e->retrieve_action_circulation($i) or return $e->event;
- if( $e->requestor->id ne $circ->usr ) {
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
- }
- return $circ;
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_circ_mods',
- api_name => 'open-ils.circ.circ_modifier.retrieve.all');
-sub fetch_circ_mods {
- my($self, $conn, $args) = @_;
- my $mods = new_editor()->retrieve_all_config_circ_modifier;
- return [ map {$_->code} @$mods ] unless $$args{full};
- return $mods;
-}
-
-__PACKAGE__->register_method(
- method => 'fetch_bill_types',
- api_name => 'open-ils.circ.billing_type.retrieve.all');
-sub fetch_bill_types {
- my $conf = OpenSRF::Utils::SettingsClient->new;
- return $conf->config_value(
- 'apps', 'open-ils.circ', 'app_settings', 'billing_types', 'type' );
-}
-
-
-__PACKAGE__->register_method(
- method => 'ranged_billing_types',
- api_name => 'open-ils.circ.billing_type.ranged.retrieve.all');
-
-sub ranged_billing_types {
- my($self, $conn, $auth, $org_id, $depth) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_BILLING_TYPE', $org_id);
- return $e->search_config_billing_type(
- {owner => $U->get_org_full_path($org_id, $depth)});
-}
-
-
-
-# ------------------------------------------------------------------------
-# Returns an array of {circ, record} hashes checked out by the user.
-# ------------------------------------------------------------------------
-__PACKAGE__->register_method(
- method => "checkouts_by_user",
- api_name => "open-ils.circ.actor.user.checked_out",
- stream => 1,
- NOTES => <<" NOTES");
- Returns a list of open circulations as a pile of objects. Each object
- contains the relevant copy, circ, and record
- NOTES
-
-sub checkouts_by_user {
- my($self, $client, $auth, $user_id) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $circ_ids = $e->search_action_circulation(
- { usr => $user_id,
- checkin_time => undef,
- '-or' => [
- {stop_fines => undef},
- {stop_fines => ['MAXFINES','LONGOVERDUE']}
- ]
- },
- {idlist => 1}
- );
-
- for my $id (@$circ_ids) {
- my $circ = $e->retrieve_action_circulation([
- $id,
- { flesh => 3,
- flesh_fields => {
- circ => ['target_copy'],
- acp => ['call_number'],
- acn => ['record']
- }
- }
- ]);
-
- # un-flesh for consistency
- my $c = $circ->target_copy;
- $circ->target_copy($c->id);
-
- my $cn = $c->call_number;
- $c->call_number($cn->id);
-
- my $t = $cn->record;
- $cn->record($t->id);
-
- $client->respond(
- { circ => $circ,
- copy => $c,
- record => $U->record_to_mvr($t)
- }
- );
- }
-
- return undef;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "checkouts_by_user_slim",
- api_name => "open-ils.circ.actor.user.checked_out.slim",
- NOTES => <<" NOTES");
- Returns a list of open circulation objects
- NOTES
-
-# DEPRECAT ME?? XXX
-sub checkouts_by_user_slim {
- my( $self, $client, $user_session, $user_id ) = @_;
-
- my( $requestor, $target, $copy, $record, $evt );
-
- ( $requestor, $target, $evt ) =
- $apputils->checkses_requestor( $user_session, $user_id, 'VIEW_CIRCULATIONS');
- return $evt if $evt;
-
- $logger->debug( 'User ' . $requestor->id .
- " retrieving checked out items for user " . $target->id );
-
- # XXX Make the call correct..
- return $apputils->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.action.open_circulation.search.atomic",
- { usr => $target->id, checkin_time => undef } );
-# { usr => $target->id } );
-}
-
-
-__PACKAGE__->register_method(
- method => "checkouts_by_user_opac",
- api_name => "open-ils.circ.actor.user.checked_out.opac",);
-
-# XXX Deprecate Me
-sub checkouts_by_user_opac {
- my( $self, $client, $auth, $user_id ) = @_;
-
- my $e = OpenILS::Utils::Editor->new( authtoken => $auth );
- return $e->event unless $e->checkauth;
- $user_id ||= $e->requestor->id;
- return $e->event unless
- my $patron = $e->retrieve_actor_user($user_id);
-
- my $data;
- my $search = {usr => $user_id, stop_fines => undef};
-
- if( $user_id ne $e->requestor->id ) {
- $data = $e->search_action_circulation(
- $search, {checkperm=>1, permorg=>$patron->home_ou})
- or return $e->event;
-
- } else {
- $data = $e->search_action_circulation($search);
- }
-
- return $data;
-}
-
-
-__PACKAGE__->register_method(
- method => "title_from_transaction",
- api_name => "open-ils.circ.circ_transaction.find_title",
- NOTES => <<" NOTES");
- Returns a mods object for the title that is linked to from the
- copy from the hold that created the given transaction
- NOTES
-
-sub title_from_transaction {
- my( $self, $client, $login_session, $transactionid ) = @_;
-
- my( $user, $circ, $title, $evt );
-
- ( $user, $evt ) = $apputils->checkses( $login_session );
- return $evt if $evt;
-
- ( $circ, $evt ) = $apputils->fetch_circulation($transactionid);
- return $evt if $evt;
-
- ($title, $evt) = $apputils->fetch_record_by_copy($circ->target_copy);
- return $evt if $evt;
-
- return $apputils->record_to_mvr($title);
-}
-
-__PACKAGE__->register_method(
- method => "staff_age_to_lost",
- api_name => "open-ils.circ.circulation.age_to_lost",
- stream => 1,
- signature => q/
- This fires a circ.staff_age_to_lost Action-Trigger event against all
- overdue circulations in scope of the specified context library and
- user profile, which effectively marks the associated items as Lost.
- This is likely to be done at the end of a semester in an academic
- library, etc.
- @param auth
- @param args : circ_lib, user_profile
- /
-);
-
-sub staff_age_to_lost {
- my( $self, $conn, $auth, $args ) = @_;
-
- my $orgs = $U->get_org_descendants($args->{'circ_lib'});
- my $profiles = $U->fetch_permission_group_descendants($args->{'user_profile'});
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
-
- my $method = 'open-ils.trigger.passive.event.autocreate.batch';
- my $hook = 'circ.staff_age_to_lost';
- my $context_org = 'circ_lib';
- my $opt_granularity = undef;
- my $filter = {
- "checkin_time" => undef,
- "due_date" => { "<" => "now" },
- "-or" => [
- { "stop_fines" => ["MAXFINES", "LONGOVERDUE"] }, # FIXME: CLAIMSRETURNED also?
- { "stop_fines" => undef }
- ],
- "-and" => [
- {"-exists" => {
- "select" => {"au" => ["id"]},
- "from" => "au",
- "where" => {
- "profile" => $profiles,
- "id" => { "=" => {"+circ" => "usr"} }
- }
- }},
- {"-exists" => {
- "select" => {"aou" => ["id"]},
- "from" => "aou",
- "where" => {
- "-and" => [
- {"id" => { "=" => {"+circ" => "circ_lib"} }},
- {"id" => $orgs}
- ]
- }
- }}
- ]
- };
- my $req_timeout = 10800;
- my $chunk_size = 100;
- my $progress = 1;
-
- my $req = $ses->request($method, $hook, $context_org, $filter, $opt_granularity);
- my @event_ids; my @chunked_ids;
- while (my $resp = $req->recv(timeout => $req_timeout)) {
- push(@event_ids, $resp->content);
- push(@chunked_ids, $resp->content);
- if (scalar(@chunked_ids) > $chunk_size) {
- $conn->respond({'progress'=>$progress++}); # 'event_ids'=>@chunked_ids
- @chunked_ids = ();
- }
- }
- if (scalar(@chunked_ids) > 0) {
- $conn->respond({'progress'=>$progress++}); # 'event_ids'=>@chunked_ids
- }
-
- if(@event_ids) {
- $logger->info("staff_age_to_lost: created ".scalar(@event_ids)." events for circ.staff_age_to_lost");
- $conn->respond_complete({'total_progress'=>$progress-1,'created'=>scalar(@event_ids)});
- } elsif($req->complete) {
- $logger->info("staff_age_to_lost: no events to create for circ.staff_age_to_lost");
- $conn->respond_complete({'total_progress'=>$progress-1,'created'=>0});
- } else {
- $logger->warn("staff_age_to_lost: timeout occurred during event creation for circ.staff_age_to_lost");
- $conn->respond_complete({'total_progress'=>$progress-1,'error'=>'timeout'});
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "new_set_circ_lost",
- api_name => "open-ils.circ.circulation.set_lost",
- signature => q/
- Sets the copy and related open circulation to lost
- @param auth
- @param args : barcode
- /
-);
-
-
-# ---------------------------------------------------------------------
-# Sets a circulation to lost. updates copy status to lost
-# applies copy and/or prcoessing fees depending on org settings
-# ---------------------------------------------------------------------
-sub new_set_circ_lost {
- my( $self, $conn, $auth, $args ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $copy = $e->search_asset_copy({barcode=>$$args{barcode}, deleted=>'f'})->[0]
- or return $e->die_event;
-
- my $evt = OpenILS::Application::Cat::AssetCommon->set_item_lost($e, $copy->id);
- return $evt if $evt;
-
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "set_circ_claims_returned",
- api_name => "open-ils.circ.circulation.set_claims_returned",
- signature => {
- desc => q/Sets the circ for a given item as claims returned
- If a backdate is provided, overdue fines will be voided
- back to the backdate/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Arguments, including "barcode" and optional "backdate"', type => 'object'}
- ],
- return => {desc => q/1 on success, failure event on error, and
- PATRON_EXCEEDS_CLAIMS_RETURN_COUNT if the patron exceeds the
- configured claims return maximum/}
- }
-);
-
-__PACKAGE__->register_method(
- method => "set_circ_claims_returned",
- api_name => "open-ils.circ.circulation.set_claims_returned.override",
- signature => {
- desc => q/This adds support for overrideing the configured max
- claims returned amount.
- @see open-ils.circ.circulation.set_claims_returned./,
- }
-);
-
-sub set_circ_claims_returned {
- my( $self, $conn, $auth, $args ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $barcode = $$args{barcode};
- my $backdate = $$args{backdate};
-
- my $copy = $e->search_asset_copy({barcode=>$barcode, deleted=>'f'})->[0]
- or return $e->die_event;
-
- my $circ = $e->search_action_circulation(
- {checkin_time => undef, target_copy => $copy->id})->[0]
- or return $e->die_event;
-
- $backdate = $circ->due_date if $$args{use_due_date};
-
- $logger->info("marking circ for item $barcode as claims returned".
- (($backdate) ? " with backdate $backdate" : ''));
-
- my $patron = $e->retrieve_actor_user($circ->usr);
- my $max_count = $U->ou_ancestor_setting_value(
- $circ->circ_lib, 'circ.max_patron_claim_return_count', $e);
-
- # If the patron has too instances of many claims returned,
- # require an override to continue. A configured max of
- # 0 means all attempts require an override
- if(defined $max_count and $patron->claims_returned_count >= $max_count) {
-
- if($self->api_name =~ /override/) {
-
- # see if we're allowed to override
- return $e->die_event unless
- $e->allowed('SET_CIRC_CLAIMS_RETURNED.override', $circ->circ_lib);
-
- } else {
-
- # exit early and return the max claims return event
- $e->rollback;
- return OpenILS::Event->new(
- 'PATRON_EXCEEDS_CLAIMS_RETURN_COUNT',
- payload => {
- patron_count => $patron->claims_returned_count,
- max_count => $max_count
- }
- );
- }
- }
-
- $e->allowed('SET_CIRC_CLAIMS_RETURNED', $circ->circ_lib)
- or return $e->die_event;
-
- $circ->stop_fines(OILS_STOP_FINES_CLAIMSRETURNED);
- $circ->stop_fines_time('now') unless $circ->stop_fines_time;
-
- if( $backdate ) {
- $backdate = cleanse_ISO8601($backdate);
-
- my $original_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($circ->due_date));
- my $new_date = DateTime::Format::ISO8601->new->parse_datetime($backdate);
- $backdate = $new_date->ymd . 'T' . $original_date->strftime('%T%z');
-
- # clean it up once again; need a : in the timezone offset. E.g. -06:00 not -0600
- $backdate = cleanse_ISO8601($backdate);
-
- # make it look like the circ stopped at the cliams returned time
- $circ->stop_fines_time($backdate);
- my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ, $backdate);
- return $evt if $evt;
- }
-
- $e->update_action_circulation($circ) or return $e->die_event;
-
- # see if there is a configured post-claims-return copy status
- if(my $stat = $U->ou_ancestor_setting_value($circ->circ_lib, 'circ.claim_return.copy_status')) {
- $copy->status($stat);
- $copy->edit_date('now');
- $copy->editor($e->requestor->id);
- $e->update_asset_copy($copy) or return $e->die_event;
- }
-
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "post_checkin_backdate_circ",
- api_name => "open-ils.circ.post_checkin_backdate",
- signature => {
- desc => q/Back-date an already checked in circulation/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Circ ID', type => 'number'},
- {desc => 'ISO8601 backdate', type => 'string'},
- ],
- return => {desc => q/1 on success, failure event on error/}
- }
-);
-
-__PACKAGE__->register_method(
- method => "post_checkin_backdate_circ",
- api_name => "open-ils.circ.post_checkin_backdate.batch",
- stream => 1,
- signature => {
- desc => q/@see open-ils.circ.post_checkin_backdate. Batch mode/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'List of Circ ID', type => 'array'},
- {desc => 'ISO8601 backdate', type => 'string'},
- ],
- return => {desc => q/Set of: 1 on success, failure event on error/}
- }
-);
-
-
-sub post_checkin_backdate_circ {
- my( $self, $conn, $auth, $circ_id, $backdate ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- if($self->api_name =~ /batch/) {
- foreach my $c (@$circ_id) {
- $conn->respond(post_checkin_backdate_circ_impl($e, $c, $backdate));
- }
- } else {
- $conn->respond_complete(post_checkin_backdate_circ_impl($e, $circ_id, $backdate));
- }
-
- $e->disconnect;
- return undef;
-}
-
-
-sub post_checkin_backdate_circ_impl {
- my($e, $circ_id, $backdate) = @_;
-
- $e->xact_begin;
-
- my $circ = $e->retrieve_action_circulation($circ_id)
- or return $e->die_event;
-
- # anyone with checkin perms can backdate (more restrictive?)
- return $e->die_event unless $e->allowed('COPY_CHECKIN', $circ->circ_lib);
-
- # don't allow back-dating an open circulation
- return OpenILS::Event->new('BAD_PARAMS') unless
- $backdate and $circ->checkin_time;
-
- # update the checkin and stop_fines times to reflect the new backdate
- $circ->stop_fines_time(cleanse_ISO8601($backdate));
- $circ->checkin_time(cleanse_ISO8601($backdate));
- $e->update_action_circulation($circ) or return $e->die_event;
-
- # now void the overdues "erased" by the back-dating
- my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ, $backdate);
- return $evt if $evt;
-
- # If the circ was closed before and the balance owned !=0, re-open the transaction
- $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($e, $circ->id);
- return $evt if $evt;
-
- $e->xact_commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method (
- method => 'set_circ_due_date',
- api_name => 'open-ils.circ.circulation.due_date.update',
- signature => q/
- Updates the due_date on the given circ
- @param authtoken
- @param circid The id of the circ to update
- @param date The timestamp of the new due date
- /
-);
-
-sub set_circ_due_date {
- my( $self, $conn, $auth, $circ_id, $date ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- my $circ = $e->retrieve_action_circulation($circ_id)
- or return $e->die_event;
-
- return $e->die_event unless $e->allowed('CIRC_OVERRIDE_DUE_DATE', $circ->circ_lib);
- $date = cleanse_ISO8601($date);
-
- if (!(interval_to_seconds($circ->duration) % 86400)) { # duration is divisible by days
- my $original_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($circ->due_date));
- my $new_date = DateTime::Format::ISO8601->new->parse_datetime($date);
- $date = cleanse_ISO8601( $new_date->ymd . 'T' . $original_date->strftime('%T%z') );
- }
-
- $circ->due_date($date);
- $e->update_action_circulation($circ) or return $e->die_event;
- $e->commit;
-
- return $circ;
-}
-
-
-__PACKAGE__->register_method(
- method => "create_in_house_use",
- api_name => 'open-ils.circ.in_house_use.create',
- signature => q/
- Creates an in-house use action.
- @param $authtoken The login session key
- @param params A hash of params including
- 'location' The org unit id where the in-house use occurs
- 'copyid' The copy in question
- 'count' The number of in-house uses to apply to this copy
- @return An array of id's representing the id's of the newly created
- in-house use objects or an event on an error
- /);
-
-__PACKAGE__->register_method(
- method => "create_in_house_use",
- api_name => 'open-ils.circ.non_cat_in_house_use.create',
-);
-
-
-sub create_in_house_use {
- my( $self, $client, $auth, $params ) = @_;
-
- my( $evt, $copy );
- my $org = $params->{location};
- my $copyid = $params->{copyid};
- my $count = $params->{count} || 1;
- my $nc_type = $params->{non_cat_type};
- my $use_time = $params->{use_time} || 'now';
-
- my $e = new_editor(xact=>1,authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('CREATE_IN_HOUSE_USE');
-
- my $non_cat = 1 if $self->api_name =~ /non_cat/;
-
- unless( $non_cat ) {
- if( $copyid ) {
- $copy = $e->retrieve_asset_copy($copyid) or return $e->event;
- } else {
- $copy = $e->search_asset_copy({barcode=>$params->{barcode}, deleted => 'f'})->[0]
- or return $e->event;
- $copyid = $copy->id;
- }
- }
-
- if( $use_time ne 'now' ) {
- $use_time = cleanse_ISO8601($use_time);
- $logger->debug("in_house_use setting use time to $use_time");
- }
-
- my @ids;
- for(1..$count) {
-
- my $ihu;
- my $method;
- my $cmeth;
-
- if($non_cat) {
- $ihu = Fieldmapper::action::non_cat_in_house_use->new;
- $ihu->item_type($nc_type);
- $method = 'open-ils.storage.direct.action.non_cat_in_house_use.create';
- $cmeth = "create_action_non_cat_in_house_use";
-
- } else {
- $ihu = Fieldmapper::action::in_house_use->new;
- $ihu->item($copyid);
- $method = 'open-ils.storage.direct.action.in_house_use.create';
- $cmeth = "create_action_in_house_use";
- }
-
- $ihu->staff($e->requestor->id);
- $ihu->org_unit($org);
- $ihu->use_time($use_time);
-
- $ihu = $e->$cmeth($ihu) or return $e->event;
- push( @ids, $ihu->id );
- }
-
- $e->commit;
- return \@ids;
-}
-
-
-
-
-
-__PACKAGE__->register_method(
- method => "view_circs",
- api_name => "open-ils.circ.copy_checkout_history.retrieve",
- notes => q/
- Retrieves the last X circs for a given copy
- @param authtoken The login session key
- @param copyid The copy to check
- @param count How far to go back in the item history
- @return An array of circ ids
- /);
-
-# ----------------------------------------------------------------------
-# Returns $count most recent circs. If count exceeds the configured
-# max, use the configured max instead
-# ----------------------------------------------------------------------
-sub view_circs {
- my( $self, $client, $authtoken, $copyid, $count ) = @_;
-
- my $e = new_editor(authtoken => $authtoken);
- return $e->event unless $e->checkauth;
-
- my $copy = $e->retrieve_asset_copy([
- $copyid,
- { flesh => 1,
- flesh_fields => {acp => ['call_number']}
- }
- ]) or return $e->event;
-
- return $e->event unless $e->allowed(
- 'VIEW_COPY_CHECKOUT_HISTORY',
- ($copy->call_number == OILS_PRECAT_CALL_NUMBER) ?
- $copy->circ_lib : $copy->call_number->owning_lib);
-
- my $max_history = $U->ou_ancestor_setting_value(
- $e->requestor->ws_ou, 'circ.item_checkout_history.max', $e);
-
- if(defined $max_history) {
- $count = $max_history unless defined $count and $count < $max_history;
- } else {
- $count = 4 unless defined $count;
- }
-
- return $e->search_action_circulation([
- {target_copy => $copyid},
- {limit => $count, order_by => { circ => "xact_start DESC" }}
- ]);
-}
-
-
-__PACKAGE__->register_method(
- method => "circ_count",
- api_name => "open-ils.circ.circulation.count",
- notes => q/
- Returns the number of times the item has circulated
- @param copyid The copy to check
- /);
-
-sub circ_count {
- my( $self, $client, $copyid, $range ) = @_;
- my $e = OpenILS::Utils::Editor->new;
- return $e->request('open-ils.storage.asset.copy.circ_count', $copyid, $range);
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_notes',
- authoritative => 1,
- api_name => 'open-ils.circ.copy_note.retrieve.all',
- signature => q/
- Returns an array of copy note objects.
- @param args A named hash of parameters including:
- authtoken : Required if viewing non-public notes
- itemid : The id of the item whose notes we want to retrieve
- pub : True if all the caller wants are public notes
- @return An array of note objects
- /);
-
-__PACKAGE__->register_method(
- method => 'fetch_notes',
- api_name => 'open-ils.circ.call_number_note.retrieve.all',
- signature => q/@see open-ils.circ.copy_note.retrieve.all/);
-
-__PACKAGE__->register_method(
- method => 'fetch_notes',
- api_name => 'open-ils.circ.title_note.retrieve.all',
- signature => q/@see open-ils.circ.copy_note.retrieve.all/);
-
-
-# NOTE: VIEW_COPY/VOLUME/TITLE_NOTES perms should always be global
-sub fetch_notes {
- my( $self, $connection, $args ) = @_;
-
- my $id = $$args{itemid};
- my $authtoken = $$args{authtoken};
- my( $r, $evt);
-
- if( $self->api_name =~ /copy/ ) {
- if( $$args{pub} ) {
- return $U->cstorereq(
- 'open-ils.cstore.direct.asset.copy_note.search.atomic',
- { owning_copy => $id, pub => 't' } );
- } else {
- ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_COPY_NOTES');
- return $evt if $evt;
- return $U->cstorereq(
- 'open-ils.cstore.direct.asset.copy_note.search.atomic', {owning_copy => $id} );
- }
-
- } elsif( $self->api_name =~ /call_number/ ) {
- if( $$args{pub} ) {
- return $U->cstorereq(
- 'open-ils.cstore.direct.asset.call_number_note.search.atomic',
- { call_number => $id, pub => 't' } );
- } else {
- ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_VOLUME_NOTES');
- return $evt if $evt;
- return $U->cstorereq(
- 'open-ils.cstore.direct.asset.call_number_note.search.atomic', { call_number => $id } );
- }
-
- } elsif( $self->api_name =~ /title/ ) {
- if( $$args{pub} ) {
- return $U->cstorereq(
- 'open-ils.cstore.direct.bilbio.record_note.search.atomic',
- { record => $id, pub => 't' } );
- } else {
- ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_TITLE_NOTES');
- return $evt if $evt;
- return $U->cstorereq(
- 'open-ils.cstore.direct.biblio.record_note.search.atomic', { record => $id } );
- }
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'has_notes',
- api_name => 'open-ils.circ.copy.has_notes');
-__PACKAGE__->register_method(
- method => 'has_notes',
- api_name => 'open-ils.circ.call_number.has_notes');
-__PACKAGE__->register_method(
- method => 'has_notes',
- api_name => 'open-ils.circ.title.has_notes');
-
-
-sub has_notes {
- my( $self, $conn, $authtoken, $id ) = @_;
- my $editor = OpenILS::Utils::Editor->new(authtoken => $authtoken);
- return $editor->event unless $editor->checkauth;
-
- my $n = $editor->search_asset_copy_note(
- {owning_copy=>$id}, {idlist=>1}) if $self->api_name =~ /copy/;
-
- $n = $editor->search_asset_call_number_note(
- {call_number=>$id}, {idlist=>1}) if $self->api_name =~ /call_number/;
-
- $n = $editor->search_biblio_record_note(
- {record=>$id}, {idlist=>1}) if $self->api_name =~ /title/;
-
- return scalar @$n;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'create_copy_note',
- api_name => 'open-ils.circ.copy_note.create',
- signature => q/
- Creates a new copy note
- @param authtoken The login session key
- @param note The note object to create
- @return The id of the new note object
- /);
-
-sub create_copy_note {
- my( $self, $connection, $authtoken, $note ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
- my $copy = $e->retrieve_asset_copy(
- [
- $note->owning_copy,
- { flesh => 1,
- flesh_fields => { 'acp' => ['call_number'] }
- }
- ]
- );
-
- return $e->event unless
- $e->allowed('CREATE_COPY_NOTE', $copy->call_number->owning_lib);
-
- $note->create_date('now');
- $note->creator($e->requestor->id);
- $note->pub( ($U->is_true($note->pub)) ? 't' : 'f' );
- $note->clear_id;
-
- $e->create_asset_copy_note($note) or return $e->event;
- $e->commit;
- return $note->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_copy_note',
- api_name => 'open-ils.circ.copy_note.delete',
- signature => q/
- Deletes an existing copy note
- @param authtoken The login session key
- @param noteid The id of the note to delete
- @return 1 on success - Event otherwise.
- /);
-sub delete_copy_note {
- my( $self, $conn, $authtoken, $noteid ) = @_;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
-
- my $note = $e->retrieve_asset_copy_note([
- $noteid,
- { flesh => 2,
- flesh_fields => {
- 'acpn' => [ 'owning_copy' ],
- 'acp' => [ 'call_number' ],
- }
- }
- ]) or return $e->die_event;
-
- if( $note->creator ne $e->requestor->id ) {
- return $e->die_event unless
- $e->allowed('DELETE_COPY_NOTE', $note->owning_copy->call_number->owning_lib);
- }
-
- $e->delete_asset_copy_note($note) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'age_hold_rules',
- api_name => 'open-ils.circ.config.rules.age_hold_protect.retrieve.all',
-);
-
-sub age_hold_rules {
- my( $self, $conn ) = @_;
- return new_editor()->retrieve_all_config_rules_age_hold_protect();
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'copy_details_barcode',
- authoritative => 1,
- api_name => 'open-ils.circ.copy_details.retrieve.barcode');
-sub copy_details_barcode {
- my( $self, $conn, $auth, $barcode ) = @_;
- my $e = new_editor();
- my $cid = $e->search_asset_copy({barcode=>$barcode, deleted=>'f'}, {idlist=>1})->[0];
- return $e->event unless $cid;
- return copy_details( $self, $conn, $auth, $cid );
-}
-
-
-__PACKAGE__->register_method(
- method => 'copy_details',
- api_name => 'open-ils.circ.copy_details.retrieve');
-
-sub copy_details {
- my( $self, $conn, $auth, $copy_id ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- my $flesh = { flesh => 1 };
-
- my $copy = $e->retrieve_asset_copy(
- [
- $copy_id,
- {
- flesh => 2,
- flesh_fields => {
- acp => ['call_number'],
- acn => ['record']
- }
- }
- ]) or return $e->event;
-
-
- # De-flesh the copy for backwards compatibility
- my $mvr;
- my $vol = $copy->call_number;
- if( ref $vol ) {
- $copy->call_number($vol->id);
- my $record = $vol->record;
- if( ref $record ) {
- $vol->record($record->id);
- $mvr = $U->record_to_mvr($record);
- }
- }
-
-
- my $hold = $e->search_action_hold_request(
- {
- current_copy => $copy_id,
- capture_time => { "!=" => undef },
- fulfillment_time => undef,
- cancel_time => undef,
- }
- )->[0];
-
- OpenILS::Application::Circ::Holds::flesh_hold_transits([$hold]) if $hold;
-
- my $transit = $e->search_action_transit_copy(
- { target_copy => $copy_id, dest_recv_time => undef } )->[0];
-
- # find the latest circ, open or closed
- my $circ = $e->search_action_circulation(
- [
- { target_copy => $copy_id },
- {
- flesh => 1,
- flesh_fields => {
- circ => [
- 'workstation',
- 'checkin_workstation',
- 'duration_rule',
- 'max_fine_rule',
- 'recurring_fine_rule'
- ]
- },
- order_by => { circ => 'xact_start desc' },
- limit => 1
- }
- ]
- )->[0];
-
-
- return {
- copy => $copy,
- hold => $hold,
- transit => $transit,
- circ => $circ,
- volume => $vol,
- mvr => $mvr,
- };
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_damaged',
- signature => q/
- Changes the status of a copy to "damaged". Requires MARK_ITEM_DAMAGED permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as damaged
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_missing',
- signature => q/
- Changes the status of a copy to "missing". Requires MARK_ITEM_MISSING permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as missing
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_bindery',
- signature => q/
- Changes the status of a copy to "bindery". Requires MARK_ITEM_BINDERY permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as bindery
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_on_order',
- signature => q/
- Changes the status of a copy to "on order". Requires MARK_ITEM_ON_ORDER permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as on order
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_ill',
- signature => q/
- Changes the status of a copy to "inter-library loan". Requires MARK_ITEM_ILL permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as inter-library loan
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_cataloging',
- signature => q/
- Changes the status of a copy to "cataloging". Requires MARK_ITEM_CATALOGING permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as cataloging
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_reserves',
- signature => q/
- Changes the status of a copy to "reserves". Requires MARK_ITEM_RESERVES permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as reserves
- @return 1 on success - Event otherwise.
- /
-);
-__PACKAGE__->register_method(
- method => 'mark_item',
- api_name => 'open-ils.circ.mark_item_discard',
- signature => q/
- Changes the status of a copy to "discard". Requires MARK_ITEM_DISCARD permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as discard
- @return 1 on success - Event otherwise.
- /
-);
-
-sub mark_item {
- my( $self, $conn, $auth, $copy_id, $args ) = @_;
- my $e = new_editor(authtoken=>$auth, xact =>1);
- return $e->die_event unless $e->checkauth;
- $args ||= {};
-
- my $copy = $e->retrieve_asset_copy([
- $copy_id,
- {flesh => 1, flesh_fields => {'acp' => ['call_number']}}])
- or return $e->die_event;
-
- my $owning_lib =
- ($copy->call_number->id == OILS_PRECAT_CALL_NUMBER) ?
- $copy->circ_lib : $copy->call_number->owning_lib;
-
- return $e->die_event unless $e->allowed('UPDATE_COPY', $owning_lib);
-
-
- my $perm = 'MARK_ITEM_MISSING';
- my $stat = OILS_COPY_STATUS_MISSING;
-
- if( $self->api_name =~ /damaged/ ) {
- $perm = 'MARK_ITEM_DAMAGED';
- $stat = OILS_COPY_STATUS_DAMAGED;
- my $evt = handle_mark_damaged($e, $copy, $owning_lib, $args);
- return $evt if $evt;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'damaged', $copy, $owning_lib);
-
- } elsif ( $self->api_name =~ /bindery/ ) {
- $perm = 'MARK_ITEM_BINDERY';
- $stat = OILS_COPY_STATUS_BINDERY;
- } elsif ( $self->api_name =~ /on_order/ ) {
- $perm = 'MARK_ITEM_ON_ORDER';
- $stat = OILS_COPY_STATUS_ON_ORDER;
- } elsif ( $self->api_name =~ /ill/ ) {
- $perm = 'MARK_ITEM_ILL';
- $stat = OILS_COPY_STATUS_ILL;
- } elsif ( $self->api_name =~ /cataloging/ ) {
- $perm = 'MARK_ITEM_CATALOGING';
- $stat = OILS_COPY_STATUS_CATALOGING;
- } elsif ( $self->api_name =~ /reserves/ ) {
- $perm = 'MARK_ITEM_RESERVES';
- $stat = OILS_COPY_STATUS_RESERVES;
- } elsif ( $self->api_name =~ /discard/ ) {
- $perm = 'MARK_ITEM_DISCARD';
- $stat = OILS_COPY_STATUS_DISCARD;
- }
-
-
- $copy->status($stat);
- $copy->edit_date('now');
- $copy->editor($e->requestor->id);
-
- $e->update_asset_copy($copy) or return $e->die_event;
-
- my $holds = $e->search_action_hold_request(
- {
- current_copy => $copy->id,
- fulfillment_time => undef,
- cancel_time => undef,
- }
- );
-
- $e->commit;
-
- $logger->debug("resetting holds that target the marked copy");
- OpenILS::Application::Circ::Holds->_reset_hold($e->requestor, $_) for @$holds;
-
- return 1;
-}
-
-sub handle_mark_damaged {
- my($e, $copy, $owning_lib, $args) = @_;
-
- my $apply = $args->{apply_fines} || '';
- return undef if $apply eq 'noapply';
-
- my $new_amount = $args->{override_amount};
- my $new_btype = $args->{override_btype};
- my $new_note = $args->{override_note};
-
- # grab the last circulation
- my $circ = $e->search_action_circulation([
- { target_copy => $copy->id},
- { limit => 1,
- order_by => {circ => "xact_start DESC"},
- flesh => 2,
- flesh_fields => {circ => ['target_copy', 'usr'], au => ['card']}
- }
- ])->[0];
-
- return undef unless $circ;
-
- my $charge_price = $U->ou_ancestor_setting_value(
- $owning_lib, 'circ.charge_on_damaged', $e);
-
- my $proc_fee = $U->ou_ancestor_setting_value(
- $owning_lib, 'circ.damaged_item_processing_fee', $e) || 0;
-
- my $void_overdue = $U->ou_ancestor_setting_value(
- $owning_lib, 'circ.damaged.void_ovedue', $e) || 0;
-
- return undef unless $charge_price or $proc_fee;
-
- my $copy_price = ($charge_price) ? $U->get_copy_price($e, $copy) : 0;
- my $total = $copy_price + $proc_fee;
-
- if($apply) {
-
- if($new_amount and $new_btype) {
-
- # Allow staff to override the amount to charge for a damaged item
- # Consider the case where the item is only partially damaged
- # This value is meant to take the place of the item price and
- # optional processing fee.
-
- my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
- $e, $new_amount, $new_btype, 'Damaged Item Override', $circ->id, $new_note);
- return $evt if $evt;
-
- } else {
-
- if($charge_price and $copy_price) {
- my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
- $e, $copy_price, 7, 'Damaged Item', $circ->id);
- return $evt if $evt;
- }
-
- if($proc_fee) {
- my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
- $e, $proc_fee, 8, 'Damaged Item Processing Fee', $circ->id);
- return $evt if $evt;
- }
- }
-
- # the assumption is that you would not void the overdues unless you
- # were also charging for the item and/or applying a processing fee
- if($void_overdue) {
- my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ);
- return $evt if $evt;
- }
-
- my $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($e, $circ->id);
- return $evt if $evt;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'checkout.damaged', $circ, $circ->circ_lib);
-
- return undef;
-
- } else {
- return OpenILS::Event->new('DAMAGE_CHARGE',
- payload => {
- circ => $circ,
- charge => $total
- }
- );
- }
-}
-
-
-
-# ----------------------------------------------------------------------
-__PACKAGE__->register_method(
- method => 'mark_item_missing_pieces',
- api_name => 'open-ils.circ.mark_item_missing_pieces',
- signature => q/
- Changes the status of a copy to "damaged" or to a custom status based on the
- circ.missing_pieces.copy_status org unit setting. Requires MARK_ITEM_MISSING_PIECES
- permission.
- @param authtoken The login session key
- @param copy_id The ID of the copy to mark as damaged
- @return Success event with circ and copy objects in the payload, or error Event otherwise.
- /
-);
-
-sub mark_item_missing_pieces {
- my( $self, $conn, $auth, $copy_id, $args ) = @_;
- ### FIXME: We're starting a transaction here, but we're doing a lot of things outside of the transaction
- my $e = new_editor(authtoken=>$auth, xact =>1);
- return $e->die_event unless $e->checkauth;
- $args ||= {};
-
- my $copy = $e->retrieve_asset_copy([
- $copy_id,
- {flesh => 1, flesh_fields => {'acp' => ['call_number']}}])
- or return $e->die_event;
-
- my $owning_lib =
- ($copy->call_number->id == OILS_PRECAT_CALL_NUMBER) ?
- $copy->circ_lib : $copy->call_number->owning_lib;
-
- return $e->die_event unless $e->allowed('MARK_ITEM_MISSING_PIECES', $owning_lib);
-
- #### grab the last circulation
- my $circ = $e->search_action_circulation([
- { target_copy => $copy->id},
- { limit => 1,
- order_by => {circ => "xact_start DESC"}
- }
- ])->[0];
-
- if ($circ) {
- if (! $circ->checkin_time) { # if circ active, attempt renew
- my ($res) = $self->method_lookup('open-ils.circ.renew')->run($e->authtoken,{'copy_id'=>$circ->target_copy});
- if (ref $res ne 'ARRAY') { $res = [ $res ]; }
- if ( $res->[0]->{textcode} eq 'SUCCESS' ) {
- $circ = $res->[0]->{payload}{'circ'};
- $circ->target_copy( $copy->id );
- $logger->info('open-ils.circ.mark_item_missing_pieces: successful renewal');
- } else {
- $logger->info('open-ils.circ.mark_item_missing_pieces: non-successful renewal');
- }
- } else {
-
- my $co_params = {
- 'copy_id'=>$circ->target_copy,
- 'patron_id'=>$circ->usr,
- 'skip_deposit_fee'=>1,
- 'skip_rental_fee'=>1
- };
-
- if ($U->ou_ancestor_setting_value($e->requestor->ws_ou, 'circ.block_renews_for_holds')) {
-
- my ($hold, undef, $retarget) = $holdcode->find_nearest_permitted_hold(
- $e, $copy, $e->requestor, 1 );
-
- if ($hold) { # needed for hold? then due now
-
- $logger->info('open-ils.circ.mark_item_missing_pieces: item needed for hold, shortening due date');
- my $due_date = DateTime->now(time_zone => 'local');
- $co_params->{'due_date'} = cleanse_ISO8601( $due_date->strftime('%FT%T%z') );
- } else {
- $logger->info('open-ils.circ.mark_item_missing_pieces: item not needed for hold');
- }
- }
-
- my ($res) = $self->method_lookup('open-ils.circ.checkout.full.override')->run($e->authtoken,$co_params);
- if (ref $res ne 'ARRAY') { $res = [ $res ]; }
- if ( $res->[0]->{textcode} eq 'SUCCESS' ) {
- $logger->info('open-ils.circ.mark_item_missing_pieces: successful checkout');
- $circ = $res->[0]->{payload}{'circ'};
- } else {
- $logger->info('open-ils.circ.mark_item_missing_pieces: non-successful checkout');
- $e->rollback;
- return $res;
- }
- }
- } else {
- $logger->info('open-ils.circ.mark_item_missing_pieces: no previous checkout');
- $e->rollback;
- return OpenILS::Event->new('ACTION_CIRCULATION_NOT_FOUND',{'copy'=>$copy});
- }
-
- ### Update the item status
-
- my $custom_stat = $U->ou_ancestor_setting_value(
- $owning_lib, 'circ.missing_pieces.copy_status', $e);
- my $stat = $custom_stat || OILS_COPY_STATUS_DAMAGED;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'missing_pieces', $copy, $owning_lib);
-
- $copy->status($stat);
- $copy->edit_date('now');
- $copy->editor($e->requestor->id);
-
- $e->update_asset_copy($copy) or return $e->die_event;
-
- my $holds = $e->search_action_hold_request(
- {
- current_copy => $copy->id,
- fulfillment_time => undef,
- cancel_time => undef,
- }
- );
-
- $logger->debug("resetting holds that target the marked copy");
- OpenILS::Application::Circ::Holds->_reset_hold($e->requestor, $_) for @$holds;
-
- if ($e->commit) {
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'circ.missing_pieces', $circ, $circ->circ_lib);
-
- return OpenILS::Event->new('SUCCESS',
- payload => {
- circ => $circ,
- copy => $copy,
- slip => $U->fire_object_event(undef, 'circ.format.missing_pieces.slip.print', $circ, $circ->circ_lib),
- letter => $U->fire_object_event(undef, 'circ.format.missing_pieces.letter.print', $circ, $circ->circ_lib)
- }
- );
-
- } else {
- return $e->die_event;
- }
-}
-
-
-
-
-
-# ----------------------------------------------------------------------
-__PACKAGE__->register_method(
- method => 'magic_fetch',
- api_name => 'open-ils.agent.fetch'
-);
-
-my @FETCH_ALLOWED = qw/ aou aout acp acn bre /;
-
-sub magic_fetch {
- my( $self, $conn, $auth, $args ) = @_;
- my $e = new_editor( authtoken => $auth );
- return $e->event unless $e->checkauth;
-
- my $hint = $$args{hint};
- my $id = $$args{id};
-
- # Is the call allowed to fetch this type of object?
- return undef unless grep { $_ eq $hint } @FETCH_ALLOWED;
-
- # Find the class the implements the given hint
- my ($class) = grep {
- $Fieldmapper::fieldmap->{$_}{hint} eq $hint } Fieldmapper->classes;
-
- $class =~ s/Fieldmapper:://og;
- $class =~ s/::/_/og;
- my $method = "retrieve_$class";
-
- my $obj = $e->$method($id) or return $e->event;
- return $obj;
-}
-# ----------------------------------------------------------------------
-
-
-__PACKAGE__->register_method(
- method => "fleshed_circ_retrieve",
- authoritative => 1,
- api_name => "open-ils.circ.fleshed.retrieve",);
-
-sub fleshed_circ_retrieve {
- my( $self, $client, $id ) = @_;
- my $e = new_editor();
- my $circ = $e->retrieve_action_circulation(
- [
- $id,
- {
- flesh => 4,
- flesh_fields => {
- circ => [ qw/ target_copy / ],
- acp => [ qw/ location status stat_cat_entry_copy_maps notes age_protect call_number / ],
- ascecm => [ qw/ stat_cat stat_cat_entry / ],
- acn => [ qw/ record / ],
- }
- }
- ]
- ) or return $e->event;
-
- my $copy = $circ->target_copy;
- my $vol = $copy->call_number;
- my $rec = $circ->target_copy->call_number->record;
-
- $vol->record($rec->id);
- $copy->call_number($vol->id);
- $circ->target_copy($copy->id);
-
- my $mvr;
-
- if( $rec->id == OILS_PRECAT_RECORD ) {
- $rec = undef;
- $vol = undef;
- } else {
- $mvr = $U->record_to_mvr($rec);
- $rec->marc(''); # drop the bulky marc data
- }
-
- return {
- circ => $circ,
- copy => $copy,
- volume => $vol,
- record => $rec,
- mvr => $mvr,
- };
-}
-
-
-
-__PACKAGE__->register_method(
- method => "test_batch_circ_events",
- api_name => "open-ils.circ.trigger_event_by_def_and_barcode.fire"
-);
-
-# method for testing the behavior of a given event definition
-sub test_batch_circ_events {
- my($self, $conn, $auth, $event_def, $barcode) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
-
- my $copy = $e->search_asset_copy({barcode => $barcode, deleted => 'f'})->[0]
- or return $e->event;
-
- my $circ = $e->search_action_circulation(
- {target_copy => $copy->id, checkin_time => undef})->[0]
- or return $e->event;
-
- return undef unless $circ;
-
- return $U->fire_object_event($event_def, undef, $circ, $e->requestor->ws_ou)
-}
-
-
-__PACKAGE__->register_method(
- method => "fire_circ_events",
- api_name => "open-ils.circ.fire_circ_trigger_events",
- signature => q/
- General event def runner for circ objects. If no event def ID
- is provided, the hook will be used to find the best event_def
- match based on the context org unit
- /
-);
-
-__PACKAGE__->register_method(
- method => "fire_circ_events",
- api_name => "open-ils.circ.fire_hold_trigger_events",
- signature => q/
- General event def runner for hold objects. If no event def ID
- is provided, the hook will be used to find the best event_def
- match based on the context org unit
- /
-);
-
-__PACKAGE__->register_method(
- method => "fire_circ_events",
- api_name => "open-ils.circ.fire_user_trigger_events",
- signature => q/
- General event def runner for user objects. If no event def ID
- is provided, the hook will be used to find the best event_def
- match based on the context org unit
- /
-);
-
-
-sub fire_circ_events {
- my($self, $conn, $auth, $org_id, $event_def, $hook, $granularity, $target_ids, $user_data) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->event unless $e->checkauth;
-
- my $targets;
-
- if($self->api_name =~ /hold/) {
- return $e->event unless $e->allowed('VIEW_HOLD', $org_id);
- $targets = $e->batch_retrieve_action_hold_request($target_ids);
- } elsif($self->api_name =~ /user/) {
- return $e->event unless $e->allowed('VIEW_USER', $org_id);
- $targets = $e->batch_retrieve_actor_user($target_ids);
- } else {
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS', $org_id);
- $targets = $e->batch_retrieve_action_circulation($target_ids);
- }
- $e->rollback; # FIXME using transaction because of pgpool/slony setups, but not
- # simply making this method authoritative because of weirdness
- # with transaction handling in A/T code that causes rollback
- # failure down the line if handling many targets
-
- return undef unless @$targets;
- return $U->fire_object_event($event_def, $hook, $targets, $org_id, $granularity, $user_data);
-}
-
-__PACKAGE__->register_method(
- method => "user_payments_list",
- api_name => "open-ils.circ.user_payments.filtered.batch",
- stream => 1,
- signature => {
- desc => q/Returns a fleshed, date-limited set of all payments a user
- has made. By default, ordered by payment date. Optionally
- ordered by other columns in the top-level "mp" object/,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'User ID', type => 'number'},
- {desc => 'Order by column(s), optional. Array of "mp" class columns', type => 'array'}
- ],
- return => {desc => q/List of "mp" objects, fleshed with the billable transaction
- and the related fully-realized payment object (e.g money.cash_payment)/}
- }
-);
-
-sub user_payments_list {
- my($self, $conn, $auth, $user_id, $start_date, $end_date, $order_by) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS', $user->home_ou);
-
- $order_by ||= ['payment_ts'];
-
- # all payments by user, between start_date and end_date
- my $payments = $e->json_query({
- select => {mp => ['id']},
- from => {
- mp => {
- mbt => {
- fkey => 'xact', field => 'id'}
- }
- },
- where => {
- '+mbt' => {usr => $user_id},
- '+mp' => {payment_ts => {between => [$start_date, $end_date]}}
- },
- order_by => {mp => $order_by}
- });
-
- for my $payment_id (@$payments) {
- my $payment = $e->retrieve_money_payment([
- $payment_id->{id},
- {
- flesh => 2,
- flesh_fields => {
- mp => [
- 'xact',
- 'cash_payment',
- 'credit_card_payment',
- 'credit_payment',
- 'check_payment',
- 'work_payment',
- 'forgive_payment',
- 'goods_payment'
- ],
- mbt => [
- 'circulation',
- 'grocery',
- 'reservation'
- ]
- }
- }
- ]);
- $conn->respond($payment);
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_circ_chain",
- api_name => "open-ils.circ.renewal_chain.retrieve_by_circ",
- stream => 1,
- signature => {
- desc => q/Given a circulation, this returns all circulation objects
- that are part of the same chain of renewals./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Circ ID', type => 'number'},
- ],
- return => {desc => q/List of circ objects, orderd by oldest circ first/}
- }
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_circ_chain",
- api_name => "open-ils.circ.renewal_chain.retrieve_by_circ.summary",
- signature => {
- desc => q/Given a circulation, this returns a summary of the circulation objects
- that are part of the same chain of renewals./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Circ ID', type => 'number'},
- ],
- return => {desc => q/Circulation Chain Summary/}
- }
-);
-
-sub retrieve_circ_chain {
- my($self, $conn, $auth, $circ_id) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
-
- if($self->api_name =~ /summary/) {
- return $U->create_circ_chain_summary($e, $circ_id);
-
- } else {
-
- my $chain = $e->json_query({from => ['action.circ_chain', $circ_id]});
-
- for my $circ_info (@$chain) {
- my $circ = Fieldmapper::action::circulation->new;
- $circ->$_($circ_info->{$_}) for keys %$circ_info;
- $conn->respond($circ);
- }
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_prev_circ_chain",
- api_name => "open-ils.circ.prev_renewal_chain.retrieve_by_circ",
- stream => 1,
- signature => {
- desc => q/Given a circulation, this returns all circulation objects
- that are part of the previous chain of renewals./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Circ ID', type => 'number'},
- ],
- return => {desc => q/List of circ objects, orderd by oldest circ first/}
- }
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_prev_circ_chain",
- api_name => "open-ils.circ.prev_renewal_chain.retrieve_by_circ.summary",
- signature => {
- desc => q/Given a circulation, this returns a summary of the circulation objects
- that are part of the previous chain of renewals./,
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Circ ID', type => 'number'},
- ],
- return => {desc => q/Object containing Circulation Chain Summary and User Id/}
- }
-);
-
-sub retrieve_prev_circ_chain {
- my($self, $conn, $auth, $circ_id) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
-
- if($self->api_name =~ /summary/) {
- my $first_circ = $e->json_query({from => ['action.circ_chain', $circ_id]})->[0];
- my $target_copy = $$first_circ{'target_copy'};
- my $usr = $$first_circ{'usr'};
- my $last_circ_from_prev_chain = $e->json_query({
- 'select' => { 'circ' => ['id','usr'] },
- 'from' => 'circ',
- 'where' => {
- target_copy => $target_copy,
- xact_start => { '<' => $$first_circ{'xact_start'} }
- },
- 'order_by' => [{ 'class'=>'circ', 'field'=>'xact_start', 'direction'=>'desc' }],
- 'limit' => 1
- })->[0];
- return undef unless $last_circ_from_prev_chain;
- return undef unless $$last_circ_from_prev_chain{'id'};
- my $sum = $e->json_query({from => ['action.summarize_circ_chain', $$last_circ_from_prev_chain{'id'}]})->[0];
- return undef unless $sum;
- my $obj = Fieldmapper::action::circ_chain_summary->new;
- $obj->$_($sum->{$_}) for keys %$sum;
- return { 'summary' => $obj, 'usr' => $$last_circ_from_prev_chain{'usr'} };
-
- } else {
-
- my $first_circ = $e->json_query({from => ['action.circ_chain', $circ_id]})->[0];
- my $target_copy = $$first_circ{'target_copy'};
- my $last_circ_from_prev_chain = $e->json_query({
- 'select' => { 'circ' => ['id'] },
- 'from' => 'circ',
- 'where' => {
- target_copy => $target_copy,
- xact_start => { '<' => $$first_circ{'xact_start'} }
- },
- 'order_by' => [{ 'class'=>'circ', 'field'=>'xact_start', 'direction'=>'desc' }],
- 'limit' => 1
- })->[0];
- return undef unless $last_circ_from_prev_chain;
- return undef unless $$last_circ_from_prev_chain{'id'};
- my $chain = $e->json_query({from => ['action.circ_chain', $$last_circ_from_prev_chain{'id'}]});
-
- for my $circ_info (@$chain) {
- my $circ = Fieldmapper::action::circulation->new;
- $circ->$_($circ_info->{$_}) for keys %$circ_info;
- $conn->respond($circ);
- }
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "get_copy_due_date",
- api_name => "open-ils.circ.copy.due_date.retrieve",
- signature => {
- desc => q/
- Given a copy ID, returns the due date for the copy if it's
- currently circulating. Otherwise, returns null. Note, this is a public
- method requiring no authentication. Only the due date is exposed.
- /,
- params => [
- {desc => 'Copy ID', type => 'number'}
- ],
- return => {desc => q/
- Due date (ISO date stamp) if the copy is circulating, null otherwise.
- /}
- }
-);
-
-sub get_copy_due_date {
- my($self, $conn, $copy_id) = @_;
- my $e = new_editor();
-
- my $circ = $e->json_query({
- select => {circ => ['due_date']},
- from => 'circ',
- where => {
- target_copy => $copy_id,
- checkin_time => undef,
- '-or' => [
- {stop_fines => ["MAXFINES","LONGOVERDUE"]},
- {stop_fines => undef}
- ],
- },
- limit => 1
- })->[0] or return undef;
-
- return $circ->{due_date};
-}
-
-
-
-
-
-# {"select":{"acp":["id"],"circ":[{"aggregate":true,"transform":"count","alias":"count","column":"id"}]},"from":{"acp":{"circ":{"field":"target_copy","fkey":"id","type":"left"},"acn"{"field":"id","fkey":"call_number"}}},"where":{"+acn":{"record":200057}}
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Circ::CircCommon;
-use strict; use warnings;
-use DateTime;
-use DateTime::Format::ISO8601;
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils qw/:datetime/;
-use OpenILS::Event;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Const qw/:const/;
-
-my $U = "OpenILS::Application::AppUtils";
-
-# -----------------------------------------------------------------
-# Do not publish methods here. This code is shared across apps.
-# -----------------------------------------------------------------
-
-
-# -----------------------------------------------------------------
-# Voids overdue fines on the given circ. if a backdate is
-# provided, then we only void back to the backdate
-# -----------------------------------------------------------------
-sub void_overdues {
- my($class, $e, $circ, $backdate, $note) = @_;
-
- my $bill_search = {
- xact => $circ->id,
- btype => 1
- };
-
- if( $backdate ) {
- # ------------------------------------------------------------------
- # Fines for overdue materials are assessed up to, but not including,
- # one fine interval after the fines are applicable. Here, we add
- # one fine interval to the backdate to ensure that we are not
- # voiding fines that were applicable before the backdate.
- # ------------------------------------------------------------------
-
- # if there is a raw time component (e.g. from postgres),
- # turn it into an interval that interval_to_seconds can parse
- my $duration = $circ->fine_interval;
- $duration =~ s/(\d{2}):(\d{2}):(\d{2})/$1 h $2 m $3 s/o;
- my $interval = OpenSRF::Utils->interval_to_seconds($duration);
-
- my $date = DateTime::Format::ISO8601->parse_datetime($backdate);
- $backdate = $U->epoch2ISO8601($date->epoch + $interval);
- $logger->info("applying backdate $backdate in overdue voiding");
- $$bill_search{billing_ts} = {'>=' => $backdate};
- }
-
- my $bills = $e->search_money_billing($bill_search);
-
- for my $bill (@$bills) {
- next if $U->is_true($bill->voided);
- $logger->info("voiding overdue bill ".$bill->id);
- $bill->voided('t');
- $bill->void_time('now');
- $bill->voider($e->requestor->id);
- my $n = ($bill->note) ? sprintf("%s\n", $bill->note) : "";
- $bill->note(sprintf("$n%s", ($note) ? $note : "System: VOIDED FOR BACKDATE"));
- $e->update_money_billing($bill) or return $e->die_event;
- }
-
- return undef;
-}
-
-
-sub reopen_xact {
- my($class, $e, $xactid) = @_;
-
- # -----------------------------------------------------------------
- # make sure the transaction is not closed
- my $xact = $e->retrieve_money_billable_transaction($xactid)
- or return $e->die_event;
-
- if( $xact->xact_finish ) {
- my ($mbts) = $U->fetch_mbts($xactid, $e);
- if( $mbts->balance_owed != 0 ) {
- $logger->info("* re-opening xact $xactid, orig xact_finish is ".$xact->xact_finish);
- $xact->clear_xact_finish;
- $e->update_money_billable_transaction($xact)
- or return $e->die_event;
- }
- }
-
- return undef;
-}
-
-
-sub create_bill {
- my($class, $e, $amount, $btype, $type, $xactid, $note) = @_;
-
- $logger->info("The system is charging $amount [$type] on xact $xactid");
- $note ||= 'SYSTEM GENERATED';
-
- # -----------------------------------------------------------------
- # now create the billing
- my $bill = Fieldmapper::money::billing->new;
- $bill->xact($xactid);
- $bill->amount($amount);
- $bill->billing_type($type);
- $bill->btype($btype);
- $bill->note($note);
- $e->create_money_billing($bill) or return $e->die_event;
-
- return undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Circ::Circulate;
-use strict; use warnings;
-use base 'OpenILS::Application';
-use OpenSRF::EX qw(:try);
-use OpenSRF::AppSession;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Const qw/:const/;
-use OpenILS::Application::AppUtils;
-use DateTime;
-my $U = "OpenILS::Application::AppUtils";
-
-my %scripts;
-my $script_libs;
-my $legacy_script_support = 0;
-my $booking_status;
-
-sub determine_booking_status {
- unless (defined $booking_status) {
- my $ses = create OpenSRF::AppSession("router");
- $booking_status = grep {$_ eq "open-ils.booking"} @{
- $ses->request("opensrf.router.info.class.list")->gather(1)
- };
- $ses->disconnect;
- $logger->info("booking status: " . ($booking_status ? "on" : "off"));
- }
-
- return $booking_status;
-}
-
-
-my $MK_ENV_FLESH = {
- flesh => 2,
- flesh_fields => {acp => ['call_number'], acn => ['record']}
-};
-
-sub initialize {
-
- my $self = shift;
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my @pfx2 = ( "apps", "open-ils.circ","app_settings" );
-
- $legacy_script_support = $conf->config_value(@pfx2, 'legacy_script_support');
- $legacy_script_support = ($legacy_script_support and $legacy_script_support =~ /true/i);
-
- my $lb = $conf->config_value( @pfx2, 'script_path' );
- $lb = [ $lb ] unless ref($lb);
- $script_libs = $lb;
-
- return unless $legacy_script_support;
-
- my @pfx = ( @pfx2, "scripts" );
- my $p = $conf->config_value( @pfx, 'circ_permit_patron' );
- my $c = $conf->config_value( @pfx, 'circ_permit_copy' );
- my $d = $conf->config_value( @pfx, 'circ_duration' );
- my $f = $conf->config_value( @pfx, 'circ_recurring_fines' );
- my $m = $conf->config_value( @pfx, 'circ_max_fines' );
- my $pr = $conf->config_value( @pfx, 'circ_permit_renew' );
-
- $logger->error( "Missing circ script(s)" )
- unless( $p and $c and $d and $f and $m and $pr );
-
- $scripts{circ_permit_patron} = $p;
- $scripts{circ_permit_copy} = $c;
- $scripts{circ_duration} = $d;
- $scripts{circ_recurring_fines} = $f;
- $scripts{circ_max_fines} = $m;
- $scripts{circ_permit_renew} = $pr;
-
- $logger->debug(
- "circulator: Loaded rules scripts for circ: " .
- "circ permit patron = $p, ".
- "circ permit copy = $c, ".
- "circ duration = $d, ".
- "circ recurring fines = $f, " .
- "circ max fines = $m, ".
- "circ renew permit = $pr. ".
- "lib paths = @$lb. ".
- "legacy script support = ". ($legacy_script_support) ? 'yes' : 'no'
- );
-}
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkout.permit",
- notes => q/
- Determines if the given checkout can occur
- @param authtoken The login session key
- @param params A trailing hash of named params including
- barcode : The copy barcode,
- patron : The patron the checkout is occurring for,
- renew : true or false - whether or not this is a renewal
- @return The event that occurred during the permit check.
- /);
-
-
-__PACKAGE__->register_method (
- method => 'run_method',
- api_name => 'open-ils.circ.checkout.permit.override',
- signature => q/@see open-ils.circ.checkout.permit/,
-);
-
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkout",
- notes => q/
- Checks out an item
- @param authtoken The login session key
- @param params A named hash of params including:
- copy The copy object
- barcode If no copy is provided, the copy is retrieved via barcode
- copyid If no copy or barcode is provide, the copy id will be use
- patron The patron's id
- noncat True if this is a circulation for a non-cataloted item
- noncat_type The non-cataloged type id
- noncat_circ_lib The location for the noncat circ.
- precat The item has yet to be cataloged
- dummy_title The temporary title of the pre-cataloded item
- dummy_author The temporary authr of the pre-cataloded item
- Default is the home org of the staff member
- @return The SUCCESS event on success, any other event depending on the error
- /);
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkin",
- argc => 2,
- signature => q/
- Generic super-method for handling all copies
- @param authtoken The login session key
- @param params Hash of named parameters including:
- barcode - The copy barcode
- force - If true, copies in bad statuses will be checked in and give good statuses
- noop - don't capture holds or put items into transit
- void_overdues - void all overdues for the circulation (aka amnesty)
- ...
- /
-);
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkin.override",
- signature => q/@see open-ils.circ.checkin/
-);
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.renew.override",
- signature => q/@see open-ils.circ.renew/,
-);
-
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.renew",
- notes => <<" NOTES");
- PARAMS( authtoken, circ => circ_id );
- open-ils.circ.renew(login_session, circ_object);
- Renews the provided circulation. login_session is the requestor of the
- renewal and if the logged in user is not the same as circ->usr, then
- the logged in user must have RENEW_CIRC permissions.
- NOTES
-
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkout.full"
-);
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkout.full.override"
-);
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.reservation.pickup"
-);
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.reservation.return"
-);
-__PACKAGE__->register_method(
- method => "run_method",
- api_name => "open-ils.circ.checkout.inspect",
- desc => q/Returns the circ matrix test result and, on success, the rule set and matrix test object/
-);
-
-
-sub run_method {
- my( $self, $conn, $auth, $args ) = @_;
- translate_legacy_args($args);
- my $api = $self->api_name;
-
- my $circulator =
- OpenILS::Application::Circ::Circulator->new($auth, %$args);
-
- return circ_events($circulator) if $circulator->bail_out;
-
- $circulator->use_booking(determine_booking_status());
-
- # --------------------------------------------------------------------------
- # First, check for a booking transit, as the barcode may not be a copy
- # barcode, but a resource barcode, and nothing else in here will work
- # --------------------------------------------------------------------------
-
- if ($circulator->use_booking && (my $bc = $circulator->copy_barcode) && $api !~ /checkout|inspect/) { # do we have a barcode?
- my $resources = $circulator->editor->search_booking_resource( { barcode => $bc } ); # any resources by this barcode?
- if (@$resources) { # yes!
-
- my $res_id_list = [ map { $_->id } @$resources ];
- my $transit = $circulator->editor->search_action_reservation_transit_copy(
- [
- { target_copy => $res_id_list, dest => $circulator->circ_lib, dest_recv_time => undef },
- { order_by => { artc => 'source_send_time' }, limit => 1 }
- ]
- )->[0]; # Any transit for this barcode?
-
- if ($transit) { # yes! unwrap it.
-
- my $reservation = $circulator->editor->retrieve_booking_reservation( $transit->reservation );
- my $res_type = $circulator->editor->retrieve_booking_resource_type( $reservation->target_resource_type );
-
- my $success_event = new OpenILS::Event(
- "SUCCESS", "payload" => {"reservation" => $reservation}
- );
- if ($U->is_true($res_type->catalog_item)) { # is there a copy to be had here?
- if (my $copy = $circulator->editor->search_asset_copy([
- { barcode => $bc, deleted => 'f' }, $MK_ENV_FLESH
- ])->[0]) { # got a copy
- $copy->status( $transit->copy_status );
- $copy->editor($circulator->editor->requestor->id);
- $copy->edit_date('now');
- $circulator->editor->update_asset_copy($copy);
- $success_event->{"payload"}->{"record"} =
- $U->record_to_mvr($copy->call_number->record);
- $copy->call_number($copy->call_number->id);
- $success_event->{"payload"}->{"copy"} = $copy;
- }
- }
-
- $transit->dest_recv_time('now');
- $circulator->editor->update_action_reservation_transit_copy( $transit );
-
- $circulator->editor->commit;
- # Formerly this branch just stopped here. Argh!
- $conn->respond_complete($success_event);
- return;
- }
- }
- }
-
-
-
- # --------------------------------------------------------------------------
- # Go ahead and load the script runner to make sure we have all
- # of the objects we need
- # --------------------------------------------------------------------------
-
- if ($circulator->use_booking) {
- $circulator->is_res_checkin($circulator->is_checkin(1))
- if $api =~ /reservation.return/ or (
- $api =~ /checkin/ and $circulator->seems_like_reservation()
- );
-
- $circulator->is_res_checkout(1) if $api =~ /reservation.pickup/;
- }
-
- $circulator->is_renewal(1) if $api =~ /renew/;
- $circulator->is_checkin(1) if $api =~ /checkin/;
-
- $circulator->mk_env();
- $circulator->noop(1) if $circulator->claims_never_checked_out;
-
- if($legacy_script_support and not $circulator->is_checkin) {
- $circulator->mk_script_runner();
- $circulator->legacy_script_support(1);
- $circulator->circ_permit_patron($scripts{circ_permit_patron});
- $circulator->circ_permit_copy($scripts{circ_permit_copy});
- $circulator->circ_duration($scripts{circ_duration});
- $circulator->circ_permit_renew($scripts{circ_permit_renew});
- }
- return circ_events($circulator) if $circulator->bail_out;
-
-
- $circulator->override(1) if $api =~ /override/o;
-
- if( $api =~ /checkout\.permit/ ) {
- $circulator->do_permit();
-
- } elsif( $api =~ /checkout.full/ ) {
-
- # requesting a precat checkout implies that any required
- # overrides have been performed. Go ahead and re-override.
- $circulator->skip_permit_key(1);
- $circulator->override(1) if $circulator->request_precat;
- $circulator->do_permit();
- $circulator->is_checkout(1);
- unless( $circulator->bail_out ) {
- $circulator->events([]);
- $circulator->do_checkout();
- }
-
- } elsif( $circulator->is_res_checkout ) {
- $circulator->do_reservation_pickup();
-
- } elsif( $api =~ /inspect/ ) {
- my $data = $circulator->do_inspect();
- $circulator->editor->rollback;
- return $data;
-
- } elsif( $api =~ /checkout/ ) {
- $circulator->is_checkout(1);
- $circulator->do_checkout();
-
- } elsif( $circulator->is_res_checkin ) {
- $circulator->do_reservation_return();
- $circulator->do_checkin() if ($circulator->copy());
- } elsif( $api =~ /checkin/ ) {
- $circulator->do_checkin();
-
- } elsif( $api =~ /renew/ ) {
- $circulator->is_renewal(1);
- $circulator->do_renew();
- }
-
- if( $circulator->bail_out ) {
-
- my @ee;
- # make sure no success event accidentally slip in
- $circulator->events(
- [ grep { $_->{textcode} ne 'SUCCESS' } @{$circulator->events} ]);
-
- # Log the events
- my @e = @{$circulator->events};
- push( @ee, $_->{textcode} ) for @e;
- $logger->info("circulator: bailing out with events: " . (join ", ", @ee));
-
- $circulator->editor->rollback;
-
- } else {
- $circulator->editor->commit;
- }
-
- $circulator->script_runner->cleanup if $circulator->script_runner;
-
- $conn->respond_complete(circ_events($circulator));
-
- unless($circulator->bail_out) {
- $circulator->do_hold_notify($circulator->notify_hold)
- if $circulator->notify_hold;
- $circulator->retarget_holds if $circulator->retarget;
- $circulator->append_reading_list;
- $circulator->make_trigger_events;
- }
-}
-
-sub circ_events {
- my $circ = shift;
- my @e = @{$circ->events};
- # if we have multiple events, SUCCESS should not be one of them;
- @e = grep { $_->{textcode} ne 'SUCCESS' } @e if @e > 1;
- return (@e == 1) ? $e[0] : \@e;
-}
-
-
-sub translate_legacy_args {
- my $args = shift;
-
- if( $$args{barcode} ) {
- $$args{copy_barcode} = $$args{barcode};
- delete $$args{barcode};
- }
-
- if( $$args{copyid} ) {
- $$args{copy_id} = $$args{copyid};
- delete $$args{copyid};
- }
-
- if( $$args{patronid} ) {
- $$args{patron_id} = $$args{patronid};
- delete $$args{patronid};
- }
-
- if( $$args{patron} and !ref($$args{patron}) ) {
- $$args{patron_id} = $$args{patron};
- delete $$args{patron};
- }
-
-
- if( $$args{noncat} ) {
- $$args{is_noncat} = $$args{noncat};
- delete $$args{noncat};
- }
-
- if( $$args{precat} ) {
- $$args{is_precat} = $$args{request_precat} = $$args{precat};
- delete $$args{precat};
- }
-}
-
-
-
-# --------------------------------------------------------------------------
-# This package actually manages all of the circulation logic
-# --------------------------------------------------------------------------
-package OpenILS::Application::Circ::Circulator;
-use strict; use warnings;
-use vars q/$AUTOLOAD/;
-use DateTime;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Cache;
-use Digest::MD5 qw(md5_hex);
-use DateTime::Format::ISO8601;
-use OpenILS::Utils::PermitHold;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::Circ::Holds;
-use OpenILS::Application::Circ::Transit;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Application::Circ::ScriptBuilder;
-use OpenILS::Const qw/:const/;
-use OpenILS::Utils::Penalty;
-use OpenILS::Application::Circ::CircCommon;
-use Time::Local;
-
-my $holdcode = "OpenILS::Application::Circ::Holds";
-my $transcode = "OpenILS::Application::Circ::Transit";
-my %user_groups;
-
-sub DESTROY { }
-
-
-# --------------------------------------------------------------------------
-# Add a pile of automagic getter/setter methods
-# --------------------------------------------------------------------------
-my @AUTOLOAD_FIELDS = qw/
- notify_hold
- remote_hold
- backdate
- reservation
- copy
- copy_id
- copy_barcode
- patron
- patron_id
- patron_barcode
- script_runner
- volume
- title
- is_renewal
- is_checkout
- is_res_checkout
- is_precat
- is_noncat
- request_precat
- is_checkin
- is_res_checkin
- noncat_type
- editor
- events
- cache_handle
- override
- circ_permit_patron
- circ_permit_copy
- circ_duration
- circ_recurring_fines
- circ_max_fines
- circ_permit_renew
- circ
- transit
- hold
- permit_key
- noncat_circ_lib
- noncat_count
- checkout_time
- dummy_title
- dummy_author
- dummy_isbn
- circ_modifier
- circ_lib
- barcode
- duration_level
- recurring_fines_level
- duration_rule
- recurring_fines_rule
- max_fine_rule
- renewal_remaining
- hard_due_date
- due_date
- fulfilled_holds
- transit
- checkin_changed
- force
- permit_override
- pending_checkouts
- cancelled_hold_transit
- opac_renewal
- phone_renewal
- desk_renewal
- sip_renewal
- retarget
- matrix_test_result
- circ_matrix_matchpoint
- circ_test_success
- legacy_script_support
- is_deposit
- is_rental
- deposit_billing
- rental_billing
- capture
- noop
- void_overdues
- parent_circ
- return_patron
- claims_never_checked_out
- skip_permit_key
- skip_deposit_fee
- skip_rental_fee
- use_booking
-/;
-
-
-sub AUTOLOAD {
- my $self = shift;
- my $type = ref($self) or die "$self is not an object";
- my $data = shift;
- my $name = $AUTOLOAD;
- $name =~ s/.*://o;
-
- unless (grep { $_ eq $name } @AUTOLOAD_FIELDS) {
- $logger->error("circulator: $type: invalid autoload field: $name");
- die "$type: invalid autoload field: $name\n"
- }
-
- {
- no strict 'refs';
- *{"${type}::${name}"} = sub {
- my $s = shift;
- my $v = shift;
- $s->{$name} = $v if defined $v;
- return $s->{$name};
- }
- }
- return $self->$name($data);
-}
-
-
-sub new {
- my( $class, $auth, %args ) = @_;
- $class = ref($class) || $class;
- my $self = bless( {}, $class );
-
- $self->events([]);
- $self->editor(new_editor(xact => 1, authtoken => $auth));
-
- unless( $self->editor->checkauth ) {
- $self->bail_on_events($self->editor->event);
- return $self;
- }
-
- $self->cache_handle(OpenSRF::Utils::Cache->new('global'));
-
- $self->$_($args{$_}) for keys %args;
-
- $self->circ_lib(
- ($self->circ_lib) ? $self->circ_lib : $self->editor->requestor->ws_ou);
-
- # if this is a renewal, default to desk_renewal
- $self->desk_renewal(1) unless
- $self->opac_renewal or $self->phone_renewal or $self->sip_renewal;
-
- $self->capture('') unless $self->capture;
-
- unless(%user_groups) {
- my $gps = $self->editor->retrieve_all_permission_grp_tree;
- %user_groups = map { $_->id => $_ } @$gps;
- }
-
- return $self;
-}
-
-
-# --------------------------------------------------------------------------
-# True if we should discontinue processing
-# --------------------------------------------------------------------------
-sub bail_out {
- my( $self, $bool ) = @_;
- if( defined $bool ) {
- $logger->info("circulator: BAILING OUT") if $bool;
- $self->{bail_out} = $bool;
- }
- return $self->{bail_out};
-}
-
-
-sub push_events {
- my( $self, @evts ) = @_;
- for my $e (@evts) {
- next unless $e;
- $e->{payload} = $self->copy if
- ($e->{textcode} eq 'COPY_NOT_AVAILABLE');
-
- $logger->info("circulator: pushing event ".$e->{textcode});
- push( @{$self->events}, $e ) unless
- grep { $_->{textcode} eq $e->{textcode} } @{$self->events};
- }
-}
-
-sub mk_permit_key {
- my $self = shift;
- return '' if $self->skip_permit_key;
- my $key = md5_hex( time() . rand() . "$$" );
- $self->cache_handle->put_cache( "oils_permit_key_$key", 1, 300 );
- return $self->permit_key($key);
-}
-
-sub check_permit_key {
- my $self = shift;
- return 1 if $self->skip_permit_key;
- my $key = $self->permit_key;
- return 0 unless $key;
- my $k = "oils_permit_key_$key";
- my $one = $self->cache_handle->get_cache($k);
- $self->cache_handle->delete_cache($k);
- return ($one) ? 1 : 0;
-}
-
-sub seems_like_reservation {
- my $self = shift;
-
- # Some words about the following method:
- # 1) It requires the VIEW_USER permission, but that's not an
- # issue, right, since all staff should have that?
- # 2) It returns only one reservation at a time, even if an item can be
- # and is currently overbooked. Hmmm....
- my $booking_ses = create OpenSRF::AppSession("open-ils.booking");
- my $result = $booking_ses->request(
- "open-ils.booking.reservations.by_returnable_resource_barcode",
- $self->editor->authtoken,
- $self->copy_barcode
- )->gather(1);
- $booking_ses->disconnect;
-
- return $self->bail_on_events($result) if defined $U->event_code($result);
-
- if (@$result > 0) {
- $self->reservation(shift @$result);
- return 1;
- } else {
- return 0;
- }
-
-}
-
-# save_trimmed_copy() used just to be a block in mk_env(), but was separated for re-use
-sub save_trimmed_copy {
- my ($self, $copy) = @_;
-
- $self->copy($copy);
- $self->volume($copy->call_number);
- $self->title($self->volume->record);
- $self->copy->call_number($self->volume->id);
- $self->volume->record($self->title->id);
- $self->is_precat(1) if $self->volume->id == OILS_PRECAT_CALL_NUMBER;
- if($self->copy->deposit_amount and $self->copy->deposit_amount > 0) {
- $self->is_deposit(1) if $U->is_true($self->copy->deposit);
- $self->is_rental(1) unless $U->is_true($self->copy->deposit);
- }
-}
-
-sub mk_env {
- my $self = shift;
- my $e = $self->editor;
-
- # --------------------------------------------------------------------------
- # Grab the fleshed copy
- # --------------------------------------------------------------------------
- unless($self->is_noncat) {
- my $copy;
- if($self->copy_id) {
- $copy = $e->retrieve_asset_copy(
- [$self->copy_id, $MK_ENV_FLESH ]) or return $e->event;
-
- } elsif( $self->copy_barcode ) {
-
- $copy = $e->search_asset_copy(
- [{barcode => $self->copy_barcode, deleted => 'f'}, $MK_ENV_FLESH ])->[0];
- } elsif( $self->reservation ) {
- my $res = $e->json_query(
- {
- "select" => {"acp" => ["id"]},
- "from" => {
- "acp" => {
- "brsrc" => {
- "fkey" => "barcode",
- "field" => "barcode",
- "join" => {
- "bresv" => {
- "fkey" => "id",
- "field" => "current_resource"
- }
- }
- }
- }
- },
- "where" => {
- "+bresv" => {
- "id" => (ref $self->reservation) ?
- $self->reservation->id : $self->reservation
- }
- }
- }
- );
- if (ref $res eq "ARRAY" and scalar @$res) {
- $logger->info("circulator: mapped reservation " .
- $self->reservation . " to copy " . $res->[0]->{"id"});
- $copy = $e->retrieve_asset_copy([$res->[0]->{"id"}, $MK_ENV_FLESH]);
- }
- }
-
- if($copy) {
- $self->save_trimmed_copy($copy);
- } else {
- # We can't renew if there is no copy
- return $self->bail_on_events(OpenILS::Event->new('ASSET_COPY_NOT_FOUND'))
- if $self->is_renewal;
- $self->is_precat(1);
- }
- }
-
- # --------------------------------------------------------------------------
- # Grab the patron
- # --------------------------------------------------------------------------
- my $patron;
- my $flesh = {
- flesh => 1,
- flesh_fields => {au => [ qw/ card / ]}
- };
-
- if( $self->patron_id ) {
- $patron = $e->retrieve_actor_user([$self->patron_id, $flesh])
- or return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'));
-
- } elsif( $self->patron_barcode ) {
-
- # note: throwing ACTOR_USER_NOT_FOUND instead of ACTOR_CARD_NOT_FOUND is intentional
- my $card = $e->search_actor_card({barcode => $self->patron_barcode})->[0]
- or return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'));
-
- $patron = $e->search_actor_user([{card => $card->id}, $flesh])->[0]
- or return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'));
-
- } else {
- if( my $copy = $self->copy ) {
-
- $flesh->{flesh} = 2;
- $flesh->{flesh_fields}->{circ} = ['usr'];
-
- my $circ = $e->search_action_circulation([
- {target_copy => $copy->id, checkin_time => undef}, $flesh
- ])->[0];
-
- if($circ) {
- $patron = $circ->usr;
- $circ->usr($patron->id); # de-flesh for consistency
- $self->circ($circ);
- }
- }
- }
-
- return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'))
- unless $self->patron($patron) or $self->is_checkin;
-
- unless($self->is_checkin) {
-
- # Check for inactivity and patron reg. expiration
-
- $self->bail_on_events(OpenILS::Event->new('PATRON_INACTIVE'))
- unless $U->is_true($patron->active);
-
- $self->bail_on_events(OpenILS::Event->new('PATRON_CARD_INACTIVE'))
- unless $U->is_true($patron->card->active);
-
- my $expire = DateTime::Format::ISO8601->new->parse_datetime(
- cleanse_ISO8601($patron->expire_date));
-
- $self->bail_on_events(OpenILS::Event->new('PATRON_ACCOUNT_EXPIRED'))
- if( CORE::time > $expire->epoch ) ;
- }
-}
-
-# --------------------------------------------------------------------------
-# This builds the script runner environment and fetches most of the
-# objects we need
-# --------------------------------------------------------------------------
-sub mk_script_runner {
- my $self = shift;
- my $args = {};
-
-
- my @fields =
- qw/copy copy_barcode copy_id patron
- patron_id patron_barcode volume title editor/;
-
- # Translate our objects into the ScriptBuilder args hash
- $$args{$_} = $self->$_() for @fields;
-
- $args->{ignore_user_status} = 1 if $self->is_checkin;
- $$args{fetch_patron_by_circ_copy} = 1;
- $$args{fetch_patron_circ_info} = 1 unless $self->is_checkin;
-
- if( my $pco = $self->pending_checkouts ) {
- $logger->info("circulator: we were given a pending checkouts number of $pco");
- $$args{patronItemsOut} = $pco;
- }
-
- # This fetches most of the objects we need
- $self->script_runner(
- OpenILS::Application::Circ::ScriptBuilder->build($args));
-
- # Now we translate the ScriptBuilder objects back into self
- $self->$_($$args{$_}) for @fields;
-
- my @evts = @{$args->{_events}} if $args->{_events};
-
- $logger->debug("circulator: script builder returned events: @evts") if @evts;
-
-
- if(@evts) {
- # Anything besides ASSET_COPY_NOT_FOUND will stop processing
- if(!$self->is_noncat and
- @evts == 1 and
- $evts[0]->{textcode} eq 'ASSET_COPY_NOT_FOUND') {
- $self->is_precat(1);
-
- } else {
- my @e = grep { $_->{textcode} ne 'ASSET_COPY_NOT_FOUND' } @evts;
- return $self->bail_on_events(@e);
- }
- }
-
- if($self->copy) {
- $self->is_precat(1) if $self->copy->call_number == OILS_PRECAT_CALL_NUMBER;
- if($self->copy->deposit_amount and $self->copy->deposit_amount > 0) {
- $self->is_deposit(1) if $U->is_true($self->copy->deposit);
- $self->is_rental(1) unless $U->is_true($self->copy->deposit);
- }
- }
-
- # We can't renew if there is no copy
- return $self->bail_on_events(@evts) if
- $self->is_renewal and !$self->copy;
-
- # Set some circ-specific flags in the script environment
- my $evt = "environment";
- $self->script_runner->insert("$evt.isRenewal", ($self->is_renewal) ? 1 : undef);
-
- if( $self->is_noncat ) {
- $self->script_runner->insert("$evt.isNonCat", 1);
- $self->script_runner->insert("$evt.nonCatType", $self->noncat_type);
- }
-
- if( $self->is_precat ) {
- $self->script_runner->insert("environment.isPrecat", 1, 1);
- }
-
- $self->script_runner->add_path( $_ ) for @$script_libs;
-
- return 1;
-}
-
-# --------------------------------------------------------------------------
-# Does the circ permit work
-# --------------------------------------------------------------------------
-sub do_permit {
- my $self = shift;
-
- $self->log_me("do_permit()");
-
- unless( $self->editor->requestor->id == $self->patron->id ) {
- return $self->bail_on_events($self->editor->event)
- unless( $self->editor->allowed('VIEW_PERMIT_CHECKOUT') );
- }
-
- $self->check_captured_holds();
- $self->do_copy_checks();
- return if $self->bail_out;
- $self->run_patron_permit_scripts();
- $self->run_copy_permit_scripts()
- unless $self->is_precat or $self->is_noncat;
- $self->check_item_deposit_events();
- $self->override_events();
- return if $self->bail_out;
-
- if($self->is_precat and not $self->request_precat) {
- $self->push_events(
- OpenILS::Event->new(
- 'ITEM_NOT_CATALOGED', payload => $self->mk_permit_key));
- return $self->bail_out(1) unless $self->is_renewal;
- }
-
- $self->push_events(
- OpenILS::Event->new('SUCCESS', payload => $self->mk_permit_key));
-}
-
-sub check_item_deposit_events {
- my $self = shift;
- $self->push_events(OpenILS::Event->new('ITEM_DEPOSIT_REQUIRED', payload => $self->copy))
- if $self->is_deposit and not $self->is_deposit_exempt;
- $self->push_events(OpenILS::Event->new('ITEM_RENTAL_FEE_REQUIRED', payload => $self->copy))
- if $self->is_rental and not $self->is_rental_exempt;
-}
-
-# returns true if the user is not required to pay deposits
-sub is_deposit_exempt {
- my $self = shift;
- my $pid = (ref $self->patron->profile) ?
- $self->patron->profile->id : $self->patron->profile;
- my $groups = $U->ou_ancestor_setting_value(
- $self->circ_lib, 'circ.deposit.exempt_groups', $self->editor);
- for my $grp (@$groups) {
- return 1 if $self->is_group_descendant($grp, $pid);
- }
- return 0;
-}
-
-# returns true if the user is not required to pay rental fees
-sub is_rental_exempt {
- my $self = shift;
- my $pid = (ref $self->patron->profile) ?
- $self->patron->profile->id : $self->patron->profile;
- my $groups = $U->ou_ancestor_setting_value(
- $self->circ_lib, 'circ.rental.exempt_groups', $self->editor);
- for my $grp (@$groups) {
- return 1 if $self->is_group_descendant($grp, $pid);
- }
- return 0;
-}
-
-sub is_group_descendant {
- my($self, $p_id, $c_id) = @_;
- return 0 unless defined $p_id and defined $c_id;
- return 1 if $c_id == $p_id;
- while(my $grp = $user_groups{$c_id}) {
- $c_id = $grp->parent;
- return 0 unless defined $c_id;
- return 1 if $c_id == $p_id;
- }
- return 0;
-}
-
-sub check_captured_holds {
- my $self = shift;
- my $copy = $self->copy;
- my $patron = $self->patron;
-
- return undef unless $copy;
-
- my $s = $U->copy_status($copy->status)->id;
- return unless $s == OILS_COPY_STATUS_ON_HOLDS_SHELF;
- $logger->info("circulator: copy is on holds shelf, searching for the correct hold");
-
- # Item is on the holds shelf, make sure it's going to the right person
- my $holds = $self->editor->search_action_hold_request(
- [
- {
- current_copy => $copy->id ,
- capture_time => { '!=' => undef },
- cancel_time => undef,
- fulfillment_time => undef
- },
- { limit => 1 }
- ]
- );
-
- if( $holds and $$holds[0] ) {
- return undef if $$holds[0]->usr == $patron->id;
- }
-
- $logger->info("circulator: this copy is needed by a different patron to fulfill a hold");
-
- $self->push_events(OpenILS::Event->new('ITEM_ON_HOLDS_SHELF'));
-}
-
-
-sub do_copy_checks {
- my $self = shift;
- my $copy = $self->copy;
- return unless $copy;
-
- my $stat = $U->copy_status($copy->status)->id;
-
- # We cannot check out a copy if it is in-transit
- if( $stat == OILS_COPY_STATUS_IN_TRANSIT ) {
- return $self->bail_on_events(OpenILS::Event->new('COPY_IN_TRANSIT'));
- }
-
- $self->handle_claims_returned();
- return if $self->bail_out;
-
- # no claims returned circ was found, check if there is any open circ
- unless( $self->is_renewal ) {
-
- my $circs = $self->editor->search_action_circulation(
- { target_copy => $copy->id, checkin_time => undef }
- );
-
- if(my $old_circ = $circs->[0]) { # an open circ was found
-
- my $payload = {copy => $copy};
-
- if($old_circ->usr == $self->patron->id) {
-
- $payload->{old_circ} = $old_circ;
-
- # If there is an open circulation on the checkout item and an auto-renew
- # interval is defined, inform the caller that they should go
- # ahead and renew the item instead of warning about open circulations.
-
- my $auto_renew_intvl = $U->ou_ancestor_setting_value(
- $self->circ_lib,
- 'circ.checkout_auto_renew_age',
- $self->editor
- );
-
- if($auto_renew_intvl) {
- my $intvl_seconds = OpenSRF::Utils->interval_to_seconds($auto_renew_intvl);
- my $checkout_time = DateTime::Format::ISO8601->new->parse_datetime( cleanse_ISO8601($old_circ->xact_start) );
-
- if(DateTime->now > $checkout_time->add(seconds => $intvl_seconds)) {
- $payload->{auto_renew} = 1;
- }
- }
- }
-
- return $self->bail_on_events(
- OpenILS::Event->new('OPEN_CIRCULATION_EXISTS', payload => $payload)
- );
- }
- }
-}
-
-my $LEGACY_CIRC_EVENT_MAP = {
- 'no_item' => 'ITEM_NOT_CATALOGED',
- 'actor.usr.barred' => 'PATRON_BARRED',
- 'asset.copy.circulate' => 'COPY_CIRC_NOT_ALLOWED',
- 'asset.copy.status' => 'COPY_NOT_AVAILABLE',
- 'asset.copy_location.circulate' => 'COPY_CIRC_NOT_ALLOWED',
- 'config.circ_matrix_test.circulate' => 'COPY_CIRC_NOT_ALLOWED',
- 'config.circ_matrix_test.max_items_out' => 'PATRON_EXCEEDS_CHECKOUT_COUNT',
- 'config.circ_matrix_test.max_overdue' => 'PATRON_EXCEEDS_OVERDUE_COUNT',
- 'config.circ_matrix_test.max_fines' => 'PATRON_EXCEEDS_FINES',
- 'config.circ_matrix_circ_mod_test' => 'PATRON_EXCEEDS_CHECKOUT_COUNT',
-};
-
-
-# ---------------------------------------------------------------------
-# This pushes any patron-related events into the list but does not
-# set bail_out for any events
-# ---------------------------------------------------------------------
-sub run_patron_permit_scripts {
- my $self = shift;
- my $runner = $self->script_runner;
- my $patronid = $self->patron->id;
-
- my @allevents;
-
- if(!$self->legacy_script_support) {
-
- my $results = $self->run_indb_circ_test;
- unless($self->circ_test_success) {
- # no_item result is OK during noncat checkout
- unless(@$results == 1 && $results->[0]->{fail_part} eq 'no_item' and $self->is_noncat) {
- push @allevents, $self->matrix_test_result_events;
- }
- }
-
- } else {
-
- # ---------------------------------------------------------------------
- # # Now run the patron permit script
- # ---------------------------------------------------------------------
- $runner->load($self->circ_permit_patron);
- my $result = $runner->run or
- throw OpenSRF::EX::ERROR ("Circ Permit Patron Script Died: $@");
-
- my $patron_events = $result->{events};
-
- OpenILS::Utils::Penalty->calculate_penalties($self->editor, $self->patron->id, $self->circ_lib);
- my $mask = ($self->is_renewal) ? 'RENEW' : 'CIRC';
- my $penalties = OpenILS::Utils::Penalty->retrieve_penalties($self->editor, $patronid, $self->circ_lib, $mask);
- $penalties = $penalties->{fatal_penalties};
-
- for my $pen (@$penalties) {
- my $event = OpenILS::Event->new($pen->name);
- $event->{desc} = $pen->label;
- push(@allevents, $event);
- }
-
- push(@allevents, OpenILS::Event->new($_)) for (@$patron_events);
- }
-
- for (@allevents) {
- $_->{payload} = $self->copy if
- ($_->{textcode} eq 'COPY_NOT_AVAILABLE');
- }
-
- $logger->info("circulator: permit_patron script returned events: @allevents") if @allevents;
-
- $self->push_events(@allevents);
-}
-
-sub matrix_test_result_codes {
- my $self = shift;
- map { $_->{"fail_part"} } @{$self->matrix_test_result};
-}
-
-sub matrix_test_result_events {
- my $self = shift;
- map {
- my $event = new OpenILS::Event(
- $LEGACY_CIRC_EVENT_MAP->{$_->{"fail_part"}} || $_->{"fail_part"}
- );
- $event->{"payload"} = {"fail_part" => $_->{"fail_part"}};
- $event;
- } (@{$self->matrix_test_result});
-}
-
-sub run_indb_circ_test {
- my $self = shift;
- return $self->matrix_test_result if $self->matrix_test_result;
-
- my $dbfunc = ($self->is_renewal) ?
- 'action.item_user_renew_test' : 'action.item_user_circ_test';
-
- if( $self->is_precat && $self->request_precat) {
- $self->make_precat_copy;
- return if $self->bail_out;
- }
-
- my $results = $self->editor->json_query(
- { from => [
- $dbfunc,
- $self->circ_lib,
- ($self->is_noncat or ($self->is_precat and !$self->override and !$self->is_renewal)) ? undef : $self->copy->id,
- $self->patron->id,
- ]
- }
- );
-
- $self->circ_test_success($U->is_true($results->[0]->{success}));
-
- if(my $mp = $results->[0]->{matchpoint}) {
- $logger->info("circulator: circ policy test found matchpoint $mp");
- $self->circ_matrix_matchpoint(
- $self->editor->retrieve_config_circ_matrix_matchpoint([
- $mp,
- { flesh => 1,
- flesh_fields => {ccmm =>
- ['duration_rule', 'recurring_fine_rule', 'max_fine_rule', 'hard_due_date']}
- }
- ])
- );
- }
-
- return $self->matrix_test_result($results);
-}
-
-# ---------------------------------------------------------------------
-# given a use and copy, this will calculate the circulation policy
-# parameters. Only works with in-db circ.
-# ---------------------------------------------------------------------
-sub do_inspect {
- my $self = shift;
-
- return OpenILS::Event->new('ASSET_COPY_NOT_FOUND') unless $self->copy;
-
- $self->run_indb_circ_test;
-
- my $results = {
- circ_test_success => $self->circ_test_success,
- failure_events => [],
- failure_codes => [],
- matchpoint => $self->circ_matrix_matchpoint
- };
-
- unless($self->circ_test_success) {
- $results->{"failure_codes"} = [ $self->matrix_test_result_codes ];
- $results->{"failure_events"} = [ $self->matrix_test_result_events ];
- }
-
- if($self->circ_matrix_matchpoint) {
- my $duration_rule = $self->circ_matrix_matchpoint->duration_rule;
- my $recurring_fine_rule = $self->circ_matrix_matchpoint->recurring_fine_rule;
- my $max_fine_rule = $self->circ_matrix_matchpoint->max_fine_rule;
- my $hard_due_date = $self->circ_matrix_matchpoint->hard_due_date;
-
- my $policy = $self->get_circ_policy(
- $duration_rule, $recurring_fine_rule, $max_fine_rule, $hard_due_date);
-
- $$results{$_} = $$policy{$_} for keys %$policy;
- }
-
- return $results;
-}
-
-# ---------------------------------------------------------------------
-# Loads the circ policy info for duration, recurring fine, and max
-# fine based on the current copy
-# ---------------------------------------------------------------------
-sub get_circ_policy {
- my($self, $duration_rule, $recurring_fine_rule, $max_fine_rule, $hard_due_date) = @_;
-
- my $policy = {
- duration_rule => $duration_rule->name,
- recurring_fine_rule => $recurring_fine_rule->name,
- max_fine_rule => $max_fine_rule->name,
- max_fine => $self->get_max_fine_amount($max_fine_rule),
- fine_interval => $recurring_fine_rule->recurrence_interval,
- renewal_remaining => $duration_rule->max_renewals
- };
-
- if($hard_due_date) {
- $policy->{duration_date_ceiling} = $hard_due_date->ceiling_date;
- $policy->{duration_date_ceiling_force} = $hard_due_date->forceto;
- }
- else {
- $policy->{duration_date_ceiling} = undef;
- $policy->{duration_date_ceiling_force} = undef;
- }
-
- $policy->{duration} = $duration_rule->shrt
- if $self->copy->loan_duration == OILS_CIRC_DURATION_SHORT;
- $policy->{duration} = $duration_rule->normal
- if $self->copy->loan_duration == OILS_CIRC_DURATION_NORMAL;
- $policy->{duration} = $duration_rule->extended
- if $self->copy->loan_duration == OILS_CIRC_DURATION_EXTENDED;
-
- $policy->{recurring_fine} = $recurring_fine_rule->low
- if $self->copy->fine_level == OILS_REC_FINE_LEVEL_LOW;
- $policy->{recurring_fine} = $recurring_fine_rule->normal
- if $self->copy->fine_level == OILS_REC_FINE_LEVEL_NORMAL;
- $policy->{recurring_fine} = $recurring_fine_rule->high
- if $self->copy->fine_level == OILS_REC_FINE_LEVEL_HIGH;
-
- return $policy;
-}
-
-sub get_max_fine_amount {
- my $self = shift;
- my $max_fine_rule = shift;
- my $max_amount = $max_fine_rule->amount;
-
- # if is_percent is true then the max->amount is
- # use as a percentage of the copy price
- if ($U->is_true($max_fine_rule->is_percent)) {
- my $price = $U->get_copy_price($self->editor, $self->copy, $self->volume);
- $max_amount = $price * $max_fine_rule->amount / 100;
- } elsif (
- $U->ou_ancestor_setting_value(
- $self->circ_lib,
- 'circ.max_fine.cap_at_price',
- $self->editor
- )
- ) {
- my $price = $U->get_copy_price($self->editor, $self->copy, $self->volume);
- $max_amount = ( $price && $max_amount > $price ) ? $price : $max_amount;
- }
-
- return $max_amount;
-}
-
-
-
-sub run_copy_permit_scripts {
- my $self = shift;
- my $copy = $self->copy || return;
- my $runner = $self->script_runner;
-
- my @allevents;
-
- if(!$self->legacy_script_support) {
- my $results = $self->run_indb_circ_test;
- push @allevents, $self->matrix_test_result_events
- unless $self->circ_test_success;
- } else {
-
- # ---------------------------------------------------------------------
- # Capture all of the copy permit events
- # ---------------------------------------------------------------------
- $runner->load($self->circ_permit_copy);
- my $result = $runner->run or
- throw OpenSRF::EX::ERROR ("Circ Permit Copy Script Died: $@");
- my $copy_events = $result->{events};
-
- # ---------------------------------------------------------------------
- # Now collect all of the events together
- # ---------------------------------------------------------------------
- push( @allevents, OpenILS::Event->new($_)) for @$copy_events;
- }
-
- # See if this copy has an alert message
- my $ae = $self->check_copy_alert();
- push( @allevents, $ae ) if $ae;
-
- # uniquify the events
- my %hash = map { ($_->{ilsevent} => $_) } @allevents;
- @allevents = values %hash;
-
- $logger->info("circulator: permit_copy script returned events: @allevents") if @allevents;
-
- $self->push_events(@allevents);
-}
-
-
-sub check_copy_alert {
- my $self = shift;
- return undef if $self->is_renewal;
- return OpenILS::Event->new(
- 'COPY_ALERT_MESSAGE', payload => $self->copy->alert_message)
- if $self->copy and $self->copy->alert_message;
- return undef;
-}
-
-
-
-# --------------------------------------------------------------------------
-# If the call is overriding and has permissions to override every collected
-# event, the are cleared. Any event that the caller does not have
-# permission to override, will be left in the event list and bail_out will
-# be set
-# XXX We need code in here to cancel any holds/transits on copies
-# that are being force-checked out
-# --------------------------------------------------------------------------
-sub override_events {
- my $self = shift;
- my @events = @{$self->events};
- return unless @events;
-
- if(!$self->override) {
- return $self->bail_out(1)
- if( @events > 1 or $events[0]->{textcode} ne 'SUCCESS' );
- }
-
- $self->events([]);
-
- for my $e (@events) {
- my $tc = $e->{textcode};
- next if $tc eq 'SUCCESS';
- my $ov = "$tc.override";
- $logger->info("circulator: attempting to override event: $ov");
-
- return $self->bail_on_events($self->editor->event)
- unless( $self->editor->allowed($ov) );
- }
-}
-
-
-# --------------------------------------------------------------------------
-# If there is an open claimsreturn circ on the requested copy, close the
-# circ if overriding, otherwise bail out
-# --------------------------------------------------------------------------
-sub handle_claims_returned {
- my $self = shift;
- my $copy = $self->copy;
-
- my $CR = $self->editor->search_action_circulation(
- {
- target_copy => $copy->id,
- stop_fines => OILS_STOP_FINES_CLAIMSRETURNED,
- checkin_time => undef,
- }
- );
-
- return unless ($CR = $CR->[0]);
-
- my $evt;
-
- # - If the caller has set the override flag, we will check the item in
- if($self->override) {
-
- $CR->checkin_time('now');
- $CR->checkin_scan_time('now');
- $CR->checkin_lib($self->circ_lib);
- $CR->checkin_workstation($self->editor->requestor->wsid);
- $CR->checkin_staff($self->editor->requestor->id);
-
- $evt = $self->editor->event
- unless $self->editor->update_action_circulation($CR);
-
- } else {
- $evt = OpenILS::Event->new('CIRC_CLAIMS_RETURNED');
- }
-
- $self->bail_on_events($evt) if $evt;
- return;
-}
-
-
-# --------------------------------------------------------------------------
-# This performs the checkout
-# --------------------------------------------------------------------------
-sub do_checkout {
- my $self = shift;
-
- $self->log_me("do_checkout()");
-
- # make sure perms are good if this isn't a renewal
- unless( $self->is_renewal ) {
- return $self->bail_on_events($self->editor->event)
- unless( $self->editor->allowed('COPY_CHECKOUT') );
- }
-
- # verify the permit key
- unless( $self->check_permit_key ) {
- if( $self->permit_override ) {
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->allowed('CIRC_PERMIT_OVERRIDE');
- } else {
- return $self->bail_on_events(OpenILS::Event->new('CIRC_PERMIT_BAD_KEY'))
- }
- }
-
- # if this is a non-cataloged circ, build the circ and finish
- if( $self->is_noncat ) {
- $self->checkout_noncat;
- $self->push_events(
- OpenILS::Event->new('SUCCESS',
- payload => { noncat_circ => $self->circ }));
- return;
- }
-
- if( $self->is_precat ) {
- $self->make_precat_copy;
- return if $self->bail_out;
-
- } elsif( $self->copy->call_number == OILS_PRECAT_CALL_NUMBER ) {
- return $self->bail_on_events(OpenILS::Event->new('ITEM_NOT_CATALOGED'));
- }
-
- $self->do_copy_checks;
- return if $self->bail_out;
-
- $self->run_checkout_scripts();
- return if $self->bail_out;
-
- $self->build_checkout_circ_object();
- return if $self->bail_out;
-
- my $modify_to_start = $self->booking_adjusted_due_date();
- return if $self->bail_out;
-
- $self->apply_modified_due_date($modify_to_start);
- return if $self->bail_out;
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->create_action_circulation($self->circ);
-
- # refresh the circ to force local time zone for now
- $self->circ($self->editor->retrieve_action_circulation($self->circ->id));
-
- $self->copy->status(OILS_COPY_STATUS_CHECKED_OUT);
- $self->update_copy;
- return if $self->bail_out;
-
- $self->apply_deposit_fee();
- return if $self->bail_out;
-
- $self->handle_checkout_holds();
- return if $self->bail_out;
-
- # ------------------------------------------------------------------------------
- # Update the patron penalty info in the DB. Run it for permit-overrides
- # since the penalties are not updated during the permit phase
- # ------------------------------------------------------------------------------
- OpenILS::Utils::Penalty->calculate_penalties($self->editor, $self->patron->id, $self->circ_lib);
-
- my $record = $U->record_to_mvr($self->title) unless $self->is_precat;
-
- my $pcirc;
- if($self->is_renewal) {
- # flesh the billing summary for the checked-in circ
- $pcirc = $self->editor->retrieve_action_circulation([
- $self->parent_circ,
- {flesh => 2, flesh_fields => {circ => ['billable_transaction'], mbt => ['summary']}}
- ]);
- }
-
- $self->push_events(
- OpenILS::Event->new('SUCCESS',
- payload => {
- copy => $U->unflesh_copy($self->copy),
- circ => $self->circ,
- record => $record,
- holds_fulfilled => $self->fulfilled_holds,
- deposit_billing => $self->deposit_billing,
- rental_billing => $self->rental_billing,
- parent_circ => $pcirc,
- patron => ($self->return_patron) ? $self->patron : undef,
- patron_money => $self->editor->retrieve_money_user_summary($self->patron->id)
- }
- )
- );
-}
-
-sub apply_deposit_fee {
- my $self = shift;
- my $copy = $self->copy;
- return unless
- ($self->is_deposit and not $self->is_deposit_exempt) or
- ($self->is_rental and not $self->is_rental_exempt);
-
- return if $self->is_deposit and $self->skip_deposit_fee;
- return if $self->is_rental and $self->skip_rental_fee;
-
- my $bill = Fieldmapper::money::billing->new;
- my $amount = $copy->deposit_amount;
- my $billing_type;
- my $btype;
-
- if($self->is_deposit) {
- $billing_type = OILS_BILLING_TYPE_DEPOSIT;
- $btype = 5;
- $self->deposit_billing($bill);
- } else {
- $billing_type = OILS_BILLING_TYPE_RENTAL;
- $btype = 6;
- $self->rental_billing($bill);
- }
-
- $bill->xact($self->circ->id);
- $bill->amount($amount);
- $bill->note(OILS_BILLING_NOTE_SYSTEM);
- $bill->billing_type($billing_type);
- $bill->btype($btype);
- $self->editor->create_money_billing($bill) or $self->bail_on_events($self->editor->event);
-
- $logger->info("circulator: charged $amount on checkout with billing type $billing_type");
-}
-
-sub update_copy {
- my $self = shift;
- my $copy = $self->copy;
-
- my $stat = $copy->status if ref $copy->status;
- my $loc = $copy->location if ref $copy->location;
- my $circ_lib = $copy->circ_lib if ref $copy->circ_lib;
-
- $copy->status($stat->id) if $stat;
- $copy->location($loc->id) if $loc;
- $copy->circ_lib($circ_lib->id) if $circ_lib;
- $copy->editor($self->editor->requestor->id);
- $copy->edit_date('now');
- $copy->age_protect($copy->age_protect->id) if ref $copy->age_protect;
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->update_asset_copy($self->copy);
-
- $copy->status($U->copy_status($copy->status));
- $copy->location($loc) if $loc;
- $copy->circ_lib($circ_lib) if $circ_lib;
-}
-
-sub update_reservation {
- my $self = shift;
- my $reservation = $self->reservation;
-
- my $usr = $reservation->usr;
- my $target_rt = $reservation->target_resource_type;
- my $target_r = $reservation->target_resource;
- my $current_r = $reservation->current_resource;
-
- $reservation->usr($usr->id) if ref $usr;
- $reservation->target_resource_type($target_rt->id) if ref $target_rt;
- $reservation->target_resource($target_r->id) if ref $target_r;
- $reservation->current_resource($current_r->id) if ref $current_r;
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->update_booking_reservation($self->reservation);
-
- my $evt;
- ($reservation, $evt) = $U->fetch_booking_reservation($reservation->id);
- $self->reservation($reservation);
-}
-
-
-sub bail_on_events {
- my( $self, @evts ) = @_;
- $self->push_events(@evts);
- $self->bail_out(1);
-}
-
-
-# ------------------------------------------------------------------------------
-# When an item is checked out, see if we can fulfill a hold for this patron
-# ------------------------------------------------------------------------------
-sub handle_checkout_holds {
- my $self = shift;
- my $copy = $self->copy;
- my $patron = $self->patron;
-
- my $e = $self->editor;
- $self->fulfilled_holds([]);
-
- # pre/non-cats can't fulfill a hold
- return if $self->is_precat or $self->is_noncat;
-
- my $hold = $e->search_action_hold_request({
- current_copy => $copy->id ,
- cancel_time => undef,
- fulfillment_time => undef,
- '-or' => [
- {expire_time => undef},
- {expire_time => {'>' => 'now'}}
- ]
- })->[0];
-
- if($hold and $hold->usr != $patron->id) {
- # reset the hold since the copy is now checked out
-
- $logger->info("circulator: un-targeting hold ".$hold->id.
- " because copy ".$copy->id." is getting checked out");
-
- $hold->clear_prev_check_time;
- $hold->clear_current_copy;
- $hold->clear_capture_time;
-
- return $self->bail_on_event($e->event)
- unless $e->update_action_hold_request($hold);
-
- $hold = undef;
- }
-
- unless($hold) {
- $hold = $self->find_related_user_hold($copy, $patron) or return;
- $logger->info("circulator: found related hold to fulfill in checkout");
- }
-
- $logger->debug("circulator: checkout fulfilling hold " . $hold->id);
-
- # if the hold was never officially captured, capture it.
- $hold->current_copy($copy->id);
- $hold->capture_time('now') unless $hold->capture_time;
- $hold->fulfillment_time('now');
- $hold->fulfillment_staff($e->requestor->id);
- $hold->fulfillment_lib($self->circ_lib);
-
- return $self->bail_on_events($e->event)
- unless $e->update_action_hold_request($hold);
-
- $holdcode->delete_hold_copy_maps($e, $hold->id);
- return $self->fulfilled_holds([$hold->id]);
-}
-
-
-# ------------------------------------------------------------------------------
-# If the circ.checkout_fill_related_hold setting is turned on and no hold for
-# the patron directly targets the checked out item, see if there is another hold
-# (with hold_type T or V) for the patron that could be fulfilled by the checked
-# out item. Fulfill the oldest hold and only fulfill 1 of them.
-# ------------------------------------------------------------------------------
-sub find_related_user_hold {
- my($self, $copy, $patron) = @_;
- my $e = $self->editor;
-
- return undef if $self->volume->id == OILS_PRECAT_CALL_NUMBER;
-
- return undef unless $U->ou_ancestor_setting_value(
- $self->circ_lib, 'circ.checkout_fills_related_hold', $e);
-
- # find the oldest unfulfilled hold that has not yet hit the holds shelf.
- my $args = {
- select => {ahr => ['id']},
- from => {
- ahr => {
- acp => {
- field => 'id',
- fkey => 'current_copy',
- type => 'left' # there may be no current_copy
- }
- }
- },
- where => {
- '+ahr' => {
- usr => $patron->id,
- fulfillment_time => undef,
- cancel_time => undef,
- '-or' => [
- {expire_time => undef},
- {expire_time => {'>' => 'now'}}
- ]
- },
- '-or' => [
- {
- '+ahr' => {
- hold_type => 'V',
- target => $self->volume->id
- }
- },
- {
- '+ahr' => {
- hold_type => 'T',
- target => $self->title->id
- }
- },
- ],
- '+acp' => {
- '-or' => [
- {id => undef}, # left-join copy may be nonexistent
- {status => {'!=' => OILS_COPY_STATUS_ON_HOLDS_SHELF}},
- ]
- }
- },
- order_by => {ahr => {request_time => {direction => 'asc'}}},
- limit => 1
- };
-
- my $hold_info = $e->json_query($args)->[0];
- return $e->retrieve_action_hold_request($hold_info->{id}) if $hold_info;
- return undef;
-}
-
-
-sub run_checkout_scripts {
- my $self = shift;
- my $nobail = shift;
-
- my $evt;
- my $runner = $self->script_runner;
-
- my $duration;
- my $recurring;
- my $max_fine;
- my $hard_due_date;
- my $duration_name;
- my $recurring_name;
- my $max_fine_name;
- my $hard_due_date_name;
-
- if(!$self->legacy_script_support) {
- $self->run_indb_circ_test();
- $duration = $self->circ_matrix_matchpoint->duration_rule;
- $recurring = $self->circ_matrix_matchpoint->recurring_fine_rule;
- $max_fine = $self->circ_matrix_matchpoint->max_fine_rule;
- $hard_due_date = $self->circ_matrix_matchpoint->hard_due_date;
-
- } else {
-
- $runner->load($self->circ_duration);
-
- my $result = $runner->run or
- throw OpenSRF::EX::ERROR ("Circ Duration Script Died: $@");
-
- $duration_name = $result->{durationRule};
- $recurring_name = $result->{recurringFinesRule};
- $max_fine_name = $result->{maxFine};
- $hard_due_date_name = $result->{hardDueDate};
- }
-
- $duration_name = $duration->name if $duration;
- if( $duration_name ne OILS_UNLIMITED_CIRC_DURATION ) {
-
- unless($duration) {
- ($duration, $evt) = $U->fetch_circ_duration_by_name($duration_name);
- return $self->bail_on_events($evt) if ($evt && !$nobail);
-
- ($recurring, $evt) = $U->fetch_recurring_fine_by_name($recurring_name);
- return $self->bail_on_events($evt) if ($evt && !$nobail);
-
- ($max_fine, $evt) = $U->fetch_max_fine_by_name($max_fine_name);
- return $self->bail_on_events($evt) if ($evt && !$nobail);
-
- if($hard_due_date_name) {
- ($hard_due_date, $evt) = $U->fetch_hard_due_date_by_name($hard_due_date_name);
- return $self->bail_on_events($evt) if ($evt && !$nobail);
- }
- }
-
- } else {
-
- # The item circulates with an unlimited duration
- $duration = undef;
- $recurring = undef;
- $max_fine = undef;
- $hard_due_date = undef;
- }
-
- $self->duration_rule($duration);
- $self->recurring_fines_rule($recurring);
- $self->max_fine_rule($max_fine);
- $self->hard_due_date($hard_due_date);
-}
-
-
-sub build_checkout_circ_object {
- my $self = shift;
-
- my $circ = Fieldmapper::action::circulation->new;
- my $duration = $self->duration_rule;
- my $max = $self->max_fine_rule;
- my $recurring = $self->recurring_fines_rule;
- my $hard_due_date = $self->hard_due_date;
- my $copy = $self->copy;
- my $patron = $self->patron;
- my $duration_date_ceiling;
- my $duration_date_ceiling_force;
-
- if( $duration ) {
-
- my $policy = $self->get_circ_policy($duration, $recurring, $max, $hard_due_date);
- $duration_date_ceiling = $policy->{duration_date_ceiling};
- $duration_date_ceiling_force = $policy->{duration_date_ceiling_force};
-
- my $dname = $duration->name;
- my $mname = $max->name;
- my $rname = $recurring->name;
- my $hdname = '';
- if($hard_due_date) {
- $hdname = $hard_due_date->name;
- }
-
- $logger->debug("circulator: building circulation ".
- "with duration=$dname, maxfine=$mname, recurring=$rname, hard due date=$hdname");
-
- $circ->duration($policy->{duration});
- $circ->recurring_fine($policy->{recurring_fine});
- $circ->duration_rule($duration->name);
- $circ->recurring_fine_rule($recurring->name);
- $circ->max_fine_rule($max->name);
- $circ->max_fine($policy->{max_fine});
- $circ->fine_interval($recurring->recurrence_interval);
- $circ->renewal_remaining($duration->max_renewals);
-
- } else {
-
- $logger->info("circulator: copy found with an unlimited circ duration");
- $circ->duration_rule(OILS_UNLIMITED_CIRC_DURATION);
- $circ->recurring_fine_rule(OILS_UNLIMITED_CIRC_DURATION);
- $circ->max_fine_rule(OILS_UNLIMITED_CIRC_DURATION);
- $circ->renewal_remaining(0);
- }
-
- $circ->target_copy( $copy->id );
- $circ->usr( $patron->id );
- $circ->circ_lib( $self->circ_lib );
- $circ->workstation($self->editor->requestor->wsid)
- if defined $self->editor->requestor->wsid;
-
- # renewals maintain a link to the parent circulation
- $circ->parent_circ($self->parent_circ);
-
- if( $self->is_renewal ) {
- $circ->opac_renewal('t') if $self->opac_renewal;
- $circ->phone_renewal('t') if $self->phone_renewal;
- $circ->desk_renewal('t') if $self->desk_renewal;
- $circ->renewal_remaining($self->renewal_remaining);
- $circ->circ_staff($self->editor->requestor->id);
- }
-
-
- # if the user provided an overiding checkout time,
- # (e.g. the checkout really happened several hours ago), then
- # we apply that here. Does this need a perm??
- $circ->xact_start(cleanse_ISO8601($self->checkout_time))
- if $self->checkout_time;
-
- # if a patron is renewing, 'requestor' will be the patron
- $circ->circ_staff($self->editor->requestor->id);
- $circ->due_date( $self->create_due_date($circ->duration, $duration_date_ceiling, $duration_date_ceiling_force) ) if $circ->duration;
-
- $self->circ($circ);
-}
-
-sub do_reservation_pickup {
- my $self = shift;
-
- $self->log_me("do_reservation_pickup()");
-
- $self->reservation->pickup_time('now');
-
- if (
- $self->reservation->current_resource &&
- $U->is_true($self->reservation->target_resource_type->catalog_item)
- ) {
- # We used to try to set $self->copy and $self->patron here,
- # but that should already be done.
-
- $self->run_checkout_scripts(1);
-
- my $duration = $self->duration_rule;
- my $max = $self->max_fine_rule;
- my $recurring = $self->recurring_fines_rule;
-
- if ($duration && $max && $recurring) {
- my $policy = $self->get_circ_policy($duration, $recurring, $max);
-
- my $dname = $duration->name;
- my $mname = $max->name;
- my $rname = $recurring->name;
-
- $logger->debug("circulator: updating reservation ".
- "with duration=$dname, maxfine=$mname, recurring=$rname");
-
- $self->reservation->fine_amount($policy->{recurring_fine});
- $self->reservation->max_fine($policy->{max_fine});
- $self->reservation->fine_interval($recurring->recurrence_interval);
- }
-
- $self->copy->status(OILS_COPY_STATUS_CHECKED_OUT);
- $self->update_copy();
-
- } else {
- $self->reservation->fine_amount(
- $self->reservation->target_resource_type->fine_amount
- );
- $self->reservation->max_fine(
- $self->reservation->target_resource_type->max_fine
- );
- $self->reservation->fine_interval(
- $self->reservation->target_resource_type->fine_interval
- );
- }
-
- $self->update_reservation();
-}
-
-sub do_reservation_return {
- my $self = shift;
- my $request = shift;
-
- $self->log_me("do_reservation_return()");
-
- if (not ref $self->reservation) {
- my ($reservation, $evt) =
- $U->fetch_booking_reservation($self->reservation);
- return $self->bail_on_events($evt) if $evt;
- $self->reservation($reservation);
- }
-
- $self->generate_fines(1);
- $self->reservation->return_time('now');
- $self->update_reservation();
- $self->reshelve_copy if $self->copy;
-
- if ( $self->reservation->current_resource && $self->reservation->current_resource->catalog_item ) {
- $self->copy( $self->reservation->current_resource->catalog_item );
- }
-}
-
-sub booking_adjusted_due_date {
- my $self = shift;
- my $circ = $self->circ;
- my $copy = $self->copy;
-
- return undef unless $self->use_booking;
-
- my $changed;
-
- if( $self->due_date ) {
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->allowed('CIRC_OVERRIDE_DUE_DATE', $self->circ_lib);
-
- $circ->due_date(cleanse_ISO8601($self->due_date));
-
- } else {
-
- return unless $copy and $circ->due_date;
- }
-
- my $booking_items = $self->editor->search_booking_resource( { barcode => $copy->barcode } );
- if (@$booking_items) {
- my $booking_item = $booking_items->[0];
- my $resource_type = $self->editor->retrieve_booking_resource_type( $booking_item->type );
-
- my $stop_circ_setting = $U->ou_ancestor_setting_value( $self->circ_lib, 'circ.booking_reservation.stop_circ', $self->editor );
- my $shorten_circ_setting = $resource_type->elbow_room ||
- $U->ou_ancestor_setting_value( $self->circ_lib, 'circ.booking_reservation.default_elbow_room', $self->editor ) ||
- '0 seconds';
-
- my $booking_ses = OpenSRF::AppSession->create( 'open-ils.booking' );
- my $bookings = $booking_ses->request(
- 'open-ils.booking.reservations.filtered_id_list', $self->editor->authtoken,
- { resource => $booking_item->id, search_start => 'now', search_end => $circ->due_date, fields => { cancel_time => undef }}
- )->gather(1);
- $booking_ses->disconnect;
-
- my $dt_parser = DateTime::Format::ISO8601->new;
- my $due_date = $dt_parser->parse_datetime( cleanse_ISO8601($circ->due_date) );
-
- for my $bid (@$bookings) {
-
- my $booking = $self->editor->retrieve_booking_reservation( $bid );
-
- my $booking_start = $dt_parser->parse_datetime( cleanse_ISO8601($booking->start_time) );
- my $booking_end = $dt_parser->parse_datetime( cleanse_ISO8601($booking->end_time) );
-
- return $self->bail_on_events( OpenILS::Event->new('COPY_RESERVED') )
- if ($booking_start < DateTime->now);
-
-
- if ($U->is_true($stop_circ_setting)) {
- $self->bail_on_events( OpenILS::Event->new('COPY_RESERVED') );
- } else {
- $due_date = $booking_start->subtract( seconds => interval_to_seconds($shorten_circ_setting) );
- $self->bail_on_events( OpenILS::Event->new('COPY_RESERVED') ) if ($due_date < DateTime->now);
- }
-
- # We set the circ duration here only to affect the logic that will
- # later (in a DB trigger) mangle the time part of the due date to
- # 11:59pm. Having any circ duration that is not a whole number of
- # days is enough to prevent the "correction."
- my $new_circ_duration = $due_date->epoch - time;
- $new_circ_duration++ if $new_circ_duration % 86400 == 0;
- $circ->duration("$new_circ_duration seconds");
-
- $circ->due_date(cleanse_ISO8601($due_date->strftime('%FT%T%z')));
- $changed = 1;
- }
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->allowed('CIRC_OVERRIDE_DUE_DATE', $self->circ_lib);
- }
-
- return $changed;
-}
-
-sub apply_modified_due_date {
- my $self = shift;
- my $shift_earlier = shift;
- my $circ = $self->circ;
- my $copy = $self->copy;
-
- if( $self->due_date ) {
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->allowed('CIRC_OVERRIDE_DUE_DATE', $self->circ_lib);
-
- $circ->due_date(cleanse_ISO8601($self->due_date));
-
- } else {
-
- # if the due_date lands on a day when the location is closed
- return unless $copy and $circ->due_date;
-
- #my $org = (ref $copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
-
- # due-date overlap should be determined by the location the item
- # is checked out from, not the owning or circ lib of the item
- my $org = $self->circ_lib;
-
- $logger->info("circulator: circ searching for closed date overlap on lib $org".
- " with an item due date of ".$circ->due_date );
-
- my $dateinfo = $U->storagereq(
- 'open-ils.storage.actor.org_unit.closed_date.overlap',
- $org, $circ->due_date );
-
- if($dateinfo) {
- $logger->info("circulator: $dateinfo : circ due data / close date overlap found : due_date=".
- $circ->due_date." start=". $dateinfo->{start}.", end=".$dateinfo->{end});
-
- # XXX make the behavior more dynamic
- # for now, we just push the due date to after the close date
- if ($shift_earlier) {
- $circ->due_date($dateinfo->{start});
- } else {
- $circ->due_date($dateinfo->{end});
- }
- }
- }
-}
-
-
-
-sub create_due_date {
- my( $self, $duration, $date_ceiling, $force_date ) = @_;
-
- # if there is a raw time component (e.g. from postgres),
- # turn it into an interval that interval_to_seconds can parse
- $duration =~ s/(\d{2}):(\d{2}):(\d{2})/$1 h $2 m $3 s/o;
-
- # for now, use the server timezone. TODO: use workstation org timezone
- my $due_date = DateTime->now(time_zone => 'local');
-
- # add the circ duration
- $due_date->add(seconds => OpenSRF::Utils->interval_to_seconds($duration));
-
- if($date_ceiling) {
- my $cdate = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($date_ceiling));
- if ($cdate > DateTime->now and ($cdate < $due_date or $U->is_true( $force_date ))) {
- $logger->info("circulator: overriding due date with date ceiling: $date_ceiling");
- $due_date = $cdate;
- }
- }
-
- # return ISO8601 time with timezone
- return $due_date->strftime('%FT%T%z');
-}
-
-
-
-sub make_precat_copy {
- my $self = shift;
- my $copy = $self->copy;
-
- if($copy) {
- $logger->debug("circulator: Pre-cat copy already exists in checkout: ID=" . $copy->id);
-
- $copy->editor($self->editor->requestor->id);
- $copy->edit_date('now');
- $copy->dummy_title($self->dummy_title || $copy->dummy_title || '');
- $copy->dummy_isbn($self->dummy_isbn || $copy->dummy_isbn || '');
- $copy->dummy_author($self->dummy_author || $copy->dummy_author || '');
- $copy->circ_modifier($self->circ_modifier || $copy->circ_modifier);
- $self->update_copy();
- return;
- }
-
- $logger->info("circulator: Creating a new precataloged ".
- "copy in checkout with barcode " . $self->copy_barcode);
-
- $copy = Fieldmapper::asset::copy->new;
- $copy->circ_lib($self->circ_lib);
- $copy->creator($self->editor->requestor->id);
- $copy->editor($self->editor->requestor->id);
- $copy->barcode($self->copy_barcode);
- $copy->call_number(OILS_PRECAT_CALL_NUMBER);
- $copy->loan_duration(OILS_PRECAT_COPY_LOAN_DURATION);
- $copy->fine_level(OILS_PRECAT_COPY_FINE_LEVEL);
-
- $copy->dummy_title($self->dummy_title || "");
- $copy->dummy_author($self->dummy_author || "");
- $copy->dummy_isbn($self->dummy_isbn || "");
- $copy->circ_modifier($self->circ_modifier);
-
-
- # See if we need to override the circ_lib for the copy with a configured circ_lib
- # Setting is shortname of the org unit
- my $precat_circ_lib = $U->ou_ancestor_setting_value(
- $self->circ_lib, 'circ.pre_cat_copy_circ_lib', $self->editor);
-
- if($precat_circ_lib) {
- my $org = $self->editor->search_actor_org_unit({shortname => $precat_circ_lib})->[0];
-
- if(!$org) {
- $self->bail_on_events($self->editor->event);
- return;
- }
-
- $copy->circ_lib($org->id);
- }
-
-
- unless( $self->copy($self->editor->create_asset_copy($copy)) ) {
- $self->bail_out(1);
- $self->push_events($self->editor->event);
- return;
- }
-
- # this is a little bit of a hack, but we need to
- # get the copy into the script runner
- $self->script_runner->insert("environment.copy", $copy, 1) if $self->script_runner;
-}
-
-
-sub checkout_noncat {
- my $self = shift;
-
- my $circ;
- my $evt;
-
- my $lib = $self->noncat_circ_lib || $self->circ_lib;
- my $count = $self->noncat_count || 1;
- my $cotime = cleanse_ISO8601($self->checkout_time) || "";
-
- $logger->info("circulator: circ creating $count noncat circs with checkout time $cotime");
-
- for(1..$count) {
-
- ( $circ, $evt ) = OpenILS::Application::Circ::NonCat::create_non_cat_circ(
- $self->editor->requestor->id,
- $self->patron->id,
- $lib,
- $self->noncat_type,
- $cotime,
- $self->editor );
-
- if( $evt ) {
- $self->push_events($evt);
- $self->bail_out(1);
- return;
- }
- $self->circ($circ);
- }
-}
-
-
-sub do_checkin {
- my $self = shift;
- $self->log_me("do_checkin()");
-
- return $self->bail_on_events(
- OpenILS::Event->new('ASSET_COPY_NOT_FOUND'))
- unless $self->copy;
-
- # the renew code and mk_env should have already found our circulation object
- unless( $self->circ ) {
-
- my $circs = $self->editor->search_action_circulation(
- { target_copy => $self->copy->id, checkin_time => undef });
-
- $self->circ($$circs[0]);
-
- # for now, just warn if there are multiple open circs on a copy
- $logger->warn("circulator: we have ".scalar(@$circs).
- " open circs for copy " .$self->copy->id."!!") if @$circs > 1;
- }
-
- # run the fine generator against this circ, if this circ is there
- $self->generate_fines_start if $self->circ;
-
-
- if( $self->checkin_check_holds_shelf() ) {
- $self->bail_on_events(OpenILS::Event->new('NO_CHANGE'));
- $self->hold($U->fetch_open_hold_by_copy($self->copy->id));
- $self->checkin_flesh_events;
- return;
- }
-
- unless( $self->is_renewal ) {
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->allowed('COPY_CHECKIN');
- }
-
- $self->push_events($self->check_copy_alert());
- $self->push_events($self->check_checkin_copy_status());
-
- # if the circ is marked as 'claims returned', add the event to the list
- $self->push_events(OpenILS::Event->new('CIRC_CLAIMS_RETURNED'))
- if ($self->circ and $self->circ->stop_fines
- and $self->circ->stop_fines eq OILS_STOP_FINES_CLAIMSRETURNED);
-
- $self->check_circ_deposit();
-
- # handle the overridable events
- $self->override_events unless $self->is_renewal;
- return if $self->bail_out;
-
- if( $self->copy ) {
- $self->transit(
- $self->editor->search_action_transit_copy(
- { target_copy => $self->copy->id, dest_recv_time => undef }
- )->[0]
- );
- }
-
- if( $self->circ ) {
- $self->checkin_handle_circ;
- return if $self->bail_out;
- $self->checkin_changed(1);
-
- } elsif( $self->transit ) {
- my $hold_transit = $self->process_received_transit;
- $self->checkin_changed(1);
-
- if( $self->bail_out ) {
- $self->checkin_flesh_events;
- return;
- }
-
- if( my $e = $self->check_checkin_copy_status() ) {
- # If the original copy status is special, alert the caller
- my $ev = $self->events;
- $self->events([$e]);
- $self->override_events;
- return if $self->bail_out;
- $self->events($ev);
- }
-
- if( $hold_transit or
- $U->copy_status($self->copy->status)->id
- == OILS_COPY_STATUS_ON_HOLDS_SHELF ) {
-
- my $hold;
- if( $hold_transit ) {
- $hold = $self->editor->retrieve_action_hold_request($hold_transit->hold);
- } else {
- ($hold) = $U->fetch_open_hold_by_copy($self->copy->id);
- }
-
- $self->hold($hold);
-
- if( $hold and $hold->cancel_time ) { # this transited hold was cancelled mid-transit
-
- $logger->info("circulator: we received a transit on a cancelled hold " . $hold->id);
- $self->reshelve_copy(1);
- $self->cancelled_hold_transit(1);
- $self->notify_hold(0); # don't notify for cancelled holds
- return if $self->bail_out;
-
- } else {
-
- # hold transited to correct location
- $self->checkin_flesh_events;
- return;
- }
- }
-
- } elsif( $U->copy_status($self->copy->status)->id == OILS_COPY_STATUS_IN_TRANSIT ) {
-
- $logger->warn("circulator: we have a copy ".$self->copy->barcode.
- " that is in-transit, but there is no transit.. repairing");
- $self->reshelve_copy(1);
- return if $self->bail_out;
- }
-
- if( $self->is_renewal ) {
- $self->push_events(OpenILS::Event->new('SUCCESS'));
- return;
- }
-
- # ------------------------------------------------------------------------------
- # Circulations and transits are now closed where necessary. Now go on to see if
- # this copy can fulfill a hold or needs to be routed to a different location
- # ------------------------------------------------------------------------------
-
- my $needed_for_something = 0; # formerly "needed_for_hold"
-
- if(!$self->noop) { # /not/ a no-op checkin, capture for hold or put item into transit
-
- if (!$self->remote_hold) {
- if ($self->use_booking) {
- my $potential_hold = $self->hold_capture_is_possible;
- my $potential_reservation = $self->reservation_capture_is_possible;
-
- if ($potential_hold and $potential_reservation) {
- $logger->info("circulator: item could fulfill either hold or reservation");
- $self->push_events(new OpenILS::Event(
- "HOLD_RESERVATION_CONFLICT",
- "hold" => $potential_hold,
- "reservation" => $potential_reservation
- ));
- return if $self->bail_out;
- } elsif ($potential_hold) {
- $needed_for_something =
- $self->attempt_checkin_hold_capture;
- } elsif ($potential_reservation) {
- $needed_for_something =
- $self->attempt_checkin_reservation_capture;
- }
- } else {
- $needed_for_something = $self->attempt_checkin_hold_capture;
- }
- }
- return if $self->bail_out;
-
- unless($needed_for_something) {
- my $circ_lib = (ref $self->copy->circ_lib) ?
- $self->copy->circ_lib->id : $self->copy->circ_lib;
-
- if( $self->remote_hold ) {
- $circ_lib = $self->remote_hold->pickup_lib;
- $logger->warn("circulator: Copy ".$self->copy->barcode.
- " is on a remote hold's shelf, sending to $circ_lib");
- }
-
- $logger->debug("circulator: circlib=$circ_lib, workstation=".$self->circ_lib);
-
- if( $circ_lib == $self->circ_lib) {
- # copy is where it needs to be, either for hold or reshelving
-
- $self->checkin_handle_precat();
- return if $self->bail_out;
-
- } else {
- # copy needs to transit "home", or stick here if it's a floating copy
-
- if ($U->is_true( $self->copy->floating ) && !$self->remote_hold) { # copy is floating, stick here
- $self->checkin_changed(1);
- $self->copy->circ_lib( $self->circ_lib );
- $self->update_copy;
- } else {
- my $bc = $self->copy->barcode;
- $logger->info("circulator: copy $bc at the wrong location, sending to $circ_lib");
- $self->checkin_build_copy_transit($circ_lib);
- return if $self->bail_out;
- $self->push_events(OpenILS::Event->new('ROUTE_ITEM', org => $circ_lib));
- }
- }
- }
- } else { # no-op checkin
- if ($U->is_true( $self->copy->floating )) { # XXX floating items still stick where they are even with no-op checkin?
- $self->checkin_changed(1);
- $self->copy->circ_lib( $self->circ_lib );
- $self->update_copy;
- }
- }
-
- if($self->claims_never_checked_out and
- $U->ou_ancestor_setting_value($self->circ->circ_lib, 'circ.claim_never_checked_out.mark_missing')) {
-
- # the item was not supposed to be checked out to the user and should now be marked as missing
- $self->copy->status(OILS_COPY_STATUS_MISSING);
- $self->update_copy;
-
- } else {
- $self->reshelve_copy unless $needed_for_something;
- }
-
- return if $self->bail_out;
-
- unless($self->checkin_changed) {
-
- $self->push_events(OpenILS::Event->new('NO_CHANGE'));
- my $stat = $U->copy_status($self->copy->status)->id;
-
- $self->hold($U->fetch_open_hold_by_copy($self->copy->id))
- if( $stat == OILS_COPY_STATUS_ON_HOLDS_SHELF );
- $self->bail_out(1); # no need to commit anything
-
- } else {
-
- $self->push_events(OpenILS::Event->new('SUCCESS'))
- unless @{$self->events};
- }
-
- # gather any updates to the circ after fine generation, if there was a circ
- $self->generate_fines_finish if ($self->circ);
-
- OpenILS::Utils::Penalty->calculate_penalties(
- $self->editor, $self->patron->id, $self->circ_lib) if $self->patron;
-
- $self->checkin_flesh_events;
- return;
-}
-
-# if a deposit was payed for this item, push the event
-sub check_circ_deposit {
- my $self = shift;
- return unless $self->circ;
- my $deposit = $self->editor->search_money_billing(
- { btype => 5,
- xact => $self->circ->id,
- voided => 'f'
- }, {idlist => 1})->[0];
-
- $self->push_events(OpenILS::Event->new(
- 'ITEM_DEPOSIT_PAID', payload => $deposit)) if $deposit;
-}
-
-sub reshelve_copy {
- my $self = shift;
- my $force = $self->force || shift;
- my $copy = $self->copy;
-
- my $stat = $U->copy_status($copy->status)->id;
-
- if($force || (
- $stat != OILS_COPY_STATUS_ON_HOLDS_SHELF and
- $stat != OILS_COPY_STATUS_CATALOGING and
- $stat != OILS_COPY_STATUS_IN_TRANSIT and
- $stat != OILS_COPY_STATUS_RESHELVING )) {
-
- $copy->status( OILS_COPY_STATUS_RESHELVING );
- $self->update_copy;
- $self->checkin_changed(1);
- }
-}
-
-
-# Returns true if the item is at the current location
-# because it was transited there for a hold and the
-# hold has not been fulfilled
-sub checkin_check_holds_shelf {
- my $self = shift;
- return 0 unless $self->copy;
-
- return 0 unless
- $U->copy_status($self->copy->status)->id ==
- OILS_COPY_STATUS_ON_HOLDS_SHELF;
-
- # find the hold that put us on the holds shelf
- my $holds = $self->editor->search_action_hold_request(
- {
- current_copy => $self->copy->id,
- capture_time => { '!=' => undef },
- fulfillment_time => undef,
- cancel_time => undef,
- }
- );
-
- unless(@$holds) {
- $logger->warn("circulator: copy is on-holds-shelf, but there is no hold - reshelving");
- $self->reshelve_copy(1);
- return 0;
- }
-
- my $hold = $$holds[0];
-
- $logger->info("circulator: we found a captured, un-fulfilled hold [".
- $hold->id. "] for copy ".$self->copy->barcode);
-
- if( $hold->pickup_lib == $self->circ_lib ) {
- $logger->info("circulator: hold is for here .. we're done: ".$self->copy->barcode);
- return 1;
- }
-
- $logger->info("circulator: hold is not for here..");
- $self->remote_hold($hold);
- return 0;
-}
-
-
-sub checkin_handle_precat {
- my $self = shift;
- my $copy = $self->copy;
-
- if( $self->is_precat and ($copy->status != OILS_COPY_STATUS_CATALOGING) ) {
- $copy->status(OILS_COPY_STATUS_CATALOGING);
- $self->update_copy();
- $self->checkin_changed(1);
- $self->push_events(OpenILS::Event->new('ITEM_NOT_CATALOGED'));
- }
-}
-
-
-sub checkin_build_copy_transit {
- my $self = shift;
- my $dest = shift;
- my $copy = $self->copy;
- my $transit = Fieldmapper::action::transit_copy->new;
-
- #$dest ||= (ref($copy->circ_lib)) ? $copy->circ_lib->id : $copy->circ_lib;
- $logger->info("circulator: transiting copy to $dest");
-
- $transit->source($self->circ_lib);
- $transit->dest($dest);
- $transit->target_copy($copy->id);
- $transit->source_send_time('now');
- $transit->copy_status( $U->copy_status($copy->status)->id );
-
- $logger->debug("circulator: setting copy status on transit: ".$transit->copy_status);
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->create_action_transit_copy($transit);
-
- $copy->status(OILS_COPY_STATUS_IN_TRANSIT);
- $self->update_copy;
- $self->checkin_changed(1);
-}
-
-
-sub hold_capture_is_possible {
- my $self = shift;
- my $copy = $self->copy;
-
- # we've been explicitly told not to capture any holds
- return 0 if $self->capture eq 'nocapture';
-
- # See if this copy can fulfill any holds
- my $hold = $holdcode->find_nearest_permitted_hold(
- $self->editor, $copy, $self->editor->requestor, 1 # check_only
- );
- return undef if ref $hold eq "HASH" and
- $hold->{"textcode"} eq "ACTION_HOLD_REQUEST_NOT_FOUND";
- return $hold;
-}
-
-sub reservation_capture_is_possible {
- my $self = shift;
- my $copy = $self->copy;
-
- # we've been explicitly told not to capture any holds
- return 0 if $self->capture eq 'nocapture';
-
- my $booking_ses = OpenSRF::AppSession->connect("open-ils.booking");
- my $resv = $booking_ses->request(
- "open-ils.booking.reservations.could_capture",
- $self->editor->authtoken, $copy->barcode
- )->gather(1);
- $booking_ses->disconnect;
- if (ref($resv) eq "HASH" and exists $resv->{"textcode"}) {
- $self->push_events($resv);
- } else {
- return $resv;
- }
-}
-
-# returns true if the item was used (or may potentially be used
-# in subsequent calls) to capture a hold.
-sub attempt_checkin_hold_capture {
- my $self = shift;
- my $copy = $self->copy;
-
- # we've been explicitly told not to capture any holds
- return 0 if $self->capture eq 'nocapture';
-
- # See if this copy can fulfill any holds
- my ($hold, undef, $retarget) = $holdcode->find_nearest_permitted_hold(
- $self->editor, $copy, $self->editor->requestor );
-
- if(!$hold) {
- $logger->debug("circulator: no potential permitted".
- "holds found for copy ".$copy->barcode);
- return 0;
- }
-
- if($self->capture ne 'capture') {
- # see if this item is in a hold-capture-delay location
- my $location = $self->editor->retrieve_asset_copy_location($self->copy->location);
- if($U->is_true($location->hold_verify)) {
- $self->bail_on_events(
- OpenILS::Event->new('HOLD_CAPTURE_DELAYED', copy_location => $location));
- return 1;
- }
- }
-
- $self->retarget($retarget);
-
- $logger->info("circulator: found permitted hold ".$hold->id." for copy, capturing...");
-
- $hold->current_copy($copy->id);
- $hold->capture_time('now');
- $self->put_hold_on_shelf($hold)
- if $hold->pickup_lib == $self->circ_lib;
-
- # prevent DB errors caused by fetching
- # holds from storage, and updating through cstore
- $hold->clear_fulfillment_time;
- $hold->clear_fulfillment_staff;
- $hold->clear_fulfillment_lib;
- $hold->clear_expire_time;
- $hold->clear_cancel_time;
- $hold->clear_prev_check_time unless $hold->prev_check_time;
-
- $self->bail_on_events($self->editor->event)
- unless $self->editor->update_action_hold_request($hold);
- $self->hold($hold);
- $self->checkin_changed(1);
-
- return 0 if $self->bail_out;
-
- if( $hold->pickup_lib == $self->circ_lib ) {
-
- # This hold was captured in the correct location
- $copy->status(OILS_COPY_STATUS_ON_HOLDS_SHELF);
- $self->push_events(OpenILS::Event->new('SUCCESS'));
-
- #$self->do_hold_notify($hold->id);
- $self->notify_hold($hold->id);
-
- } else {
-
- # Hold needs to be picked up elsewhere. Build a hold
- # transit and route the item.
- $self->checkin_build_hold_transit();
- $copy->status(OILS_COPY_STATUS_IN_TRANSIT);
- return 0 if $self->bail_out;
- $self->push_events(OpenILS::Event->new('ROUTE_ITEM', org => $hold->pickup_lib));
- }
-
- # make sure we save the copy status
- $self->update_copy;
- return 1;
-}
-
-sub attempt_checkin_reservation_capture {
- my $self = shift;
- my $copy = $self->copy;
-
- # we've been explicitly told not to capture any holds
- return 0 if $self->capture eq 'nocapture';
-
- my $booking_ses = OpenSRF::AppSession->connect("open-ils.booking");
- my $evt = $booking_ses->request(
- "open-ils.booking.resources.capture_for_reservation",
- $self->editor->authtoken,
- $copy->barcode,
- 1 # don't update copy - we probably have it locked
- )->gather(1);
- $booking_ses->disconnect;
-
- if (ref($evt) ne "HASH" or not exists $evt->{"textcode"}) {
- $logger->warn(
- "open-ils.booking.resources.capture_for_reservation " .
- "didn't return an event!"
- );
- } else {
- if (
- $evt->{"textcode"} eq "RESERVATION_NOT_FOUND" and
- $evt->{"payload"}->{"fail_cause"} eq "not-transferable"
- ) {
- # not-transferable is an error event we'll pass on the user
- $logger->warn("reservation capture attempted against non-transferable item");
- $self->push_events($evt);
- return 0;
- } elsif ($evt->{"textcode"} eq "SUCCESS") {
- # Re-retrieve copy as reservation capture may have changed
- # its status and whatnot.
- $logger->info(
- "circulator: booking capture win on copy " . $self->copy->id
- );
- if (my $new_copy_status = $evt->{"payload"}->{"new_copy_status"}) {
- $logger->info(
- "circulator: changing copy " . $self->copy->id .
- "'s status from " . $self->copy->status . " to " .
- $new_copy_status
- );
- $self->copy->status($new_copy_status);
- $self->update_copy;
- }
- $self->reservation($evt->{"payload"}->{"reservation"});
-
- if (exists $evt->{"payload"}->{"transit"}) {
- $self->push_events(
- new OpenILS::Event(
- "ROUTE_ITEM",
- "org" => $evt->{"payload"}->{"transit"}->dest
- )
- );
- }
- $self->checkin_changed(1);
- return 1;
- }
- }
- # other results are treated as "nothing to capture"
- return 0;
-}
-
-sub do_hold_notify {
- my( $self, $holdid ) = @_;
-
- my $e = new_editor(xact => 1);
- my $hold = $e->retrieve_action_hold_request($holdid) or return $e->die_event;
- $e->rollback;
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'hold.available', $hold, $hold->pickup_lib);
-
- $logger->info("circulator: running delayed hold notify process");
-
-# my $notifier = OpenILS::Application::Circ::HoldNotify->new(
-# hold_id => $holdid, editor => new_editor(requestor=>$self->editor->requestor));
-
- my $notifier = OpenILS::Application::Circ::HoldNotify->new(
- hold_id => $holdid, requestor => $self->editor->requestor);
-
- $logger->debug("circulator: built hold notifier");
-
- if(!$notifier->event) {
-
- $logger->info("circulator: attempt at sending hold notification for hold $holdid");
-
- my $stat = $notifier->send_email_notify;
- if( $stat == '1' ) {
- $logger->info("circulator: hold notify succeeded for hold $holdid");
- return;
- }
-
- $logger->debug("circulator: * hold notify cancelled or failed for hold $holdid");
-
- } else {
- $logger->info("circulator: Not sending hold notification since the patron has no email address");
- }
-}
-
-sub retarget_holds {
- my $self = shift;
- $logger->info("circulator: retargeting holds @{$self->retarget} after opportunistic capture");
- my $ses = OpenSRF::AppSession->create('open-ils.storage');
- $ses->request('open-ils.storage.action.hold_request.copy_targeter', undef, $self->retarget);
- # no reason to wait for the return value
- return;
-}
-
-sub checkin_build_hold_transit {
- my $self = shift;
-
- my $copy = $self->copy;
- my $hold = $self->hold;
- my $trans = Fieldmapper::action::hold_transit_copy->new;
-
- $logger->debug("circulator: building hold transit for ".$copy->barcode);
-
- $trans->hold($hold->id);
- $trans->source($self->circ_lib);
- $trans->dest($hold->pickup_lib);
- $trans->source_send_time("now");
- $trans->target_copy($copy->id);
-
- # when the copy gets to its destination, it will recover
- # this status - put it onto the holds shelf
- $trans->copy_status(OILS_COPY_STATUS_ON_HOLDS_SHELF);
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->create_action_hold_transit_copy($trans);
-}
-
-
-
-sub process_received_transit {
- my $self = shift;
- my $copy = $self->copy;
- my $copyid = $self->copy->id;
-
- my $status_name = $U->copy_status($copy->status)->name;
- $logger->debug("circulator: attempting transit receive on ".
- "copy $copyid. Copy status is $status_name");
-
- my $transit = $self->transit;
-
- if( $transit->dest != $self->circ_lib ) {
- # - this item is in-transit to a different location
-
- my $tid = $transit->id;
- my $loc = $self->circ_lib;
- my $dest = $transit->dest;
-
- $logger->info("circulator: Fowarding transit on copy which is destined ".
- "for a different location. transit=$tid, copy=$copyid, current ".
- "location=$loc, destination location=$dest");
-
- my $evt = OpenILS::Event->new('ROUTE_ITEM', org => $dest, payload => {});
-
- # grab the associated hold object if available
- my $ht = $self->editor->retrieve_action_hold_transit_copy($tid);
- $self->hold($self->editor->retrieve_action_hold_request($ht->hold)) if $ht;
-
- return $self->bail_on_events($evt);
- }
-
- # The transit is received, set the receive time
- $transit->dest_recv_time('now');
- $self->bail_on_events($self->editor->event)
- unless $self->editor->update_action_transit_copy($transit);
-
- my $hold_transit = $self->editor->retrieve_action_hold_transit_copy($transit->id);
-
- $logger->info("circulator: Recovering original copy status in transit: ".$transit->copy_status);
- $copy->status( $transit->copy_status );
- $self->update_copy();
- return if $self->bail_out;
-
- my $ishold = 0;
- if($hold_transit) {
- my $hold = $self->editor->retrieve_action_hold_request($hold_transit->hold);
-
- # hold has arrived at destination, set shelf time
- $self->put_hold_on_shelf($hold);
- $self->bail_on_events($self->editor->event)
- unless $self->editor->update_action_hold_request($hold);
- return if $self->bail_out;
-
- $self->notify_hold($hold_transit->hold);
- $ishold = 1;
- }
-
- $self->push_events(
- OpenILS::Event->new(
- 'SUCCESS',
- ishold => $ishold,
- payload => { transit => $transit, holdtransit => $hold_transit } ));
-
- return $hold_transit;
-}
-
-
-# ------------------------------------------------------------------
-# Sets the shelf_time and shelf_expire_time for a newly shelved hold
-# ------------------------------------------------------------------
-sub put_hold_on_shelf {
- my($self, $hold) = @_;
-
- $hold->shelf_time('now');
-
- my $shelf_expire = $U->ou_ancestor_setting_value(
- $self->circ_lib, 'circ.holds.default_shelf_expire_interval', $self->editor);
-
- if($shelf_expire) {
- my $seconds = OpenSRF::Utils->interval_to_seconds($shelf_expire);
- my $expire_time = DateTime->now->add(seconds => $seconds);
- $hold->shelf_expire_time($expire_time->strftime('%FT%T%z'));
- }
-
- return undef;
-}
-
-
-
-sub generate_fines {
- my $self = shift;
- my $reservation = shift;
-
- $self->generate_fines_start($reservation);
- $self->generate_fines_finish($reservation);
-
- return undef;
-}
-
-sub generate_fines_start {
- my $self = shift;
- my $reservation = shift;
-
- my $id = $reservation ? $self->reservation->id : $self->circ->id;
-
- if (!exists($self->{_gen_fines_req})) {
- $self->{_gen_fines_req} = OpenSRF::AppSession->create('open-ils.storage')
- ->request(
- 'open-ils.storage.action.circulation.overdue.generate_fines',
- undef,
- $id
- );
- }
-
- return undef;
-}
-
-sub generate_fines_finish {
- my $self = shift;
- my $reservation = shift;
-
- my $id = $reservation ? $self->reservation->id : $self->circ->id;
-
- $self->{_gen_fines_req}->wait_complete;
- delete($self->{_gen_fines_req});
-
- # refresh the circ in case the fine generator set the stop_fines field
- $self->reservation($self->editor->retrieve_booking_reservation($id)) if $reservation;
- $self->circ($self->editor->retrieve_action_circulation($id)) if !$reservation;
-
- return undef;
-}
-
-sub checkin_handle_circ {
- my $self = shift;
- my $circ = $self->circ;
- my $copy = $self->copy;
- my $evt;
- my $obt;
-
- $self->backdate($circ->xact_start) if $self->claims_never_checked_out;
-
- # backdate the circ if necessary
- if($self->backdate) {
- my $evt = $self->checkin_handle_backdate;
- return $self->bail_on_events($evt) if $evt;
- }
-
- if($self->void_overdues) {
- my $evt = OpenILS::Application::Circ::CircCommon->void_overdues(
- $self->editor, $circ, undef, 'System: Amnesty Checkin'); # TODO i18n for system-generated notes
- return $self->bail_on_events($evt) if $evt;
- }
-
- if(!$circ->stop_fines) {
- $circ->stop_fines(OILS_STOP_FINES_CHECKIN);
- $circ->stop_fines(OILS_STOP_FINES_RENEW) if $self->is_renewal;
- $circ->stop_fines(OILS_STOP_FINES_CLAIMS_NEVERCHECKEDOUT) if $self->claims_never_checked_out;
- $circ->stop_fines_time('now');
- $circ->stop_fines_time($self->backdate) if $self->backdate;
- }
-
- # Set the checkin vars since we have the item
- $circ->checkin_time( ($self->backdate) ? $self->backdate : 'now' );
-
- # capture the true scan time for back-dated checkins
- $circ->checkin_scan_time('now');
-
- $circ->checkin_staff($self->editor->requestor->id);
- $circ->checkin_lib($self->circ_lib);
- $circ->checkin_workstation($self->editor->requestor->wsid);
-
- my $circ_lib = (ref $self->copy->circ_lib) ?
- $self->copy->circ_lib->id : $self->copy->circ_lib;
- my $stat = $U->copy_status($self->copy->status)->id;
-
- # immediately available keeps items lost or missing items from going home before being handled
- my $lost_immediately_available = $U->ou_ancestor_setting_value(
- $circ_lib, OILS_SETTING_LOST_IMMEDIATELY_AVAILABLE, $self->editor) || 0;
-
-
- if ( (!$lost_immediately_available) && ($circ_lib != $self->circ_lib) ) {
-
- if( ($stat == OILS_COPY_STATUS_LOST or $stat == OILS_COPY_STATUS_MISSING) ) {
- $logger->info("circulator: not updating copy status on checkin because copy is lost/missing");
- } else {
- $self->copy->status($U->copy_status(OILS_COPY_STATUS_RESHELVING));
- $self->update_copy;
- }
-
- } elsif ($stat == OILS_COPY_STATUS_LOST) {
-
- $self->checkin_handle_lost($circ_lib);
-
- } else {
-
- $self->copy->status($U->copy_status(OILS_COPY_STATUS_RESHELVING));
- $self->update_copy;
- }
-
-
- # see if there are any fines owed on this circ. if not, close it
- ($obt) = $U->fetch_mbts($circ->id, $self->editor);
- $circ->xact_finish('now') if( $obt and $obt->balance_owed == 0 );
-
- $logger->debug("circulator: ".$obt->balance_owed." is owed on this circulation");
-
- return $self->bail_on_events($self->editor->event)
- unless $self->editor->update_action_circulation($circ);
-
- # make sure the circ isn't closed if we just voided some fines
- $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($self->editor, $circ->id);
- return $self->bail_on_events($evt) if $evt;
-
- return undef;
-}
-
-
-# ------------------------------------------------------------------
-# See if we need to void billings for lost checkin
-# ------------------------------------------------------------------
-sub checkin_handle_lost {
- my $self = shift;
- my $circ_lib = shift;
- my $circ = $self->circ;
-
- my $max_return = $U->ou_ancestor_setting_value(
- $circ_lib, OILS_SETTING_MAX_ACCEPT_RETURN_OF_LOST, $self->editor) || 0;
-
- if ($max_return) {
-
- my $today = time();
- my @tm = reverse($circ->due_date =~ /([\d\.]+)/og);
- $tm[5] -= 1 if $tm[5] > 0;
- my $due = timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]), int($tm[5]), int($tm[6]));
-
- my $last_chance = OpenSRF::Utils->interval_to_seconds($max_return) + int($due);
- $logger->info("MAX OD: ".$max_return." DUEDATE: ".$circ->due_date." TODAY: ".$today." DUE: ".$due." LAST: ".$last_chance);
-
- $max_return = 0 if $today < $last_chance;
- }
-
- if (!$max_return){ # there's either no max time to accept returns defined or we're within that time
-
- my $void_lost = $U->ou_ancestor_setting_value(
- $circ_lib, OILS_SETTING_VOID_LOST_ON_CHECKIN, $self->editor) || 0;
- my $void_lost_fee = $U->ou_ancestor_setting_value(
- $circ_lib, OILS_SETTING_VOID_LOST_PROCESS_FEE_ON_CHECKIN, $self->editor) || 0;
- my $restore_od = $U->ou_ancestor_setting_value(
- $circ_lib, OILS_SETTING_RESTORE_OVERDUE_ON_LOST_RETURN, $self->editor) || 0;
-
- $self->checkin_handle_lost_now_found(3) if $void_lost;
- $self->checkin_handle_lost_now_found(4) if $void_lost_fee;
- $self->checkin_handle_lost_now_found_restore_od() if $restore_od && ! $self->void_overdues;
- }
-
- $self->copy->status($U->copy_status(OILS_COPY_STATUS_RESHELVING));
- $self->update_copy;
-}
-
-
-sub checkin_handle_backdate {
- my $self = shift;
-
- # ------------------------------------------------------------------
- # clean up the backdate for date comparison
- # XXX We are currently taking the due-time from the original due-date,
- # not the input. Do we need to do this? This certainly interferes with
- # backdating of hourly checkouts, but that is likely a very rare case.
- # ------------------------------------------------------------------
- my $bd = cleanse_ISO8601($self->backdate);
- my $original_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($self->circ->due_date));
- my $new_date = DateTime::Format::ISO8601->new->parse_datetime($bd);
- $bd = cleanse_ISO8601($new_date->ymd . 'T' . $original_date->strftime('%T%z'));
-
- $self->backdate($bd);
-
- my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($self->editor, $self->circ, $bd);
- return $evt if $evt;
-
- return undef;
-}
-
-
-sub check_checkin_copy_status {
- my $self = shift;
- my $copy = $self->copy;
-
- my $status = $U->copy_status($copy->status)->id;
-
- return undef
- if( $status == OILS_COPY_STATUS_AVAILABLE ||
- $status == OILS_COPY_STATUS_CHECKED_OUT ||
- $status == OILS_COPY_STATUS_IN_PROCESS ||
- $status == OILS_COPY_STATUS_ON_HOLDS_SHELF ||
- $status == OILS_COPY_STATUS_IN_TRANSIT ||
- $status == OILS_COPY_STATUS_CATALOGING ||
- $status == OILS_COPY_STATUS_ON_RESV_SHELF ||
- $status == OILS_COPY_STATUS_RESHELVING );
-
- return OpenILS::Event->new('COPY_STATUS_LOST', payload => $copy )
- if( $status == OILS_COPY_STATUS_LOST );
-
- return OpenILS::Event->new('COPY_STATUS_MISSING', payload => $copy )
- if( $status == OILS_COPY_STATUS_MISSING );
-
- return OpenILS::Event->new('COPY_BAD_STATUS', payload => $copy );
-}
-
-
-
-# --------------------------------------------------------------------------
-# On checkin, we need to return as many relevant objects as we can
-# --------------------------------------------------------------------------
-sub checkin_flesh_events {
- my $self = shift;
-
- if( grep { $_->{textcode} eq 'SUCCESS' } @{$self->events}
- and grep { $_->{textcode} eq 'ITEM_NOT_CATALOGED' } @{$self->events} ) {
- $self->events([grep { $_->{textcode} eq 'ITEM_NOT_CATALOGED' } @{$self->events}]);
- }
-
- my $record = $U->record_to_mvr($self->title) if($self->title and !$self->is_precat);
-
- my $hold;
- if($self->hold and !$self->hold->cancel_time) {
- $hold = $self->hold;
- $hold->notes($self->editor->search_action_hold_request_note({hold => $hold->id}));
- }
-
- if($self->circ) {
- # if we checked in a circulation, flesh the billing summary data
- $self->circ->billable_transaction(
- $self->editor->retrieve_money_billable_transaction([
- $self->circ->id,
- {flesh => 1, flesh_fields => {mbt => ['summary']}}
- ])
- );
- }
-
- if($self->patron) {
- # flesh some patron fields before returning
- $self->patron(
- $self->editor->retrieve_actor_user([
- $self->patron->id,
- {
- flesh => 1,
- flesh_fields => {
- au => ['card', 'billing_address', 'mailing_address']
- }
- }
- ])
- );
- }
-
- for my $evt (@{$self->events}) {
-
- my $payload = {};
- $payload->{copy} = $U->unflesh_copy($self->copy);
- $payload->{record} = $record,
- $payload->{circ} = $self->circ;
- $payload->{transit} = $self->transit;
- $payload->{cancelled_hold_transit} = 1 if $self->cancelled_hold_transit;
- $payload->{hold} = $hold;
- $payload->{patron} = $self->patron;
- $payload->{reservation} = $self->reservation
- unless (not $self->reservation or $self->reservation->cancel_time);
-
- $evt->{payload} = $payload;
- }
-}
-
-sub log_me {
- my( $self, $msg ) = @_;
- my $bc = ($self->copy) ? $self->copy->barcode :
- $self->barcode;
- $bc ||= "";
- my $usr = ($self->patron) ? $self->patron->id : "";
- $logger->info("circulator: $msg requestor=".$self->editor->requestor->id.
- ", recipient=$usr, copy=$bc");
-}
-
-
-sub do_renew {
- my $self = shift;
- $self->log_me("do_renew()");
-
- # Make sure there is an open circ to renew that is not
- # marked as LOST, CLAIMSRETURNED, or LONGOVERDUE
- my $usrid = $self->patron->id if $self->patron;
- my $circ = $self->editor->search_action_circulation({
- target_copy => $self->copy->id,
- xact_finish => undef,
- ($usrid ? (usr => $usrid) : ()),
- '-or' => [
- {stop_fines => undef},
- {stop_fines => OILS_STOP_FINES_MAX_FINES}
- ]
- })->[0];
-
- return $self->bail_on_events($self->editor->event) unless $circ;
-
- # A user is not allowed to renew another user's items without permission
- unless( $circ->usr eq $self->editor->requestor->id ) {
- return $self->bail_on_events($self->editor->events)
- unless $self->editor->allowed('RENEW_CIRC', $circ->circ_lib);
- }
-
- $self->push_events(OpenILS::Event->new('MAX_RENEWALS_REACHED'))
- if $circ->renewal_remaining < 1;
-
- # -----------------------------------------------------------------
-
- $self->parent_circ($circ->id);
- $self->renewal_remaining( $circ->renewal_remaining - 1 );
- $self->circ($circ);
-
- # Run the fine generator against the old circ
- $self->generate_fines_start;
-
- $self->run_renew_permit;
-
- # Check the item in
- $self->do_checkin();
- return if $self->bail_out;
-
- unless( $self->permit_override ) {
- $self->do_permit();
- return if $self->bail_out;
- $self->is_precat(1) if $self->have_event('ITEM_NOT_CATALOGED');
- $self->remove_event('ITEM_NOT_CATALOGED');
- }
-
- $self->override_events;
- return if $self->bail_out;
-
- $self->events([]);
- $self->do_checkout();
-}
-
-
-sub remove_event {
- my( $self, $evt ) = @_;
- $evt = (ref $evt) ? $evt->{textcode} : $evt;
- $logger->debug("circulator: removing event from list: $evt");
- my @events = @{$self->events};
- $self->events( [ grep { $_->{textcode} ne $evt } @events ] );
-}
-
-
-sub have_event {
- my( $self, $evt ) = @_;
- $evt = (ref $evt) ? $evt->{textcode} : $evt;
- return grep { $_->{textcode} eq $evt } @{$self->events};
-}
-
-
-
-sub run_renew_permit {
- my $self = shift;
-
- if ($U->ou_ancestor_setting_value($self->circ_lib, 'circ.block_renews_for_holds')) {
- my ($hold, undef, $retarget) = $holdcode->find_nearest_permitted_hold(
- $self->editor, $self->copy, $self->editor->requestor, 1
- );
- $self->push_events(new OpenILS::Event("COPY_NEEDED_FOR_HOLD")) if $hold;
- }
-
- if(!$self->legacy_script_support) {
- my $results = $self->run_indb_circ_test;
- $self->push_events($self->matrix_test_result_events)
- unless $self->circ_test_success;
- } else {
-
- my $runner = $self->script_runner;
-
- $runner->load($self->circ_permit_renew);
- my $result = $runner->run or
- throw OpenSRF::EX::ERROR ("Circ Permit Renew Script Died: $@");
- if ($result->{"events"}) {
- $self->push_events(
- map { new OpenILS::Event($_) } @{$result->{"events"}}
- );
- $logger->activity(
- "circulator: circ_permit_renew for user " .
- $self->patron->id . " returned " .
- scalar(@{$result->{"events"}}) . " event(s)"
- );
- }
-
- $self->mk_script_runner;
- }
-
- $logger->debug("circulator: re-creating script runner to be safe");
-}
-
-
-# XXX: The primary mechanism for storing circ history is now handled
-# by tracking real circulation objects instead of bibs in a bucket.
-# However, this code is disabled by default and could be useful
-# some day, so may as well leave it for now.
-sub append_reading_list {
- my $self = shift;
-
- return undef unless
- $self->is_checkout and
- $self->patron and
- $self->copy and
- !$self->is_noncat;
-
-
- # verify history is globally enabled and uses the bucket mechanism
- my $htype = OpenSRF::Utils::SettingsClient->new->config_value(
- apps => 'open-ils.circ' => app_settings => 'checkout_history_mechanism');
-
- return undef unless $htype and $htype eq 'bucket';
-
- my $e = new_editor(xact => 1, requestor => $self->editor->requestor);
-
- # verify the patron wants to retain the hisory
- my $setting = $e->search_actor_user_setting(
- {usr => $self->patron->id, name => 'circ.keep_checkout_history'})->[0];
-
- unless($setting and $setting->value) {
- $e->rollback;
- return undef;
- }
-
- my $bkt = $e->search_container_copy_bucket(
- {owner => $self->patron->id, btype => 'circ_history'})->[0];
-
- my $pos = 1;
-
- if($bkt) {
- # find the next item position
- my $last_item = $e->search_container_copy_bucket_item(
- {bucket => $bkt->id}, {order_by => {ccbi => 'pos desc'}, limit => 1})->[0];
- $pos = $last_item->pos + 1 if $last_item;
-
- } else {
- # create the history bucket if necessary
- $bkt = Fieldmapper::container::copy_bucket->new;
- $bkt->owner($self->patron->id);
- $bkt->name('');
- $bkt->btype('circ_history');
- $bkt->pub('f');
- $e->create_container_copy_bucket($bkt) or return $e->die_event;
- }
-
- my $item = Fieldmapper::container::copy_bucket_item->new;
-
- $item->bucket($bkt->id);
- $item->target_copy($self->copy->id);
- $item->pos($pos);
-
- $e->create_container_copy_bucket_item($item) or return $e->die_event;
- $e->commit;
-
- return undef;
-}
-
-
-sub make_trigger_events {
- my $self = shift;
- return unless $self->circ;
- $U->create_events_for_hook('checkout', $self->circ, $self->circ_lib) if $self->is_checkout;
- $U->create_events_for_hook('checkin', $self->circ, $self->circ_lib) if $self->is_checkin;
- $U->create_events_for_hook('renewal', $self->circ, $self->circ_lib) if $self->is_renewal;
-}
-
-
-
-sub checkin_handle_lost_now_found {
- my ($self, $bill_type) = @_;
-
- # ------------------------------------------------------------------
- # remove charge from patron's account if lost item is returned
- # ------------------------------------------------------------------
-
- my $bills = $self->editor->search_money_billing(
- {
- xact => $self->circ->id,
- btype => $bill_type
- }
- );
-
- $logger->debug("voiding lost item charge of ".scalar(@$bills));
- for my $bill (@$bills) {
- if( !$U->is_true($bill->voided) ) {
- $logger->info("lost item returned - voiding bill ".$bill->id);
- $bill->voided('t');
- $bill->void_time('now');
- $bill->voider($self->editor->requestor->id);
- my $note = ($bill->note) ? $bill->note . "\n" : '';
- $bill->note("${note}System: VOIDED FOR LOST ITEM RETURNED");
-
- $self->bail_on_events($self->editor->event)
- unless $self->editor->update_money_billing($bill);
- }
- }
-}
-
-sub checkin_handle_lost_now_found_restore_od {
- my $self = shift;
-
- # ------------------------------------------------------------------
- # restore those overdue charges voided when item was set to lost
- # ------------------------------------------------------------------
-
- my $ods = $self->editor->search_money_billing(
- {
- xact => $self->circ->id,
- btype => 1
- }
- );
-
- $logger->debug("returning overdue charges pre-lost ".scalar(@$ods));
- for my $bill (@$ods) {
- if( $U->is_true($bill->voided) ) {
- $logger->info("lost item returned - restoring overdue ".$bill->id);
- $bill->voided('f');
- $bill->clear_void_time;
- $bill->voider($self->editor->requestor->id);
- my $note = ($bill->note) ? $bill->note . "\n" : '';
- $bill->note("${note}System: LOST RETURNED - OVERDUES REINSTATED");
-
- $self->bail_on_events($self->editor->event)
- unless $self->editor->update_money_billing($bill);
- }
- }
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Circ::CopyLocations;
-use base 'OpenILS::Application';
-use strict; use warnings;
-use Data::Dumper;
-$Data::Dumper::Indent = 0;
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-my $U = "OpenILS::Application::AppUtils";
-
-
-__PACKAGE__->register_method(
- api_name => "open-ils.circ.copy_location.retrieve.all",
- method => 'cl_retrieve_all',
- argc => 2,
- signature => q/
- Retrieves the ranged set of copy locations for the requested org.
- If no org is provided, all copy locations are returned
- @param orgId The org location id
- @param noi18n No i18n in result
- @param flesh_owning_lib Flesh owning lib in results
- @return An array of copy location objects
- /);
-
-sub cl_retrieve_all {
- my ($self, $client, $org_id, $no_i18n, $flesh_owning_lib) = @_;
-
- if(!$org_id) {
- my $otree = $U->get_org_tree();
- $org_id = $otree->id;
- }
-
- my $second_cstore_arg = {"no_i18n" => scalar($no_i18n)};
- if ($flesh_owning_lib) {
- $second_cstore_arg->{"flesh"} = 1;
- $second_cstore_arg->{"flesh_fields"} = {"acpl" => ["owning_lib"]};
- }
-
- return new_editor()->search_asset_copy_location([{
- owning_lib => $U->get_org_full_path($org_id)
- }, $second_cstore_arg]);
-}
-
-__PACKAGE__->register_method(
- "api_name" => "open-ils.circ.copy_location.retrieve.distinct",
- "method" => "cl_retrieve_distinct",
- "stream" => 1,
- "argc" => 0,
- "signature" => q/Retrieve copy locations with distinct names globally/
-);
-
-sub cl_retrieve_distinct {
- my ($self, $client) = @_;
-
- my $e = new_editor();
- my $names = $e->json_query({
- "select" => {
- "acpl" => [{"transform" => "distinct", "column" => "name"}]
- },
- "from" => {"acpl" => {}}
- }) or return $e->die_event;
- $e->disconnect;
-
- $client->respond($_->{"name"}) for @$names;
- undef;
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.circ.copy_location.create',
- method => 'cl_create',
- argc => 2,
- signature => q/
- Creates a new copy location. Requestor must have the CREATE_COPY_LOCATION
- permission at the location specified on the new location object
- @param authtoken The login session key
- @param copyLoc The new copy location object
- @return The if of the new location object on success, event on error
- /);
-
-
-sub cl_create {
- my( $self, $conn, $auth, $location ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless
- $e->allowed('CREATE_COPY_LOCATION', $location->owning_lib);
-
- # make sure there is no copy_location with the same name in the same place
- my $existing = $e->search_asset_copy_location(
- {owning_lib => $location->owning_lib, name => $location->name}, {idlist=>1});
- return OpenILS::Event->new('COPY_LOCATION_EXISTS') if @$existing;
-
- $e->create_asset_copy_location($location) or return $e->die_event;
- $e->commit;
- return $location->id;
-}
-
-
-
-__PACKAGE__->register_method (
- api_name => 'open-ils.circ.copy_location.delete',
- method => 'cl_delete',
- argc => 2,
- signature => q/
- Deletes a copy location. Requestor must have the
- DELETE_COPY_LOCATION permission.
- @param authtoken The login session key
- @param id The copy location object id
- @return 1 on success, event on error
- /);
-
-
-sub cl_delete {
- my( $self, $conn, $auth, $id ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $cloc = $e->retrieve_asset_copy_location($id)
- or return $e->die_event;
- return $e->die_event unless
- $e->allowed('DELETE_COPY_LOCATION', $cloc->owning_lib);
-
- $e->delete_asset_copy_location($cloc) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method (
- api_name => 'open-ils.circ.copy_location.update',
- method => 'cl_update',
- argc => 2,
- signature => q/
- Updates a copy location object. Requestor must have
- the UPDATE_COPY_LOCATION permission
- @param authtoken The login session key
- @param copyLoc The copy location object
- @return 1 on success, event on error
- /);
-
-
-sub cl_update {
- my( $self, $conn, $auth, $location ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- # check permissions against the original copy location
- my $orig_loc = $e->retrieve_asset_copy_location($location->id)
- or return $e->die_event;
-
- return $e->die_event unless
- $e->allowed('UPDATE_COPY_LOCATION', $orig_loc->owning_lib);
-
- # disallow hijacking of the location
- $location->owning_lib($orig_loc->owning_lib);
-
- $e->update_asset_copy_location($location)
- or return $e->die_event;
-
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_loc',
- authoritative => 1,
- api_name => 'open-ils.circ.copy_location.retrieve',
-);
-
-sub fetch_loc {
- my( $self, $con, $id ) = @_;
- my $e = new_editor();
- my $cl = $e->retrieve_asset_copy_location($id)
- or return $e->event;
- return $cl;
-}
-
-__PACKAGE__->register_method(
- api_name => "open-ils.circ.copy_location_order.update",
- method => 'update_clo',
- argc => 2,
-);
-
-sub update_clo {
- my($self, $client, $auth, $orders) = @_;
- return [] unless $orders and @$orders;
-
- my $e = new_editor(authtoken => $auth, xact =>1);
- return $e->die_event unless $e->checkauth;
-
- my $org = $$orders[0]->org;
- return $e->die_event unless $e->allowed('ADMIN_COPY_LOCATION_ORDER', $org);
-
- # clear out the previous order entries
- my $existing = $e->search_asset_copy_location_order({org => $org});
- $e->delete_asset_copy_location_order($_) or return $e->die_event for @$existing;
-
- # create the new order entries
- my $progress = 0;
- for my $order (@$orders) {
- return $e->die_event(OpenILS::Event->new('BAD_PARAMS')) unless $order->org == $org;
- $e->create_asset_copy_location_order($order) or return $e->die_event;
- $client->respond({maximum => scalar(@$orders), progress => $progress}) unless ($progress++ % 10);
- }
-
- # fetch the new entries
- $orders = $e->search_asset_copy_location_order({org => $org});
- $e->commit;
- return {orders => $orders};
-}
-
-
-1;
+++ /dev/null
-# --------------------------------------------------------------------
-# Copyright (C) 2008 Niles Ingalls
-# Niles Ingalls <nilesi@zionsville.lib.in.us>
-# Bill Erickson <erickson@esilibrary.com>
-# Joe Atzberger <jatzberger@esilibrary.com>
-# Lebbeous Fogle-Weekley <lebbeous@esilibrary.com>
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# --------------------------------------------------------------------
-package OpenILS::Application::Circ::CreditCard;
-use base qw/OpenSRF::Application/;
-use strict; use warnings;
-
-use Business::CreditCard;
-use Business::OnlinePayment;
-use UUID::Tiny qw/:std/;
-use Locale::Country;
-
-use OpenILS::Event;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Application::AppUtils;
-my $U = "OpenILS::Application::AppUtils";
-
-use constant CREDIT_NS => "credit";
-
-# Given the argshash from process_payment(), this helper function just finds
-# a function in the current namespace named "bop_args_{processor}" and calls
-# it with $argshash as an argument, returning the result, or returning an
-# empty hash if it can't find such a function.
-sub get_bop_args_filler {
- no strict 'refs';
-
- my $argshash = shift;
- my $funcname = "bop_args_" . $argshash->{processor};
- return &{$funcname}($argshash) if defined &{$funcname};
- return ();
-}
-
-# Provide default arguments for calls using the AuthorizeNet processor
-sub bop_args_AuthorizeNet {
- my $argshash = shift;
- if ($argshash->{server}) {
- return (
- # One might provide "test.authorize.net" here.
- Server => $argshash->{server},
- );
- }
- else {
- return ();
- }
-}
-
-# Provide default arguments for calls using the PayPal processor
-sub bop_args_PayPal {
- my $argshash = shift;
- return (
- Username => $argshash->{login},
- Password => $argshash->{password},
- Signature => $argshash->{signature}
- );
-}
-
-# Provide default arguments for calls using the PayflowPro processor
-sub bop_args_PayflowPro {
- my $argshash = shift;
- return (
- "vendor" => $argshash->{vendor},
- "partner" => $argshash->{partner} || "PayPal" # reasonable default?
- );
-}
-
-sub get_processor_settings {
- my $org_unit = shift;
- my $processor = lc shift;
-
- # XXX TODO: make this one single cstore request instead of many
- +{ map { ($_ =>
- $U->ou_ancestor_setting_value(
- $org_unit, CREDIT_NS . ".processor.${processor}.${_}"
- )) } qw/enabled login password signature server testmode vendor partner/
- };
-}
-
-# argshash (Hash of arguments with these keys):
-# patron_id: Not a barcode, but a patron's internal ID
-# ou: Org unit where transaction happens
-# processor: Payment processor to use
-# (AuthorizeNet/PayPal/PayflowPro)
-# cc: credit card number
-# cvv2: 3 or 4 digits from back of card
-# amount: transaction value
-# action: optional (default: Normal Authorization)
-# first_name: optional (default: patron's first_given_name field)
-# last_name: optional (default: patron's family_name field)
-# address: optional (default: patron's street1 field + street2)
-# city: optional (default: patron's city field)
-# state: optional (default: patron's state field)
-# zip: optional (default: patron's zip field)
-# country: optional (some processor APIs: 2 letter code.)
-# description: optional
-
-sub process_payment {
- my ($argshash) = @_;
-
- # Confirm some required arguments.
- return OpenILS::Event->new('BAD_PARAMS')
- unless $argshash
- and $argshash->{cc}
- and $argshash->{amount}
- and $argshash->{expiration}
- and $argshash->{ou};
-
- if (!$argshash->{processor}) {
- if (!($argshash->{processor} =
- $U->ou_ancestor_setting_value(
- $argshash->{ou}, CREDIT_NS . '.processor.default'))) {
- return OpenILS::Event->new('CREDIT_PROCESSOR_NOT_SPECIFIED');
- }
- }
- # Basic sanity check on processor name.
- if ($argshash->{processor} !~ /^[a-z0-9_\-]+$/i) {
- return OpenILS::Event->new('CREDIT_PROCESSOR_NOT_ALLOWED');
- }
-
- # Get org unit settings related to our processor
- my $psettings = get_processor_settings(
- $argshash->{ou}, $argshash->{processor}
- );
-
- if (!$psettings->{enabled}) {
- return OpenILS::Event->new('CREDIT_PROCESSOR_NOT_ENABLED');
- }
-
- # Add the org unit settings for the chosen processor to our argshash.
- $argshash = +{ %{$argshash}, %{$psettings} };
-
- # At least the following (derived from org unit settings) are required.
- return OpenILS::Event->new('CREDIT_PROCESSOR_BAD_PARAMS')
- unless $argshash->{login}
- and $argshash->{password};
-
- # A valid patron_id is also required.
- my $e = new_editor();
- my $patron = $e->retrieve_actor_user(
- [
- $argshash->{patron_id},
- {
- flesh => 1,
- flesh_fields => { au => ["mailing_address"] }
- }
- ]
- ) or return $e->event;
-
- return dispatch($argshash, $patron);
-}
-
-sub prepare_bop_content {
- my ($argshash, $patron, $cardtype) = @_;
-
- my %content;
- foreach (qw/
- login
- password
- description
- first_name
- last_name
- amount
- expiration
- cvv2
- address
- city
- state
- zip
- country/) {
- if (exists $argshash->{$_}) {
- $content{$_} = $argshash->{$_};
- }
- }
-
- $content{action} = $argshash->{action} || "Normal Authorization";
- $content{type} = $cardtype; #'American Express', 'VISA', 'MasterCard'
- $content{card_number} = $argshash->{cc};
- $content{customer_id} = $patron->id;
-
- $content{first_name} ||= $patron->first_given_name;
- $content{last_name} ||= $patron->family_name;
-
- $content{FirstName} = $content{first_name}; # kludge mcugly for PP
- $content{LastName} = $content{last_name};
-
-
- # Especially for the following fields, do we need to support different
- # mapping of fields for different payment processors, particularly ones
- # in other countries?
- $content{address} ||= $patron->mailing_address->street1;
- $content{address} .= ", " . $patron->mailing_address->street2
- if $patron->mailing_address->street2;
-
- $content{city} ||= $patron->mailing_address->city;
- $content{state} ||= $patron->mailing_address->state;
- $content{zip} ||= $patron->mailing_address->post_code;
- $content{country} ||= $patron->mailing_address->country;
-
- # Yet another fantastic kludge. country2code() comes from Locale::Country.
- # PayPal must have 2 letter country field (ISO 3166) that's uppercase.
- if (length($content{country}) > 2 && $argshash->{processor} eq 'PayPal') {
- $content{country} = uc country2code($content{country});
- } elsif($argshash->{processor} eq "PayflowPro") {
- ($content{request_id} = create_uuid_as_string(UUID_V4)) =~ s/-//;
- }
-
- %content;
-}
-
-sub dispatch {
- my ($argshash, $patron) = @_;
-
- # The validate() sub is exported by Business::CreditCard.
- if (!validate($argshash->{cc})) {
- # Although it might help a troubleshooter, it's probably not a good
- # idea to put the credit card number in the log file.
- $logger->info("Credit card number invalid");
-
- return new OpenILS::Event("CREDIT_PROCESSOR_INVALID_CC_NUMBER");
- }
-
- # cardtype() also comes from Business::CreditCard. It is not certain that
- # a) the card type returned by this method will be suitable input for
- # a payment processor, nor that
- # b) it is even necessary to supply this argument to processors in all
- # cases. Testing this with several processors would be a good idea.
- (my $cardtype = cardtype($argshash->{cc})) =~ s/ card//i;
-
- if (lc($cardtype) eq "unknown") {
- $logger->info("Credit card number passed validate(), " .
- "yet cardtype() returned $cardtype");
- return new OpenILS::Event(
- "CREDIT_PROCESSOR_INVALID_CC_NUMBER", "note" => "cardtype $cardtype"
- );
- }
-
- $logger->debug(
- "applying payment via processor '" . $argshash->{processor} . "'"
- );
-
- # Find B:OP constructor arguments specific to our payment processor.
- my %bop_args = get_bop_args_filler($argshash);
-
- # We're assuming that all B:OP processors accept this argument to the
- # constructor.
- $bop_args{test_transaction} = $argshash->{testmode};
-
- my $transaction = new Business::OnlinePayment(
- $argshash->{processor}, %bop_args
- );
-
- my %content = prepare_bop_content($argshash, $patron, $cardtype);
- $transaction->content(%content);
-
- # submit() does not return a value, although crashing is possible here
- # with some bad input depending on the payment processor.
- $transaction->submit;
-
- my $payload = {
- "processor" => $argshash->{"processor"}, "card_type" => $cardtype
- };
-
- # Put the values of any of these fields into the event payload, if present.
- foreach (qw/authorization correlationid avs_code request_id
- server_response cvv2_response cvv2_code error_message order_number/) {
- $payload->{$_} = $transaction->$_ if $transaction->can($_);
- }
-
- my $event_name;
-
- if ($transaction->is_success) {
- $logger->info($argshash->{processor} . " payment succeeded");
- $event_name = "SUCCESS";
- } else {
- $logger->info($argshash->{processor} . " payment failed");
- $event_name = "CREDIT_PROCESSOR_DECLINED_TRANSACTION";
- }
-
- return new OpenILS::Event($event_name, "payload" => $payload);
-}
-
-
-1;
+++ /dev/null
-# ---------------------------------------------------------------
-# Copyright (C) 2005 Georgia Public Library Service
-# Bill Erickson <billserickson@gmail.com>
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-
-package OpenILS::Application::Circ::HoldNotify;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use OpenSRF::EX qw(:try);
-use vars q/$AUTOLOAD/;
-use OpenILS::Event;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::AppUtils;
-use OpenILS::Const qw/:const/;
-use OpenILS::Utils::Fieldmapper;
-use Email::Send;
-use Data::Dumper;
-use OpenSRF::EX qw/:try/;
-my $U = 'OpenILS::Application::AppUtils';
-
-use open ':utf8';
-
-
-__PACKAGE__->register_method(
- method => 'send_email_notify_pub',
- api_name => 'open-ils.circ.send_hold_notify.email',
-);
-
-
-sub send_email_notify_pub {
- my( $self, $conn, $auth, $hold_id ) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('CREATE_HOLD_NOTIFICATION');
- my $notifier = __PACKAGE__->new(requestor => $e->requestor, hold_id => $hold_id);
- return $notifier->event if $notifier->event;
- my $stat = $notifier->send_email_notify;
-# $e->commit if $stat == '1';
- return $stat;
-}
-
-
-
-
-
-# ---------------------------------------------------------------
-# Define the notifier object
-# ---------------------------------------------------------------
-
-my @AUTOLOAD_FIELDS = qw/
- hold
- copy
- volume
- title
- editor
- patron
- event
- pickup_lib
- smtp_server
- settings_client
-/;
-
-sub AUTOLOAD {
- my $self = shift;
- my $type = ref($self) or die "$self is not an object";
- my $data = shift;
- my $name = $AUTOLOAD;
- $name =~ s/.*://o;
-
- unless (grep { $_ eq $name } @AUTOLOAD_FIELDS) {
- $logger->error("hold_notify: $type: invalid autoload field: $name");
- die "$type: invalid autoload field: $name\n"
- }
-
- {
- no strict 'refs';
- *{"${type}::${name}"} = sub {
- my $s = shift;
- my $v = shift;
- $s->{$name} = $v if defined $v;
- return $s->{$name};
- }
- }
- return $self->$name($data);
-}
-
-
-sub new {
- my( $class, %args ) = @_;
- $class = ref($class) || $class;
- my $self = bless( {}, $class );
- $self->editor( new_editor( xact => 1, requestor => $args{requestor} ));
- $logger->debug("circulator: creating new hold-notifier with requestor ".
- $self->editor->requestor->id);
- $self->fetch_data($args{hold_id});
- return $self;
-}
-
-sub send_email_notify {
- my $self = shift;
-
- my $sc = OpenSRF::Utils::SettingsClient->new;
- my $setting = $sc->config_value(
- qw/ apps open-ils.circ app_settings notify_hold email / );
-
- $logger->debug("hold_notify: email enabled setting = $setting");
-
- if( !$setting or $setting ne 'true' ) {
- $self->editor->rollback;
- $logger->info("hold_notify: not sending hold notify - email notifications disabled");
- return 0;
- }
-
- unless ($U->is_true($self->hold->email_notify)) {
- $self->editor->rollback;
- $logger->info("hold_notify: not sending hold notification because email_notify is false");
- return 0;
- }
-
- unless( $self->patron->email and $self->patron->email =~ /.+\@.+/ ) { # see if it's remotely email-esque
- $self->editor->rollback;
- return OpenILS::Event->new('PATRON_NO_EMAIL_ADDRESS');
- }
-
- $logger->info("hold_notify: attempting email notify on hold ".$self->hold->id);
-
- my $sclient = OpenSRF::Utils::SettingsClient->new;
- $self->settings_client($sclient);
- my $template = $sclient->config_value('email_notify', 'template');
- my $str = $self->flesh_template($self->load_template($template));
-
- unless( $str ) {
- $self->editor->rollback;
- $logger->error("hold_notify: No email notify template found - cannot notify");
- return 0;
- }
-
- my $reqr = $self->editor->requestor;
- $self->editor->rollback; # we're done with this transaction
-
- return 0 unless $self->send_email($str);
-
- # ------------------------------------------------------------------
- # If the hold email takes too long to send, the existing editor
- # transaction may have timed out. Create a one-off editor to write
- # the notification to the DB.
- # ------------------------------------------------------------------
- my $we = new_editor(xact=>1, requestor=>$reqr);
-
- my $notify = Fieldmapper::action::hold_notification->new;
- $notify->hold($self->hold->id);
- $notify->notify_staff($we->requestor->id);
- $notify->notify_time('now');
- $notify->method('email');
-
- $we->create_action_hold_notification($notify)
- or return $we->die_event;
- $we->commit;
-
- return 1;
-}
-
-sub send_email {
- my( $self, $text ) = @_;
-
- # !!! $self->editor xact has been rolled back before we get here
-
- my $smtp = $self->settings_client->config_value('email_notify', 'smtp_server');
-
- $logger->info("hold_notify: sending email notice to ".
- $self->patron->email." with SMTP server $smtp");
-
- my $sender = Email::Send->new({mailer => 'SMTP'});
- $sender->mailer_args([Host => $smtp]);
-
- my $stat;
- my $err;
-
- try {
- $stat = $sender->send($text);
- } catch Error with {
- $err = $stat = shift;
- $logger->error("hold_notify: Email notify failed with error: $err");
- };
-
- if( !$err and $stat and $stat->type eq 'success' ) {
- $logger->info("hold_notify: successfully sent hold notification");
- return 1;
- } else {
- $logger->warn("hold_notify: unable to send hold notification: ".Dumper($stat));
- return 0;
- }
-
- return undef;
-}
-
-
-# -------------------------------------------------------------------------
-# Fetches all of the hold-related data
-# -------------------------------------------------------------------------
-sub fetch_data {
- my $self = shift;
- my $holdid = shift;
- my $e = $self->editor;
-
- $logger->debug("circulator: fetching hold notify data");
-
- $self->hold($e->retrieve_action_hold_request($holdid)) or return $self->event($e->event);
- $self->copy($e->retrieve_asset_copy($self->hold->current_copy)) or return $self->event($e->event);
- $self->volume($e->retrieve_asset_call_number($self->copy->call_number)) or return $self->event($e->event);
- $self->title($e->retrieve_biblio_record_entry($self->volume->record)) or return $self->event($e->event);
- $self->patron($e->retrieve_actor_user($self->hold->usr)) or return $self->event($e->event);
- $self->pickup_lib($e->retrieve_actor_org_unit($self->hold->pickup_lib)) or return $self->event($e->event);
-}
-
-
-sub extract_data {
- my $self = shift;
- my $e = $self->editor;
-
- my $patron = $self->patron;
- my $o_name = $self->pickup_lib->name;
- my $p_name = $patron->first_given_name .' '.$patron->family_name;
-
- # try to find a suitable address for the patron
- my $p_addr;
- my $p_addrs;
- unless( $p_addr =
- $e->retrieve_actor_user_address($patron->billing_address)) {
- unless( $p_addr =
- $e->retrieve_actor_user_address($patron->mailing_address)) {
- $logger->warn("hold_notify: No address for user ".$patron->id);
- $p_addrs = "";
- }
- }
-
- unless( defined $p_addrs ) {
- $p_addrs =
- $p_addr->street1." ".
- $p_addr->street2." ".
- $p_addr->city." ".
- $p_addr->state." ".
- $p_addr->post_code;
- }
-
- my $l_addr = $e->retrieve_actor_org_address($self->pickup_lib->holds_address);
- my $l_addrs = (!$l_addr) ? "" :
- $l_addr->street1." ".
- $l_addr->street2." ".
- $l_addr->city." ".
- $l_addr->state." ".
- $l_addr->post_code;
-
- my $title;
- my $author;
-
- if( $self->title->id == OILS_PRECAT_RECORD ) {
- $title = ($self->copy->dummy_title) ?
- $self->copy->dummy_title : "";
- $author = ($self->copy->dummy_author) ?
- $self->copy->dummy_author : "";
- } else {
- my $mods = $U->record_to_mvr($self->title);
- $title = ($mods->title) ? $mods->title : "";
- $author = ($mods->author) ? $mods->author : "";
- }
-
-
- return {
- patron_email => $self->patron->email,
- pickup_lib_name => $o_name,
- pickup_lib_addr => $l_addrs,
- patron_name => $p_name,
- patron_addr => $p_addrs,
- title => $title,
- author => $author,
- call_number => $self->volume->label,
- copy_barcode => $self->copy->barcode,
- copy_number => $self->copy->copy_number,
- };
-}
-
-
-
-sub load_template {
- my $self = shift;
- my $template = shift;
-
- unless( open(F, $template) ) {
- $logger->error("hold_notify: Unable to open hold notification template file: $template");
- return undef;
- }
-
- # load the template, strip comments
- my @lines = <F>;
- close(F);
-
- my $str = '';
- for(@lines) {
- chomp $_;
- next if $_ =~ /^\s*\#/o;
- $_ =~ s/\#.*//og;
- $str .= "$_\n";
- }
-
- return $str;
-}
-
-sub flesh_template {
- my( $self, $str ) = @_;
- return undef unless $str;
-
- my @time = CORE::localtime();
- my $day = $time[3];
- my $month = $time[4] + 1;
- my $year = $time[5] + 1900;
-
- my $data = $self->extract_data;
-
- my $email = $$data{patron_email};
- my $p_name = $$data{patron_name};
- my $p_addr = $$data{patron_addr};
- my $o_name = $$data{pickup_lib_name};
- my $o_addr = $$data{pickup_lib_addr};
- my $title = $$data{title};
- my $author = $$data{author};
- my $cn = $$data{call_number};
- my $barcode = $$data{copy_barcode};
- my $copy_number = $$data{copy_number};
-
- my $sender = $self->settings_client->config_value('email_notify', 'sender_address');
- my $reply_to = $self->pickup_lib->email;
- $reply_to ||= $sender;
-
- # if they have an org setting for bounced emails, use that as the sender address
- if( my $set = $self->editor->search_actor_org_unit_setting(
- { name => OILS_SETTING_ORG_BOUNCED_EMAIL,
- org_unit => $self->pickup_lib->id } )->[0] ) {
-
- my $bemail = OpenSRF::Utils::JSON->JSON2perl($set->value);
- $sender = $bemail if $bemail;
- }
-
- $str =~ s/\${EMAIL_SENDER}/$sender/;
- $str =~ s/\${EMAIL_RECIPIENT}/$email/;
- $str =~ s/\${EMAIL_REPLY_TO}/$reply_to/;
- $str =~ s/\${EMAIL_HEADERS}//;
-
- $str =~ s/\${DATE}/$year-$month-$day/;
- $str =~ s/\${LIBRARY}/$o_name/;
- $str =~ s/\${LIBRARY_ADDRESS}/$o_addr/;
- $str =~ s/\${PATRON_NAME}/$p_name/;
- $str =~ s/\${PATRON_ADDRESS}/$p_addr/;
-
- $str =~ s/\${TITLE}/$title/;
- $str =~ s/\${AUTHOR}/$author/;
- $str =~ s/\${CALL_NUMBER}/$cn/;
- $str =~ s/\${COPY_BARCODE}/$barcode/;
- $str =~ s/\${COPY_NUMBER}/$copy_number/;
-
- return $str;
-}
-
-
-
-
-
-1;
+++ /dev/null
-# ---------------------------------------------------------------
-# Copyright (C) 2005 Georgia Public Library Service
-# Bill Erickson <highfalutin@gmail.com>
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-
-package OpenILS::Application::Circ::Holds;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use OpenILS::Application::AppUtils;
-use DateTime;
-use Data::Dumper;
-use OpenSRF::EX qw(:try);
-use OpenILS::Perm;
-use OpenILS::Event;
-use OpenSRF::Utils;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Utils::PermitHold;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Const qw/:const/;
-use OpenILS::Application::Circ::Transit;
-use OpenILS::Application::Actor::Friends;
-use DateTime;
-use DateTime::Format::ISO8601;
-use OpenSRF::Utils qw/:datetime/;
-use Digest::MD5 qw(md5_hex);
-use OpenSRF::Utils::Cache;
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-
-
-__PACKAGE__->register_method(
- method => "create_hold_batch",
- api_name => "open-ils.circ.holds.create.batch",
- stream => 1,
- signature => {
- desc => q/@see open-ils.circ.holds.create.batch/,
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Array of hold objects', type => 'array' }
- ],
- return => {
- desc => 'Array of hold ID on success, -1 on missing arg, event (or ref to array of events) on error(s)',
- },
- }
-);
-
-__PACKAGE__->register_method(
- method => "create_hold_batch",
- api_name => "open-ils.circ.holds.create.override.batch",
- stream => 1,
- signature => {
- desc => '@see open-ils.circ.holds.create.batch',
- }
-);
-
-
-sub create_hold_batch {
- my( $self, $conn, $auth, $hold_list ) = @_;
- (my $method = $self->api_name) =~ s/\.batch//og;
- foreach (@$hold_list) {
- my ($res) = $self->method_lookup($method)->run($auth, $_);
- $conn->respond($res);
- }
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "create_hold",
- api_name => "open-ils.circ.holds.create",
- signature => {
- desc => "Create a new hold for an item. From a permissions perspective, " .
- "the login session is used as the 'requestor' of the hold. " .
- "The hold recipient is determined by the 'usr' setting within the hold object. " .
- 'First we verify the requestor has holds request permissions. ' .
- 'Then we verify that the recipient is allowed to make the given hold. ' .
- 'If not, we see if the requestor has "override" capabilities. If not, ' .
- 'a permission exception is returned. If permissions allow, we cycle ' .
- 'through the set of holds objects and create. ' .
- 'If the recipient does not have permission to place multiple holds ' .
- 'on a single title and said operation is attempted, a permission ' .
- 'exception is returned',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Hold object for hold to be created',
- type => 'object', class => 'ahr' }
- ],
- return => {
- desc => 'New ahr ID on success, -1 on missing arg, event (or ref to array of events) on error(s)',
- },
- }
-);
-
-__PACKAGE__->register_method(
- method => "create_hold",
- api_name => "open-ils.circ.holds.create.override",
- notes => '@see open-ils.circ.holds.create',
- signature => {
- desc => "If the recipient is not allowed to receive the requested hold, " .
- "call this method to attempt the override",
- params => [
- { desc => 'Authentication token', type => 'string' },
- {
- desc => 'Hold object for hold to be created',
- type => 'object', class => 'ahr'
- }
- ],
- return => {
- desc => 'New hold (ahr) ID on success, -1 on missing arg, event (or ref to array of events) on error(s)',
- },
- }
-);
-
-sub create_hold {
- my( $self, $conn, $auth, $hold ) = @_;
- return -1 unless $hold;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $override = 1 if $self->api_name =~ /override/;
-
- my @events;
-
- my $requestor = $e->requestor;
- my $recipient = $requestor;
-
- if( $requestor->id ne $hold->usr ) {
- # Make sure the requestor is allowed to place holds for
- # the recipient if they are not the same people
- $recipient = $e->retrieve_actor_user($hold->usr) or return $e->die_event;
- $e->allowed('REQUEST_HOLDS', $recipient->home_ou) or return $e->die_event;
- }
-
- # If the related org setting tells us to, block if patron privs have expired
- my $expire_setting = $U->ou_ancestor_setting_value($recipient->home_ou, OILS_SETTING_BLOCK_HOLD_FOR_EXPIRED_PATRON);
- if ($expire_setting) {
- my $expire = DateTime::Format::ISO8601->new->parse_datetime(
- cleanse_ISO8601($recipient->expire_date));
-
- push( @events, OpenILS::Event->new(
- 'PATRON_ACCOUNT_EXPIRED',
- "payload" => {"fail_part" => "actor.usr.privs_expired"}
- )) if( CORE::time > $expire->epoch ) ;
- }
-
- # Now make sure the recipient is allowed to receive the specified hold
- my $porg = $recipient->home_ou;
- my $rid = $e->requestor->id;
- my $t = $hold->hold_type;
-
- # See if a duplicate hold already exists
- my $sargs = {
- usr => $recipient->id,
- hold_type => $t,
- fulfillment_time => undef,
- target => $hold->target,
- cancel_time => undef,
- };
-
- $sargs->{holdable_formats} = $hold->holdable_formats if $t eq 'M';
-
- my $existing = $e->search_action_hold_request($sargs);
- push( @events, OpenILS::Event->new('HOLD_EXISTS')) if @$existing;
-
- my $checked_out = hold_item_is_checked_out($e, $recipient->id, $hold->hold_type, $hold->target);
- push( @events, OpenILS::Event->new('HOLD_ITEM_CHECKED_OUT')) if $checked_out;
-
- if ( $t eq OILS_HOLD_TYPE_METARECORD ) {
- return $e->die_event unless $e->allowed('MR_HOLDS', $porg);
- } elsif ( $t eq OILS_HOLD_TYPE_TITLE ) {
- return $e->die_event unless $e->allowed('TITLE_HOLDS', $porg);
- } elsif ( $t eq OILS_HOLD_TYPE_VOLUME ) {
- return $e->die_event unless $e->allowed('VOLUME_HOLDS', $porg);
- } elsif ( $t eq OILS_HOLD_TYPE_ISSUANCE ) {
- return $e->die_event unless $e->allowed('ISSUANCE_HOLDS', $porg);
- } elsif ( $t eq OILS_HOLD_TYPE_COPY ) {
- return $e->die_event unless $e->allowed('COPY_HOLDS', $porg);
- } elsif ( $t eq OILS_HOLD_TYPE_FORCE ) {
- return $e->die_event unless $e->allowed('COPY_HOLDS', $porg);
- } elsif ( $t eq OILS_HOLD_TYPE_RECALL ) {
- return $e->die_event unless $e->allowed('COPY_HOLDS', $porg);
- }
-
- if( @events ) {
- if (!$override) {
- $e->rollback;
- return \@events;
- }
- for my $evt (@events) {
- next unless $evt;
- my $name = $evt->{textcode};
- return $e->die_event unless $e->allowed("$name.override", $porg);
- }
- }
-
- # set the configured expire time
- unless($hold->expire_time) {
- my $interval = $U->ou_ancestor_setting_value($recipient->home_ou, OILS_SETTING_HOLD_EXPIRE);
- if($interval) {
- my $date = DateTime->now->add(seconds => OpenSRF::Utils::interval_to_seconds($interval));
- $hold->expire_time($U->epoch2ISO8601($date->epoch));
- }
- }
-
- $hold->requestor($e->requestor->id);
- $hold->request_lib($e->requestor->ws_ou);
- $hold->selection_ou($hold->pickup_lib) unless $hold->selection_ou;
- $hold = $e->create_action_hold_request($hold) or return $e->die_event;
-
- $e->commit;
-
- $conn->respond_complete($hold->id);
-
- $U->storagereq(
- 'open-ils.storage.action.hold_request.copy_targeter',
- undef, $hold->id ) unless $U->is_true($hold->frozen);
-
- return undef;
-}
-
-# makes sure that a user has permission to place the type of requested hold
-# returns the Perm exception if not allowed, returns undef if all is well
-sub _check_holds_perm {
- my($type, $user_id, $org_id) = @_;
-
- my $evt;
- if ($type eq "M") {
- $evt = $apputils->check_perms($user_id, $org_id, "MR_HOLDS" );
- } elsif ($type eq "T") {
- $evt = $apputils->check_perms($user_id, $org_id, "TITLE_HOLDS" );
- } elsif($type eq "V") {
- $evt = $apputils->check_perms($user_id, $org_id, "VOLUME_HOLDS");
- } elsif($type eq "C") {
- $evt = $apputils->check_perms($user_id, $org_id, "COPY_HOLDS" );
- }
-
- return $evt if $evt;
- return undef;
-}
-
-# tests if the given user is allowed to place holds on another's behalf
-sub _check_request_holds_perm {
- my $user_id = shift;
- my $org_id = shift;
- if (my $evt = $apputils->check_perms(
- $user_id, $org_id, "REQUEST_HOLDS")) {
- return $evt;
- }
-}
-
-my $ses_is_req_note = 'The login session is the requestor. If the requestor is different from the user, ' .
- 'then the requestor must have VIEW_HOLD permissions';
-
-__PACKAGE__->register_method(
- method => "retrieve_holds_by_id",
- api_name => "open-ils.circ.holds.retrieve_by_id",
- signature => {
- desc => "Retrieve the hold, with hold transits attached, for the specified ID. $ses_is_req_note",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Hold ID', type => 'number' }
- ],
- return => {
- desc => 'Hold object with transits attached, event on error',
- }
- }
-);
-
-
-sub retrieve_holds_by_id {
- my($self, $client, $auth, $hold_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- $e->checkauth or return $e->event;
- $e->allowed('VIEW_HOLD') or return $e->event;
-
- my $holds = $e->search_action_hold_request(
- [
- { id => $hold_id , fulfillment_time => undef },
- {
- order_by => { ahr => "request_time" },
- flesh => 1,
- flesh_fields => {ahr => ['notes']}
- }
- ]
- );
-
- flesh_hold_transits($holds);
- flesh_hold_notices($holds, $e);
- return $holds;
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_holds",
- api_name => "open-ils.circ.holds.retrieve",
- signature => {
- desc => "Retrieves all the holds, with hold transits attached, for the specified user. $ses_is_req_note",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User ID', type => 'integer' }
- ],
- return => {
- desc => 'list of holds, event on error',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_holds",
- api_name => "open-ils.circ.holds.id_list.retrieve",
- authoritative => 1,
- signature => {
- desc => "Retrieves all the hold IDs, for the specified user. $ses_is_req_note",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User ID', type => 'integer' }
- ],
- return => {
- desc => 'list of holds, event on error',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_holds",
- api_name => "open-ils.circ.holds.canceled.retrieve",
- authoritative => 1,
- signature => {
- desc => "Retrieves all the cancelled holds for the specified user. $ses_is_req_note",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User ID', type => 'integer' }
- ],
- return => {
- desc => 'list of holds, event on error',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_holds",
- api_name => "open-ils.circ.holds.canceled.id_list.retrieve",
- authoritative => 1,
- signature => {
- desc => "Retrieves list of cancelled hold IDs for the specified user. $ses_is_req_note",
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User ID', type => 'integer' }
- ],
- return => {
- desc => 'list of hold IDs, event on error',
- }
- }
-);
-
-
-sub retrieve_holds {
- my ($self, $client, $auth, $user_id) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- $user_id = $e->requestor->id unless defined $user_id;
-
- my $notes_filter = {staff => 'f'};
- my $user = $e->retrieve_actor_user($user_id) or return $e->event;
- unless($user_id == $e->requestor->id) {
- if($e->allowed('VIEW_HOLD', $user->home_ou)) {
- $notes_filter = {staff => 't'}
- } else {
- my $allowed = OpenILS::Application::Actor::Friends->friend_perm_allowed(
- $e, $user_id, $e->requestor->id, 'hold.view');
- return $e->event unless $allowed;
- }
- } else {
- # staff member looking at his/her own holds can see staff and non-staff notes
- $notes_filter = {} if $e->allowed('VIEW_HOLD', $user->home_ou);
- }
-
- my $holds_query = {
- select => {ahr => ['id']},
- from => 'ahr',
- where => {usr => $user_id, fulfillment_time => undef}
- };
-
- if($self->api_name =~ /canceled/) {
-
- # Fetch the canceled holds
- # order cancelled holds by cancel time, most recent first
-
- $holds_query->{order_by} = [{class => 'ahr', field => 'cancel_time', direction => 'desc'}];
-
- my $cancel_age;
- my $cancel_count = $U->ou_ancestor_setting_value(
- $e->requestor->ws_ou, 'circ.holds.canceled.display_count', $e);
-
- unless($cancel_count) {
- $cancel_age = $U->ou_ancestor_setting_value(
- $e->requestor->ws_ou, 'circ.holds.canceled.display_age', $e);
-
- # if no settings are defined, default to last 10 cancelled holds
- $cancel_count = 10 unless $cancel_age;
- }
-
- if($cancel_count) { # limit by count
-
- $holds_query->{where}->{cancel_time} = {'!=' => undef};
- $holds_query->{limit} = $cancel_count;
-
- } elsif($cancel_age) { # limit by age
-
- # find all of the canceled holds that were canceled within the configured time frame
- my $date = DateTime->now->subtract(seconds => OpenSRF::Utils::interval_to_seconds($cancel_age));
- $date = $U->epoch2ISO8601($date->epoch);
- $holds_query->{where}->{cancel_time} = {'>=' => $date};
- }
-
- } else {
-
- # order non-cancelled holds by ready-for-pickup, then active, followed by suspended
- $holds_query->{order_by} = {ahr => ['shelf_time', 'frozen', 'request_time']};
- $holds_query->{where}->{cancel_time} = undef;
- }
-
- my $hold_ids = $e->json_query($holds_query);
- $hold_ids = [ map { $_->{id} } @$hold_ids ];
-
- return $hold_ids if $self->api_name =~ /id_list/;
-
- my @holds;
- for my $hold_id ( @$hold_ids ) {
-
- my $hold = $e->retrieve_action_hold_request($hold_id);
- $hold->notes($e->search_action_hold_request_note({hold => $hold_id, %$notes_filter}));
-
- $hold->transit(
- $e->search_action_hold_transit_copy([
- {hold => $hold->id},
- {order_by => {ahtc => 'source_send_time desc'}, limit => 1}])->[0]
- );
-
- push(@holds, $hold);
- }
-
- return \@holds;
-}
-
-
-__PACKAGE__->register_method(
- method => 'user_hold_count',
- api_name => 'open-ils.circ.hold.user.count'
-);
-
-sub user_hold_count {
- my ( $self, $conn, $auth, $userid ) = @_;
- my $e = new_editor( authtoken => $auth );
- return $e->event unless $e->checkauth;
- my $patron = $e->retrieve_actor_user($userid)
- or return $e->event;
- return $e->event unless $e->allowed( 'VIEW_HOLD', $patron->home_ou );
- return __user_hold_count( $self, $e, $userid );
-}
-
-sub __user_hold_count {
- my ( $self, $e, $userid ) = @_;
- my $holds = $e->search_action_hold_request(
- {
- usr => $userid,
- fulfillment_time => undef,
- cancel_time => undef,
- },
- { idlist => 1 }
- );
-
- return scalar(@$holds);
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_holds_by_pickup_lib",
- api_name => "open-ils.circ.holds.retrieve_by_pickup_lib",
- notes =>
- "Retrieves all the holds, with hold transits attached, for the specified pickup_ou id."
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_holds_by_pickup_lib",
- api_name => "open-ils.circ.holds.id_list.retrieve_by_pickup_lib",
- notes => "Retrieves all the hold ids for the specified pickup_ou id. "
-);
-
-sub retrieve_holds_by_pickup_lib {
- my ($self, $client, $login_session, $ou_id) = @_;
-
- #FIXME -- put an appropriate permission check here
- #my( $user, $target, $evt ) = $apputils->checkses_requestor(
- # $login_session, $user_id, 'VIEW_HOLD' );
- #return $evt if $evt;
-
- my $holds = $apputils->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.action.hold_request.search.atomic",
- {
- pickup_lib => $ou_id ,
- fulfillment_time => undef,
- cancel_time => undef
- },
- { order_by => { ahr => "request_time" } }
- );
-
- if ( ! $self->api_name =~ /id_list/ ) {
- flesh_hold_transits($holds);
- return $holds;
- }
- # else id_list
- return [ map { $_->id } @$holds ];
-}
-
-
-__PACKAGE__->register_method(
- method => "uncancel_hold",
- api_name => "open-ils.circ.hold.uncancel"
-);
-
-sub uncancel_hold {
- my($self, $client, $auth, $hold_id) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $hold = $e->retrieve_action_hold_request($hold_id)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('CANCEL_HOLDS', $hold->request_lib);
-
- if ($hold->fulfillment_time) {
- $e->rollback;
- return 0;
- }
- unless ($hold->cancel_time) {
- $e->rollback;
- return 1;
- }
-
- # if configured to reset the request time, also reset the expire time
- if($U->ou_ancestor_setting_value(
- $hold->request_lib, 'circ.holds.uncancel.reset_request_time', $e)) {
-
- $hold->request_time('now');
- my $interval = $U->ou_ancestor_setting_value($hold->request_lib, OILS_SETTING_HOLD_EXPIRE);
- if($interval) {
- my $date = DateTime->now->add(seconds => OpenSRF::Utils::interval_to_seconds($interval));
- $hold->expire_time($U->epoch2ISO8601($date->epoch));
- }
- }
-
- $hold->clear_cancel_time;
- $hold->clear_cancel_cause;
- $hold->clear_cancel_note;
- $e->update_action_hold_request($hold) or return $e->die_event;
- $e->commit;
-
- $U->storagereq('open-ils.storage.action.hold_request.copy_targeter', undef, $hold_id);
-
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "cancel_hold",
- api_name => "open-ils.circ.hold.cancel",
- signature => {
- desc => 'Cancels the specified hold. The login session is the requestor. If the requestor is different from the usr field ' .
- 'on the hold, the requestor must have CANCEL_HOLDS permissions. The hold may be either the hold object or the hold id',
- param => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Hold ID', type => 'number'},
- {desc => 'Cause of Cancellation', type => 'string'},
- {desc => 'Note', type => 'string'}
- ],
- return => {
- desc => '1 on success, event on error'
- }
- }
-);
-
-sub cancel_hold {
- my($self, $client, $auth, $holdid, $cause, $note) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $hold = $e->retrieve_action_hold_request($holdid)
- or return $e->die_event;
-
- if( $e->requestor->id ne $hold->usr ) {
- return $e->die_event unless $e->allowed('CANCEL_HOLDS');
- }
-
- if ($hold->cancel_time) {
- $e->rollback;
- return 1;
- }
-
- # If the hold is captured, reset the copy status
- if( $hold->capture_time and $hold->current_copy ) {
-
- my $copy = $e->retrieve_asset_copy($hold->current_copy)
- or return $e->die_event;
-
- if( $copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF ) {
- $logger->info("canceling hold $holdid whose item is on the holds shelf");
-# $logger->info("setting copy to status 'reshelving' on hold cancel");
-# $copy->status(OILS_COPY_STATUS_RESHELVING);
-# $copy->editor($e->requestor->id);
-# $copy->edit_date('now');
-# $e->update_asset_copy($copy) or return $e->event;
-
- } elsif( $copy->status == OILS_COPY_STATUS_IN_TRANSIT ) {
-
- my $hid = $hold->id;
- $logger->warn("! canceling hold [$hid] that is in transit");
- my $transid = $e->search_action_hold_transit_copy({hold=>$hold->id},{idlist=>1})->[0];
-
- if( $transid ) {
- my $trans = $e->retrieve_action_transit_copy($transid);
- # Leave the transit alive, but set the copy status to
- # reshelving so it will be properly reshelved when it gets back home
- if( $trans ) {
- $trans->copy_status( OILS_COPY_STATUS_RESHELVING );
- $e->update_action_transit_copy($trans) or return $e->die_event;
- }
- }
- }
- }
-
- $hold->cancel_time('now');
- $hold->cancel_cause($cause);
- $hold->cancel_note($note);
- $e->update_action_hold_request($hold)
- or return $e->die_event;
-
- delete_hold_copy_maps($self, $e, $hold->id);
-
- $e->commit;
-
- $U->create_events_for_hook('hold_request.cancel.staff', $hold, $hold->pickup_lib)
- if $e->requestor->id != $hold->usr;
-
- return 1;
-}
-
-sub delete_hold_copy_maps {
- my $class = shift;
- my $editor = shift;
- my $holdid = shift;
-
- my $maps = $editor->search_action_hold_copy_map({hold=>$holdid});
- for(@$maps) {
- $editor->delete_action_hold_copy_map($_)
- or return $editor->event;
- }
- return undef;
-}
-
-
-my $update_hold_desc = 'The login session is the requestor. ' .
- 'If the requestor is different from the usr field on the hold, ' .
- 'the requestor must have UPDATE_HOLDS permissions. ' .
- 'If supplying a hash of hold data, "id" must be included. ' .
- 'The hash is ignored if a hold object is supplied, ' .
- 'so you should supply only one kind of hold data argument.' ;
-
-__PACKAGE__->register_method(
- method => "update_hold",
- api_name => "open-ils.circ.hold.update",
- signature => {
- desc => "Updates the specified hold. $update_hold_desc",
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Hold Object', type => 'object'},
- {desc => 'Hash of values to be applied', type => 'object'}
- ],
- return => {
- desc => 'Hold ID on success, event on error',
- # type => 'number'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "batch_update_hold",
- api_name => "open-ils.circ.hold.update.batch",
- stream => 1,
- signature => {
- desc => "Updates the specified hold(s). $update_hold_desc",
- params => [
- {desc => 'Authentication token', type => 'string'},
- {desc => 'Array of hold obejcts', type => 'array' },
- {desc => 'Array of hashes of values to be applied', type => 'array' }
- ],
- return => {
- desc => 'Hold ID per success, event per error',
- }
- }
-);
-
-sub update_hold {
- my($self, $client, $auth, $hold, $values) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- my $resp = update_hold_impl($self, $e, $hold, $values);
- if ($U->event_code($resp)) {
- $e->rollback;
- return $resp;
- }
- $e->commit; # FIXME: update_hold_impl already does $e->commit ??
- return $resp;
-}
-
-sub batch_update_hold {
- my($self, $client, $auth, $hold_list, $values_list) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- my $count = ($hold_list) ? scalar(@$hold_list) : scalar(@$values_list); # FIXME: we don't know for sure that we got $values_list. we could have neither list.
- $hold_list ||= [];
- $values_list ||= []; # FIXME: either move this above $count declaration, or send an event if both lists undef. Probably the latter.
-
-# FIXME: Failing over to [] guarantees warnings for "Use of unitialized value" in update_hold_impl call.
-# FIXME: We should be sure we only call update_hold_impl with hold object OR hash, not both.
-
- for my $idx (0..$count-1) {
- $e->xact_begin;
- my $resp = update_hold_impl($self, $e, $hold_list->[$idx], $values_list->[$idx]);
- $e->xact_commit unless $U->event_code($resp);
- $client->respond($resp);
- }
-
- $e->disconnect;
- return undef; # not in the register return type, assuming we should always have at least one list populated
-}
-
-sub update_hold_impl {
- my($self, $e, $hold, $values) = @_;
-
- unless($hold) {
- $hold = $e->retrieve_action_hold_request($values->{id})
- or return $e->die_event;
- for my $k (keys %$values) {
- if (defined $values->{$k}) {
- $hold->$k($values->{$k});
- } else {
- my $f = "clear_$k"; $hold->$f();
- }
- }
- }
-
- my $orig_hold = $e->retrieve_action_hold_request($hold->id)
- or return $e->die_event;
-
- # don't allow the user to be changed
- return OpenILS::Event->new('BAD_PARAMS') if $hold->usr != $orig_hold->usr;
-
- if($hold->usr ne $e->requestor->id) {
- # if the hold is for a different user, make sure the
- # requestor has the appropriate permissions
- my $usr = $e->retrieve_actor_user($hold->usr)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('UPDATE_HOLD', $usr->home_ou);
- }
-
-
- # --------------------------------------------------------------
- # Changing the request time is like playing God
- # --------------------------------------------------------------
- if($hold->request_time ne $orig_hold->request_time) {
- return OpenILS::Event->new('BAD_PARAMS') if $hold->fulfillment_time;
- return $e->die_event unless $e->allowed('UPDATE_HOLD_REQUEST_TIME', $hold->pickup_lib);
- }
-
- # --------------------------------------------------------------
- # if the hold is on the holds shelf or in transit and the pickup
- # lib changes we need to create a new transit.
- # --------------------------------------------------------------
- if($orig_hold->pickup_lib ne $hold->pickup_lib) {
-
- my $status = _hold_status($e, $hold);
-
- if($status == 3) { # in transit
-
- return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_TRANSIT', $orig_hold->pickup_lib);
- return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_TRANSIT', $hold->pickup_lib);
-
- $logger->info("updating pickup lib for hold ".$hold->id." while already in transit");
-
- # update the transit to reflect the new pickup location
- my $transit = $e->search_action_hold_transit_copy(
- {hold=>$hold->id, dest_recv_time => undef})->[0]
- or return $e->die_event;
-
- $transit->prev_dest($transit->dest); # mark the previous destination on the transit
- $transit->dest($hold->pickup_lib);
- $e->update_action_hold_transit_copy($transit) or return $e->die_event;
-
- } elsif($status == 4) { # on holds shelf
-
- return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_HOLDS_SHELF', $orig_hold->pickup_lib);
- return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_HOLDS_SHELF', $hold->pickup_lib);
-
- $logger->info("updating pickup lib for hold ".$hold->id." while on holds shelf");
-
- # create the new transit
- my $evt = transit_hold($e, $orig_hold, $hold, $e->retrieve_asset_copy($hold->current_copy));
- return $evt if $evt;
- }
- }
-
- update_hold_if_frozen($self, $e, $hold, $orig_hold);
- $e->update_action_hold_request($hold) or return $e->die_event;
- $e->commit;
-
- # a change to mint-condition changes the set of potential copies, so retarget the hold;
- if($U->is_true($hold->mint_condition) and !$U->is_true($orig_hold->mint_condition)) {
- _reset_hold($self, $e->requestor, $hold)
- }
-
- return $hold->id;
-}
-
-sub transit_hold {
- my($e, $orig_hold, $hold, $copy) = @_;
- my $src = $orig_hold->pickup_lib;
- my $dest = $hold->pickup_lib;
-
- $logger->info("putting hold into transit on pickup_lib update");
-
- my $transit = Fieldmapper::action::hold_transit_copy->new;
- $transit->hold($hold->id);
- $transit->source($src);
- $transit->dest($dest);
- $transit->target_copy($copy->id);
- $transit->source_send_time('now');
- $transit->copy_status(OILS_COPY_STATUS_ON_HOLDS_SHELF);
-
- $copy->status(OILS_COPY_STATUS_IN_TRANSIT);
- $copy->editor($e->requestor->id);
- $copy->edit_date('now');
-
- $e->create_action_hold_transit_copy($transit) or return $e->die_event;
- $e->update_asset_copy($copy) or return $e->die_event;
- return undef;
-}
-
-# if the hold is frozen, this method ensures that the hold is not "targeted",
-# that is, it clears the current_copy and prev_check_time to essentiallly
-# reset the hold. If it is being activated, it runs the targeter in the background
-sub update_hold_if_frozen {
- my($self, $e, $hold, $orig_hold) = @_;
- return if $hold->capture_time;
-
- if($U->is_true($hold->frozen)) {
- $logger->info("clearing current_copy and check_time for frozen hold ".$hold->id);
- $hold->clear_current_copy;
- $hold->clear_prev_check_time;
-
- } else {
- if($U->is_true($orig_hold->frozen)) {
- $logger->info("Running targeter on activated hold ".$hold->id);
- $U->storagereq( 'open-ils.storage.action.hold_request.copy_targeter', undef, $hold->id );
- }
- }
-}
-
-__PACKAGE__->register_method(
- method => "hold_note_CUD",
- api_name => "open-ils.circ.hold_request.note.cud",
- signature => {
- desc => 'Create, update or delete a hold request note. If the operator (from Auth. token) '
- . 'is not the owner of the hold, the UPDATE_HOLD permission is required',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Hold note object', type => 'object' }
- ],
- return => {
- desc => 'Returns the note ID, event on error'
- },
- }
-);
-
-sub hold_note_CUD {
- my($self, $conn, $auth, $note) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $hold = $e->retrieve_action_hold_request($note->hold)
- or return $e->die_event;
-
- if($hold->usr ne $e->requestor->id) {
- my $usr = $e->retrieve_actor_user($hold->usr);
- return $e->die_event unless $e->allowed('UPDATE_HOLD', $usr->home_ou);
- $note->staff('t') if $note->isnew;
- }
-
- if($note->isnew) {
- $e->create_action_hold_request_note($note) or return $e->die_event;
- } elsif($note->ischanged) {
- $e->update_action_hold_request_note($note) or return $e->die_event;
- } elsif($note->isdeleted) {
- $e->delete_action_hold_request_note($note) or return $e->die_event;
- }
-
- $e->commit;
- return $note->id;
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_hold_status",
- api_name => "open-ils.circ.hold.status.retrieve",
- signature => {
- desc => 'Calculates the current status of the hold. The requestor must have ' .
- 'VIEW_HOLD permissions if the hold is for a user other than the requestor' ,
- param => [
- { desc => 'Hold ID', type => 'number' }
- ],
- return => {
- # type => 'number', # event sometimes
- desc => <<'END_OF_DESC'
-Returns event on error or:
--1 on error (for now),
- 1 for 'waiting for copy to become available',
- 2 for 'waiting for copy capture',
- 3 for 'in transit',
- 4 for 'arrived',
- 5 for 'hold-shelf-delay'
- 6 for 'canceled'
-END_OF_DESC
- }
- }
-);
-
-sub retrieve_hold_status {
- my($self, $client, $auth, $hold_id) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- my $hold = $e->retrieve_action_hold_request($hold_id)
- or return $e->event;
-
- if( $e->requestor->id != $hold->usr ) {
- return $e->event unless $e->allowed('VIEW_HOLD');
- }
-
- return _hold_status($e, $hold);
-
-}
-
-sub _hold_status {
- my($e, $hold) = @_;
- if ($hold->cancel_time) {
- return 6;
- }
- return 1 unless $hold->current_copy;
- return 2 unless $hold->capture_time;
-
- my $copy = $hold->current_copy;
- unless( ref $copy ) {
- $copy = $e->retrieve_asset_copy($hold->current_copy)
- or return $e->event;
- }
-
- return 3 if $copy->status == OILS_COPY_STATUS_IN_TRANSIT;
-
- if($copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF) {
-
- my $hs_wait_interval = $U->ou_ancestor_setting_value($hold->pickup_lib, 'circ.hold_shelf_status_delay');
- return 4 unless $hs_wait_interval;
-
- # if a hold_shelf_status_delay interval is defined and start_time plus
- # the interval is greater than now, consider the hold to be in the virtual
- # "on its way to the holds shelf" status. Return 5.
-
- my $transit = $e->search_action_hold_transit_copy({hold => $hold->id})->[0];
- my $start_time = ($transit) ? $transit->dest_recv_time : $hold->capture_time;
- $start_time = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($start_time));
- my $end_time = $start_time->add(seconds => OpenSRF::Utils::interval_to_seconds($hs_wait_interval));
-
- return 5 if $end_time > DateTime->now;
- return 4;
- }
-
- return -1; # error
-}
-
-
-
-__PACKAGE__->register_method(
- method => "retrieve_hold_queue_stats",
- api_name => "open-ils.circ.hold.queue_stats.retrieve",
- signature => {
- desc => 'Returns summary data about the state of a hold',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Hold ID', type => 'number'},
- ],
- return => {
- desc => q/Summary object with keys:
- total_holds : total holds in queue
- queue_position : current queue position
- potential_copies : number of potential copies for this hold
- estimated_wait : estimated wait time in days
- status : hold status
- -1 => error or unexpected state,
- 1 => 'waiting for copy to become available',
- 2 => 'waiting for copy capture',
- 3 => 'in transit',
- 4 => 'arrived',
- 5 => 'hold-shelf-delay'
- /,
- type => 'object'
- }
- }
-);
-
-sub retrieve_hold_queue_stats {
- my($self, $conn, $auth, $hold_id) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- my $hold = $e->retrieve_action_hold_request($hold_id) or return $e->event;
- if($e->requestor->id != $hold->usr) {
- return $e->event unless $e->allowed('VIEW_HOLD');
- }
- return retrieve_hold_queue_status_impl($e, $hold);
-}
-
-sub retrieve_hold_queue_status_impl {
- my $e = shift;
- my $hold = shift;
-
- # The holds queue is defined as the distinct set of holds that share at
- # least one potential copy with the context hold, plus any holds that
- # share the same hold type and target. The latter part exists to
- # accomodate holds that currently have no potential copies
- my $q_holds = $e->json_query({
-
- # fetch cut_in_line and request_time since they're in the order_by
- # and we're asking for distinct values
- select => {ahr => ['id', 'cut_in_line', 'request_time']},
- from => { ahr => 'ahcm' },
- order_by => [
- {
- "class" => "ahr",
- "field" => "cut_in_line",
- "transform" => "coalesce",
- "params" => [ 0 ],
- "direction" => "desc"
- },
- { "class" => "ahr", "field" => "request_time" }
- ],
- distinct => 1,
- where => {
- '+ahcm' => {
- target_copy => {
- in => {
- select => {ahcm => ['target_copy']},
- from => 'ahcm',
- where => {hold => $hold->id}
- }
- }
- }
- }
- });
-
- if (!@$q_holds) { # none? maybe we don't have a map ...
- $q_holds = $e->json_query({
- select => {ahr => ['id', 'cut_in_line', 'request_time']},
- from => 'ahr',
- order_by => [
- {
- "class" => "ahr",
- "field" => "cut_in_line",
- "transform" => "coalesce",
- "params" => [ 0 ],
- "direction" => "desc"
- },
- { "class" => "ahr", "field" => "request_time" }
- ],
- where => {
- hold_type => $hold->hold_type,
- target => $hold->target
- }
- });
- }
-
-
- my $qpos = 1;
- for my $h (@$q_holds) {
- last if $h->{id} == $hold->id;
- $qpos++;
- }
-
- my $hold_data = $e->json_query({
- select => {
- acp => [ {column => 'id', transform => 'count', aggregate => 1, alias => 'count'} ],
- ccm => [ {column =>'avg_wait_time'} ]
- },
- from => {
- ahcm => {
- acp => {
- join => {
- ccm => {type => 'left'}
- }
- }
- }
- },
- where => {'+ahcm' => {hold => $hold->id} }
- });
-
- my $user_org = $e->json_query({select => {au => ['home_ou']}, from => 'au', where => {id => $hold->usr}})->[0]->{home_ou};
-
- my $default_wait = $U->ou_ancestor_setting_value($user_org, OILS_SETTING_HOLD_ESIMATE_WAIT_INTERVAL);
- my $min_wait = $U->ou_ancestor_setting_value($user_org, 'circ.holds.min_estimated_wait_interval');
- $min_wait = OpenSRF::Utils::interval_to_seconds($min_wait || '0 seconds');
- $default_wait ||= '0 seconds';
-
- # Estimated wait time is the average wait time across the set
- # of potential copies, divided by the number of potential copies
- # times the queue position.
-
- my $combined_secs = 0;
- my $num_potentials = 0;
-
- for my $wait_data (@$hold_data) {
- my $count += $wait_data->{count};
- $combined_secs += $count *
- OpenSRF::Utils::interval_to_seconds($wait_data->{avg_wait_time} || $default_wait);
- $num_potentials += $count;
- }
-
- my $estimated_wait = -1;
-
- if($num_potentials) {
- my $avg_wait = $combined_secs / $num_potentials;
- $estimated_wait = $qpos * ($avg_wait / $num_potentials);
- $estimated_wait = $min_wait if $estimated_wait < $min_wait and $estimated_wait != -1;
- }
-
- return {
- total_holds => scalar(@$q_holds),
- queue_position => $qpos,
- potential_copies => $num_potentials,
- status => _hold_status( $e, $hold ),
- estimated_wait => int($estimated_wait)
- };
-}
-
-
-sub fetch_open_hold_by_current_copy {
- my $class = shift;
- my $copyid = shift;
- my $hold = $apputils->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.action.hold_request.search.atomic',
- { current_copy => $copyid , cancel_time => undef, fulfillment_time => undef });
- return $hold->[0] if ref($hold);
- return undef;
-}
-
-sub fetch_related_holds {
- my $class = shift;
- my $copyid = shift;
- return $apputils->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.action.hold_request.search.atomic',
- { current_copy => $copyid , cancel_time => undef, fulfillment_time => undef });
-}
-
-
-__PACKAGE__->register_method(
- method => "hold_pull_list",
- api_name => "open-ils.circ.hold_pull_list.retrieve",
- signature => {
- desc => 'Returns (reference to) a list of holds that need to be "pulled" by a given location. ' .
- 'The location is determined by the login session.',
- params => [
- { desc => 'Limit (optional)', type => 'number'},
- { desc => 'Offset (optional)', type => 'number'},
- ],
- return => {
- desc => 'reference to a list of holds, or event on failure',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "hold_pull_list",
- api_name => "open-ils.circ.hold_pull_list.id_list.retrieve",
- signature => {
- desc => 'Returns (reference to) a list of holds IDs that need to be "pulled" by a given location. ' .
- 'The location is determined by the login session.',
- params => [
- { desc => 'Limit (optional)', type => 'number'},
- { desc => 'Offset (optional)', type => 'number'},
- ],
- return => {
- desc => 'reference to a list of holds, or event on failure',
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "hold_pull_list",
- api_name => "open-ils.circ.hold_pull_list.retrieve.count",
- signature => {
- desc => 'Returns a count of holds that need to be "pulled" by a given location. ' .
- 'The location is determined by the login session.',
- params => [
- { desc => 'Limit (optional)', type => 'number'},
- { desc => 'Offset (optional)', type => 'number'},
- ],
- return => {
- desc => 'Holds count (integer), or event on failure',
- # type => 'number'
- }
- }
-);
-
-
-sub hold_pull_list {
- my( $self, $conn, $authtoken, $limit, $offset ) = @_;
- my( $reqr, $evt ) = $U->checkses($authtoken);
- return $evt if $evt;
-
- my $org = $reqr->ws_ou || $reqr->home_ou;
- # the perm locaiton shouldn't really matter here since holds
- # will exist all over and VIEW_HOLDS should be universal
- $evt = $U->check_perms($reqr->id, $org, 'VIEW_HOLD');
- return $evt if $evt;
-
- if($self->api_name =~ /count/) {
-
- my $count = $U->storagereq(
- 'open-ils.storage.direct.action.hold_request.pull_list.current_copy_circ_lib.status_filtered.count',
- $org, $limit, $offset );
-
- $logger->info("Grabbing pull list for org unit $org with $count items");
- return $count;
-
- } elsif( $self->api_name =~ /id_list/ ) {
- return $U->storagereq(
- 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib.status_filtered.atomic',
- $org, $limit, $offset );
-
- } else {
- return $U->storagereq(
- 'open-ils.storage.direct.action.hold_request.pull_list.search.current_copy_circ_lib.status_filtered.atomic',
- $org, $limit, $offset );
- }
-}
-
-__PACKAGE__->register_method(
- method => "print_hold_pull_list",
- api_name => "open-ils.circ.hold_pull_list.print",
- signature => {
- desc => 'Returns an HTML-formatted holds pull list',
- params => [
- { desc => 'Authtoken', type => 'string'},
- { desc => 'Org unit ID. Optional, defaults to workstation org unit', type => 'number'},
- ],
- return => {
- desc => 'HTML string',
- type => 'string'
- }
- }
-);
-
-sub print_hold_pull_list {
- my($self, $client, $auth, $org_id) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
-
- $org_id = (defined $org_id) ? $org_id : $e->requestor->ws_ou;
- return $e->event unless $e->allowed('VIEW_HOLD', $org_id);
-
- my $hold_ids = $U->storagereq(
- 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib.status_filtered.atomic',
- $org_id, 10000);
-
- return undef unless @$hold_ids;
-
- $client->status(new OpenSRF::DomainObject::oilsContinueStatus);
-
- # Holds will /NOT/ be in order after this ...
- my $holds = $e->search_action_hold_request({id => $hold_ids}, {substream => 1});
- $client->status(new OpenSRF::DomainObject::oilsContinueStatus);
-
- # ... so we must resort.
- my $hold_map = +{map { $_->id => $_ } @$holds};
- my $sorted_holds = [];
- push @$sorted_holds, $hold_map->{$_} foreach @$hold_ids;
-
- return $U->fire_object_event(
- undef, "ahr.format.pull_list", $sorted_holds,
- $org_id, undef, undef, $client
- );
-
-}
-
-__PACKAGE__->register_method(
- method => "print_hold_pull_list_stream",
- stream => 1,
- api_name => "open-ils.circ.hold_pull_list.print.stream",
- signature => {
- desc => 'Returns a stream of fleshed holds',
- params => [
- { desc => 'Authtoken', type => 'string'},
- { desc => 'Hash of optional param: Org unit ID (defaults to workstation org unit), limit, offset, sort (array of: acplo.position, call_number, request_time)',
- type => 'object'
- },
- ],
- return => {
- desc => 'A stream of fleshed holds',
- type => 'object'
- }
- }
-);
-
-sub print_hold_pull_list_stream {
- my($self, $client, $auth, $params) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
-
- delete($$params{org_id}) unless (int($$params{org_id}));
- delete($$params{limit}) unless (int($$params{limit}));
- delete($$params{offset}) unless (int($$params{offset}));
- delete($$params{chunk_size}) unless (int($$params{chunk_size}));
- delete($$params{chunk_size}) if ($$params{chunk_size} && $$params{chunk_size} > 50); # keep the size reasonable
- $$params{chunk_size} ||= 10;
-
- $$params{org_id} = (defined $$params{org_id}) ? $$params{org_id}: $e->requestor->ws_ou;
- return $e->die_event unless $e->allowed('VIEW_HOLD', $$params{org_id });
-
- my $sort = [];
- if ($$params{sort} && @{ $$params{sort} }) {
- for my $s (@{ $$params{sort} }) {
- if ($s eq 'acplo.position') {
- push @$sort, {
- "class" => "acplo", "field" => "position",
- "transform" => "coalesce", "params" => [999]
- };
- } elsif ($s eq 'call_number') {
- push @$sort, {"class" => "acn", "field" => "label"};
- } elsif ($s eq 'request_time') {
- push @$sort, {"class" => "ahr", "field" => "request_time"};
- }
- }
- } else {
- push @$sort, {"class" => "ahr", "field" => "request_time"};
- }
-
- my $holds_ids = $e->json_query(
- {
- "select" => {"ahr" => ["id"]},
- "from" => {
- "ahr" => {
- "acp" => {
- "field" => "id",
- "fkey" => "current_copy",
- "filter" => {
- "circ_lib" => $$params{org_id}, "status" => [0,7]
- },
- "join" => {
- "acn" => {
- "field" => "id",
- "fkey" => "call_number"
- },
- "acplo" => {
- "field" => "org",
- "fkey" => "circ_lib",
- "type" => "left",
- "filter" => {
- "location" => {"=" => {"+acp" => "location"}}
- }
- }
- }
- }
- }
- },
- "where" => {
- "+ahr" => {
- "capture_time" => undef,
- "cancel_time" => undef,
- "-or" => [
- {"expire_time" => undef },
- {"expire_time" => {">" => "now"}}
- ]
- }
- },
- (@$sort ? (order_by => $sort) : ()),
- ($$params{limit} ? (limit => $$params{limit}) : ()),
- ($$params{offset} ? (offset => $$params{offset}) : ())
- }, {"substream" => 1}
- ) or return $e->die_event;
-
- $logger->info("about to stream back " . scalar(@$holds_ids) . " holds");
-
- my @chunk;
- for my $hid (@$holds_ids) {
- push @chunk, $e->retrieve_action_hold_request([
- $hid->{"id"}, {
- "flesh" => 3,
- "flesh_fields" => {
- "ahr" => ["usr", "current_copy"],
- "au" => ["card"],
- "acp" => ["location", "call_number"],
- "acn" => ["record"]
- }
- }
- ]);
-
- if (@chunk >= $$params{chunk_size}) {
- $client->respond( \@chunk );
- @chunk = ();
- }
- }
- $client->respond_complete( \@chunk ) if (@chunk);
- $e->disconnect;
- return undef;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_hold_notify',
- api_name => 'open-ils.circ.hold_notification.retrieve_by_hold',
- authoritative => 1,
- signature => q/
-Returns a list of hold notification objects based on hold id.
-@param authtoken The loggin session key
-@param holdid The id of the hold whose notifications we want to retrieve
-@return An array of hold notification objects, event on error.
-/
-);
-
-sub fetch_hold_notify {
- my( $self, $conn, $authtoken, $holdid ) = @_;
- my( $requestor, $evt ) = $U->checkses($authtoken);
- return $evt if $evt;
- my ($hold, $patron);
- ($hold, $evt) = $U->fetch_hold($holdid);
- return $evt if $evt;
- ($patron, $evt) = $U->fetch_user($hold->usr);
- return $evt if $evt;
-
- $evt = $U->check_perms($requestor->id, $patron->home_ou, 'VIEW_HOLD_NOTIFICATION');
- return $evt if $evt;
-
- $logger->info("User ".$requestor->id." fetching hold notifications for hold $holdid");
- return $U->cstorereq(
- 'open-ils.cstore.direct.action.hold_notification.search.atomic', {hold => $holdid} );
-}
-
-
-__PACKAGE__->register_method(
- method => 'create_hold_notify',
- api_name => 'open-ils.circ.hold_notification.create',
- signature => q/
-Creates a new hold notification object
-@param authtoken The login session key
-@param notification The hold notification object to create
-@return ID of the new object on success, Event on error
-/
-);
-
-sub create_hold_notify {
- my( $self, $conn, $auth, $note ) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $hold = $e->retrieve_action_hold_request($note->hold)
- or return $e->die_event;
- my $patron = $e->retrieve_actor_user($hold->usr)
- or return $e->die_event;
-
- return $e->die_event unless
- $e->allowed('CREATE_HOLD_NOTIFICATION', $patron->home_ou);
-
- $note->notify_staff($e->requestor->id);
- $e->create_action_hold_notification($note) or return $e->die_event;
- $e->commit;
- return $note->id;
-}
-
-__PACKAGE__->register_method(
- method => 'create_hold_note',
- api_name => 'open-ils.circ.hold_note.create',
- signature => q/
- Creates a new hold request note object
- @param authtoken The login session key
- @param note The hold note object to create
- @return ID of the new object on success, Event on error
- /
-);
-
-sub create_hold_note {
- my( $self, $conn, $auth, $note ) = @_;
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $hold = $e->retrieve_action_hold_request($note->hold)
- or return $e->die_event;
- my $patron = $e->retrieve_actor_user($hold->usr)
- or return $e->die_event;
-
- return $e->die_event unless
- $e->allowed('UPDATE_HOLD', $patron->home_ou); # FIXME: Using permcrud perm listed in fm_IDL.xml for ahrn. Probably want something more specific
-
- $e->create_action_hold_request_note($note) or return $e->die_event;
- $e->commit;
- return $note->id;
-}
-
-__PACKAGE__->register_method(
- method => 'reset_hold',
- api_name => 'open-ils.circ.hold.reset',
- signature => q/
- Un-captures and un-targets a hold, essentially returning
- it to the state it was in directly after it was placed,
- then attempts to re-target the hold
- @param authtoken The login session key
- @param holdid The id of the hold
- /
-);
-
-
-sub reset_hold {
- my( $self, $conn, $auth, $holdid ) = @_;
- my $reqr;
- my ($hold, $evt) = $U->fetch_hold($holdid);
- return $evt if $evt;
- ($reqr, $evt) = $U->checksesperm($auth, 'UPDATE_HOLD');
- return $evt if $evt;
- $evt = _reset_hold($self, $reqr, $hold);
- return $evt if $evt;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'reset_hold_batch',
- api_name => 'open-ils.circ.hold.reset.batch'
-);
-
-sub reset_hold_batch {
- my($self, $conn, $auth, $hold_ids) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- for my $hold_id ($hold_ids) {
-
- my $hold = $e->retrieve_action_hold_request(
- [$hold_id, {flesh => 1, flesh_fields => {ahr => ['usr']}}])
- or return $e->event;
-
- next unless $e->allowed('UPDATE_HOLD', $hold->usr->home_ou);
- _reset_hold($self, $e->requestor, $hold);
- }
-
- return 1;
-}
-
-
-sub _reset_hold {
- my ($self, $reqr, $hold) = @_;
-
- my $e = new_editor(xact =>1, requestor => $reqr);
-
- $logger->info("reseting hold ".$hold->id);
-
- my $hid = $hold->id;
-
- if( $hold->capture_time and $hold->current_copy ) {
-
- my $copy = $e->retrieve_asset_copy($hold->current_copy)
- or return $e->die_event;
-
- if( $copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF ) {
- $logger->info("setting copy to status 'reshelving' on hold retarget");
- $copy->status(OILS_COPY_STATUS_RESHELVING);
- $copy->editor($e->requestor->id);
- $copy->edit_date('now');
- $e->update_asset_copy($copy) or return $e->die_event;
-
- } elsif( $copy->status == OILS_COPY_STATUS_IN_TRANSIT ) {
-
- # We don't want the copy to remain "in transit"
- $copy->status(OILS_COPY_STATUS_RESHELVING);
- $logger->warn("! reseting hold [$hid] that is in transit");
- my $transid = $e->search_action_hold_transit_copy({hold=>$hold->id},{idlist=>1})->[0];
-
- if( $transid ) {
- my $trans = $e->retrieve_action_transit_copy($transid);
- if( $trans ) {
- $logger->info("Aborting transit [$transid] on hold [$hid] reset...");
- my $evt = OpenILS::Application::Circ::Transit::__abort_transit($e, $trans, $copy, 1);
- $logger->info("Transit abort completed with result $evt");
- unless ("$evt" eq 1) {
- $e->rollback;
- return $evt;
- }
- }
- }
- }
- }
-
- $hold->clear_capture_time;
- $hold->clear_current_copy;
- $hold->clear_shelf_time;
- $hold->clear_shelf_expire_time;
-
- $e->update_action_hold_request($hold) or return $e->die_event;
- $e->commit;
-
- $U->storagereq(
- 'open-ils.storage.action.hold_request.copy_targeter', undef, $hold->id );
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_open_title_holds',
- api_name => 'open-ils.circ.open_holds.retrieve',
- signature => q/
- Returns a list ids of un-fulfilled holds for a given title id
- @param authtoken The login session key
- @param id the id of the item whose holds we want to retrieve
- @param type The hold type - M, T, I, V, C, F, R
- /
-);
-
-sub fetch_open_title_holds {
- my( $self, $conn, $auth, $id, $type, $org ) = @_;
- my $e = new_editor( authtoken => $auth );
- return $e->event unless $e->checkauth;
-
- $type ||= "T";
- $org ||= $e->requestor->ws_ou;
-
-# return $e->search_action_hold_request(
-# { target => $id, hold_type => $type, fulfillment_time => undef }, {idlist=>1});
-
- # XXX make me return IDs in the future ^--
- my $holds = $e->search_action_hold_request(
- {
- target => $id,
- cancel_time => undef,
- hold_type => $type,
- fulfillment_time => undef
- }
- );
-
- flesh_hold_transits($holds);
- return $holds;
-}
-
-
-sub flesh_hold_transits {
- my $holds = shift;
- for my $hold ( @$holds ) {
- $hold->transit(
- $apputils->simplereq(
- 'open-ils.cstore',
- "open-ils.cstore.direct.action.hold_transit_copy.search.atomic",
- { hold => $hold->id },
- { order_by => { ahtc => 'id desc' }, limit => 1 }
- )->[0]
- );
- }
-}
-
-sub flesh_hold_notices {
- my( $holds, $e ) = @_;
- $e ||= new_editor();
-
- for my $hold (@$holds) {
- my $notices = $e->search_action_hold_notification(
- [
- { hold => $hold->id },
- { order_by => { anh => 'notify_time desc' } },
- ],
- {idlist=>1}
- );
-
- $hold->notify_count(scalar(@$notices));
- if( @$notices ) {
- my $n = $e->retrieve_action_hold_notification($$notices[0])
- or return $e->event;
- $hold->notify_time($n->notify_time);
- }
- }
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_captured_holds',
- api_name => 'open-ils.circ.captured_holds.on_shelf.retrieve',
- stream => 1,
- signature => q/
- Returns a list of un-fulfilled holds (on the Holds Shelf) for a given title id
- @param authtoken The login session key
- @param org The org id of the location in question
- /
-);
-
-__PACKAGE__->register_method(
- method => 'fetch_captured_holds',
- api_name => 'open-ils.circ.captured_holds.id_list.on_shelf.retrieve',
- stream => 1,
- signature => q/
- Returns list ids of un-fulfilled holds (on the Holds Shelf) for a given title id
- @param authtoken The login session key
- @param org The org id of the location in question
- /
-);
-
-__PACKAGE__->register_method(
- method => 'fetch_captured_holds',
- api_name => 'open-ils.circ.captured_holds.id_list.expired_on_shelf.retrieve',
- stream => 1,
- signature => q/
- Returns list ids of shelf-expired un-fulfilled holds for a given title id
- @param authtoken The login session key
- @param org The org id of the location in question
- /
-);
-
-
-sub fetch_captured_holds {
- my( $self, $conn, $auth, $org ) = @_;
-
- my $e = new_editor(authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('VIEW_HOLD'); # XXX rely on editor perm
-
- $org ||= $e->requestor->ws_ou;
-
- my $query = {
- select => { ahr => ['id'] },
- from => {
- ahr => {
- acp => {
- field => 'id',
- fkey => 'current_copy'
- },
- }
- },
- where => {
- '+acp' => { status => OILS_COPY_STATUS_ON_HOLDS_SHELF },
- '+ahr' => {
- capture_time => { "!=" => undef },
- current_copy => { "!=" => undef },
- fulfillment_time => undef,
- pickup_lib => $org,
- cancel_time => undef,
- }
- }
- };
- if($self->api_name =~ /expired/) {
- $query->{'where'}->{'+ahr'}->{'shelf_expire_time'} = {'<' => 'now'};
- $query->{'where'}->{'+ahr'}->{'shelf_time'} = {'!=' => undef};
- }
- my $hold_ids = $e->json_query( $query );
-
- for my $hold_id (@$hold_ids) {
- if($self->api_name =~ /id_list/) {
- $conn->respond($hold_id->{id});
- next;
- } else {
- $conn->respond(
- $e->retrieve_action_hold_request([
- $hold_id->{id},
- {
- flesh => 1,
- flesh_fields => {ahr => ['notifications', 'transit', 'notes']},
- order_by => {anh => 'notify_time desc'}
- }
- ])
- );
- }
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "print_expired_holds_stream",
- api_name => "open-ils.circ.captured_holds.expired.print.stream",
- stream => 1
-);
-
-sub print_expired_holds_stream {
- my ($self, $client, $auth, $params) = @_;
-
- # No need to check specific permissions: we're going to call another method
- # that will do that.
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- delete($$params{org_id}) unless (int($$params{org_id}));
- delete($$params{limit}) unless (int($$params{limit}));
- delete($$params{offset}) unless (int($$params{offset}));
- delete($$params{chunk_size}) unless (int($$params{chunk_size}));
- delete($$params{chunk_size}) if ($$params{chunk_size} && $$params{chunk_size} > 50); # keep the size reasonable
- $$params{chunk_size} ||= 10;
-
- $$params{org_id} = (defined $$params{org_id}) ? $$params{org_id}: $e->requestor->ws_ou;
-
- my @hold_ids = $self->method_lookup(
- "open-ils.circ.captured_holds.id_list.expired_on_shelf.retrieve"
- )->run($auth, $params->{"org_id"});
-
- if (!@hold_ids) {
- $e->disconnect;
- return;
- } elsif (defined $U->event_code($hold_ids[0])) {
- $e->disconnect;
- return $hold_ids[0];
- }
-
- $logger->info("about to stream back up to " . scalar(@hold_ids) . " expired holds");
-
- while (@hold_ids) {
- my @hid_chunk = splice @hold_ids, 0, $params->{"chunk_size"};
-
- my $result_chunk = $e->json_query({
- "select" => {
- "acp" => ["barcode"],
- "au" => [qw/
- first_given_name second_given_name family_name alias
- /],
- "acn" => ["label"],
- "bre" => ["marc"],
- "acpl" => ["name"]
- },
- "from" => {
- "ahr" => {
- "acp" => {
- "field" => "id", "fkey" => "current_copy",
- "join" => {
- "acn" => {
- "field" => "id", "fkey" => "call_number",
- "join" => {
- "bre" => {
- "field" => "id", "fkey" => "record"
- }
- }
- },
- "acpl" => {"field" => "id", "fkey" => "location"}
- }
- },
- "au" => {"field" => "id", "fkey" => "usr"}
- }
- },
- "where" => {"+ahr" => {"id" => \@hid_chunk}}
- }) or return $e->die_event;
- $client->respond($result_chunk);
- }
-
- $e->disconnect;
- undef;
-}
-
-__PACKAGE__->register_method(
- method => "check_title_hold_batch",
- api_name => "open-ils.circ.title_hold.is_possible.batch",
- stream => 1,
- signature => {
- desc => '@see open-ils.circ.title_hold.is_possible.batch',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Array of Hash of named parameters', type => 'array'},
- ],
- return => {
- desc => 'Array of response objects',
- type => 'array'
- }
- }
-);
-
-sub check_title_hold_batch {
- my($self, $client, $authtoken, $param_list) = @_;
- foreach (@$param_list) {
- my ($res) = $self->method_lookup('open-ils.circ.title_hold.is_possible')->run($authtoken, $_);
- $client->respond($res);
- }
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "check_title_hold",
- api_name => "open-ils.circ.title_hold.is_possible",
- signature => {
- desc => 'Determines if a hold were to be placed by a given user, ' .
- 'whether or not said hold would have any potential copies to fulfill it.' .
- 'The named paramaters of the second argument include: ' .
- 'patronid, titleid, volume_id, copy_id, mrid, depth, pickup_lib, hold_type, selection_ou. ' .
- 'See perldoc ' . __PACKAGE__ . ' for more info on these fields.' ,
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Hash of named parameters', type => 'object'},
- ],
- return => {
- desc => 'List of new message IDs (empty if none)',
- type => 'array'
- }
- }
-);
-
-=head3 check_title_hold (token, hash)
-
-The named fields in the hash are:
-
- patronid - ID of the hold recipient (required)
- depth - hold range depth (default 0)
- pickup_lib - destination for hold, fallback value for selection_ou
- selection_ou - ID of org_unit establishing hard and soft hold boundary settings
- issuanceid - ID of the issuance to be held, required for Issuance level hold
- titleid - ID (BRN) of the title to be held, required for Title level hold
- volume_id - required for Volume level hold
- copy_id - required for Copy level hold
- mrid - required for Meta-record level hold
- hold_type - T, C (or R or F), I, V or M for Title, Copy, Issuance, Volume or Meta-record (default "T")
-
-All key/value pairs are passed on to do_possibility_checks.
-
-=cut
-
-# FIXME: better params checking. what other params are required, if any?
-# FIXME: 3 copies of values confusing: $x, $params->{x} and $params{x}
-# FIXME: for example, $depth gets a default value, but then $$params{depth} is still
-# used in conditionals, where it may be undefined, causing a warning.
-# FIXME: specify proper usage/interaction of selection_ou and pickup_lib
-
-sub check_title_hold {
- my( $self, $client, $authtoken, $params ) = @_;
- my $e = new_editor(authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- my %params = %$params;
- my $depth = $params{depth} || 0;
- my $selection_ou = $params{selection_ou} || $params{pickup_lib};
-
- my $patron = $e->retrieve_actor_user($params{patronid})
- or return $e->event;
-
- if( $e->requestor->id ne $patron->id ) {
- return $e->event unless
- $e->allowed('VIEW_HOLD_PERMIT', $patron->home_ou);
- }
-
- return OpenILS::Event->new('PATRON_BARRED') if $U->is_true($patron->barred);
-
- my $request_lib = $e->retrieve_actor_org_unit($e->requestor->ws_ou)
- or return $e->event;
-
- my $soft_boundary = $U->ou_ancestor_setting_value($selection_ou, OILS_SETTING_HOLD_SOFT_BOUNDARY);
- my $hard_boundary = $U->ou_ancestor_setting_value($selection_ou, OILS_SETTING_HOLD_HARD_BOUNDARY);
-
- my @status = ();
- my $return_depth = $hard_boundary; # default depth to return on success
- if(defined $soft_boundary and $depth < $soft_boundary) {
- # work up the tree and as soon as we find a potential copy, use that depth
- # also, make sure we don't go past the hard boundary if it exists
-
- # our min boundary is the greater of user-specified boundary or hard boundary
- my $min_depth = (defined $hard_boundary and $hard_boundary > $depth) ?
- $hard_boundary : $depth;
-
- my $depth = $soft_boundary;
- while($depth >= $min_depth) {
- $logger->info("performing hold possibility check with soft boundary $depth");
- @status = do_possibility_checks($e, $patron, $request_lib, $depth, %params);
- if ($status[0]) {
- $return_depth = $depth;
- last;
- }
- $depth--;
- }
- } elsif(defined $hard_boundary and $depth < $hard_boundary) {
- # there is no soft boundary, enforce the hard boundary if it exists
- $logger->info("performing hold possibility check with hard boundary $hard_boundary");
- @status = do_possibility_checks($e, $patron, $request_lib, $hard_boundary, %params);
- } else {
- # no boundaries defined, fall back to user specifed boundary or no boundary
- $logger->info("performing hold possibility check with no boundary");
- @status = do_possibility_checks($e, $patron, $request_lib, $params{depth}, %params);
- }
-
- if ($status[0]) {
- return {
- "success" => 1,
- "depth" => $return_depth,
- "local_avail" => $status[1]
- };
- } elsif ($status[2]) {
- my $n = scalar @{$status[2]};
- return {"success" => 0, "last_event" => $status[2]->[$n - 1]};
- } else {
- return {"success" => 0};
- }
-}
-
-
-
-sub do_possibility_checks {
- my($e, $patron, $request_lib, $depth, %params) = @_;
-
- my $issuanceid = $params{issuanceid} || "";
- my $titleid = $params{titleid} || "";
- my $volid = $params{volume_id};
- my $copyid = $params{copy_id};
- my $mrid = $params{mrid} || "";
- my $pickup_lib = $params{pickup_lib};
- my $hold_type = $params{hold_type} || 'T';
- my $selection_ou = $params{selection_ou} || $pickup_lib;
-
-
- my $copy;
- my $volume;
- my $title;
-
- if( $hold_type eq OILS_HOLD_TYPE_FORCE || $hold_type eq OILS_HOLD_TYPE_RECALL || $hold_type eq OILS_HOLD_TYPE_COPY ) {
-
- return $e->event unless $copy = $e->retrieve_asset_copy($copyid);
- return $e->event unless $volume = $e->retrieve_asset_call_number($copy->call_number);
- return $e->event unless $title = $e->retrieve_biblio_record_entry($volume->record);
-
- return verify_copy_for_hold(
- $patron, $e->requestor, $title, $copy, $pickup_lib, $request_lib
- );
-
- } elsif( $hold_type eq OILS_HOLD_TYPE_VOLUME ) {
-
- return $e->event unless $volume = $e->retrieve_asset_call_number($volid);
- return $e->event unless $title = $e->retrieve_biblio_record_entry($volume->record);
-
- return _check_volume_hold_is_possible(
- $volume, $title, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
- );
-
- } elsif( $hold_type eq OILS_HOLD_TYPE_TITLE ) {
-
- return _check_title_hold_is_possible(
- $titleid, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
- );
-
- } elsif( $hold_type eq OILS_HOLD_TYPE_ISSUANCE ) {
-
- return _check_issuance_hold_is_possible(
- $issuanceid, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
- );
-
- } elsif( $hold_type eq OILS_HOLD_TYPE_METARECORD ) {
-
- my $maps = $e->search_metabib_metarecord_source_map({metarecord=>$mrid});
- my @recs = map { $_->source } @$maps;
- my @status = ();
- for my $rec (@recs) {
- @status = _check_title_hold_is_possible(
- $rec, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
- );
- last if $status[1];
- }
- return @status;
- }
-# else { Unrecognized hold_type ! } # FIXME: return error? or 0?
-}
-
-my %prox_cache;
-sub create_ranged_org_filter {
- my($e, $selection_ou, $depth) = @_;
-
- # find the orgs from which this hold may be fulfilled,
- # based on the selection_ou and depth
-
- my $top_org = $e->search_actor_org_unit([
- {parent_ou => undef},
- {flesh=>1, flesh_fields=>{aou=>['ou_type']}}])->[0];
- my %org_filter;
-
- return () if $depth == $top_org->ou_type->depth;
-
- my $org_list = $U->storagereq('open-ils.storage.actor.org_unit.descendants.atomic', $selection_ou, $depth);
- %org_filter = (circ_lib => []);
- push(@{$org_filter{circ_lib}}, $_->id) for @$org_list;
-
- $logger->info("hold org filter at depth $depth and selection_ou ".
- "$selection_ou created list of @{$org_filter{circ_lib}}");
-
- return %org_filter;
-}
-
-
-sub _check_title_hold_is_possible {
- my( $titleid, $depth, $request_lib, $patron, $requestor, $pickup_lib, $selection_ou ) = @_;
-
- my $e = new_editor();
- my %org_filter = create_ranged_org_filter($e, $selection_ou, $depth);
-
- # this monster will grab the id and circ_lib of all of the "holdable" copies for the given record
- my $copies = $e->json_query(
- {
- select => { acp => ['id', 'circ_lib'] },
- from => {
- acp => {
- acn => {
- field => 'id',
- fkey => 'call_number',
- 'join' => {
- bre => {
- field => 'id',
- filter => { id => $titleid },
- fkey => 'record'
- }
- }
- },
- acpl => { field => 'id', filter => { holdable => 't'}, fkey => 'location' },
- ccs => { field => 'id', filter => { holdable => 't'}, fkey => 'status' }
- }
- },
- where => {
- '+acp' => { circulate => 't', deleted => 'f', holdable => 't', %org_filter }
- }
- }
- );
-
- $logger->info("title possible found ".scalar(@$copies)." potential copies");
- return (
- 0, 0, [
- new OpenILS::Event(
- "HIGH_LEVEL_HOLD_HAS_NO_COPIES",
- "payload" => {"fail_part" => "no_ultimate_items"}
- )
- ]
- ) unless @$copies;
-
- # -----------------------------------------------------------------------
- # sort the copies into buckets based on their circ_lib proximity to
- # the patron's home_ou.
- # -----------------------------------------------------------------------
-
- my $home_org = $patron->home_ou;
- my $req_org = $request_lib->id;
-
- $logger->info("prox cache $home_org " . $prox_cache{$home_org});
-
- $prox_cache{$home_org} =
- $e->search_actor_org_unit_proximity({from_org => $home_org})
- unless $prox_cache{$home_org};
- my $home_prox = $prox_cache{$home_org};
-
- my %buckets;
- my %hash = map { ($_->to_org => $_->prox) } @$home_prox;
- push( @{$buckets{ $hash{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
-
- my @keys = sort { $a <=> $b } keys %buckets;
-
-
- if( $home_org ne $req_org ) {
- # -----------------------------------------------------------------------
- # shove the copies close to the request_lib into the primary buckets
- # directly before the farthest away copies. That way, they are not
- # given priority, but they are checked before the farthest copies.
- # -----------------------------------------------------------------------
- $prox_cache{$req_org} =
- $e->search_actor_org_unit_proximity({from_org => $req_org})
- unless $prox_cache{$req_org};
- my $req_prox = $prox_cache{$req_org};
-
- my %buckets2;
- my %hash2 = map { ($_->to_org => $_->prox) } @$req_prox;
- push( @{$buckets2{ $hash2{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
-
- my $highest_key = $keys[@keys - 1]; # the farthest prox in the exising buckets
- my $new_key = $highest_key - 0.5; # right before the farthest prox
- my @keys2 = sort { $a <=> $b } keys %buckets2;
- for my $key (@keys2) {
- last if $key >= $highest_key;
- push( @{$buckets{$new_key}}, $_ ) for @{$buckets2{$key}};
- }
- }
-
- @keys = sort { $a <=> $b } keys %buckets;
-
- my $title;
- my %seen;
- my @status;
- OUTER: for my $key (@keys) {
- my @cps = @{$buckets{$key}};
-
- $logger->info("looking at " . scalar(@{$buckets{$key}}). " copies in proximity bucket $key");
-
- for my $copyid (@cps) {
-
- next if $seen{$copyid};
- $seen{$copyid} = 1; # there could be dupes given the merged buckets
- my $copy = $e->retrieve_asset_copy($copyid);
- $logger->debug("looking at bucket_key=$key, copy $copyid : circ_lib = " . $copy->circ_lib);
-
- unless($title) { # grab the title if we don't already have it
- my $vol = $e->retrieve_asset_call_number(
- [ $copy->call_number, { flesh => 1, flesh_fields => { bre => ['fixed_fields'], acn => ['record'] } } ] );
- $title = $vol->record;
- }
-
- @status = verify_copy_for_hold(
- $patron, $requestor, $title, $copy, $pickup_lib, $request_lib);
-
- last OUTER if $status[0];
- }
- }
-
- return @status;
-}
-
-sub _check_issuance_hold_is_possible {
- my( $issuanceid, $depth, $request_lib, $patron, $requestor, $pickup_lib, $selection_ou ) = @_;
-
- my $e = new_editor();
- my %org_filter = create_ranged_org_filter($e, $selection_ou, $depth);
-
- # this monster will grab the id and circ_lib of all of the "holdable" copies for the given record
- my $copies = $e->json_query(
- {
- select => { acp => ['id', 'circ_lib'] },
- from => {
- acp => {
- sitem => {
- field => 'unit',
- fkey => 'id',
- filter => { issuance => $issuanceid }
- },
- acpl => { field => 'id', filter => { holdable => 't'}, fkey => 'location' },
- ccs => { field => 'id', filter => { holdable => 't'}, fkey => 'status' }
- }
- },
- where => {
- '+acp' => { circulate => 't', deleted => 'f', holdable => 't', %org_filter }
- },
- distinct => 1
- }
- );
-
- $logger->info("issuance possible found ".scalar(@$copies)." potential copies");
-
- my $empty_ok;
- if (!@$copies) {
- $empty_ok = $e->retrieve_config_global_flag('circ.holds.empty_issuance_ok');
- $empty_ok = ($empty_ok and $U->is_true($empty_ok->enabled));
-
- return (
- 0, 0, [
- new OpenILS::Event(
- "HIGH_LEVEL_HOLD_HAS_NO_COPIES",
- "payload" => {"fail_part" => "no_ultimate_items"}
- )
- ]
- ) unless $empty_ok;
-
- return (1, 0);
- }
-
- # -----------------------------------------------------------------------
- # sort the copies into buckets based on their circ_lib proximity to
- # the patron's home_ou.
- # -----------------------------------------------------------------------
-
- my $home_org = $patron->home_ou;
- my $req_org = $request_lib->id;
-
- $logger->info("prox cache $home_org " . $prox_cache{$home_org});
-
- $prox_cache{$home_org} =
- $e->search_actor_org_unit_proximity({from_org => $home_org})
- unless $prox_cache{$home_org};
- my $home_prox = $prox_cache{$home_org};
-
- my %buckets;
- my %hash = map { ($_->to_org => $_->prox) } @$home_prox;
- push( @{$buckets{ $hash{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
-
- my @keys = sort { $a <=> $b } keys %buckets;
-
-
- if( $home_org ne $req_org ) {
- # -----------------------------------------------------------------------
- # shove the copies close to the request_lib into the primary buckets
- # directly before the farthest away copies. That way, they are not
- # given priority, but they are checked before the farthest copies.
- # -----------------------------------------------------------------------
- $prox_cache{$req_org} =
- $e->search_actor_org_unit_proximity({from_org => $req_org})
- unless $prox_cache{$req_org};
- my $req_prox = $prox_cache{$req_org};
-
- my %buckets2;
- my %hash2 = map { ($_->to_org => $_->prox) } @$req_prox;
- push( @{$buckets2{ $hash2{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
-
- my $highest_key = $keys[@keys - 1]; # the farthest prox in the exising buckets
- my $new_key = $highest_key - 0.5; # right before the farthest prox
- my @keys2 = sort { $a <=> $b } keys %buckets2;
- for my $key (@keys2) {
- last if $key >= $highest_key;
- push( @{$buckets{$new_key}}, $_ ) for @{$buckets2{$key}};
- }
- }
-
- @keys = sort { $a <=> $b } keys %buckets;
-
- my $title;
- my %seen;
- my @status;
- OUTER: for my $key (@keys) {
- my @cps = @{$buckets{$key}};
-
- $logger->info("looking at " . scalar(@{$buckets{$key}}). " copies in proximity bucket $key");
-
- for my $copyid (@cps) {
-
- next if $seen{$copyid};
- $seen{$copyid} = 1; # there could be dupes given the merged buckets
- my $copy = $e->retrieve_asset_copy($copyid);
- $logger->debug("looking at bucket_key=$key, copy $copyid : circ_lib = " . $copy->circ_lib);
-
- unless($title) { # grab the title if we don't already have it
- my $vol = $e->retrieve_asset_call_number(
- [ $copy->call_number, { flesh => 1, flesh_fields => { bre => ['fixed_fields'], acn => ['record'] } } ] );
- $title = $vol->record;
- }
-
- @status = verify_copy_for_hold(
- $patron, $requestor, $title, $copy, $pickup_lib, $request_lib);
-
- last OUTER if $status[0];
- }
- }
-
- if (!$status[0]) {
- if (!defined($empty_ok)) {
- $empty_ok = $e->retrieve_config_global_flag('circ.holds.empty_issuance_ok');
- $empty_ok = ($empty_ok and $U->is_true($empty_ok->enabled));
- }
-
- return (1,0) if ($empty_ok);
- }
- return @status;
-}
-
-
-sub _check_volume_hold_is_possible {
- my( $vol, $title, $depth, $request_lib, $patron, $requestor, $pickup_lib, $selection_ou ) = @_;
- my %org_filter = create_ranged_org_filter(new_editor(), $selection_ou, $depth);
- my $copies = new_editor->search_asset_copy({call_number => $vol->id, %org_filter});
- $logger->info("checking possibility of volume hold for volume ".$vol->id);
-
- return (
- 0, 0, [
- new OpenILS::Event(
- "HIGH_LEVEL_HOLD_HAS_NO_COPIES",
- "payload" => {"fail_part" => "no_ultimate_items"}
- )
- ]
- ) unless @$copies;
-
- my @status;
- for my $copy ( @$copies ) {
- @status = verify_copy_for_hold(
- $patron, $requestor, $title, $copy, $pickup_lib, $request_lib );
- last if $status[0];
- }
- return @status;
-}
-
-
-
-sub verify_copy_for_hold {
- my( $patron, $requestor, $title, $copy, $pickup_lib, $request_lib ) = @_;
- $logger->info("checking possibility of copy in hold request for copy ".$copy->id);
- my $permitted = OpenILS::Utils::PermitHold::permit_copy_hold(
- { patron => $patron,
- requestor => $requestor,
- copy => $copy,
- title => $title,
- title_descriptor => $title->fixed_fields, # this is fleshed into the title object
- pickup_lib => $pickup_lib,
- request_lib => $request_lib,
- new_hold => 1,
- show_event_list => 1
- }
- );
-
- return (
- (not scalar @$permitted), # true if permitted is an empty arrayref
- (
- ($copy->circ_lib == $pickup_lib) and
- ($copy->status == OILS_COPY_STATUS_AVAILABLE)
- ),
- $permitted
- );
-}
-
-
-
-sub find_nearest_permitted_hold {
-
- my $class = shift;
- my $editor = shift; # CStoreEditor object
- my $copy = shift; # copy to target
- my $user = shift; # staff
- my $check_only = shift; # do no updates, just see if the copy could fulfill a hold
-
- my $evt = OpenILS::Event->new('ACTION_HOLD_REQUEST_NOT_FOUND');
-
- my $bc = $copy->barcode;
-
- # find any existing holds that already target this copy
- my $old_holds = $editor->search_action_hold_request(
- { current_copy => $copy->id,
- cancel_time => undef,
- capture_time => undef
- }
- );
-
- # hold->type "R" means we need this copy
- for my $h (@$old_holds) { return ($h) if $h->hold_type eq 'R'; }
-
-
- my $hold_stall_interval = $U->ou_ancestor_setting_value($user->ws_ou, OILS_SETTING_HOLD_SOFT_STALL);
-
- $logger->info("circulator: searching for best hold at org ".$user->ws_ou.
- " and copy $bc with a hold stalling interval of ". ($hold_stall_interval || "(none)"));
-
- my $fifo = $U->ou_ancestor_setting_value($user->ws_ou, 'circ.holds_fifo');
-
- # search for what should be the best holds for this copy to fulfill
- my $best_holds = $U->storagereq(
- "open-ils.storage.action.hold_request.nearest_hold.atomic",
- $user->ws_ou, $copy->id, 10, $hold_stall_interval, $fifo );
-
- unless(@$best_holds) {
-
- if( my $hold = $$old_holds[0] ) {
- $logger->info("circulator: using existing pre-targeted hold ".$hold->id." in hold search");
- return ($hold);
- }
-
- $logger->info("circulator: no suitable holds found for copy $bc");
- return (undef, $evt);
- }
-
-
- my $best_hold;
-
- # for each potential hold, we have to run the permit script
- # to make sure the hold is actually permitted.
- my %reqr_cache;
- my %org_cache;
- for my $holdid (@$best_holds) {
- next unless $holdid;
- $logger->info("circulator: checking if hold $holdid is permitted for copy $bc");
-
- my $hold = $editor->retrieve_action_hold_request($holdid) or next;
- my $reqr = $reqr_cache{$hold->requestor} || $editor->retrieve_actor_user($hold->requestor);
- my $rlib = $org_cache{$hold->request_lib} || $editor->retrieve_actor_org_unit($hold->request_lib);
-
- $reqr_cache{$hold->requestor} = $reqr;
- $org_cache{$hold->request_lib} = $rlib;
-
- # see if this hold is permitted
- my $permitted = OpenILS::Utils::PermitHold::permit_copy_hold(
- { patron_id => $hold->usr,
- requestor => $reqr,
- copy => $copy,
- pickup_lib => $hold->pickup_lib,
- request_lib => $rlib,
- retarget => 1
- }
- );
-
- if( $permitted ) {
- $best_hold = $hold;
- last;
- }
- }
-
-
- unless( $best_hold ) { # no "good" permitted holds were found
- if( my $hold = $$old_holds[0] ) { # can we return a pre-targeted hold?
- $logger->info("circulator: using existing pre-targeted hold ".$hold->id." in hold search");
- return ($hold);
- }
-
- # we got nuthin
- $logger->info("circulator: no suitable holds found for copy $bc");
- return (undef, $evt);
- }
-
- $logger->info("circulator: best hold ".$best_hold->id." found for copy $bc");
-
- # indicate a permitted hold was found
- return $best_hold if $check_only;
-
- # we've found a permitted hold. we need to "grab" the copy
- # to prevent re-targeted holds (next part) from re-grabbing the copy
- $best_hold->current_copy($copy->id);
- $editor->update_action_hold_request($best_hold)
- or return (undef, $editor->event);
-
-
- my @retarget;
-
- # re-target any other holds that already target this copy
- for my $old_hold (@$old_holds) {
- next if $old_hold->id eq $best_hold->id; # don't re-target the hold we want
- $logger->info("circulator: clearing current_copy and prev_check_time on hold ".
- $old_hold->id." after a better hold [".$best_hold->id."] was found");
- $old_hold->clear_current_copy;
- $old_hold->clear_prev_check_time;
- $editor->update_action_hold_request($old_hold)
- or return (undef, $editor->event);
- push(@retarget, $old_hold->id);
- }
-
- return ($best_hold, undef, (@retarget) ? \@retarget : undef);
-}
-
-
-
-
-
-
-__PACKAGE__->register_method(
- method => 'all_rec_holds',
- api_name => 'open-ils.circ.holds.retrieve_all_from_title',
-);
-
-sub all_rec_holds {
- my( $self, $conn, $auth, $title_id, $args ) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- $e->checkauth or return $e->event;
- $e->allowed('VIEW_HOLD') or return $e->event;
-
- $args ||= {};
- $args->{fulfillment_time} = undef; # we don't want to see old fulfilled holds
- $args->{cancel_time} = undef;
-
- my $resp = { volume_holds => [], copy_holds => [], metarecord_holds => [] };
-
- my $mr_map = $e->search_metabib_metarecord_source_map({source => $title_id})->[0];
- if($mr_map) {
- $resp->{metarecord_holds} = $e->search_action_hold_request(
- { hold_type => OILS_HOLD_TYPE_METARECORD,
- target => $mr_map->metarecord,
- %$args
- }, {idlist => 1}
- );
- }
-
- $resp->{title_holds} = $e->search_action_hold_request(
- {
- hold_type => OILS_HOLD_TYPE_TITLE,
- target => $title_id,
- %$args
- }, {idlist=>1} );
-
- my $vols = $e->search_asset_call_number(
- { record => $title_id, deleted => 'f' }, {idlist=>1});
-
- return $resp unless @$vols;
-
- $resp->{volume_holds} = $e->search_action_hold_request(
- {
- hold_type => OILS_HOLD_TYPE_VOLUME,
- target => $vols,
- %$args },
- {idlist=>1} );
-
- my $copies = $e->search_asset_copy(
- { call_number => $vols, deleted => 'f' }, {idlist=>1});
-
- return $resp unless @$copies;
-
- $resp->{copy_holds} = $e->search_action_hold_request(
- {
- hold_type => OILS_HOLD_TYPE_COPY,
- target => $copies,
- %$args },
- {idlist=>1} );
-
- return $resp;
-}
-
-
-
-
-
-__PACKAGE__->register_method(
- method => 'uber_hold',
- authoritative => 1,
- api_name => 'open-ils.circ.hold.details.retrieve'
-);
-
-sub uber_hold {
- my($self, $client, $auth, $hold_id) = @_;
- my $e = new_editor(authtoken=>$auth);
- $e->checkauth or return $e->event;
- return uber_hold_impl($e, $hold_id);
-}
-
-__PACKAGE__->register_method(
- method => 'batch_uber_hold',
- authoritative => 1,
- stream => 1,
- api_name => 'open-ils.circ.hold.details.batch.retrieve'
-);
-
-sub batch_uber_hold {
- my($self, $client, $auth, $hold_ids) = @_;
- my $e = new_editor(authtoken=>$auth);
- $e->checkauth or return $e->event;
- $client->respond(uber_hold_impl($e, $_)) for @$hold_ids;
- return undef;
-}
-
-sub uber_hold_impl {
- my($e, $hold_id) = @_;
-
- my $resp = {};
-
- my $hold = $e->retrieve_action_hold_request(
- [
- $hold_id,
- {
- flesh => 1,
- flesh_fields => { ahr => [ 'current_copy', 'usr', 'notes' ] }
- }
- ]
- ) or return $e->event;
-
- if($hold->usr->id ne $e->requestor->id) {
- # A user is allowed to see his/her own holds
- $e->allowed('VIEW_HOLD') or return $e->event;
- $hold->notes( # filter out any non-staff ("private") notes
- [ grep { !$U->is_true($_->staff) } @{$hold->notes} ] );
-
- } else {
- # caller is asking for own hold, but may not have permission to view staff notes
- unless($e->allowed('VIEW_HOLD')) {
- $hold->notes( # filter out any staff notes
- [ grep { $U->is_true($_->staff) } @{$hold->notes} ] );
- }
- }
-
- my $user = $hold->usr;
- $hold->usr($user->id);
-
- my $card = $e->retrieve_actor_card($user->card)
- or return $e->event;
-
- my( $mvr, $volume, $copy ) = find_hold_mvr($e, $hold);
-
- flesh_hold_notices([$hold], $e);
- flesh_hold_transits([$hold]);
-
- my $details = retrieve_hold_queue_status_impl($e, $hold);
-
- return {
- hold => $hold,
- copy => $copy,
- volume => $volume,
- mvr => $mvr,
- patron_first => $user->first_given_name,
- patron_last => $user->family_name,
- patron_barcode => $card->barcode,
- patron_alias => $user->alias,
- %$details
- };
-}
-
-
-
-# -----------------------------------------------------
-# Returns the MVR object that represents what the
-# hold is all about
-# -----------------------------------------------------
-sub find_hold_mvr {
- my( $e, $hold ) = @_;
-
- my $tid;
- my $copy;
- my $volume;
- my $issuance;
-
- if( $hold->hold_type eq OILS_HOLD_TYPE_METARECORD ) {
- my $mr = $e->retrieve_metabib_metarecord($hold->target)
- or return $e->event;
- $tid = $mr->master_record;
-
- } elsif( $hold->hold_type eq OILS_HOLD_TYPE_TITLE ) {
- $tid = $hold->target;
-
- } elsif( $hold->hold_type eq OILS_HOLD_TYPE_VOLUME ) {
- $volume = $e->retrieve_asset_call_number($hold->target)
- or return $e->event;
- $tid = $volume->record;
-
- } elsif( $hold->hold_type eq OILS_HOLD_TYPE_ISSUANCE ) {
- $issuance = $e->retrieve_serial_issuance([
- $hold->target,
- {flesh => 1, flesh_fields => {siss => [ qw/subscription/ ]}}
- ]) or return $e->event;
-
- $tid = $issuance->subscription->record_entry;
-
- } elsif( $hold->hold_type eq OILS_HOLD_TYPE_COPY ) {
- $copy = $e->retrieve_asset_copy([
- $hold->target,
- {flesh => 1, flesh_fields => {acp => ['call_number']}}
- ]) or return $e->event;
-
- $volume = $copy->call_number;
- $tid = $volume->record;
- }
-
- if(!$copy and ref $hold->current_copy ) {
- $copy = $hold->current_copy;
- $hold->current_copy($copy->id);
- }
-
- if(!$volume and $copy) {
- $volume = $e->retrieve_asset_call_number($copy->call_number);
- }
-
- # TODO return metarcord mvr for M holds
- my $title = $e->retrieve_biblio_record_entry($tid);
- return ( $U->record_to_mvr($title), $volume, $copy, $issuance );
-}
-
-__PACKAGE__->register_method(
- method => 'clear_shelf_cache',
- api_name => 'open-ils.circ.hold.clear_shelf.get_cache',
- stream => 1,
- signature => {
- desc => q/
- Returns the holds processed with the given cache key
- /
- }
-);
-
-sub clear_shelf_cache {
- my($self, $client, $auth, $cache_key, $chunk_size) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth and $e->allowed('VIEW_HOLD');
-
- $chunk_size ||= 25;
- my $hold_data = OpenSRF::Utils::Cache->new('global')->get_cache($cache_key);
-
- if (!$hold_data) {
- $logger->info("no hold data found in cache"); # XXX TODO return event
- $e->rollback;
- return undef;
- }
-
- my $maximum = 0;
- foreach (keys %$hold_data) {
- $maximum += scalar(@{ $hold_data->{$_} });
- }
- $client->respond({"maximum" => $maximum, "progress" => 0});
-
- for my $action (sort keys %$hold_data) {
- while (@{$hold_data->{$action}}) {
- my @hid_chunk = splice @{$hold_data->{$action}}, 0, $chunk_size;
-
- my $result_chunk = $e->json_query({
- "select" => {
- "acp" => ["barcode"],
- "au" => [qw/
- first_given_name second_given_name family_name alias
- /],
- "acn" => ["label"],
- "bre" => ["marc"],
- "acpl" => ["name"],
- "ahr" => ["id"]
- },
- "from" => {
- "ahr" => {
- "acp" => {
- "field" => "id", "fkey" => "current_copy",
- "join" => {
- "acn" => {
- "field" => "id", "fkey" => "call_number",
- "join" => {
- "bre" => {
- "field" => "id", "fkey" => "record"
- }
- }
- },
- "acpl" => {"field" => "id", "fkey" => "location"}
- }
- },
- "au" => {"field" => "id", "fkey" => "usr"}
- }
- },
- "where" => {"+ahr" => {"id" => \@hid_chunk}}
- }, {"substream" => 1}) or return $e->die_event;
-
- $client->respond([
- map {
- +{"action" => $action, "hold_details" => $_}
- } @$result_chunk
- ]);
- }
- }
-
- $e->rollback;
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'clear_shelf_process',
- stream => 1,
- api_name => 'open-ils.circ.hold.clear_shelf.process',
- signature => {
- desc => q/
- 1. Find all holds that have expired on the holds shelf
- 2. Cancel the holds
- 3. If a clear-shelf status is configured, put targeted copies into this status
- 4. Divide copies into 3 groups: items to transit, items to reshelve, and items
- that are needed for holds. No subsequent action is taken on the holds
- or items after grouping.
- /
- }
-);
-
-sub clear_shelf_process {
- my($self, $client, $auth, $org_id) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact => 1);
- $e->checkauth or return $e->die_event;
- my $cache = OpenSRF::Utils::Cache->new('global');
-
- $org_id ||= $e->requestor->ws_ou;
- $e->allowed('UPDATE_HOLD', $org_id) or return $e->die_event;
-
- my $copy_status = $U->ou_ancestor_setting_value($org_id, 'circ.holds.clear_shelf.copy_status');
-
- # Find holds on the shelf that have been there too long
- my $hold_ids = $e->search_action_hold_request(
- { shelf_expire_time => {'<' => 'now'},
- pickup_lib => $org_id,
- cancel_time => undef,
- fulfillment_time => undef,
- shelf_time => {'!=' => undef},
- capture_time => {'!=' => undef},
- current_copy => {'!=' => undef},
- },
- { idlist => 1 }
- );
-
- my @holds;
- my $chunk_size = 25; # chunked status updates
- my $counter = 0;
- for my $hold_id (@$hold_ids) {
-
- $logger->info("Clear shelf processing hold $hold_id");
-
- my $hold = $e->retrieve_action_hold_request([
- $hold_id, {
- flesh => 1,
- flesh_fields => {ahr => ['current_copy']}
- }
- ]);
-
- $hold->cancel_time('now');
- $hold->cancel_cause(2); # Hold Shelf expiration
- $e->update_action_hold_request($hold) or return $e->die_event;
-
- my $copy = $hold->current_copy;
-
- if($copy_status or $copy_status == 0) {
- # if a clear-shelf copy status is defined, update the copy
- $copy->status($copy_status);
- $copy->edit_date('now');
- $copy->editor($e->requestor->id);
- $e->update_asset_copy($copy) or return $e->die_event;
- }
-
- push(@holds, $hold);
- $client->respond({maximum => scalar(@holds), progress => $counter}) if ( (++$counter % $chunk_size) == 0);
- }
-
- if ($e->commit) {
-
- my %cache_data = (
- hold => [],
- transit => [],
- shelf => []
- );
-
- for my $hold (@holds) {
-
- my $copy = $hold->current_copy;
- my ($alt_hold) = __PACKAGE__->find_nearest_permitted_hold($e, $copy, $e->requestor, 1);
-
- if($alt_hold) {
-
- push(@{$cache_data{hold}}, $hold->id); # copy is needed for a hold
-
- } elsif($copy->circ_lib != $e->requestor->ws_ou) {
-
- push(@{$cache_data{transit}}, $hold->id); # copy needs to transit
-
- } else {
-
- push(@{$cache_data{shelf}}, $hold->id); # copy needs to go back to the shelf
- }
- }
-
- my $cache_key = md5_hex(time . $$ . rand());
- $logger->info("clear_shelf_cache: storing under $cache_key");
- $cache->put_cache($cache_key, \%cache_data, 7200); # TODO: 2 hours. configurable?
-
- # tell the client we're done
- $client->respond_complete({cache_key => $cache_key});
-
- # fire off the hold cancelation trigger and wait for response so don't flood the service
- $U->create_events_for_hook(
- 'hold_request.cancel.expire_holds_shelf',
- $_, $org_id, undef, undef, 1) for @holds;
-
- } else {
- # tell the client we're done
- $client->respond_complete;
- }
-}
-
-__PACKAGE__->register_method(
- method => 'usr_hold_summary',
- api_name => 'open-ils.circ.holds.user_summary',
- signature => q/
- Returns a summary of holds statuses for a given user
- /
-);
-
-sub usr_hold_summary {
- my($self, $conn, $auth, $user_id) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- $e->checkauth or return $e->event;
- $e->allowed('VIEW_HOLD') or return $e->event;
-
- my $holds = $e->search_action_hold_request(
- {
- usr => $user_id ,
- fulfillment_time => undef,
- cancel_time => undef,
- }
- );
-
- my %summary = (1 => 0, 2 => 0, 3 => 0, 4 => 0);
- $summary{_hold_status($e, $_)} += 1 for @$holds;
- return \%summary;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'hold_has_copy_at',
- api_name => 'open-ils.circ.hold.has_copy_at',
- signature => {
- desc =>
- 'Returns the ID of the found copy and name of the shelving location if there is ' .
- 'an available copy at the specified org unit. Returns empty hash otherwise. ' .
- 'The anticipated use for this method is to determine whether an item is ' .
- 'available at the library where the user is placing the hold (or, alternatively, '.
- 'at the pickup library) to encourage bypassing the hold placement and just ' .
- 'checking out the item.' ,
- params => {
- { desc => 'Authentication Token', type => 'string' },
- { desc => 'Method Arguments. Options include: hold_type, hold_target, org_unit. '
- . 'hold_type is the hold type code (T, V, C, M, ...). '
- . 'hold_target is the identifier of the hold target object. '
- . 'org_unit is org unit ID.',
- type => 'object'
- },
- },
- return => {
- desc => q/Result hash like { "copy" : copy_id, "location" : location_name }, empty hash on misses, event on error./,
- type => 'object'
- }
- }
-);
-
-sub hold_has_copy_at {
- my($self, $conn, $auth, $args) = @_;
-
- my $e = new_editor(authtoken=>$auth);
- $e->checkauth or return $e->event;
-
- my $hold_type = $$args{hold_type};
- my $hold_target = $$args{hold_target};
- my $org_unit = $$args{org_unit};
-
- my $query = {
- select => {acp => ['id'], acpl => ['name']},
- from => {
- acp => {
- acpl => {field => 'id', filter => { holdable => 't'}, fkey => 'location'},
- ccs => {field => 'id', filter => { holdable => 't'}, fkey => 'status' }
- }
- },
- where => {'+acp' => { circulate => 't', deleted => 'f', holdable => 't', circ_lib => $org_unit}},
- limit => 1
- };
-
- if($hold_type eq 'C') {
-
- $query->{where}->{'+acp'}->{id} = $hold_target;
-
- } elsif($hold_type eq 'V') {
-
- $query->{where}->{'+acp'}->{call_number} = $hold_target;
-
- } elsif($hold_type eq 'T') {
-
- $query->{from}->{acp}->{acn} = {
- field => 'id',
- fkey => 'call_number',
- 'join' => {
- bre => {
- field => 'id',
- filter => {id => $hold_target},
- fkey => 'record'
- }
- }
- };
-
- } else {
-
- $query->{from}->{acp}->{acn} = {
- field => 'id',
- fkey => 'call_number',
- join => {
- bre => {
- field => 'id',
- fkey => 'record',
- join => {
- mmrsm => {
- field => 'source',
- fkey => 'id',
- filter => {metarecord => $hold_target},
- }
- }
- }
- }
- };
- }
-
- my $res = $e->json_query($query)->[0] or return {};
- return {copy => $res->{id}, location => $res->{name}} if $res;
-}
-
-
-# returns true if the user already has an item checked out
-# that could be used to fulfill the requested hold.
-sub hold_item_is_checked_out {
- my($e, $user_id, $hold_type, $hold_target) = @_;
-
- my $query = {
- select => {acp => ['id']},
- from => {acp => {}},
- where => {
- '+acp' => {
- id => {
- in => { # copies for circs the user has checked out
- select => {circ => ['target_copy']},
- from => 'circ',
- where => {
- usr => $user_id,
- checkin_time => undef,
- '-or' => [
- {stop_fines => ["MAXFINES","LONGOVERDUE"]},
- {stop_fines => undef}
- ],
- }
- }
- }
- }
- },
- limit => 1
- };
-
- if($hold_type eq 'C' || $hold_type eq 'R' || $hold_type eq 'F') {
-
- $query->{where}->{'+acp'}->{id}->{in}->{where}->{'target_copy'} = $hold_target;
-
- } elsif($hold_type eq 'V') {
-
- $query->{where}->{'+acp'}->{call_number} = $hold_target;
-
- } elsif($hold_type eq 'I') {
-
- $query->{from}->{acp}->{sitem} = {
- field => 'unit',
- fkey => 'id',
- filter => {issuance => $hold_target},
- };
-
- } elsif($hold_type eq 'T') {
-
- $query->{from}->{acp}->{acn} = {
- field => 'id',
- fkey => 'call_number',
- 'join' => {
- bre => {
- field => 'id',
- filter => {id => $hold_target},
- fkey => 'record'
- }
- }
- };
-
- } else {
-
- $query->{from}->{acp}->{acn} = {
- field => 'id',
- fkey => 'call_number',
- join => {
- bre => {
- field => 'id',
- fkey => 'record',
- join => {
- mmrsm => {
- field => 'source',
- fkey => 'id',
- filter => {metarecord => $hold_target},
- }
- }
- }
- }
- };
- }
-
- return $e->json_query($query)->[0];
-}
-
-__PACKAGE__->register_method(
- method => 'change_hold_title',
- api_name => 'open-ils.circ.hold.change_title',
- signature => {
- desc => q/
- Updates all title level holds targeting the specified bibs to point a new bib./,
- params => [
- { desc => 'Authentication Token', type => 'string' },
- { desc => 'New Target Bib Id', type => 'number' },
- { desc => 'Old Target Bib Ids', type => 'array' },
- ],
- return => { desc => '1 on success' }
- }
-);
-
-sub change_hold_title {
- my( $self, $client, $auth, $new_bib_id, $bib_ids ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
-
- my $holds = $e->search_action_hold_request(
- [
- {
- cancel_time => undef,
- fulfillment_time => undef,
- hold_type => 'T',
- target => $bib_ids
- },
- {
- flesh => 1,
- flesh_fields => { ahr => ['usr'] }
- }
- ],
- { substream => 1 }
- );
-
- for my $hold (@$holds) {
- $e->allowed('UPDATE_HOLD', $hold->usr->home_ou) or return $e->die_event;
- $logger->info("Changing hold " . $hold->id . " target from " . $hold->target . " to $new_bib_id in title hold target change");
- $hold->target( $new_bib_id );
- $e->update_action_hold_request($hold) or return $e->die_event;
- }
-
- $e->commit;
-
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'rec_hold_count',
- api_name => 'open-ils.circ.bre.holds.count',
- signature => {
- desc => q/Returns the total number of holds that target the
- selected bib record or its associated copies and call_numbers/,
- params => [
- { desc => 'Bib ID', type => 'number' },
- ],
- return => {desc => 'Hold count', type => 'number'}
- }
-);
-
-__PACKAGE__->register_method(
- method => 'rec_hold_count',
- api_name => 'open-ils.circ.mmr.holds.count',
- signature => {
- desc => q/Returns the total number of holds that target the
- selected metarecord or its associated copies, call_numbers, and bib records/,
- params => [
- { desc => 'Metarecord ID', type => 'number' },
- ],
- return => {desc => 'Hold count', type => 'number'}
- }
-);
-
-sub rec_hold_count {
- my($self, $conn, $target_id) = @_;
-
-
- my $mmr_join = {
- mmrsm => {
- field => 'id',
- fkey => 'source',
- filter => {metarecord => $target_id}
- }
- };
-
- my $bre_join = {
- bre => {
- field => 'id',
- filter => { id => $target_id },
- fkey => 'record'
- }
- };
-
- if($self->api_name =~ /mmr/) {
- delete $bre_join->{bre}->{filter};
- $bre_join->{bre}->{join} = $mmr_join;
- }
-
- my $cn_join = {
- acn => {
- field => 'id',
- fkey => 'call_number',
- join => $bre_join
- }
- };
-
- my $query = {
- select => {ahr => [{column => 'id', transform => 'count', alias => 'count'}]},
- from => 'ahr',
- where => {
- '+ahr' => {
- cancel_time => undef,
- fulfillment_time => undef,
- '-or' => [
- {
- '-and' => {
- hold_type => 'C',
- target => {
- in => {
- select => {acp => ['id']},
- from => { acp => $cn_join }
- }
- }
- }
- },
- {
- '-and' => {
- hold_type => 'V',
- target => {
- in => {
- select => {acn => ['id']},
- from => {acn => $bre_join}
- }
- }
- }
- },
- {
- '-and' => {
- hold_type => 'T',
- target => $target_id
- }
- }
- ]
- }
- }
- };
-
- if($self->api_name =~ /mmr/) {
- $query->{where}->{'+ahr'}->{'-or'}->[2] = {
- '-and' => {
- hold_type => 'T',
- target => {
- in => {
- select => {bre => ['id']},
- from => {bre => $mmr_join}
- }
- }
- }
- };
-
- $query->{where}->{'+ahr'}->{'-or'}->[3] = {
- '-and' => {
- hold_type => 'M',
- target => $target_id
- }
- };
- }
-
-
- return new_editor()->json_query($query)->[0]->{count};
-}
-
-
-
-
-
-
-1;
+++ /dev/null
-# ---------------------------------------------------------------
-# Copyright (C) 2005 Georgia Public Library Service
-# Bill Erickson <billserickson@gmail.com>
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-package OpenILS::Application::Circ::Money;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use OpenILS::Application::AppUtils;
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = "OpenILS::Application::AppUtils";
-
-use OpenSRF::EX qw(:try);
-use OpenILS::Perm;
-use Data::Dumper;
-use OpenILS::Event;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Utils::Penalty;
-$Data::Dumper::Indent = 0;
-
-__PACKAGE__->register_method(
- method => "make_payments",
- api_name => "open-ils.circ.money.payment",
- signature => {
- desc => q/Create payments for a given user and set of transactions,
- login must have CREATE_PAYMENT privileges.
- If any payments fail, all are reverted back./,
- params => [
- {desc => 'Authtoken', type => 'string'},
- {desc => q/Arguments Hash, supporting the following params:
- {
- payment_type
- userid
- patron_credit
- note
- cc_args: {
- where_process 1 to use processor, !1 for out-of-band
- approval_code (for out-of-band payment)
- type (for out-of-band payment)
- number (for call to payment processor)
- expire_month (for call to payment processor)
- expire_year (for call to payment processor)
- billing_first (for out-of-band payments and for call to payment processor)
- billing_last (for out-of-band payments and for call to payment processor)
- billing_address (for call to payment processor)
- billing_city (for call to payment processor)
- billing_state (for call to payment processor)
- billing_zip (for call to payment processor)
- note (if payments->{note} is blank, use this)
- },
- check_number
- payments: [
- [trans_id, amt],
- [...]
- ],
- }/, type => 'hash'
- },
- {
- desc => q/Last user transaction ID. This is the actor.usr.last_xact_id value/,
- type => 'string'
- }
- ],
- "return" => {
- "desc" =>
- q{Array of payment IDs on success, event on failure. Event possibilities include:
- BAD_PARAMS
- Bad parameters were given to this API method itself.
- See note field.
- INVALID_USER_XACT_ID
- The last user transaction ID does not match the ID in the database. This means
- the user object has been updated since the last retrieval. The client should
- be instructed to reload the user object and related transactions before attempting
- another payment
- REFUND_EXCEEDS_BALANCE
- REFUND_EXCEEDS_DESK_PAYMENTS
- CREDIT_PROCESSOR_NOT_SPECIFIED
- Evergreen has not been set up to process CC payments.
- CREDIT_PROCESSOR_NOT_ALLOWED
- Evergreen has been incorrectly setup for CC payments.
- CREDIT_PROCESSOR_NOT_ENABLED
- Evergreen has been set up for CC payments, but an admin
- has not explicitly enabled them.
- CREDIT_PROCESSOR_BAD_PARAMS
- Evergreen has been incorrectly setup for CC payments;
- specifically, the login and/or password for the CC
- processor weren't provided.
- CREDIT_PROCESSOR_INVALID_CC_NUMBER
- You have supplied a credit card number that Evergreen
- has judged to be invalid even before attempting to contact
- the payment processor.
- CREDIT_PROCESSOR_DECLINED_TRANSACTION
- We contacted the CC processor to attempt the charge, but
- they declined it.
- The error_message field of the event payload will
- contain the payment processor's response. This
- typically includes a message in plain English intended
- for human consumption. In PayPal's case, the message
- is preceded by an integer, a colon, and a space, so
- a caller might take the 2nd match from /^(\d+: )?(.+)$/
- to present to the user.
- The payload also contains other fields from the payment
- processor, but these are generally not user-friendly
- strings.
- CREDIT_PROCESSOR_SUCCESS_WO_RECORD
- A payment was processed successfully, but couldn't be
- recorded in Evergreen. This is _bad bad bad_, as it means
- somebody made a payment but isn't getting credit for it.
- See errors in the system log if this happens. Info from
- the credit card transaction will also be available in the
- event payload, although this probably won't be suitable for
- staff client/OPAC display.
-},
- "type" => "number"
- }
- }
-);
-sub make_payments {
- my($self, $client, $auth, $payments, $last_xact_id) = @_;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $type = $payments->{payment_type};
- my $user_id = $payments->{userid};
- my $credit = $payments->{patron_credit} || 0;
- my $drawer = $e->requestor->wsid;
- my $note = $payments->{note};
- my $cc_args = $payments->{cc_args};
- my $check_number = $payments->{check_number};
- my $total_paid = 0;
- my $this_ou = $e->requestor->ws_ou;
- my %orgs;
-
- # unless/until determined by payment processor API
- my ($approval_code, $cc_processor, $cc_type) = (undef,undef,undef);
-
- my $patron = $e->retrieve_actor_user($user_id) or return $e->die_event;
-
- if($patron->last_xact_id ne $last_xact_id) {
- $e->rollback;
- return OpenILS::Event->new('INVALID_USER_XACT_ID');
- }
-
- # A user is allowed to make credit card payments on his/her own behalf
- # All other scenarious require permission
- unless($type eq 'credit_card_payment' and $user_id == $e->requestor->id) {
- return $e->die_event unless $e->allowed('CREATE_PAYMENT', $patron->home_ou);
- }
-
- # first collect the transactions and make sure the transaction
- # user matches the requested user
- my %xacts;
- for my $pay (@{$payments->{payments}}) {
- my $xact_id = $pay->[0];
- my $xact = $e->retrieve_money_billable_transaction_summary($xact_id)
- or return $e->die_event;
-
- if($xact->usr != $user_id) {
- $e->rollback;
- return OpenILS::Event->new('BAD_PARAMS', note => q/user does not match transaction/);
- }
-
- $xacts{$xact_id} = $xact;
- }
-
- my @payment_objs;
-
- for my $pay (@{$payments->{payments}}) {
- my $transid = $pay->[0];
- my $amount = $pay->[1];
- $amount =~ s/\$//og; # just to be safe
- my $trans = $xacts{$transid};
-
- $total_paid += $amount;
-
- $orgs{$U->xact_org($transid, $e)} = 1;
-
- # A negative payment is a refund.
- if( $amount < 0 ) {
-
- # Negative credit card payments are not allowed
- if($type eq 'credit_card_payment') {
- $e->rollback;
- return OpenILS::Event->new(
- 'BAD_PARAMS',
- note => q/Negative credit card payments not allowed/
- );
- }
-
- # If the refund causes the transaction balance to exceed 0 dollars,
- # we are in effect loaning the patron money. This is not allowed.
- if( ($trans->balance_owed - $amount) > 0 ) {
- $e->rollback;
- return OpenILS::Event->new('REFUND_EXCEEDS_BALANCE');
- }
-
- # Otherwise, make sure the refund does not exceed desk payments
- # This is also not allowed
- my $desk_total = 0;
- my $desk_payments = $e->search_money_desk_payment({xact => $transid, voided => 'f'});
- $desk_total += $_->amount for @$desk_payments;
-
- if( (-$amount) > $desk_total ) {
- $e->rollback;
- return OpenILS::Event->new(
- 'REFUND_EXCEEDS_DESK_PAYMENTS',
- payload => { allowed_refund => $desk_total, submitted_refund => -$amount } );
- }
- }
-
- my $payobj = "Fieldmapper::money::$type";
- $payobj = $payobj->new;
-
- $payobj->amount($amount);
- $payobj->amount_collected($amount);
- $payobj->xact($transid);
- $payobj->note($note);
- if ((not $payobj->note) and ($type eq 'credit_card_payment')) {
- $payobj->note($cc_args->{note});
- }
-
- if ($payobj->has_field('accepting_usr')) { $payobj->accepting_usr($e->requestor->id); }
- if ($payobj->has_field('cash_drawer')) { $payobj->cash_drawer($drawer); }
- if ($payobj->has_field('cc_type')) { $payobj->cc_type($cc_args->{type}); }
- if ($payobj->has_field('check_number')) { $payobj->check_number($check_number); }
-
- # Store the last 4 digits of the CC number
- if ($payobj->has_field('cc_number')) {
- $payobj->cc_number(substr($cc_args->{number}, -4));
- }
- if ($payobj->has_field('expire_month')) { $payobj->expire_month($cc_args->{expire_month}); }
- if ($payobj->has_field('expire_year')) { $payobj->expire_year($cc_args->{expire_year}); }
-
- # Note: It is important not to set approval_code
- # on the fieldmapper object yet.
-
- push(@payment_objs, $payobj);
-
- } # all payment objects have been created and inserted.
-
- #### NO WRITES TO THE DB ABOVE THIS LINE -- THEY'LL ONLY BE DISCARDED ###
- $e->rollback;
-
- # After we try to externally process a credit card (if desired), we'll
- # open a new transaction. We cannot leave one open while credit card
- # processing might be happening, as it can easily time out the database
- # transaction.
-
- my $cc_payload;
-
- if($type eq 'credit_card_payment') {
- $approval_code = $cc_args->{approval_code};
- # If an approval code was not given, we'll need
- # to call to the payment processor ourselves.
- if ($cc_args->{where_process} == 1) {
- return OpenILS::Event->new('BAD_PARAMS', note => 'Need CC number')
- if not $cc_args->{number};
- my $response =
- OpenILS::Application::Circ::CreditCard::process_payment({
- "desc" => $cc_args->{note},
- "amount" => $total_paid,
- "patron_id" => $user_id,
- "cc" => $cc_args->{number},
- "expiration" => sprintf(
- "%02d-%04d",
- $cc_args->{expire_month},
- $cc_args->{expire_year}
- ),
- "ou" => $this_ou,
- "first_name" => $cc_args->{billing_first},
- "last_name" => $cc_args->{billing_last},
- "address" => $cc_args->{billing_address},
- "city" => $cc_args->{billing_city},
- "state" => $cc_args->{billing_state},
- "zip" => $cc_args->{billing_zip},
- });
-
- if ($U->event_code($response)) { # non-success
- $logger->info(
- "Credit card payment for user $user_id failed: " .
- $response->{"textcode"} . " " .
- $response->{"payload"}->{"error_message"}
- );
-
- return $response;
- } else {
- # We need to save this for later in case there's a failure on
- # the EG side to store the processor's result.
- $cc_payload = $response->{"payload"};
-
- $approval_code = $cc_payload->{"authorization"};
- $cc_type = $cc_payload->{"card_type"};
- $cc_processor = $cc_payload->{"processor"};
- $logger->info("Credit card payment for user $user_id succeeded");
- }
- } else {
- return OpenILS::Event->new(
- 'BAD_PARAMS', note => 'Need approval code'
- ) if not $cc_args->{approval_code};
- }
- }
-
- ### RE-OPEN TRANSACTION HERE ###
- $e->xact_begin;
- my @payment_ids;
-
- # create payment records
- my $create_money_method = "create_money_" . $type;
- for my $payment (@payment_objs) {
- # update the transaction if it's done
- my $amount = $payment->amount;
- my $transid = $payment->xact;
- my $trans = $xacts{$transid};
- if( (my $cred = ($trans->balance_owed - $amount)) <= 0 ) {
- # Any overpay on this transaction goes directly into patron
- # credit making payment with existing patron credit.
- $credit -= $amount if $type eq 'credit_payment';
-
- $cred = -$cred;
- $credit += $cred;
- my $circ = $e->retrieve_action_circulation($transid);
-
- if(!$circ || $circ->stop_fines) {
- # If this is a circulation, we can't close the transaction
- # unless stop_fines is set.
- $trans = $e->retrieve_money_billable_transaction($transid);
- $trans->xact_finish("now");
- if (!$e->update_money_billable_transaction($trans)) {
- return _recording_failure(
- $e, "update_money_billable_transaction() failed",
- $payment, $cc_payload
- )
- }
- }
- }
-
- $payment->approval_code($approval_code) if $approval_code;
- $payment->cc_type($cc_type) if $cc_type;
- $payment->cc_processor($cc_processor) if $cc_processor;
- $payment->cc_first_name($cc_args->{'billing_first'}) if $cc_args->{'billing_first'};
- $payment->cc_last_name($cc_args->{'billing_last'}) if $cc_args->{'billing_last'};
- if (!$e->$create_money_method($payment)) {
- return _recording_failure(
- $e, "$create_money_method failed", $payment, $cc_payload
- );
- }
-
- push(@payment_ids, $payment->id);
- }
-
- my $evt = _update_patron_credit($e, $patron, $credit);
- if ($evt) {
- return _recording_failure(
- $e, "_update_patron_credit() failed", undef, $cc_payload
- );
- }
-
- for my $org_id (keys %orgs) {
- # calculate penalties for each of the affected orgs
- $evt = OpenILS::Utils::Penalty->calculate_penalties(
- $e, $user_id, $org_id
- );
- if ($evt) {
- return _recording_failure(
- $e, "calculate_penalties() failed", undef, $cc_payload
- );
- }
- }
-
- # update the user to create a new last_xact_id
- $e->update_actor_user($patron) or return $e->die_event;
- $patron = $e->retrieve_actor_user($patron) or return $e->die_event;
- $e->commit;
-
- # update the cached user object if a user is making a payment toward
- # his/her own account
- $U->simplereq('open-ils.auth', 'open-ils.auth.session.reset_timeout', $auth, 1)
- if $user_id == $e->requestor->id;
-
- return {last_xact_id => $patron->last_xact_id, payments => \@payment_ids};
-}
-
-sub _recording_failure {
- my ($e, $msg, $payment, $payload) = @_;
-
- if ($payload) { # If the payment processor already accepted a payment:
- $logger->error($msg);
- $logger->error("Payment processor payload: " . Dumper($payload));
- # payment shouldn't contain CC number
- $logger->error("Payment: " . Dumper($payment)) if $payment;
-
- $e->rollback;
-
- return new OpenILS::Event(
- "CREDIT_PROCESSOR_SUCCESS_WO_RECORD",
- "payload" => $payload
- );
- } else { # Otherwise, the problem is somewhat less severe:
- $logger->warn($msg);
- $logger->warn("Payment: " . Dumper($payment)) if $payment;
- return $e->die_event;
- }
-}
-
-sub _update_patron_credit {
- my($e, $patron, $credit) = @_;
- return undef if $credit == 0;
- $patron->credit_forward_balance($patron->credit_forward_balance + $credit);
- return OpenILS::Event->new('NEGATIVE_PATRON_BALANCE') if $patron->credit_forward_balance < 0;
- $e->update_actor_user($patron) or return $e->die_event;
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_payments",
- api_name => "open-ils.circ.money.payment.retrieve.all_",
- notes => "Returns a list of payments attached to a given transaction"
- );
-sub retrieve_payments {
- my( $self, $client, $login, $transid ) = @_;
-
- my( $staff, $evt ) =
- $apputils->checksesperm($login, 'VIEW_TRANSACTION');
- return $evt if $evt;
-
- # XXX the logic here is wrong.. we need to check the owner of the transaction
- # to make sure the requestor has access
-
- # XXX grab the view, for each object in the view, grab the real object
-
- return $apputils->simplereq(
- 'open-ils.cstore',
- 'open-ils.cstore.direct.money.payment.search.atomic', { xact => $transid } );
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_payments2",
- authoritative => 1,
- api_name => "open-ils.circ.money.payment.retrieve.all",
- notes => "Returns a list of payments attached to a given transaction"
- );
-
-sub retrieve_payments2 {
- my( $self, $client, $login, $transid ) = @_;
-
- my $e = new_editor(authtoken=>$login);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_TRANSACTION');
-
- my @payments;
- my $pmnts = $e->search_money_payment({ xact => $transid });
- for( @$pmnts ) {
- my $type = $_->payment_type;
- my $meth = "retrieve_money_$type";
- my $p = $e->$meth($_->id) or return $e->event;
- $p->payment_type($type);
- $p->cash_drawer($e->retrieve_actor_workstation($p->cash_drawer))
- if $p->has_field('cash_drawer');
- push( @payments, $p );
- }
-
- return \@payments;
-}
-
-__PACKAGE__->register_method(
- method => "format_payment_receipt",
- api_name => "open-ils.circ.money.payment_receipt.print",
- signature => {
- desc => 'Returns a printable receipt for the specified payments',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Payment ID or array of payment IDs', type => 'number' },
- ],
- return => {
- desc => q/An action_trigger.event object or error event./,
- type => 'object',
- }
- }
-);
-__PACKAGE__->register_method(
- method => "format_payment_receipt",
- api_name => "open-ils.circ.money.payment_receipt.email",
- signature => {
- desc => 'Emails a receipt for the specified payments to the user associated with the first payment',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Payment ID or array of payment IDs', type => 'number' },
- ],
- return => {
- desc => q/Undefined on success, otherwise an error event./,
- type => 'object',
- }
- }
-);
-
-sub format_payment_receipt {
- my($self, $conn, $auth, $mp_id) = @_;
-
- my $mp_ids;
- if (ref $mp_id ne 'ARRAY') {
- $mp_ids = [ $mp_id ];
- } else {
- $mp_ids = $mp_id;
- }
-
- my $for_print = ($self->api_name =~ /print/);
- my $for_email = ($self->api_name =~ /email/);
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $payments = [];
- for my $id (@$mp_ids) {
-
- my $payment = $e->retrieve_money_payment([
- $id,
- { flesh => 2,
- flesh_fields => {
- mp => ['xact'],
- mbt => ['usr']
- }
- }
- ]) or return OpenILS::Event->new('MP_NOT_FOUND');
-
- return $e->event unless $e->allowed('VIEW_TRANSACTION', $payment->xact->usr->home_ou);
-
- push @$payments, $payment;
- }
-
- if ($for_print) {
-
- return $U->fire_object_event(undef, 'money.format.payment_receipt.print', $payments, $$payments[0]->xact->usr->home_ou);
-
- } elsif ($for_email) {
-
- for my $p (@$payments) {
- $U->create_events_for_hook('money.format.payment_receipt.email', $p, $p->xact->usr->home_ou, undef, undef, 1);
- }
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => "create_grocery_bill",
- api_name => "open-ils.circ.money.grocery.create",
- notes => <<" NOTE");
- Creates a new grocery transaction using the transaction object provided
- PARAMS: (login_session, money.grocery (mg) object)
- NOTE
-
-sub create_grocery_bill {
- my( $self, $client, $login, $transaction ) = @_;
-
- my( $staff, $evt ) = $apputils->checkses($login);
- return $evt if $evt;
- $evt = $apputils->check_perms($staff->id,
- $transaction->billing_location, 'CREATE_TRANSACTION' );
- return $evt if $evt;
-
-
- $logger->activity("Creating grocery bill " . Dumper($transaction) );
-
- $transaction->clear_id;
- my $session = $apputils->start_db_session;
- my $transid = $session->request(
- 'open-ils.storage.direct.money.grocery.create', $transaction)->gather(1);
-
- throw OpenSRF::EX ("Error creating new money.grocery") unless defined $transid;
-
- $logger->debug("Created new grocery transaction $transid");
-
- $apputils->commit_db_session($session);
-
- my $e = new_editor(xact=>1);
- $evt = _check_open_xact($e, $transid);
- return $evt if $evt;
- $e->commit;
-
- return $transid;
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_reservation',
- api_name => 'open-ils.circ.booking.reservation.retrieve'
-);
-sub fetch_reservation {
- my( $self, $conn, $auth, $id ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_TRANSACTION'); # eh.. basically the same permission
- my $g = $e->retrieve_booking_reservation($id)
- or return $e->event;
- return $g;
-}
-
-__PACKAGE__->register_method(
- method => 'fetch_grocery',
- api_name => 'open-ils.circ.money.grocery.retrieve'
-);
-sub fetch_grocery {
- my( $self, $conn, $auth, $id ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_TRANSACTION'); # eh.. basically the same permission
- my $g = $e->retrieve_money_grocery($id)
- or return $e->event;
- return $g;
-}
-
-
-__PACKAGE__->register_method(
- method => "billing_items",
- api_name => "open-ils.circ.money.billing.retrieve.all",
- authoritative => 1,
- signature => {
- desc => 'Returns a list of billing items for the given transaction ID. ' .
- 'If the operator is not the owner of the transaction, the VIEW_TRANSACTION permission is required.',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Transaction ID', type => 'number'}
- ],
- return => {
- desc => 'Transaction object, event on error'
- },
- }
-);
-
-sub billing_items {
- my( $self, $client, $login, $transid ) = @_;
-
- my( $trans, $evt ) = $U->fetch_billable_xact($transid);
- return $evt if $evt;
-
- my $staff;
- ($staff, $evt ) = $apputils->checkses($login);
- return $evt if $evt;
-
- if($staff->id ne $trans->usr) {
- $evt = $U->check_perms($staff->id, $staff->home_ou, 'VIEW_TRANSACTION');
- return $evt if $evt;
- }
-
- return $apputils->simplereq( 'open-ils.cstore',
- 'open-ils.cstore.direct.money.billing.search.atomic', { xact => $transid } )
-}
-
-
-__PACKAGE__->register_method(
- method => "billing_items_create",
- api_name => "open-ils.circ.money.billing.create",
- notes => <<" NOTE");
- Creates a new billing line item
- PARAMS( login, bill_object (mb) )
- NOTE
-
-sub billing_items_create {
- my( $self, $client, $login, $billing ) = @_;
-
- my $e = new_editor(authtoken => $login, xact => 1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_BILL');
-
- my $xact = $e->retrieve_money_billable_transaction($billing->xact)
- or return $e->die_event;
-
- # if the transaction was closed, re-open it
- if($xact->xact_finish) {
- $xact->clear_xact_finish;
- $e->update_money_billable_transaction($xact)
- or return $e->die_event;
- }
-
- my $amt = $billing->amount;
- $amt =~ s/\$//og;
- $billing->amount($amt);
-
- $e->create_money_billing($billing) or return $e->die_event;
- my $evt = OpenILS::Utils::Penalty->calculate_penalties($e, $xact->usr, $U->xact_org($xact->id));
- return $evt if $evt;
- $e->commit;
-
- return $billing->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'void_bill',
- api_name => 'open-ils.circ.money.billing.void',
- signature => q/
- Voids a bill
- @param authtoken Login session key
- @param billid Id for the bill to void. This parameter may be repeated to reference other bills.
- @return 1 on success, Event on error
- /
-);
-sub void_bill {
- my( $s, $c, $authtoken, @billids ) = @_;
-
- my $e = new_editor( authtoken => $authtoken, xact => 1 );
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('VOID_BILLING');
-
- my %users;
- for my $billid (@billids) {
-
- my $bill = $e->retrieve_money_billing($billid)
- or return $e->die_event;
-
- my $xact = $e->retrieve_money_billable_transaction($bill->xact)
- or return $e->die_event;
-
- if($U->is_true($bill->voided)) {
- $e->rollback;
- return OpenILS::Event->new('BILL_ALREADY_VOIDED', payload => $bill);
- }
-
- my $org = $U->xact_org($bill->xact, $e);
- $users{$xact->usr} = {} unless $users{$xact->usr};
- $users{$xact->usr}->{$org} = 1;
-
- $bill->voided('t');
- $bill->voider($e->requestor->id);
- $bill->void_time('now');
-
- $e->update_money_billing($bill) or return $e->die_event;
- my $evt = _check_open_xact($e, $bill->xact, $xact);
- return $evt if $evt;
- }
-
- # calculate penalties for all user/org combinations
- for my $user_id (keys %users) {
- for my $org_id (keys %{$users{$user_id}}) {
- OpenILS::Utils::Penalty->calculate_penalties($e, $user_id, $org_id);
- }
- }
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'edit_bill_note',
- api_name => 'open-ils.circ.money.billing.note.edit',
- signature => q/
- Edits the note for a bill
- @param authtoken Login session key
- @param note The replacement note for the bills we're editing
- @param billid Id for the bill to edit the note of. This parameter may be repeated to reference other bills.
- @return 1 on success, Event on error
- /
-);
-sub edit_bill_note {
- my( $s, $c, $authtoken, $note, @billids ) = @_;
-
- my $e = new_editor( authtoken => $authtoken, xact => 1 );
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('UPDATE_BILL_NOTE');
-
- for my $billid (@billids) {
-
- my $bill = $e->retrieve_money_billing($billid)
- or return $e->die_event;
-
- $bill->note($note);
- # FIXME: Does this get audited? Need some way so that the original creator of the bill does not get credit/blame for the new note.
-
- $e->update_money_billing($bill) or return $e->die_event;
- }
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'edit_payment_note',
- api_name => 'open-ils.circ.money.payment.note.edit',
- signature => q/
- Edits the note for a payment
- @param authtoken Login session key
- @param note The replacement note for the payments we're editing
- @param paymentid Id for the payment to edit the note of. This parameter may be repeated to reference other payments.
- @return 1 on success, Event on error
- /
-);
-sub edit_payment_note {
- my( $s, $c, $authtoken, $note, @paymentids ) = @_;
-
- my $e = new_editor( authtoken => $authtoken, xact => 1 );
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('UPDATE_PAYMENT_NOTE');
-
- for my $paymentid (@paymentids) {
-
- my $payment = $e->retrieve_money_payment($paymentid)
- or return $e->die_event;
-
- $payment->note($note);
- # FIXME: Does this get audited? Need some way so that the original taker of the payment does not get credit/blame for the new note.
-
- $e->update_money_payment($payment) or return $e->die_event;
- }
-
- $e->commit;
- return 1;
-}
-
-sub _check_open_xact {
- my( $editor, $xactid, $xact ) = @_;
-
- # Grab the transaction
- $xact ||= $editor->retrieve_money_billable_transaction($xactid);
- return $editor->event unless $xact;
- $xactid ||= $xact->id;
-
- # grab the summary and see how much is owed on this transaction
- my ($summary) = $U->fetch_mbts($xactid, $editor);
-
- # grab the circulation if it is a circ;
- my $circ = $editor->retrieve_action_circulation($xactid);
-
- # If nothing is owed on the transaction but it is still open
- # and this transaction is not an open circulation, close it
- if(
- ( $summary->balance_owed == 0 and ! $xact->xact_finish ) and
- ( !$circ or $circ->stop_fines )) {
-
- $logger->info("closing transaction ".$xact->id. ' becauase balance_owed == 0');
- $xact->xact_finish('now');
- $editor->update_money_billable_transaction($xact)
- or return $editor->event;
- return undef;
- }
-
- # If money is owed or a refund is due on the xact and xact_finish
- # is set, clear it (to reopen the xact) and update
- if( $summary->balance_owed != 0 and $xact->xact_finish ) {
- $logger->info("re-opening transaction ".$xact->id. ' becauase balance_owed != 0');
- $xact->clear_xact_finish;
- $editor->update_money_billable_transaction($xact)
- or return $editor->event;
- return undef;
- }
- return undef;
-}
-
-
-__PACKAGE__->register_method (
- method => 'fetch_mbts',
- authoritative => 1,
- api_name => 'open-ils.circ.money.billable_xact_summary.retrieve'
-);
-sub fetch_mbts {
- my( $self, $conn, $auth, $id) = @_;
-
- my $e = new_editor(xact => 1, authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my ($mbts) = $U->fetch_mbts($id, $e);
-
- my $user = $e->retrieve_actor_user($mbts->usr)
- or return $e->die_event;
-
- return $e->die_event unless $e->allowed('VIEW_TRANSACTION', $user->home_ou);
- $e->rollback;
- return $mbts
-}
-
-
-__PACKAGE__->register_method(
- method => 'desk_payments',
- api_name => 'open-ils.circ.money.org_unit.desk_payments'
-);
-sub desk_payments {
- my( $self, $conn, $auth, $org, $start_date, $end_date ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_TRANSACTION', $org);
- my $data = $U->storagereq(
- 'open-ils.storage.money.org_unit.desk_payments.atomic',
- $org, $start_date, $end_date );
-
- $_->workstation( $_->workstation->name ) for(@$data);
- return $data;
-}
-
-
-__PACKAGE__->register_method(
- method => 'user_payments',
- api_name => 'open-ils.circ.money.org_unit.user_payments'
-);
-
-sub user_payments {
- my( $self, $conn, $auth, $org, $start_date, $end_date ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_TRANSACTION', $org);
- my $data = $U->storagereq(
- 'open-ils.storage.money.org_unit.user_payments.atomic',
- $org, $start_date, $end_date );
- for(@$data) {
- $_->usr->card(
- $e->retrieve_actor_card($_->usr->card)->barcode);
- $_->usr->home_ou(
- $e->retrieve_actor_org_unit($_->usr->home_ou)->shortname);
- }
- return $data;
-}
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_credit_payable_balance',
- api_name => 'open-ils.circ.credit.payable_balance.retrieve',
- authoritative => 1,
- signature => {
- desc => q/Returns the total amount the patron can pay via credit card/,
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'User id', type => 'number' }
- ],
- return => { desc => 'The ID of the new provider' }
- }
-);
-
-sub retrieve_credit_payable_balance {
- my ( $self, $conn, $auth, $user_id ) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $user = $e->retrieve_actor_user($user_id)
- or return $e->event;
-
- if($e->requestor->id != $user_id) {
- return $e->event unless $e->allowed('VIEW_USER_TRANSACTIONS', $user->home_ou)
- }
-
- my $circ_orgs = $e->json_query({
- "select" => {circ => ["circ_lib"]},
- from => "circ",
- "where" => {usr => $user_id, xact_finish => undef},
- distinct => 1
- });
-
- my $groc_orgs = $e->json_query({
- "select" => {mg => ["billing_location"]},
- from => "mg",
- "where" => {usr => $user_id, xact_finish => undef},
- distinct => 1
- });
-
- my %hash;
- for my $org ( @$circ_orgs, @$groc_orgs ) {
- my $o = $org->{billing_location};
- $o = $org->{circ_lib} unless $o;
- next if $hash{$o}; # was $hash{$org}, but that doesn't make sense. $org is a hashref and $o gets added in the next line.
- $hash{$o} = $U->ou_ancestor_setting_value($o, 'credit.payments.allow', $e);
- }
-
- my @credit_orgs = map { $hash{$_} ? ($_) : () } keys %hash;
- $logger->debug("credit: relevant orgs that allow credit payments => @credit_orgs");
-
- my $xact_summaries =
- OpenILS::Application::AppUtils->simplereq('open-ils.actor',
- 'open-ils.actor.user.transactions.have_charge', $auth, $user_id);
-
- my $sum = 0.0;
-
- for my $xact (@$xact_summaries) {
-
- # make two lists and grab them in batch XXX
- if ( $xact->xact_type eq 'circulation' ) {
- my $circ = $e->retrieve_action_circulation($xact->id) or return $e->event;
- next unless grep { $_ == $circ->circ_lib } @credit_orgs;
-
- } elsif ($xact->xact_type eq 'grocery') {
- my $bill = $e->retrieve_money_grocery($xact->id) or return $e->event;
- next unless grep { $_ == $bill->billing_location } @credit_orgs;
- } elsif ($xact->xact_type eq 'reservation') {
- my $bill = $e->retrieve_booking_reservation($xact->id) or return $e->event;
- next unless grep { $_ == $bill->pickup_lib } @credit_orgs;
- }
- $sum += $xact->balance_owed();
- }
-
- return $sum;
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Circ::NonCat;
-use base 'OpenILS::Application';
-use strict; use warnings;
-use OpenSRF::EX qw(:try);
-use Data::Dumper;
-use DateTime;
-use DateTime::Format::ISO8601;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::Editor;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-$Data::Dumper::Indent = 0;
-
-my $U = "OpenILS::Application::AppUtils";
-my $_dt_parser = DateTime::Format::ISO8601->new;
-
-
-# returns ( $newid, $evt ). If $evt, then there was an error
-sub create_non_cat_circ {
- my( $staffid, $patronid, $circ_lib, $noncat_type, $circ_time, $editor ) = @_;
-
- my( $id, $nct, $evt );
- $circ_time ||= 'now';
- my $circ = Fieldmapper::action::non_cataloged_circulation->new;
-
- $logger->activity("Creating non-cataloged circulation for ".
- "staff $staffid, patron $patronid, location $circ_lib, and non-cat type $noncat_type");
-
- $circ->patron($patronid);
- $circ->staff($staffid);
- $circ->circ_lib($circ_lib);
- $circ->item_type($noncat_type);
- $circ->circ_time($circ_time);
-
- if( $editor ) {
- $evt = $editor->event unless
- $circ = $editor->create_action_non_cataloged_circulation( $circ )
-
-
- } else {
- $id = $U->simplereq(
- 'open-ils.storage',
- 'open-ils.storage.direct.action.non_cataloged_circulation.create', $circ );
- $evt = $U->DB_UPDATE_FAILED($circ) unless $id;
- $circ->id($id);
- }
-
- if($circ) {
- my $e = ($editor) ? $editor : new_editor();
- $circ = noncat_due_date($e, $circ);
- }
-
- return( $circ, $evt );
-}
-
-
-__PACKAGE__->register_method(
- method => "create_noncat_type",
- api_name => "open-ils.circ.non_cat_type.create",
- notes => q/
- Creates a new non cataloged item type
- @param authtoken The login session key
- @param name The name of the new type
- @param orgId The location where the type will live
- @return The type object on success and the corresponding
- event on failure
- /
-);
-
-sub create_noncat_type {
- my( $self, $client, $authtoken, $name, $orgId, $interval, $inhouse ) = @_;
-
- my $e = new_editor(authtoken=>$authtoken, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_NON_CAT_TYPE', $orgId);
-
- # grab all of "my" non-cat types and see if one with
- # the requested name already exists
- my $types = retrieve_noncat_types_all($self, $client, $orgId);
- for(@$types) {
- if( $_->name eq $name ) {
- $e->rollback;
- return OpenILS::Event->new('NON_CAT_TYPE_EXISTS', payload => $name);
- }
- }
-
- my $type = Fieldmapper::config::non_cataloged_type->new;
- $type->name($name);
- $type->owning_lib($orgId);
- $type->circ_duration($interval);
- $type->in_house( ($inhouse) ? 't' : 'f' );
-
- $e->create_config_non_cataloged_type($type) or return $e->die_event;
- $e->commit;
- return $type;
-}
-
-
-__PACKAGE__->register_method(
- method => "update_noncat_type",
- api_name => "open-ils.circ.non_cat_type.update",
- notes => q/
- Updates a non-cataloged type object
- @param authtoken The login session key
- @param type The updated type object
- @return The result of the DB update call unless a preceeding event occurs,
- in which case the event will be returned
- /
-);
-
-sub update_noncat_type {
- my( $self, $client, $authtoken, $type ) = @_;
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
-
- my $otype = $e->retrieve_config_non_cataloged_type($type->id)
- or return $e->die_event;
-
- return $e->die_event unless
- $e->allowed('UPDATE_NON_CAT_TYPE', $otype->owning_lib);
-
- $type->owning_lib($otype->owning_lib); # do not allow them to "move" the object
-
- $e->update_config_non_cataloged_type($type) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_noncat_types_all",
- api_name => "open-ils.circ.non_cat_types.retrieve.all",
- signature => {
- desc => 'Retrieves the non-cat types at the requested location as well '
- . 'as those above and below it in the org tree',
- params => [
- { name => 'orgId', desc => 'Org unit ID of the base location', type => 'number' },
- { name => 'depth', desc => 'Depth limit of the tree (optional)', type => 'number' }
- ],
- return => {
- desc => 'Array of non-cat objects, event on error'
- },
- }
-);
-
-sub retrieve_noncat_types_all {
- my( $self, $client, $orgId, $depth ) = @_;
- my $meth = 'open-ils.storage.ranged.config.non_cataloged_type.retrieve.atomic';
- my $svc = 'open-ils.storage';
- return $U->simplereq($svc, $meth, $orgId, $depth) if defined($depth);
- return $U->simplereq($svc, $meth, $orgId);
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_noncat',
- api_name => 'open-ils.circ.non_cataloged_circulation.retrieve',
- signature => {
- desc => 'Retrieve a circulation on a non cataloged item for a given Circ ID. If the operator is not the '
- . 'patron owner of the circ, the VIEW_CIRCULATIONS permission is required',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'Circulation ID', type => 'number' }
- ],
- return => {
- desc => 'Circulation object, event on error',
- },
- }
-);
-
-sub fetch_noncat {
- my( $self, $conn, $auth, $circid ) = @_;
- my $e = new_editor( authtoken => $auth );
- return $e->event unless $e->checkauth;
- my $c = $e->retrieve_action_non_cataloged_circulation($circid)
- or return $e->event;
- if( $c->patron ne $e->requestor->id ) {
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # XXX rely on editor perm
- }
- return noncat_due_date($e, $c);
-}
-
-sub noncat_due_date {
- my($e, $circ) = @_;
-
- my $otype = $e->retrieve_config_non_cataloged_type($circ->item_type)
- or return $e->die_event;
-
- my $duedate = $_dt_parser->parse_datetime( cleanse_ISO8601($circ->circ_time) );
- $duedate = $duedate
- ->add( seconds => interval_to_seconds($otype->circ_duration) )
- ->strftime('%FT%T%z');
-
- my $offset = $U->storagereq(
- 'open-ils.storage.actor.org_unit.closed_date.overlap',
- $circ->circ_lib,
- $duedate
- );
-
- $duedate = $offset->{end} if ($offset);
- $circ->duedate($duedate);
-
- return $circ;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_open_noncats',
- authoritative => 1,
- api_name => 'open-ils.circ.open_non_cataloged_circulation.user',
- signature => {
- desca => 'For a given user, returns an id-list of non-cataloged circulations that are considered open as of now. ' .
- 'A circ is open if circ time + circ duration (based on type) is > than now. If trying to view the circs ' .
- 'of another user, the VIEW_CIRCULATIONS permission is required',
- params => [
- { desc => 'Authentication token', type => 'string' },
- { desc => 'UserID (optional: defaults to the session user)', type => 'number' }
- ],
- return => {
- desc => 'Array of non-cataloged circ IDs, event on error'
- },
- }
-);
-
-sub fetch_open_noncats {
- my( $self, $conn, $auth, $userid ) = @_;
- my $e = OpenILS::Utils::Editor->new( authtoken => $auth );
- return $e->event unless $e->checkauth;
- $userid ||= $e->requestor->id;
- if( $e->requestor->id ne $userid ) {
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # XXX rely on editor perm
- }
- return $e->request(
- 'open-ils.storage.action.open_non_cataloged_circulation.user', $userid );
-}
-
-
-__PACKAGE__->register_method(
- method => 'delete_noncat',
- api_name => 'open-ils.circ.non_cataloged_type.delete',
-);
-sub delete_noncat {
- my( $self, $conn, $auth, $typeid ) = @_;
- my $e = new_editor(xact=>1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $nc = $e->retrieve_config_non_cataloged_type($typeid)
- or return $e->die_event;
-
- $e->allowed('DELETE_NON_CAT_TYPE', $nc->owning_lib) # XXX rely on editor perm
- or return $e->die_event;
-
- # XXX Add checks to see if this type is in use by a transaction
-
- $e->delete_config_non_cataloged_type($nc) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Circ::ScriptBuilder;
-use strict; use warnings;
-use OpenILS::Utils::ScriptRunner;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Application::Circ::Holds;
-use DateTime::Format::ISO8601;
-use OpenSRF::Utils qw/:datetime/;
-use Scalar::Util qw/weaken/;
-my $U = "OpenILS::Application::AppUtils";
-use Data::Dumper;
-
-my $holdcode = "OpenILS::Application::Circ::Holds";
-
-my $evt = "environment";
-my %GROUP_SET;
-my $GROUP_TREE;
-my $ORG_TREE;
-my @ORG_LIST;
-my @OU_TYPES;
-
-
-# -----------------------------------------------------------------------
-# Possible Args:
-# copy
-# copy_id
-# copy_barcode
-#
-# patron
-# patron_id
-# patron_barcode
-#
-# fetch_patron_circ_info - load info on items out, overdues, and fines.
-#
-# _direct - this is a hash of key/value pairs to shove directly into the
-# script runner. Use this to cover data not covered by this module
-# -----------------------------------------------------------------------
-sub build {
- my( $class, $args ) = @_;
-
- my $evt;
- my @evts;
-
- my $rollback;
- my $editor = $$args{editor};
-
- unless($editor) {
- $editor = new_editor(xact => 1);
- $rollback = 1;
- }
-
- $args->{_direct} = {} unless $args->{_direct};
- #$args->{editor} = $editor;
-
- $evt = fetch_bib_data($editor, $args);
- push(@evts, $evt) if $evt;
- $evt = fetch_user_data($editor, $args);
- push(@evts, $evt) if $evt;
-
- if(@evts) {
- my @e;
- push( @e, $_->{textcode} ) for @evts;
- $logger->info("script_builder: some events occurred: @e");
- $logger->debug("script_builder: some events occurred: " . Dumper(\@evts));
- $args->{_events} = \@evts;
- }
-
- my $r = build_runner($editor, $args);
- $editor->rollback if $rollback;
- return $r;
-}
-
-
-sub build_runner {
- my $editor = shift;
- my $ctx = shift;
-
- my $runner = OpenILS::Utils::ScriptRunner->new;
-
- my $gt = $GROUP_TREE;
- $runner->insert( "$evt.groupTree", $gt, 1);
-
-
- $runner->insert( "$evt.patron", $ctx->{patron}, 1);
- $runner->insert( "$evt.copy", $ctx->{copy}, 1);
- $runner->insert( "$evt.volume", $ctx->{volume}, 1);
- $runner->insert( "$evt.title", $ctx->{title}, 1);
-
- if( ref $ctx->{requestor} ) {
- $runner->insert( "$evt.requestor", $ctx->{requestor}, 1);
- if($ctx->{requestor}->ws_ou) {
- $runner->insert( "$evt.location",
- $editor->retrieve_actor_org_unit($ctx->{requestor}->ws_ou), 1);
- }
- }
-
- $runner->insert( "$evt.patronItemsOut", $ctx->{patronItemsOut}, 1 );
- $runner->insert( "$evt.patronOverdueCount", $ctx->{patronOverdue}, 1 );
- $runner->insert( "$evt.patronFines", $ctx->{patronFines}, 1 );
-
- $runner->insert("$evt.$_", $ctx->{_direct}->{$_}, 1) for keys %{$ctx->{_direct}};
-
- insert_org_methods( $editor, $runner );
- insert_copy_methods( $editor, $ctx, $runner );
- insert_user_funcs( $editor, $ctx, $runner );
-
- return $runner;
-}
-
-sub fetch_bib_data {
- my $e = shift;
- my $ctx = shift;
-
- my $flesh = {
- flesh => 2,
- flesh_fields => {
- acp => [ 'location', 'status', 'circ_lib', 'age_protect', 'call_number' ],
- acn => [ 'record' ]
- }
- };
-
- if( $ctx->{copy} ) {
- $ctx->{copy_id} = $ctx->{copy}->id
- unless $ctx->{copy_id} or $ctx->{copy_barcode};
- }
-
- my $copy;
-
- if($ctx->{copy_id}) {
- $copy = $e->retrieve_asset_copy(
- [$ctx->{copy_id}, $flesh ]) or return $e->event;
-
- } elsif( $ctx->{copy_barcode} ) {
-
- $copy = $e->search_asset_copy(
- [{barcode => $ctx->{copy_barcode}, deleted => 'f'}, $flesh ])->[0]
- or return $e->event;
- }
-
- return undef unless $copy;
-
- my $vol = $copy->call_number;
- my $rec = $vol->record;
- $ctx->{copy} = $copy;
- $ctx->{volume} = $vol;
- $copy->call_number($vol->id);
- $ctx->{title} = $rec;
- $vol->record($rec->id);
-
- return undef;
-}
-
-
-
-sub fetch_user_data {
- my( $e, $ctx ) = @_;
-
- my $flesh = {
- flesh => 2,
- flesh_fields => {
- au => [ qw/ profile home_ou card / ],
- aou => [ 'ou_type' ],
- }
- };
-
- if( $ctx->{patron} ) {
- $ctx->{patron_id} = $ctx->{patron}->id unless $ctx->{patron_id};
- }
-
- my $patron;
-
- if( $ctx->{patron_id} ) {
- $patron = $e->retrieve_actor_user([$ctx->{patron_id}, $flesh]);
-
- } elsif( $ctx->{patron_barcode} ) {
-
- my $card = $e->search_actor_card(
- { barcode => $ctx->{patron_barcode} } )->[0] or return $e->event;
-
- $patron = $e->search_actor_user(
- [{ card => $card->id }, $flesh ]
- )->[0] or return $e->event;
-
- } elsif( $ctx->{fetch_patron_by_circ_copy} ) {
-
- if( my $copy = $ctx->{copy} ) {
- my $circs = $e->search_action_circulation(
- { target_copy => $copy->id, checkin_time => undef });
-
- if( my $circ = $circs->[0] ) {
- $patron = $e->retrieve_actor_user([$circ->usr, $flesh])
- or return $e->event;
- }
- }
- }
-
- return undef unless $ctx->{patron} = $patron;
-
- flatten_groups($e);
-
- $ctx->{requestor} = $ctx->{requestor} || $e->requestor;
-
- if( $ctx->{fetch_patron_circ_info} ) {
- my $circ_counts = $U->storagereq('open-ils.storage.actor.user.checked_out.count', $patron->id);
-
- $ctx->{patronOverdue} = $circ_counts->{overdue} + $circ_counts->{long_overdue};
- my $out = $ctx->{patronOverdue} + $circ_counts->{out};
-
- $ctx->{patronItemsOut} = $out
- unless( $ctx->{patronItemsOut} and $ctx->{patronItemsOut} > $out );
-
- $logger->debug("script_builder: patron overdue count is " . $ctx->{patronOverdue});
- }
-
- if( $ctx->{fetch_patron_money_info} ) {
- $ctx->{patronFines} = $U->patron_money_owed($patron->id);
- $logger->debug("script_builder: patron fines determined to be ".$ctx->{patronFines});
- }
-
- unless( $ctx->{ignore_user_status} ) {
- return OpenILS::Event->new('PATRON_INACTIVE')
- unless $U->is_true($patron->active);
-
- return OpenILS::Event->new('PATRON_CARD_INACTIVE')
- unless $U->is_true($patron->card->active);
-
- my $expire = DateTime::Format::ISO8601->new->parse_datetime(
- cleanse_ISO8601($patron->expire_date));
-
- return OpenILS::Event->new('PATRON_ACCOUNT_EXPIRED')
- if( CORE::time > $expire->epoch ) ;
- }
-
- return undef;
-}
-
-
-sub flatten_groups {
- my $e = shift;
- my $tree = shift;
-
- if(!%GROUP_SET) {
- $GROUP_TREE = $e->search_permission_grp_tree(
- [
- { parent => undef },
- {
- flesh => 100,
- flesh_fields => { pgt => ['children'] }
- }
- ]
- )->[0];
- $tree = $GROUP_TREE;
- }
-
- return undef unless $tree;
- $GROUP_SET{$tree->id} = $tree;
- if( $tree->children ) {
- flatten_groups($e, $_) for @{$tree->children};
- }
-}
-
-sub flatten_org_tree {
- my $tree = shift;
- return undef unless $tree;
- push( @ORG_LIST, $tree );
- if( $tree->children ) {
- flatten_org_tree($_) for @{$tree->children};
- }
-}
-
-
-
-sub insert_org_methods {
- my ( $editor, $runner ) = @_;
-
- if(!$ORG_TREE) {
- $ORG_TREE = $editor->search_actor_org_unit(
- [
- {"parent_ou" => undef },
- {
- flesh => -1,
- flesh_fields => { aou => ['children'] },
- order_by => { aou => 'name'}
- }
- ]
- )->[0];
- flatten_org_tree($ORG_TREE);
- }
-
- my $r = $runner;
- weaken($r);
-
- $r->insert(__OILS_FUNC_isOrgDescendent =>
- sub {
- my( $write_key, $sname, $id ) = @_;
- my ($parent) = grep { $_->shortname eq $sname } @ORG_LIST;
- my ($child) = grep { $_->id == $id } @ORG_LIST;
- my $val = is_org_descendent( $parent, $child );
- $logger->debug("script_builder: is_org_desc $sname:$id returned val $val, writing to $write_key");
- $r->insert($write_key, $val, 1) if $val;
- return $val;
- }
- );
-
- $r->insert(__OILS_FUNC_hasCommonAncestor =>
- sub {
- my( $write_key, $orgid1, $orgid2, $depth ) = @_;
- my $val = has_common_ancestor( $orgid1, $orgid2, $depth );
- $logger->debug("script_builder: has_common_ancestor resturned $val");
- $r->insert($write_key, $val, 1) if $val;
- return $val;
- }
- );
-}
-
-
-sub is_org_descendent {
- my( $parent, $child ) = @_;
- return 0 unless $parent and $child;
- $logger->debug("script_builder: is_org_desc checking parent=".$parent->id.", child=".$child->id);
- do {
- return 0 unless defined $child->parent_ou;
- return 1 if $parent->id == $child->id;
- } while( ($child) = grep { $_->id == $child->parent_ou } @ORG_LIST );
- return 0;
-}
-
-sub has_common_ancestor {
- my( $org1, $org2, $depth ) = @_;
- return 0 unless $org1 and $org2;
- $logger->debug("script_builder: has_common_ancestor checking orgs $org1 : $org2");
-
- return 1 if $org1 == $org2;
- ($org1) = grep { $_->id == $org1 } @ORG_LIST;
- ($org2) = grep { $_->id == $org2 } @ORG_LIST;
-
- my $p1 = find_parent_at_depth($org1, $depth);
- my $p2 = find_parent_at_depth($org2, $depth);
-
- return 1 if $p1->id == $p2->id;
- return 0;
-}
-
-
-sub find_parent_at_depth {
- my $org = shift;
- my $depth = shift;
- return undef unless $org and $depth;
- fetch_ou_types();
- do {
- my ($t) = grep { $_->id == $org->ou_type } @OU_TYPES;
- return $org if $t->depth == $depth;
- } while( ($org) = grep { $_->id == $org->parent_ou } @ORG_LIST );
- return undef;
-}
-
-
-sub fetch_ou_types {
- return if @OU_TYPES;
- @OU_TYPES = @{new_editor()->retrieve_all_actor_org_unit_type()};
-}
-
-sub insert_copy_methods {
- my( $e, $ctx, $runner ) = @_;
- my $reqr = $ctx->{requestor} || $e->requestor;
- if( my $copy = $ctx->{copy} ) {
- $runner->insert_method( 'environment.copy', '__OILS_FUNC_fetch_best_hold', sub {
- my $key = shift;
- $logger->debug("script_builder: searching for permitted hold for copy ".$copy->barcode);
- my ($hold) = $holdcode->find_nearest_permitted_hold( $e, $copy, $reqr, 1 ); # do we need a new editor here since the xact may be dead??
- $runner->insert( $key, $hold, 1 );
- }
- );
- }
-}
-
-sub insert_user_funcs {
- my( $e, $ctx, $runner ) = @_;
-
- # tells how many holds a user has
- $runner->insert(__OILS_FUNC_userHoldCount =>
- sub {
- my( $write_key, $userid ) = @_;
- my $val = $holdcode->__user_hold_count(new_editor(), $userid);
- $logger->info("script_runner: user hold count is $val");
- $runner->insert($write_key, $val, 1) if $val;
- return $val;
- }
- );
-
- $runner->insert(__OILS_FUNC_userCircsByCircmod =>
- sub {
- my( $write_key, $userid ) = @_;
- use OpenSRF::Utils::JSON;
-
- # this bug ugly thing generates a count of checkouts by circ_modifier
- my $query = {
- "select" => {
- "acp" => ["circ_modifier"],
- "circ"=>[{
- "aggregate"=> OpenSRF::Utils::JSON->true,
- "transform"=>"count",
- "alias"=>"count",
- "column"=>"id"
- }],
- },
- "from"=>{"acp"=>{"circ"=>{"field"=>"target_copy","fkey"=>"id"}}},
- "where"=>{
- "+circ"=>{
- "checkin_time"=>undef,
- "usr"=>$userid,
- "-or"=>[
- {"stop_fines"=>["MAXFINES","LONGOVERDUE"]},
- {"stop_fines"=>undef}
- ]
- }
- }
- };
-
- my $mods = $e->json_query($query);
- my $breakdown = {};
- $breakdown->{$_->{circ_modifier}} = $_->{count} for @$mods;
- $logger->info("script_runner: Loaded checkouts by circ_modifier breakdown:".
- OpenSRF::Utils::JSON->perl2JSON($breakdown));
- $runner->insert($write_key, $breakdown, 1) if (keys %$breakdown);
- }
- );
-
-}
-
-
-
-
-1;
+++ /dev/null
-# ---------------------------------------------------------------
-# Copyright (C) 2006 Georgia Public Library Service
-# Bill Erickson <billserickson@gmail.com>
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-package OpenILS::Application::Circ::StatCat;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::Utils::Logger qw($logger);
-use OpenSRF::EX qw/:try/;
-use OpenILS::Application::AppUtils;
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-
-
-
-__PACKAGE__->register_method(
- method => "retrieve_stat_cat_list",
- argc => 1,
- api_name => "open-ils.circ.stat_cat.actor.retrieve.batch");
-
-__PACKAGE__->register_method(
- method => "retrieve_stat_cat_list",
- argc => 1,
- api_name => "open-ils.circ.stat_cat.asset.retrieve.batch");
-
-# retrieves all of the stat cats for a given org unit
-# if no orgid, user_session->home_ou is used
-
-sub retrieve_stat_cat_list {
- my( $self, $client, $user_session, @sc ) = @_;
-
- if (ref($sc[0])) {
- @sc = @{$sc[0]};
- }
-
- my $method = "open-ils.storage.fleshed.actor.stat_cat.retrieve.batch.atomic";
- if( $self->api_name =~ /asset/ ) {
- $method = "open-ils.storage.fleshed.asset.stat_cat.retrieve.batch.atomic";
- }
-
- my($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- my $cats = $apputils->simple_scalar_request(
- "open-ils.storage", $method, @sc);
-
- return [ sort { $a->name cmp $b->name } @$cats ];
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_stat_cats",
- api_name => "open-ils.circ.stat_cat.actor.retrieve.all");
-
-__PACKAGE__->register_method(
- method => "retrieve_stat_cats",
- api_name => "open-ils.circ.stat_cat.asset.retrieve.all");
-
-# retrieves all of the stat cats for a given org unit
-# if no orgid, user_session->home_ou is used
-
-sub retrieve_stat_cats {
- my( $self, $client, $user_session, $orgid ) = @_;
-
- my $method = "open-ils.storage.ranged.fleshed.actor.stat_cat.all.atomic";
- if( $self->api_name =~ /asset/ ) {
- $method = "open-ils.storage.ranged.fleshed.asset.stat_cat.all.atomic";
- }
-
- my($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- if(!$orgid) { $orgid = $user_obj->home_ou; }
- my $cats = $apputils->simple_scalar_request(
- "open-ils.storage", $method, $orgid );
-
- return [ sort { $a->name cmp $b->name } @$cats ];
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_ranged_intersect_stat_cats",
- api_name => "open-ils.circ.stat_cat.asset.multirange.intersect.retrieve");
-
-sub retrieve_ranged_intersect_stat_cats {
- my( $self, $client, $user_session, $orglist ) = @_;
-
- my($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- if(!$orglist) { $orglist = [ $user_obj->home_ou ]; }
-
- # uniquify, yay!
- my %hash = map { ($_ => 1) } @$orglist;
- $orglist = [ keys %hash ];
-
- warn "range: @$orglist\n";
-
- my $method = "open-ils.storage.multiranged.intersect.fleshed.asset.stat_cat.all.atomic";
- return $apputils->simple_scalar_request(
- "open-ils.storage", $method, $orglist );
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_ranged_union_stat_cats",
- api_name => "open-ils.circ.stat_cat.asset.multirange.union.retrieve");
-
-sub retrieve_ranged_union_stat_cats {
- my( $self, $client, $user_session, $orglist ) = @_;
-
- my $method = "open-ils.storage.multiranged.union.fleshed.asset.stat_cat.all.atomic";
- use Data::Dumper;
- warn "Retrieving stat_cats with method $method and orgs " . Dumper($orglist) . "\n";
-
- my($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- if(!$orglist) { $orglist = [ $user_obj->home_ou ]; }
-
- # uniquify, yay!
- my %hash = map { ($_ => 1) } @$orglist;
- $orglist = [ keys %hash ];
-
- warn "range: @$orglist\n";
-
- return $apputils->simple_scalar_request(
- "open-ils.storage", $method, $orglist );
-}
-
-
-
-__PACKAGE__->register_method(
- method => "stat_cat_create",
- api_name => "open-ils.circ.stat_cat.asset.create");
-
-__PACKAGE__->register_method(
- method => "stat_cat_create",
- api_name => "open-ils.circ.stat_cat.actor.create");
-
-sub stat_cat_create {
- my( $self, $client, $user_session, $stat_cat ) = @_;
-
- my $method = "open-ils.storage.direct.actor.stat_cat.create";
- my $entry_create = "open-ils.storage.direct.actor.stat_cat_entry.create";
- my $perm = 'CREATE_PATRON_STAT_CAT';
- my $eperm = 'CREATE_PATRON_STAT_CAT_ENTRY';
-
- if($self->api_name =~ /asset/) {
- $method = "open-ils.storage.direct.asset.stat_cat.create";
- $entry_create = "open-ils.storage.direct.asset.stat_cat_entry.create";
- $perm = 'CREATE_COPY_STAT_CAT_ENTRY';
- }
-
- #my $user_obj = $apputils->check_user_session($user_session);
- #my $orgid = $user_obj->home_ou();
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
- $evt = $apputils->check_perms($user_obj->id, $stat_cat->owner, $perm);
- return $evt if $evt;
-
- if($stat_cat->entries) {
- $evt = $apputils->check_perms($user_obj->id, $stat_cat->owner, $eperm);
- return $evt if $evt;
- }
-
-
- my $session = $apputils->start_db_session();
- my $newid = _create_stat_cat($session, $stat_cat, $method);
-
- if( ref($stat_cat->entries) ) {
- for my $entry (@{$stat_cat->entries}) {
- $entry->stat_cat($newid);
- _create_stat_entry($session, $entry, $entry_create);
- }
- }
-
- $apputils->commit_db_session($session);
-
- $logger->debug("Stat cat creation successful with id $newid");
-
- my $orgid = $user_obj->home_ou;
- if( $self->api_name =~ /asset/ ) {
- return _flesh_asset_cat($newid, $orgid);
- } else {
- return _flesh_user_cat($newid, $orgid);
- }
-}
-
-
-sub _flesh_user_cat {
- my $id = shift;
- my $orgid = shift;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- my $cat = $session->request(
- "open-ils.storage.direct.actor.stat_cat.retrieve",
- $id )->gather(1);
-
- $cat->entries(
- $session->request(
- "open-ils.storage.ranged.actor.stat_cat_entry.search.stat_cat.atomic",
- $orgid, $id )->gather(1) );
-
- return $cat;
-}
-
-
-sub _flesh_asset_cat {
- my $id = shift;
- my $orgid = shift;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- my $cat = $session->request(
- "open-ils.storage.direct.asset.stat_cat.retrieve",
- $id )->gather(1);
-
- $cat->entries(
- $session->request(
- "open-ils.storage.ranged.asset.stat_cat_entry.search.stat_cat.atomic",
- $orgid, $id )->gather(1) );
-
- return $cat;
-
-}
-
-
-sub _create_stat_cat {
- my( $session, $stat_cat, $method) = @_;
- warn "Creating new stat cat with name " . $stat_cat->name . "\n";
- $stat_cat->clear_id();
- my $req = $session->request( $method, $stat_cat );
- my $id = $req->gather(1);
- if(!$id) {
- throw OpenSRF::EX::ERROR
- ("Error creating new statistical category"); }
-
- warn "Stat cat create returned id $id\n";
- return $id;
-}
-
-
-sub _create_stat_entry {
- my( $session, $stat_entry, $method) = @_;
-
- warn "Creating new stat entry with value " . $stat_entry->value . "\n";
- $stat_entry->clear_id();
-
- my $req = $session->request($method, $stat_entry);
- my $id = $req->gather(1);
-
- warn "Stat entry " . Dumper($stat_entry) . "\n";
-
- if(!$id) {
- throw OpenSRF::EX::ERROR
- ("Error creating new stat cat entry"); }
-
- warn "Stat cat entry create returned id $id\n";
- return $id;
-}
-
-
-__PACKAGE__->register_method(
- method => "update_stat_entry",
- api_name => "open-ils.circ.stat_cat.actor.entry.update");
-
-__PACKAGE__->register_method(
- method => "update_stat_entry",
- api_name => "open-ils.circ.stat_cat.asset.entry.update");
-
-sub update_stat_entry {
- my( $self, $client, $user_session, $entry ) = @_;
-
-
- my $method = "open-ils.storage.direct.actor.stat_cat_entry.update";
- my $perm = 'UPDATE_PATRON_STAT_CAT_ENTRY';
- if($self->api_name =~ /asset/) {
- $method = "open-ils.storage.direct.asset.stat_cat_entry.update";
- $perm = 'UPDATE_COPY_STAT_CAT_ENTRY';
- }
-
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
- $evt = $apputils->check_perms( $user_obj->id, $entry->owner, $perm );
- return $evt if $evt;
-
- my $session = $apputils->start_db_session();
- my $req = $session->request($method, $entry);
- my $status = $req->gather(1);
- $apputils->commit_db_session($session);
- warn "stat cat entry with value " . $entry->value . " updated with status $status\n";
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "update_stat",
- api_name => "open-ils.circ.stat_cat.actor.update");
-
-__PACKAGE__->register_method(
- method => "update_stat",
- api_name => "open-ils.circ.stat_cat.asset.update");
-
-sub update_stat {
- my( $self, $client, $user_session, $cat ) = @_;
-
- my $method = "open-ils.storage.direct.actor.stat_cat.update";
- my $perm = 'UPDATE_PATRON_STAT_CAT';
- if($self->api_name =~ /asset/) {
- $method = "open-ils.storage.direct.asset.stat_cat.update";
- $perm = 'UPDATE_COPY_STAT_CAT';
- }
-
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
- $evt = $apputils->check_perms( $user_obj->id, $cat->owner, $perm );
- return $evt if $evt;
-
- my $session = $apputils->start_db_session();
- my $req = $session->request($method, $cat);
- my $status = $req->gather(1);
- $apputils->commit_db_session($session);
- warn "stat cat with id " . $cat->id . " updated with status $status\n";
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "create_stat_entry",
- api_name => "open-ils.circ.stat_cat.actor.entry.create");
-
-__PACKAGE__->register_method(
- method => "create_stat_entry",
- api_name => "open-ils.circ.stat_cat.asset.entry.create");
-
-sub create_stat_entry {
- my( $self, $client, $user_session, $entry ) = @_;
-
- my $method = "open-ils.storage.direct.actor.stat_cat_entry.create";
- my $perm = 'CREATE_PATRON_STAT_CAT_ENTRY';
- if($self->api_name =~ /asset/) {
- $method = "open-ils.storage.direct.asset.stat_cat_entry.create";
- $perm = 'CREATE_COPY_STAT_CAT_ENTRY';
- }
-
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
- $evt = $apputils->check_perms( $user_obj->id, $entry->owner, $perm );
- return $evt if $evt;
-
- $entry->clear_id();
- my $session = $apputils->start_db_session();
- my $req = $session->request($method, $entry);
- my $status = $req->gather(1);
- $apputils->commit_db_session($session);
-
- $logger->info("created stat cat entry $status");
- return $status;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "create_stat_map",
- api_name => "open-ils.circ.stat_cat.actor.user_map.create");
-
-__PACKAGE__->register_method(
- method => "create_stat_map",
- api_name => "open-ils.circ.stat_cat.asset.copy_map.create");
-
-sub create_stat_map {
- my( $self, $client, $user_session, $map ) = @_;
-
-
- my ( $evt, $copy, $volume, $patron, $user_obj );
-
- my $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.create";
- my $ret = "open-ils.storage.direct.actor.stat_cat_entry_user_map.retrieve";
- my $perm = 'CREATE_PATRON_STAT_CAT_ENTRY_MAP';
- my $perm_org;
-
- if($self->api_name =~ /asset/) {
- $method = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.create";
- $ret = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.retrieve";
- $perm = 'CREATE_COPY_STAT_CAT_ENTRY_MAP';
- ( $copy, $evt ) = $apputils->fetch_copy($map->owning_copy);
- return $evt if $evt;
- ( $volume, $evt ) = $apputils->fetch_callnumber($copy->call_number);
- return $evt if $evt;
- $perm_org = $volume->owning_lib;
-
- } else {
- ($patron, $evt) = $apputils->fetch_user($map->target_usr);
- return $evt if $evt;
- $perm_org = $patron->home_ou;
- }
-
- ( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
- $evt = $apputils->check_perms( $user_obj->id, $perm_org, $perm );
- return $evt if $evt;
-
- $logger->debug( $user_obj->id . " creating new stat cat map" );
-
- $map->clear_id();
-
- my $session = $apputils->start_db_session();
- my $req = $session->request($method, $map);
- my $newid = $req->gather(1);
- warn "Created new stat cat map with id $newid\n";
- $apputils->commit_db_session($session);
-
- return $apputils->simple_scalar_request( "open-ils.storage", $ret, $newid );
-
-}
-
-
-__PACKAGE__->register_method(
- method => "update_stat_map",
- api_name => "open-ils.circ.stat_cat.actor.user_map.update");
-
-__PACKAGE__->register_method(
- method => "update_stat_map",
- api_name => "open-ils.circ.stat_cat.asset.copy_map.update");
-
-sub update_stat_map {
- my( $self, $client, $user_session, $map ) = @_;
-
- my ( $evt, $copy, $volume, $patron, $user_obj );
-
- my $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.update";
- my $perm = 'UPDATE_PATRON_STAT_ENTRY_MAP';
- my $perm_org;
-
- if($self->api_name =~ /asset/) {
- $method = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.update";
- $perm = 'UPDATE_COPY_STAT_ENTRY_MAP';
- ( $copy, $evt ) = $apputils->fetch_copy($map->owning_copy);
- return $evt if $evt;
- ( $volume, $evt ) = $apputils->fetch_callnumber($copy->call_number);
- return $evt if $evt;
- $perm_org = $volume->owning_lib;
-
- } else {
- ($patron, $evt) = $apputils->fetch_user($map->target_usr);
- return $evt if $evt;
- $perm_org = $patron->home_ou;
- }
-
-
- ( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
- $evt = $apputils->check_perms( $user_obj->id, $perm_org, $perm );
- return $evt if $evt;
-
-
- my $session = $apputils->start_db_session();
- my $req = $session->request($method, $map);
- my $newid = $req->gather(1);
- warn "Updated new stat cat map with id $newid\n";
- $apputils->commit_db_session($session);
-
- return $newid;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "retrieve_maps",
- api_name => "open-ils.circ.stat_cat.actor.user_map.retrieve");
-
-__PACKAGE__->register_method(
- method => "retrieve_maps",
- api_name => "open-ils.circ.stat_cat.asset.copy_map.retrieve");
-
-sub retrieve_maps {
- my( $self, $client, $user_session, $target ) = @_;
-
-
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- my $method = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.search.owning_copy.atomic";
- if($self->api_name =~ /actor/ ) {
- if(!$target) { $target = $user_obj->id; }
- $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.search.target_usr.atomic";
- }
-
- return $apputils->simple_scalar_request("open-ils.storage", $method, $target);
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => "delete_stats",
- api_name => "open-ils.circ.stat_cat.actor.delete");
-
-__PACKAGE__->register_method(
- method => "delete_stats",
- api_name => "open-ils.circ.stat_cat.asset.delete");
-
-sub delete_stats {
- my( $self, $client, $user_session, $target ) = @_;
-
- my $cat;
-
- my $type = "actor";
- my $perm = 'DELETE_PATRON_STAT_CAT';
- if($self->api_name =~ /asset/) {
- $type = "asset";
- $perm = 'DELETE_COPY_STAT_CAT';
- }
-
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- ( $cat, $evt ) = $apputils->fetch_stat_cat( $type, $target );
- return $evt if $evt;
-
- $evt = $apputils->check_perms( $user_obj->id, $cat->owner, $perm );
- return $evt if $evt;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- return _delete_stats($session, $target, $type);
-}
-
-sub _delete_stats {
- my( $session, $stat, $type) = @_;
-
- my $method = "open-ils.storage.direct.asset.stat_cat.delete";
- if($type =~ /actor/ ) {
- $method = "open-ils.storage.direct.actor.stat_cat.delete";
- }
- return $session->request($method, $stat)->gather(1);
-}
-
-
-
-__PACKAGE__->register_method(
- method => "delete_entry",
- api_name => "open-ils.circ.stat_cat.actor.entry.delete");
-
-__PACKAGE__->register_method(
- method => "delete_entry",
- api_name => "open-ils.circ.stat_cat.asset.entry.delete");
-
-sub delete_entry {
- my( $self, $client, $user_session, $target ) = @_;
-
- my $type = "actor";
- my $perm = 'DELETE_PATRON_STAT_CAT_ENTRY';
- if($self->api_name =~ /asset/) {
- $type = "asset";
- $perm = 'DELETE_COPY_STAT_CAT_ENTRY';
- }
-
- my $entry;
- my( $user_obj, $evt ) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- ( $entry, $evt ) = $apputils->fetch_stat_cat_entry( $type, $target );
- return $evt if $evt;
-
- $evt = $apputils->check_perms( $user_obj->id, $entry->owner, $perm );
- return $evt if $evt;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- return _delete_entry($session, $target, $type);
-}
-
-sub _delete_entry {
- my( $session, $stat_entry, $type) = @_;
-
- my $method = "open-ils.storage.direct.asset.stat_cat_entry.delete";
- if($type =~ /actor/ ) {
- $method = "open-ils.storage.direct.actor.stat_cat_entry.delete";
- }
-
- return $session->request($method, $stat_entry)->gather(1);
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_stats_by_copy',
- api_name => 'open-ils.circ.asset.stat_cat_entries.fleshed.retrieve_by_copy',
-);
-
-
-sub fetch_stats_by_copy {
- my( $self, $conn, $args ) = @_;
-
- my @entries;
-
- if( $$args{public} ) {
- my $maps = $U->cstorereq(
- 'open-ils.cstore.direct.asset.stat_cat_entry_copy_map.search.atomic', { owning_copy => $$args{copyid} });
-
-
- warn "here\n";
- for my $map (@$maps) {
-
- warn "map ".$map->id."\n";
- warn "map ".$map->stat_cat_entry."\n";
-
- my $entry = $U->cstorereq(
- 'open-ils.cstore.direct.asset.stat_cat_entry.retrieve', $map->stat_cat_entry);
-
- warn "Found entry ".$entry->id."\n";
-
- my $cat = $U->cstorereq(
- 'open-ils.cstore.direct.asset.stat_cat.retrieve', $entry->stat_cat );
- $entry->stat_cat( $cat );
- push( @entries, $entry );
- }
- }
-
- return \@entries;
-}
-
-
-
-1;
+++ /dev/null
-# ---------------------------------------------------------------
-# Copyright (C) 2005 Georgia Public Library Service
-# Bill Erickson <highfalutin@gmail.com>
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-package OpenILS::Application::Circ::Survey;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use OpenSRF::EX qw/:try/;
-use OpenILS::Application::AppUtils;
-use Data::Dumper;
-use OpenILS::Event;
-use Time::HiRes qw(time);
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-
-my $apputils = "OpenILS::Application::AppUtils";
-
-# - creates a new survey
-# expects a survey complete with questions and answers
-__PACKAGE__->register_method(
- method => "add_survey",
- api_name => "open-ils.circ.survey.create");
-
-sub add_survey {
- my( $self, $client, $user_session, $survey ) = @_;
-
- my($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- my $session = $apputils->start_db_session();
- my $err = undef; my $id;
-
-
- try {
-
- $survey = _add_survey($session, $survey);
- _add_questions($session, $survey);
- $apputils->commit_db_session($session);
-
- } catch Error with {
- my $e = shift;
- $err = "Error creating survey: $e\n";
- $apputils->rollback_db_session($session);
- };
-
- if($err) { throw OpenSRF::EX::ERROR ($err); }
-
- # re-retrieve the survey from the db and return it
- return get_fleshed_survey($self, $client, $survey->id() );
-}
-
-
-sub _add_survey {
- my($session, $survey) = @_;
- my $req = $session->request(
- "open-ils.storage.direct.action.survey.create",
- $survey );
-
- my $id = $req->gather(1);
-
- if(!$id) {
- throw OpenSRF::EX::ERROR
- ("Unable to create new survey " . $survey->name());
- }
-
- $survey->id($id);
- return $survey;
-}
-
-sub _update_survey {
- my($session, $survey) = @_;
-}
-
-sub _add_questions {
- my($session, $survey) = @_;
-
- # create new questions in the db
- if( $survey->questions() ) {
- for my $question (@{$survey->questions()}){
-
- $question->survey($survey->id());
- my $virtual_id = $question->id();
- $question->clear_id();
-
-
- my $req = $session->request(
- 'open-ils.storage.direct.action.survey_question.create',
- $question );
- my $new_id = $req->gather(1);
-
- if(!$new_id) {
- throw OpenSRF::EX::ERROR
- ("Error creating new survey question " . $question->question() . "\n")
- }
-
- # now update the responses to this question
- if($question->answers()) {
- for my $answer (@{$question->answers()}) {
- $answer->question($new_id);
- _add_answer($session,$answer);
- }
- }
- }
- }
-}
-
-
-sub _add_answer {
- my($session, $answer) = @_;
- $answer->clear_id();
- my $req = $session->request(
- "open-ils.storage.direct.action.survey_answer.create",
- $answer );
- my $id = $req->gather(1);
- if(!$id) {
- throw OpenSRF::EX::ERROR
- ("Error creating survey answer " . $answer->answer() );
- }
-
-}
-
-
-
-# retrieve surveys for a specific org subtree.
-__PACKAGE__->register_method(
- method => "get_required_surveys",
- api_name => "open-ils.circ.survey.retrieve.required");
-
-sub get_required_surveys {
- my( $self, $client, $user_session ) = @_;
-
-
- my ($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- my $orgid = $user_obj->ws_ou() ? $user_obj->ws_ou() : $user_obj->home_ou();
- my $surveys = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.action.survey.required.atomic",
- $orgid );
-
- my @fleshed;
- for my $survey (@$surveys) {
- push(@fleshed, get_fleshed_survey($self, $client, $survey));
- }
- return \@fleshed;
-
-}
-
-__PACKAGE__->register_method(
- method => "get_survey_responses",
- api_name => "open-ils.circ.survey.response.retrieve");
-
-sub get_survey_responses {
- my( $self, $client, $user_session, $survey_id, $user_id ) = @_;
-
- if(!$user_id) {
- my ($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
- $user_id = $user_obj->id;
- }
-
- my $res = $apputils->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.action.survey_response.search.atomic",
- { usr => $user_id, survey => $survey_id } );
-
- if( $res && ref($res) and $res->[0]) {
- return [ sort { $a->id() <=> $b->id() } @$res ];
- }
-
- return [];
-}
-
-__PACKAGE__->register_method(
- method => "get_all_surveys",
- api_name => "open-ils.circ.survey.retrieve.all");
-
-sub get_all_surveys {
- my( $self, $client, $user_session ) = @_;
-
- my ($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- my $orgid = $user_obj->ws_ou() ? $user_obj->ws_ou() : $user_obj->home_ou();
- my $surveys = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.action.survey.all.atomic",
- $orgid );
-
- my @fleshed;
- for my $survey (@$surveys) {
- push(@fleshed, get_fleshed_survey($self, $client, $survey));
- }
- return \@fleshed;
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => "get_fleshed_survey",
- api_name => "open-ils.circ.survey.fleshed.retrieve");
-
-sub get_fleshed_survey {
- my( $self, $client, $survey_id ) = @_;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
-
- my $survey;
- if( ref($survey_id) and
- (ref($survey_id) =~ /^Fieldmapper/)) {
- $survey = $survey_id;
-
- } else {
-
- my $sreq = $session->request(
- "open-ils.storage.direct.action.survey.retrieve",
- $survey_id );
- $survey = $sreq->gather(1);
- if(! $survey) { return undef; }
- }
-
- $survey->questions([]);
-
-
- my $qreq = $session->request(
- "open-ils.storage.direct.action.survey_question.search.survey.atomic",
- $survey->id() );
-
- my $questions = $qreq->gather(1);
-
- if($questions) {
-
- for my $question (@$questions) {
- next unless defined $question;
-
- # add this question to the survey
- push( @{$survey->questions()}, $question );
-
-
- my $ans_req = $session->request(
- "open-ils.storage.direct.action.survey_answer.search.question.atomic",
- $question->id() );
-
- # add this array of answers to this question
- $question->answers( $ans_req->gather(1) );
-
- }
- }
-
- $session->disconnect();
- return $survey;
-
-}
-
-
-
-__PACKAGE__->register_method(
- method => "submit_survey",
- api_name => "open-ils.circ.survey.submit.session");
-
-__PACKAGE__->register_method(
- method => "submit_survey",
- api_name => "open-ils.circ.survey.submit.user_id");
-
-__PACKAGE__->register_method(
- method => "submit_survey",
- api_name => "open-ils.circ.survey.submit.anon");
-
-
-sub submit_survey {
- my( $self, $client, $responses ) = @_;
-
- if(!$responses) {
- throw OpenSRF::EX::ERROR
- ("No survey object sent in update");
- }
-
-
- if(!ref($responses)) { $responses = [$responses]; }
-
- my $session = $apputils->start_db_session();
-
- my $group_id = $session->request(
- "open-ils.storage.action.survey_response.next_group_id")->gather(1);
-
- my %already_seen;
- for my $res (@$responses) {
-
- my $id;
-
- if($self->api_name =~ /session/) {
- if( ! ($id = $already_seen{$res->usr}) ) {
- my ($user_obj, $evt) = $apputils->checkses($res->usr);
- return $evt if $evt;
- $id = $user_obj->id;
- $already_seen{$res->usr} = $id;
- }
- $res->usr($id);
- } elsif( $self->api_name =~ /anon/ ) {
- $res->clear_usr();
- }
-
- $res->response_group_id($group_id);
- my $req = $session->request(
- "open-ils.storage.direct.action.survey_response.create",
- $res );
- my $newid = $req->gather(1);
-
- if(!$newid) {
- throw OpenSRF::EX::ERROR
- ("Error creating new survey response");
- }
- }
-
- $apputils->commit_db_session($session);
-
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => "get_random_survey",
- api_name => "open-ils.circ.survey.retrieve.opac.random");
-
-sub get_random_survey {
- my( $self, $client, $user_session ) = @_;
-
- my ($user_obj, $evt) = $apputils->checkses($user_session);
- return $evt if $evt;
-
- my $surveys = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.action.survey.opac.atomic",
- $user_obj->home_ou() );
-
- my $random = int(rand(scalar(@$surveys)));
- my $surv = $surveys->[$random];
-
- return get_fleshed_survey($self, $client, $surv);
-
-}
-
-__PACKAGE__->register_method(
- method => "get_random_survey_global",
- api_name => "open-ils.circ.survey.retrieve.opac.random.global");
-
-sub get_random_survey_global {
- my( $self, $client ) = @_;
-
- my $surveys = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.direct.action.survey.search.atomic",
- # XXX grab the org tree to get the root id...
- { owner => 1, opac => 't' } );
-
- my $random = int(rand(scalar(@$surveys)));
- my $surv = $surveys->[$random];
-
- return get_fleshed_survey($self, $client, $surv);
-
-}
-
-
-__PACKAGE__->register_method (
- method => 'delete_survey',
- api_name => 'open-ils.circ.survey.delete.cascade'
-);
-__PACKAGE__->register_method (
- method => 'delete_survey',
- api_name => 'open-ils.circ.survey.delete.cascade.override'
-);
-
-sub delete_survey {
- my($self, $conn, $auth, $survey_id) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $survey = $e->retrieve_action_survey($survey_id)
- or return $e->die_event;
- return $e->die_event unless $e->allowed('ADMIN_SURVEY', $survey->owner);
-
- my $questions = $e->search_action_survey_question({survey => $survey_id});
- my @answers;
- push(@answers, @{$e->search_action_survey_answer({question => $_->id})}) for @$questions;
- my $responses = $e->search_action_survey_response({survey => $survey_id});
-
- return OpenILS::Event->new('SURVEY_RESPONSES_EXIST')
- if @$responses and $self->api_name =! /override/;
-
- for my $resp (@$responses) {
- $e->delete_action_survey_response($resp) or return $e->die_event;
- }
-
- for my $ans (@answers) {
- $e->delete_action_survey_answer($ans) or return $e->die_event;
- }
-
- for my $quest (@$questions) {
- $e->delete_action_survey_question($quest) or return $e->die_event;
- }
-
- $e->delete_action_survey($survey) or return $e->die_event;
-
- $e->commit;
- return 1;
-}
-
-
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Circ::Transit;
-use base 'OpenILS::Application';
-use strict; use warnings;
-use OpenSRF::EX qw(:try);
-use Data::Dumper;
-use OpenSRF::Utils;
-use OpenSRF::Utils::Cache;
-use Digest::MD5 qw(md5_hex);
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Circ::Holds;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenSRF::AppSession;
-use OpenILS::Const qw/:const/;
-
-my $U = "OpenILS::Application::AppUtils";
-my $holdcode = "OpenILS::Application::Circ::Holds";
-$Data::Dumper::Indent = 0;
-
-
-
-__PACKAGE__->register_method(
- method => "copy_transit_receive",
- api_name => "open-ils.circ.copy_transit.receive",
- notes => q/
- Closes out a copy transit
- Requestor needs the COPY_TRANSIT_RECEIVE permission
- @param authtoken The login session key
- @param params An object of named params including
- copyid - the id of the copy in quest
- barcode - the barcode of the copy in question
- If copyid is not sent, this is used.
- @return A ROUTE_ITEM if the copy is destined for a different location.
- A SUCCESS event on success. Other events on error.
- /);
-
-sub copy_transit_receive {
- my( $self, $client, $authtoken, $params ) = @_;
- my %params = %$params;
- my( $evt, $copy, $requestor );
- ($requestor, $evt) = $U->checksesperm($authtoken, 'COPY_TRANSIT_RECEIVE');
- return $evt if $evt;
- ($copy, $evt) = $U->fetch_copy($params{copyid});
- ($copy, $evt) = $U->fetch_copy_by_barcode($params{barcode}) unless $copy;
- return $evt if $evt;
- my $session = $U->start_db_session();
- $evt = transit_receive( $self, $copy, $requestor, $session );
- $U->commit_db_session($session) if $U->event_equals($evt,'SUCCESS');
- return $evt;
-}
-
-# ------------------------------------------------------------------------------
-# If the transit destination is different than the requestor's lib,
-# a ROUTE_TO event is returned with the org set.
-# If
-# ------------------------------------------------------------------------------
-sub transit_receive {
- my ( $class, $copy, $requestor, $session ) = @_;
- $U->logmark;
-
- my( $transit, $evt );
- my $copyid = $copy->id;
-
- my $status_name = $U->copy_status_to_name($copy->status);
- $logger->debug("Attempting transit receive on copy $copyid. Copy status is $status_name");
-
- # fetch the transit
- ($transit, $evt) = $U->fetch_open_transit_by_copy($copyid);
- return $evt if $evt;
-
- if( $transit->dest != $requestor->home_ou ) {
- $logger->activity("Fowarding transit on copy which is destined ".
- "for a different location. copy=$copyid,current ".
- "location=".$requestor->home_ou.",destination location=".$transit->dest);
-
- return OpenILS::Event->new('ROUTE_ITEM', org => $transit->dest );
- }
-
- # The transit is received, set the receive time
- $transit->dest_recv_time('now');
- my $r = $session->request(
- 'open-ils.storage.direct.action.transit_copy.update', $transit )->gather(1);
- return $U->DB_UPDATE_FAILED($transit) unless $r;
-
- my $ishold = 0;
- my ($ht) = $U->fetch_hold_transit( $transit->id );
- if($ht) {
- $logger->info("Hold transit found in transit receive...");
- $ishold = 1;
- }
-
- $logger->info("Recovering original copy status in transit: ".$transit->copy_status);
- $copy->status( $transit->copy_status );
- return $evt if ( $evt =
- $U->update_copy( copy => $copy, editor => $requestor->id, session => $session ));
-
- return OpenILS::Event->new('SUCCESS', ishold => $ishold,
- payload => { transit => $transit, holdtransit => $ht } );
-}
-
-
-
-
-
-__PACKAGE__->register_method(
- method => "copy_transit_create",
- api_name => "open-ils.circ.copy_transit.create",
- notes => q/
- Creates a new copy transit. Requestor must have the
- CREATE_COPY_TRANSIT permission.
- @param authtoken The login session key
- @param params A param object containing the following keys:
- copyid - the copy id
- destination - the id of the org destination. If not defined,
- defaults to the copy's circ_lib
- @return SUCCESS event on success, other event on error
- /);
-
-sub copy_transit_create {
-
- my( $self, $client, $authtoken, $params ) = @_;
- my %params = %$params;
-
- my( $requestor, $evt ) =
- $U->checksesperm( $authtoken, 'CREATE_COPY_TRANSIT' );
- return $evt if $evt;
-
- my $copy;
- ($copy,$evt) = $U->fetch_copy($params{copyid});
- return $evt if $evt;
-
- my $session = $params{session} || $U->start_db_session();
- my $source = $requestor->home_ou;
- my $dest = $params{destination} || $copy->circ_lib;
- my $transit = Fieldmapper::action::transit_copy->new;
-
- $logger->activity("User ". $requestor->id ." creating a ".
- " new copy transit for copy ".$copy->id." to org $dest");
-
- $transit->source($source);
- $transit->dest($dest);
- $transit->target_copy($copy->id);
- $transit->source_send_time("now");
- $transit->copy_status($copy->status);
-
- $logger->debug("Creating new copy_transit in DB");
-
- my $s = $session->request(
- "open-ils.storage.direct.action.transit_copy.create", $transit )->gather(1);
- return $U->DB_UPDATE_FAILED($transit) unless $s;
-
- my $stat = $U->copy_status_from_name('in transit');
-
- $copy->status($stat->id);
- return $evt if ($evt = $U->update_copy(
- copy => $copy, editor => $requestor->id, session => $session ));
-
- $U->commit_db_session($session) unless $params{session};
-
- return OpenILS::Event->new('SUCCESS',
- payload => { copy => $copy, transit => $transit } );
-}
-
-
-__PACKAGE__->register_method(
- method => 'abort_transit',
- api_name => 'open-ils.circ.transit.abort',
- signature => q/
- Deletes a cleans up a transit
- /
-);
-
-sub abort_transit {
- my( $self, $conn, $authtoken, $params ) = @_;
-
- my $copyid = $$params{copyid};
- my $barcode = $$params{barcode};
- my $transitid = $$params{transitid};
-
- my $copy;
- my $transit;
- my $evt;
-
- my $e = new_editor(xact => 1, authtoken => $authtoken);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('ABORT_TRANSIT');
-
- # ---------------------------------------------------------------------
- # Find the related copy and/or transit based on whatever data we have
- if( $barcode ) {
- $copy = $e->search_asset_copy({barcode=>$barcode, deleted => 'f'})->[0];
- return $e->event unless $copy;
-
- } elsif( $copyid ) {
- $copy = $e->retrieve_asset_copy($copyid) or return $e->event;
- }
-
- if( $transitid ) {
- $transit = $e->retrieve_action_transit_copy($transitid)
- or return $e->event;
-
- } elsif( $copy ) {
-
- $transit = $e->search_action_transit_copy(
- { target_copy => $copy->id, dest_recv_time => undef })->[0];
- return $e->event unless $transit;
- }
-
- if($transit and !$copy) {
- $copy = $e->retrieve_asset_copy($transit->target_copy)
- or return $e->event;
- }
- # ---------------------------------------------------------------------
-
- return __abort_transit( $e, $transit, $copy );
-}
-
-
-
-sub __abort_transit {
-
- my( $e, $transit, $copy, $no_reset_hold ) = @_;
-
- my $evt;
- my $hold;
-
- if( $transit->copy_status == OILS_COPY_STATUS_LOST or
- $transit->copy_status == OILS_COPY_STATUS_MISSING ) {
- $e->rollback;
- return OpenILS::Event->new('TRANSIT_ABORT_NOT_ALLOWED');
- }
-
-
- if( $transit->dest != $e->requestor->ws_ou
- and $transit->source != $e->requestor->ws_ou ) {
- return $e->event unless $e->allowed('ABORT_REMOTE_TRANSIT', $e->requestor->ws_ou);
- }
-
- # recover the copy status
- $copy->status( $transit->copy_status );
- $copy->editor( $e->requestor->id );
- $copy->edit_date('now');
-
- my $holdtransit = $e->retrieve_action_hold_transit_copy($transit->id);
-
- if( $holdtransit ) {
- $logger->info("setting copy to reshelving on hold transit abort");
- $copy->status( OILS_COPY_STATUS_RESHELVING );
- }
-
- return $e->event unless $e->delete_action_transit_copy($transit);
- return $e->event unless $e->update_asset_copy($copy);
-
- $e->commit;
-
- # if this is a hold transit, un-capture/un-target the hold
- if($holdtransit and !$no_reset_hold) {
- $hold = $e->retrieve_action_hold_request($holdtransit->hold)
- or return $e->event;
- $evt = $holdcode->_reset_hold( $e->requestor, $hold );
- return $evt if $evt;
- }
-
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- method => 'get_open_copy_transit',
- api_name => 'open-ils.circ.open_copy_transit.retrieve',
- signature => q/
- Retrieves the open transit object for a given copy
- @param auth The login session key
- @param copyid The id of the copy
- @return Transit object
- /
-);
-
-sub get_open_copy_transit {
- my( $self, $conn, $auth, $copyid ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER'); # XXX rely on editor perms
- my $t = $e->search_action_transit_copy(
- { target_copy => $copyid, dest_recv_time => undef });
- return $e->event unless @$t;
- return $$t[0];
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_transit_by_copy',
- api_name => 'open-ils.circ.fetch_transit_by_copy',
-);
-
-sub fetch_transit_by_copy {
- my( $self, $conn, $auth, $copyid ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- my $t = $e->search_action_transit_copy(
- {
- target_copy => $copyid,
- dest_recv_time => undef
- }
- )->[0];
- return $e->event unless $t;
- my $ht = $e->retrieve_action_hold_transit_copy($t->id);
- return { atc => $t, ahtc => $ht };
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'transits_by_lib',
- api_name => 'open-ils.circ.transit.retrieve_by_lib',
-);
-
-
-# start_date and end_date are optional endpoints for the transit creation date
-sub transits_by_lib {
- my( $self, $conn, $auth, $orgid, $start_date, $end_date ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # eh.. basically the same permission
-
- my $order_by = {order_by => { atc => 'source_send_time' }};
- my $search = { dest_recv_time => undef };
-
- if($end_date) {
- if($start_date) {
- $search->{source_send_time} = {between => [$start_date, $end_date]};
- } else {
- $search->{source_send_time} = {'<=' => $end_date};
- }
- } elsif($start_date) {
- $search->{source_send_time} = {'>=' => $start_date};
- }
-
- $search->{dest} = $orgid;
-
- my $tos = $e->search_action_transit_copy([ $search, $order_by ], {idlist=>1});
-
- delete $$search{dest};
- $search->{source} = $orgid;
-
- my $froms = $e->search_action_transit_copy([ $search, $order_by ], {idlist=>1});
-
- return { from => $froms, to => $tos };
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_transit',
- api_name => 'open-ils.circ.transit.retrieve',
-);
-sub fetch_transit {
- my( $self, $conn, $auth, $transid ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # eh.. basically the same permission
-
- my $ht = $e->retrieve_action_hold_transit_copy($transid);
- return $ht if $ht;
-
- my $t = $e->retrieve_action_transit_copy($transid)
- or return $e->event;
- return $t;
-}
-
-
-
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Collections;
-use strict; use warnings;
-use OpenSRF::EX qw(:try);
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenSRF::Utils qw/:datetime/;
-use OpenILS::Application;
-use OpenILS::Utils::Fieldmapper;
-use base 'OpenILS::Application';
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Event;
-use OpenILS::Const qw/:const/;
-my $U = "OpenILS::Application::AppUtils";
-
-
-# --------------------------------------------------------------
-# Loads the config info
-# --------------------------------------------------------------
-sub initialize { return 1; }
-
-__PACKAGE__->register_method(
- method => 'user_from_bc',
- api_name => 'open-ils.collections.user_id_from_barcode',
-);
-
-sub user_from_bc {
- my( $self, $conn, $auth, $bc ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('VIEW_USER');
- my $card = $e->search_actor_card({barcode=>$bc})->[0]
- or return $e->event;
- my $user = $e->retrieve_actor_user($card->usr)
- or return $e->event;
- return $user->id;
-}
-
-
-__PACKAGE__->register_method(
- method => 'users_of_interest',
- api_name => 'open-ils.collections.users_of_interest.retrieve',
- api_level => 1,
- argc => 4,
- stream => 1,
- signature => {
- desc => q/
- Returns an array of user information objects that the system
- based on the search criteria provided. If the total fines
- a user owes reaches or exceeds "fine_level" on or befre "age"
- and the fines were created at "location", the user will be
- included in the return set/,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'age',
- desc => q/Number of days back to check/,
- type => q/number/,
- },
-
- { name => 'fine_level',
- desc => q/The fine threshold at which users will be included in the search results /,
- type => q/number/,
- },
- { name => 'location',
- desc => q/The short-name of the orginization unit (library) at which the fines were created.
- If a selected location has 'child' locations (e.g. a library region), the
- child locations will be included in the search/,
- type => q/string/,
- },
- ],
-
- 'return' => {
- desc => q/An array of user information objects.
- usr : Array of user information objects containing id, dob, profile, and groups
- threshold_amount : The total amount the patron owes that is at least as old
- as the fine "age" and whose transaction was created at the searched location
- last_pertinent_billing : The time of the last billing that relates to this query
- /,
- type => 'array',
- example => {
- usr => {
- id => 'id',
- dob => '1970-01-01',
- profile => 'Patron',
- groups => [ 'Patron', 'Staff' ],
- },
- threshold_amount => 99,
- }
- }
- }
-);
-
-
-sub users_of_interest {
- my( $self, $conn, $auth, $age, $fine_level, $location ) = @_;
-
- return OpenILS::Event->new('BAD_PARAMS')
- unless ($auth and $age and $location);
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $org = $e->search_actor_org_unit({shortname => $location})
- or return $e->event; $org = $org->[0];
-
- # they need global perms to view users so no org is provided
- return $e->event unless $e->allowed('VIEW_USER');
-
- my $data = [];
-
- my $ses = OpenSRF::AppSession->create('open-ils.storage');
-
- my $start = time;
- my $req = $ses->request(
- 'open-ils.storage.money.collections.users_of_interest',
- $age, $fine_level, $location);
-
- # let the client know we're still here
- $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- return process_users_of_interest_results(
- $self, $conn, $e, $req, $start, $age, $fine_level, $location);
-}
-
-
-__PACKAGE__->register_method(
- method => 'users_of_interest_warning_penalty',
- api_name => 'open-ils.collections.users_of_interest.warning_penalty.retrieve',
- api_level => 1,
- argc => 4,
- stream => 1,
- signature => {
- desc => q/
- Returns an array of user information objects for users that have the
- PATRON_EXCEEDS_COLLECTIONS_WARNING penalty applied,
- based on the search criteria provided./,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string'
- }, {
- name => 'location',
- desc => q/The short-name of the orginization unit (library) at which the penalty is applied.
- If a selected location has 'child' locations (e.g. a library region), the
- child locations will be included in the search/,
- type => q/string/,
- }, {
- name => 'min_age',
- desc => q/Optional. Minimum age of the penalty application/,
- type => q/interval, e.g "30 days"/,
- }, {
- name => 'max_age',
- desc => q/Optional. Maximum age of the penalty application/,
- type => q/interval, e.g "90 days"/,
- }
- ],
-
- 'return' => {
- desc => q/An array of user information objects.
- usr : Array of user information objects containing id, dob, profile, and groups
- threshold_amount : The total amount the patron owes that is at least as old
- as the fine "age" and whose transaction was created at the searched location
- last_pertinent_billing : The time of the last billing that relates to this query
- /,
- type => 'array',
- example => {
- usr => {
- id => 'id',
- dob => '1970-01-01',
- profile => 'Patron',
- groups => [ 'Patron', 'Staff' ],
- },
- threshold_amount => 99, # TODO: still needed?
- }
- }
- }
-);
-
-
-
-sub users_of_interest_warning_penalty {
- my( $self, $conn, $auth, $location, $min_age, $max_age ) = @_;
-
- return OpenILS::Event->new('BAD_PARAMS') unless ($auth and $location);
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $org = $e->search_actor_org_unit({shortname => $location})
- or return $e->event; $org = $org->[0];
-
- # they need global perms to view users so no org is provided
- return $e->event unless $e->allowed('VIEW_USER');
-
- my $org_ids = $e->json_query({from => ['actor.org_unit_full_path', $org->id]});
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- # max age == oldest
- my $max_set_date = DateTime->now->subtract(seconds =>
- interval_to_seconds($max_age))->strftime( '%F %T%z' ) if $max_age;
- my $min_set_date = DateTime->now->subtract(seconds =>
- interval_to_seconds($min_age))->strftime( '%F %T%z' ) if $min_age;
-
- my $start = time;
- my $query = {
- select => {ausp => ['usr']},
- from => 'ausp',
- where => {
- standing_penalty => 4, # PATRON_EXCEEDS_COLLECTIONS_WARNING
- org_unit => [ map {$_->{id}} @$org_ids ],
- '-or' => [
- {stop_date => undef},
- {stop_date => {'>' => 'now'}}
- ]
- }
- };
-
- $query->{where}->{'-and'} = [] if $max_set_date or $min_set_date;
- push(@{$query->{where}->{'-and'}}, {set_date => {'>' => $max_set_date}}) if $max_set_date;
- push(@{$query->{where}->{'-and'}}, {set_date => {'<' => $min_set_date}}) if $min_set_date;
-
- my $req = $ses->request('open-ils.cstore.json_query', $query);
-
- # let the client know we're still here
- $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- return process_users_of_interest_results(
- $self, $conn, $e, $req, $start, $min_age, '', $location, $max_age);
-}
-
-
-
-
-sub process_users_of_interest_results {
- my($self, $conn, $e, $req, $starttime, @params) = @_;
-
- my $total;
- while( my $resp = $req->recv(timeout => 7200) ) {
-
- return $req->failed if $req->failed;
- my $hash = $resp->content;
- next unless $hash;
-
- unless($total) {
- $total = time - $starttime;
- $logger->info("collections: request (@params) took $total seconds");
- }
-
- my $u = $e->retrieve_actor_user(
- [
- $hash->{usr},
- {
- flesh => 1,
- flesh_fields => {au => ["groups","profile", "card"]},
- }
- ]
- ) or return $e->event;
-
- $hash->{usr} = {
- id => $u->id,
- dob => $u->dob,
- profile => $u->profile->name,
- barcode => $u->card->barcode,
- groups => [ map { $_->name } @{$u->groups} ],
- };
-
- $conn->respond($hash);
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => 'users_owing_money',
- api_name => 'open-ils.collections.users_owing_money.retrieve',
- api_level => 1,
- argc => 5,
- stream => 1,
- signature => {
- desc => q/
- Returns an array of users that owe money during
- the given time frame at the location (or child locations)
- provided/,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'start_date',
- desc => 'The start of the time interval to check',
- type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
- },
-
- { name => 'end_date',
- desc => q/Then end date of the time interval to check/,
- type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
- },
- { name => 'fine_level',
- desc => q/The fine threshold at which users will be included in the search results /,
- type => q/number/,
- },
- { name => 'locations',
- desc => q/ A list of one or more org-unit short names.
- If a selected location has 'child' locations (e.g. a library region), the
- child locations will be included in the search/,
- type => q'string',
- },
- ],
- 'return' => {
- desc => q/An array of user information objects/,
- type => 'array',
- }
- }
-);
-
-
-sub users_owing_money {
- my( $self, $conn, $auth, $start_date, $end_date, $fine_level, @locations ) = @_;
-
- return OpenILS::Event->new('BAD_PARAMS')
- unless ($auth and $start_date and $end_date and @locations);
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- # they need global perms to view users so no org is provided
- return $e->event unless $e->allowed('VIEW_USER');
-
- my $data = [];
-
- my $ses = OpenSRF::AppSession->create('open-ils.storage');
-
- my $start = time;
- my $req = $ses->request(
- 'open-ils.storage.money.collections.users_owing_money',
- $start_date, $end_date, $fine_level, @locations);
-
- # let the client know we're still here
- $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- return process_users_of_interest_results(
- $self, $conn, $e, $req, $start, $start_date, $end_date, $fine_level, @locations);
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'users_with_activity',
- api_name => 'open-ils.collections.users_with_activity.retrieve',
- api_level => 1,
- argc => 4,
- stream => 1,
- signature => {
- desc => q/
- Returns an array of users that are already in collections
- and had any type of billing or payment activity within
- the given time frame at the location (or child locations)
- provided/,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'start_date',
- desc => 'The start of the time interval to check',
- type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
- },
-
- { name => 'end_date',
- desc => q/Then end date of the time interval to check/,
- type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
- },
- { name => 'location',
- desc => q/The short-name of the orginization unit (library) at which the activity occurred.
- If a selected location has 'child' locations (e.g. a library region), the
- child locations will be included in the search/,
- type => q'string',
- },
- ],
-
- 'return' => {
- desc => q/An array of user information objects/,
- type => 'array',
- }
- }
-);
-
-sub users_with_activity {
- my( $self, $conn, $auth, $start_date, $end_date, $location ) = @_;
- return OpenILS::Event->new('BAD_PARAMS')
- unless ($auth and $start_date and $end_date and $location);
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- my $org = $e->search_actor_org_unit({shortname => $location})
- or return $e->event; $org = $org->[0];
- return $e->event unless $e->allowed('VIEW_USER', $org->id);
-
- my $ses = OpenSRF::AppSession->create('open-ils.storage');
-
- my $start = time;
- my $req = $ses->request(
- 'open-ils.storage.money.collections.users_with_activity.atomic',
- $start_date, $end_date, $location);
-
- $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- my $total;
- while( my $resp = $req->recv(timeout => 7200) ) {
-
- unless($total) {
- $total = time - $start;
- $logger->info("collections: users_with_activity search ".
- "($start_date, $end_date, $location) took $total seconds");
- }
-
- return $req->failed if $req->failed;
- $conn->respond($resp->content);
- }
-
- return undef;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'put_into_collections',
- api_name => 'open-ils.collections.put_into_collections',
- api_level => 1,
- argc => 3,
- signature => {
- desc => q/
- Marks a user as being "in collections" at a given location
- /,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'user_id',
- desc => 'The id of the user to plact into collections',
- type => 'number',
- },
-
- { name => 'location',
- desc => q/The short-name of the orginization unit (library)
- for which the user is being placed in collections/,
- type => q'string',
- },
- { name => 'fee_amount',
- desc => q/
- The amount of money that a patron should be fined.
- If this field is empty, no fine is created.
- /,
- type => 'string',
- },
- { name => 'fee_note',
- desc => q/
- Custom note that is added to the the billing.
- This field is not required.
- Note: fee_note is not the billing_type. Billing_type type is
- decided by the system. (e.g. "fee for collections").
- fee_note is purely used for any additional needed information
- and is only visible to staff.
- /,
- type => 'string',
- },
- ],
-
- 'return' => {
- desc => q/A SUCCESS event on success, error event on failure/,
- type => 'object',
- }
- }
-);
-sub put_into_collections {
- my( $self, $conn, $auth, $user_id, $location, $fee_amount, $fee_note ) = @_;
-
- return OpenILS::Event->new('BAD_PARAMS')
- unless ($auth and $user_id and $location);
-
- my $e = new_editor(authtoken => $auth, xact =>1);
- return $e->event unless $e->checkauth;
-
- my $org = $e->search_actor_org_unit({shortname => $location});
- return $e->event unless $org = $org->[0];
- return $e->event unless $e->allowed('money.collections_tracker.create', $org->id);
-
- my $existing = $e->search_money_collections_tracker(
- {
- location => $org->id,
- usr => $user_id,
- collector => $e->requestor->id
- },
- {idlist => 1}
- );
-
- return OpenILS::Event->new('MONEY_COLLECTIONS_TRACKER_EXISTS') if @$existing;
-
- $logger->info("collect: user ".$e->requestor->id.
- " putting user $user_id into collections for $location");
-
- my $tracker = Fieldmapper::money::collections_tracker->new;
-
- $tracker->usr($user_id);
- $tracker->collector($e->requestor->id);
- $tracker->location($org->id);
- $tracker->enter_time('now');
-
- $e->create_money_collections_tracker($tracker)
- or return $e->event;
-
- if( $fee_amount ) {
- my $evt = add_collections_fee($e, $user_id, $org, $fee_amount, $fee_note );
- return $evt if $evt;
- }
-
- $e->commit;
-
- my $pen = Fieldmapper::actor::user_standing_penalty->new;
- $pen->org_unit($org->id);
- $pen->usr($user_id);
- $pen->standing_penalty(30); # PATRON_IN_COLLECTIONS
- $pen->staff($e->requestor->id);
- $pen->note($fee_note) if $fee_note;
- $U->simplereq('open-ils.actor', 'open-ils.actor.user.penalty.apply', $auth, $pen);
-
- return OpenILS::Event->new('SUCCESS');
-}
-
-sub add_collections_fee {
- my( $e, $patron_id, $org, $fee_amount, $fee_note ) = @_;
-
- $fee_note ||= "";
-
- $logger->info("collect: adding fee to user $patron_id : $fee_amount : $fee_note");
-
- my $xact = Fieldmapper::money::grocery->new;
- $xact->usr($patron_id);
- $xact->xact_start('now');
- $xact->billing_location($org->id);
-
- $xact = $e->create_money_grocery($xact) or return $e->event;
-
- my $bill = Fieldmapper::money::billing->new;
- $bill->note($fee_note);
- $bill->xact($xact->id);
- $bill->btype(2);
- $bill->billing_type(OILS_BILLING_TYPE_COLLECTION_FEE);
- $bill->amount($fee_amount);
-
- $e->create_money_billing($bill) or return $e->event;
- return undef;
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => 'remove_from_collections',
- api_name => 'open-ils.collections.remove_from_collections',
- signature => q/
- Returns the users that are currently in collections and
- had activity during the provided interval. Dates are inclusive.
- @param start_date The beginning of the activity interval
- @param end_date The end of the activity interval
- @param location The location at which the fines were created
- /
-);
-
-
-__PACKAGE__->register_method(
- method => 'remove_from_collections',
- api_name => 'open-ils.collections.remove_from_collections',
- api_level => 1,
- argc => 3,
- signature => {
- desc => q/
- Removes a user from the collections table for the given location
- /,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'user_id',
- desc => 'The id of the user to plact into collections',
- type => 'number',
- },
-
- { name => 'location',
- desc => q/The short-name of the orginization unit (library)
- for which the user is being removed from collections/,
- type => q'string',
- },
- ],
-
- 'return' => {
- desc => q/A SUCCESS event on success, error event on failure/,
- type => 'object',
- }
- }
-);
-
-sub remove_from_collections {
- my( $self, $conn, $auth, $user_id, $location ) = @_;
-
- return OpenILS::Event->new('BAD_PARAMS')
- unless ($auth and $user_id and $location);
-
- my $e = new_editor(authtoken => $auth, xact=>1);
- return $e->event unless $e->checkauth;
-
- my $org = $e->search_actor_org_unit({shortname => $location})
- or return $e->event; $org = $org->[0];
- return $e->event unless $e->allowed('money.collections_tracker.delete', $org->id);
-
- my $tracker = $e->search_money_collections_tracker(
- { usr => $user_id, location => $org->id })
- or return $e->event;
-
- $e->delete_money_collections_tracker($tracker->[0])
- or return $e->event;
-
- $e->commit;
- return OpenILS::Event->new('SUCCESS');
-}
-
-
-#__PACKAGE__->register_method(
-# method => 'transaction_details',
-# api_name => 'open-ils.collections.user_transaction_details.retrieve',
-# signature => q/
-# /
-#);
-
-
-__PACKAGE__->register_method(
- method => 'transaction_details',
- api_name => 'open-ils.collections.user_transaction_details.retrieve',
- api_level => 1,
- argc => 5,
- signature => {
- desc => q/
- Returns a list of fleshed user objects with transaction details
- /,
-
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'start_date',
- desc => 'The start of the time interval to check',
- type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
- },
-
- { name => 'end_date',
- desc => q/Then end date of the time interval to check/,
- type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
- },
- { name => 'location',
- desc => q/The short-name of the orginization unit (library) at which the activity occurred.
- If a selected location has 'child' locations (e.g. a library region), the
- child locations will be included in the search/,
- type => q'string',
- },
- {
- name => 'user_list',
- desc => 'An array of user ids',
- type => 'array',
- },
- ],
-
- 'return' => {
- desc => q/A list of objects. Object keys include:
- usr :
- transactions : An object with keys :
- circulations : Fleshed circulation objects
- grocery : Fleshed 'grocery' transaction objects
- /,
- type => 'object'
- }
- }
-);
-
-sub transaction_details {
- my( $self, $conn, $auth, $start_date, $end_date, $location, $user_list ) = @_;
-
- return OpenILS::Event->new('BAD_PARAMS')
- unless ($auth and $start_date and $end_date and $location and $user_list);
-
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
-
- # they need global perms to view users so no org is provided
- return $e->event unless $e->allowed('VIEW_USER');
-
- my $org = $e->search_actor_org_unit({shortname => $location})
- or return $e->event; $org = $org->[0];
-
- # get a reference to the org inside of the tree
- $org = $U->find_org($U->fetch_org_tree(), $org->id);
-
- my @data;
- for my $uid (@$user_list) {
- my $blob = {};
-
- $blob->{usr} = $e->retrieve_actor_user(
- [
- $uid,
- {
- "flesh" => 1,
- "flesh_fields" => {
- "au" => [
- "cards",
- "card",
- "standing_penalties",
- "addresses",
- "billing_address",
- "mailing_address",
- "stat_cat_entries"
- ]
- }
- }
- ]
- );
-
- $blob->{transactions} = {
- circulations =>
- fetch_circ_xacts($e, $uid, $org, $start_date, $end_date),
- grocery =>
- fetch_grocery_xacts($e, $uid, $org, $start_date, $end_date),
- reservations =>
- fetch_reservation_xacts($e, $uid, $org, $start_date, $end_date)
- };
-
- # for each transaction, flesh the workstatoin on any attached payment
- # and make the payment object a real object (e.g. cash payment),
- # not just a generic payment object
- for my $xact (
- @{$blob->{transactions}->{circulations}},
- @{$blob->{transactions}->{reservations}},
- @{$blob->{transactions}->{grocery}} ) {
-
- my $ps;
- if( $ps = $xact->payments and @$ps ) {
- my @fleshed; my $evt;
- for my $p (@$ps) {
- ($p, $evt) = flesh_payment($e,$p);
- return $evt if $evt;
- push(@fleshed, $p);
- }
- $xact->payments(\@fleshed);
- }
- }
-
- push( @data, $blob );
- }
-
- return \@data;
-}
-
-sub flesh_payment {
- my $e = shift;
- my $p = shift;
- my $type = $p->payment_type;
- $logger->debug("collect: fleshing workstation on payment $type : ".$p->id);
- my $meth = "retrieve_money_$type";
- $p = $e->$meth($p->id) or return (undef, $e->event);
- try {
- $p->payment_type($type);
- $p->cash_drawer(
- $e->retrieve_actor_workstation(
- [
- $p->cash_drawer,
- {
- flesh => 1,
- flesh_fields => { aws => [ 'owning_lib' ] }
- }
- ]
- )
- );
- } catch Error with {};
- return ($p);
-}
-
-
-# --------------------------------------------------------------
-# Collect all open circs for the user
-# For each circ, see if any billings or payments were created
-# during the given time period.
-# --------------------------------------------------------------
-sub fetch_circ_xacts {
- my $e = shift;
- my $uid = shift;
- my $org = shift;
- my $start_date = shift;
- my $end_date = shift;
-
- my @circs;
-
- # at the specified org and each descendent org,
- # fetch the open circs for this user
- $U->walk_org_tree( $org,
- sub {
- my $n = shift;
- $logger->debug("collect: searching for open circs at " . $n->shortname);
- push( @circs,
- @{
- $e->search_action_circulation(
- {
- usr => $uid,
- circ_lib => $n->id,
- },
- {idlist => 1}
- )
- }
- );
- }
- );
-
-
- my @data;
- my $active_ids = fetch_active($e, \@circs, $start_date, $end_date);
-
- for my $cid (@$active_ids) {
- push( @data,
- $e->retrieve_action_circulation(
- [
- $cid,
- {
- flesh => 1,
- flesh_fields => {
- circ => [ "billings", "payments", "circ_lib", 'target_copy' ]
- }
- }
- ]
- )
- );
- }
-
- return \@data;
-}
-
-sub fetch_grocery_xacts {
- my $e = shift;
- my $uid = shift;
- my $org = shift;
- my $start_date = shift;
- my $end_date = shift;
-
- my @xacts;
- $U->walk_org_tree( $org,
- sub {
- my $n = shift;
- $logger->debug("collect: searching for open grocery xacts at " . $n->shortname);
- push( @xacts,
- @{
- $e->search_money_grocery(
- {
- usr => $uid,
- billing_location => $n->id,
- },
- {idlist => 1}
- )
- }
- );
- }
- );
-
- my @data;
- my $active_ids = fetch_active($e, \@xacts, $start_date, $end_date);
-
- for my $id (@$active_ids) {
- push( @data,
- $e->retrieve_money_grocery(
- [
- $id,
- {
- flesh => 1,
- flesh_fields => {
- mg => [ "billings", "payments", "billing_location" ] }
- }
- ]
- )
- );
- }
-
- return \@data;
-}
-
-sub fetch_reservation_xacts {
- my $e = shift;
- my $uid = shift;
- my $org = shift;
- my $start_date = shift;
- my $end_date = shift;
-
- my @xacts;
- $U->walk_org_tree( $org,
- sub {
- my $n = shift;
- $logger->debug("collect: searching for open grocery xacts at " . $n->shortname);
- push( @xacts,
- @{
- $e->search_booking_reservation(
- {
- usr => $uid,
- pickup_lib => $n->id,
- },
- {idlist => 1}
- )
- }
- );
- }
- );
-
- my @data;
- my $active_ids = fetch_active($e, \@xacts, $start_date, $end_date);
-
- for my $id (@$active_ids) {
- push( @data,
- $e->retrieve_booking_reservation(
- [
- $id,
- {
- flesh => 1,
- flesh_fields => {
- bresv => [ "billings", "payments", "pickup_lib" ] }
- }
- ]
- )
- );
- }
-
- return \@data;
-}
-
-
-
-# --------------------------------------------------------------
-# Given a list of xact id's, this returns a list of id's that
-# had any activity within the given time span
-# --------------------------------------------------------------
-sub fetch_active {
- my( $e, $ids, $start_date, $end_date ) = @_;
-
- # use this..
- # { payment_ts => { between => [ $start, $end ] } } ' ;)
-
- my @active;
- for my $id (@$ids) {
-
- # see if any billings were created in the given time range
- my $bills = $e->search_money_billing (
- {
- xact => $id,
- billing_ts => { between => [ $start_date, $end_date ] },
- },
- {idlist =>1}
- );
-
- my $payments = [];
-
- if( !@$bills ) {
-
- # see if any payments were created in the given range
- $payments = $e->search_money_payment (
- {
- xact => $id,
- payment_ts => { between => [ $start_date, $end_date ] },
- },
- {idlist =>1}
- );
- }
-
-
- push( @active, $id ) if @$bills or @$payments;
- }
-
- return \@active;
-}
-
-
-__PACKAGE__->register_method(
- method => 'create_user_note',
- api_name => 'open-ils.collections.patron_note.create',
- api_level => 1,
- argc => 4,
- signature => {
- desc => q/ Adds a note to a patron's account /,
- params => [
- { name => 'auth',
- desc => 'The authentication token',
- type => 'string' },
-
- { name => 'user_barcode',
- desc => q/The patron's barcode/,
- type => q/string/,
- },
- { name => 'title',
- desc => q/The title of the note/,
- type => q/string/,
- },
-
- { name => 'note',
- desc => q/The text of the note/,
- type => q/string/,
- },
- ],
-
- 'return' => {
- desc => q/
- Returns SUCCESS event on success, error event otherwise.
- /,
- type => 'object'
- }
- }
-);
-
-
-sub create_user_note {
- my( $self, $conn, $auth, $user_barcode, $title, $note_txt ) = @_;
-
- my $e = new_editor(authtoken=>$auth, xact=>1);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('UPDATE_USER'); # XXX Makre more specific perm for this
-
- return $e->event unless
- my $card = $e->search_actor_card({barcode=>$user_barcode})->[0];
-
- my $note = Fieldmapper::actor::usr_note->new;
- $note->usr($card->usr);
- $note->title($title);
- $note->creator($e->requestor->id);
- $note->create_date('now');
- $note->pub('f');
- $note->value($note_txt);
-
- $e->create_actor_usr_note($note) or return $e->event;
- $e->commit;
- return OpenILS::Event->new('SUCCESS');
-}
-
-
-
-1;
+++ /dev/null
-# vim:et:ts=4:sw=4:
-
-package OpenILS::Application::Fielder;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-use Unicode::Normalize;
-use OpenSRF::EX qw/:try/;
-
-use OpenSRF::AppSession;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Cache;
-use OpenSRF::Utils::Logger qw/:level/;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::JSON;
-
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-
-use Digest::MD5 qw(md5_hex);
-
-use XML::LibXML;
-use XML::LibXML::XPathContext;
-use XML::LibXSLT;
-
-our %namespace_map = (
- oils_persist=> {ns => 'http://open-ils.org/spec/opensrf/IDL/persistence/v1'},
- oils_obj => {ns => 'http://open-ils.org/spec/opensrf/IDL/objects/v1'},
- idl => {ns => 'http://opensrf.org/spec/IDL/base/v1'},
- reporter => {ns => 'http://open-ils.org/spec/opensrf/IDL/reporter/v1'},
- perm => {ns => 'http://open-ils.org/spec/opensrf/IDL/permacrud/v1'},
-);
-
-
-my $log = 'OpenSRF::Utils::Logger';
-
-my $cache;
-my $cache_timeout;
-my $parser = XML::LibXML->new();
-my $xslt = XML::LibXSLT->new();
-
-my $xpc = XML::LibXML::XPathContext->new();
-$xpc->registerNs($_, $namespace_map{$_}{ns}) for ( keys %namespace_map );
-
-my $idl;
-
-sub initialize {
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $idl_file = $conf->config_value( 'IDL' );
-
- $idl = $parser->parse_file( $idl_file );
-
- $log->debug( 'IDL XML file loaded' );
-
- $cache_timeout = $conf->config_value(
- "apps", "open-ils.fielder", "app_settings", "cache_timeout" ) || 300;
-
- generate_methods();
-
-}
-sub child_init {
- $cache = OpenSRF::Utils::Cache->new('global');
-}
-
-sub fielder_fetch {
- my $self = shift;
- my $client = shift;
- my $obj = shift;
-
- my $query = $obj->{query};
- my $nocache = $obj->{cache} ? 0 : 1;
- my $fields = $obj->{fields};
- my $distinct = $obj->{distinct} ? 1 : 0;
-
- return undef unless $query;
-
- my $obj_class = $self->{class_hint};
- my $fm_class = $self->{class_name};
-
- if (!$fields) {
- $fields = [ $fm_class->real_fields ];
- }
-
- $fields = [$fields] if (!ref($fields));
-
- my $qstring = OpenSRF::Utils::JSON->perl2JSON( $query );
- my $fstring = OpenSRF::Utils::JSON->perl2JSON( [ sort { $a cmp $b } @$fields ] );
-
- $log->debug( 'Query Class: '. $obj_class );
- $log->debug( 'Field list: '. $fstring );
- $log->debug( 'Query: '. $qstring );
-
- my ($key,$res);
- unless ($nocache) {
- $key = 'open-ils.fielder_' . md5_hex(
- $self->api_name .
- $qstring .
- $fstring .
- $distinct .
- $obj_class
- );
-
- $res = $cache->get_cache( $key );
-
- if ($res) {
- $client->respond($_) for (@$res);
- return undef;
- }
- }
-
- $res = new_editor()->json_query({
- select => { $obj_class => $fields },
- from => $obj_class,
- where => $query,
- distinct=> $distinct
- });
-
- for my $value (@$res) {
- $client->respond($value);
- }
-
- $client->respond_complete();
-
- $cache->put_cache( $key => $res => $cache_timeout ) unless ($nocache);
- return undef;
-}
-
-sub generate_methods {
- try {
- for my $class_node ( $xpc->findnodes( '//idl:class[@oils_persist:field_safe="true"]', $idl->documentElement ) ) {
- my $hint = $class_node->getAttribute('id');
- my $fm = $class_node->getAttributeNS('http://open-ils.org/spec/opensrf/IDL/objects/v1','fieldmapper');
- $log->debug("Fielder class_node $hint");
-
- __PACKAGE__->register_method(
- method => 'fielder_fetch',
- api_name => 'open-ils.fielder.' . $hint,
- class_hint => $hint,
- class_name => "Fieldmapper::$fm",
- stream => 1,
- argc => 1
- );
- }
- } catch Error with {
- my $e = shift;
- $log->error("error generating Fielder methods: $e");
- };
-}
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Ingest;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-use Unicode::Normalize;
-use OpenSRF::EX qw/:try/;
-
-use OpenSRF::AppSession;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/:level/;
-
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::ScriptRunner;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::JSON;
-
-use OpenILS::Utils::Fieldmapper;
-
-use XML::LibXML;
-use XML::LibXSLT;
-use Time::HiRes qw(time);
-
-our %supported_formats = (
- mods33 => {ns => 'http://www.loc.gov/mods/v3'},
- mods32 => {ns => 'http://www.loc.gov/mods/v3'},
- mods3 => {ns => 'http://www.loc.gov/mods/v3'},
- mods => {ns => 'http://www.loc.gov/mods/'},
- marcxml => {ns => 'http://www.loc.gov/MARC21/slim'},
- srw_dc => {ns => 'info:srw/schema/1/dc-schema'},
- oai_dc => {ns => 'http://www.openarchives.org/OAI/2.0/oai_dc/'},
- rdf_dc => {ns => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#'},
- atom => {ns => 'http://www.w3.org/2005/Atom'},
- rss091 => {ns => 'http://my.netscape.com/rdf/simple/0.9/'},
- rss092 => {ns => ''},
- rss093 => {ns => ''},
- rss094 => {ns => ''},
- rss10 => {ns => 'http://purl.org/rss/1.0/'},
- rss11 => {ns => 'http://purl.org/net/rss1.1#'},
- rss2 => {ns => ''},
-);
-
-
-my $log = 'OpenSRF::Utils::Logger';
-
-my $parser = XML::LibXML->new();
-my $xslt = XML::LibXSLT->new();
-
-my $mods_sheet;
-my $mads_sheet;
-my $xpathset = {};
-sub initialize {}
-sub child_init {}
-
-sub post_init {
-
- unless (keys %$xpathset) {
- $log->debug("Running post_init", DEBUG);
-
- my $xsldir = OpenSRF::Utils::SettingsClient->new->config_value(dirs => 'xsl');
-
- unless ($supported_formats{mods}{xslt}) {
- $log->debug("Loading MODS XSLT", DEBUG);
- my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS.xsl");
- $supported_formats{mods}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
- }
-
- unless ($supported_formats{mods3}{xslt}) {
- $log->debug("Loading MODS v3 XSLT", DEBUG);
- my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS3.xsl");
- $supported_formats{mods3}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
- }
-
- unless ($supported_formats{mods32}{xslt}) {
- $log->debug("Loading MODS v32 XSLT", DEBUG);
- my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS32.xsl");
- $supported_formats{mods32}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
- }
-
- unless ($supported_formats{mods33}{xslt}) {
- $log->debug("Loading MODS v33 XSLT", DEBUG);
- my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS33.xsl");
- $supported_formats{mods33}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
- }
-
- my $req = OpenSRF::AppSession
- ->create('open-ils.cstore')
-
- # XXX testing new metabib field use for faceting
- #->request( 'open-ils.cstore.direct.config.metabib_field.search.atomic', { id => { '!=' => undef } } )
- ->request( 'open-ils.cstore.direct.config.metabib_field.search.atomic', { search_field => 't' } )
-
- ->gather(1);
-
- if (ref $req and @$req) {
- for my $f (@$req) {
- $xpathset->{ $f->field_class }->{ $f->name }->{xpath} = $f->xpath;
- $xpathset->{ $f->field_class }->{ $f->name }->{id} = $f->id;
- $xpathset->{ $f->field_class }->{ $f->name }->{format} = $f->format;
- $log->debug("Loaded XPath from DB: ".$f->field_class." => ".$f->name." : ".$f->xpath, DEBUG);
- }
- }
- }
-}
-
-# --------------------------------------------------------------------------------
-# Biblio ingest
-
-package OpenILS::Application::Ingest::Biblio;
-use base qw/OpenILS::Application::Ingest/;
-use Unicode::Normalize;
-
-sub rw_biblio_ingest_single_object {
- my $self = shift;
- my $client = shift;
- my $bib = shift;
-
- my ($blob) = $self->method_lookup("open-ils.ingest.full.biblio.object.readonly")->run($bib);
- return undef unless ($blob);
-
- $bib->fingerprint( $blob->{fingerprint}->{fingerprint} );
- $bib->quality( $blob->{fingerprint}->{quality} );
-
- my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
-
- my $xact = $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
- my $tmp;
-
- # update uri stuff ...
-
- # gather URI call numbers for this record
- my $uri_cns = $u->{call_number} = $cstore->request(
- 'open-ils.cstore.direct.asset.call_number.id_list.atomic' => { record => $bib->id, label => '##URI##' }
- )->gather(1);
-
- if (@$uri_cns) {
- # gather the maps for those call numbers
- my $uri_maps = $u->{call_number} = $cstore->request(
- 'open-ils.cstore.direct.asset.uri_call_number_map.id_list.atomic' => { call_number => $uri_cns }
- )->gather(1);
-
- # delete the old maps
- $cstore->request( 'open-ils.cstore.direct.asset.uri_call_number_map.delete' => $_ )->gather(1) for (@$uri_maps);
-
- # and delete the call numbers if there are no more URIs
- if (!@{ $blob->{uri} }) {
- $cstore->request( 'open-ils.cstore.direct.asset.call_number.delete' => $_ )->gather(1) for (@$uri_cns);
- }
- }
-
- # now, add CNs, URIs and maps
- my %new_cns_by_owner;
- my %new_uris_by_owner;
- for my $u ( @{ $blob->{uri} } ) {
-
- my $owner = $u->{call_number}->owning_lib;
-
- if ($u->{call_number}->isnew) {
- if ($new_cns_by_owner{$owner}) {
- $u->{call_number} = $new_cns_by_owner{$owner};
- } else {
- $u->{call_number}->clear_id;
- $u->{call_number} = $new_cns_by_owner{$owner} = $cstore->request(
- 'open-ils.cstore.direct.asset.call_number.create' => $u->{call_number}
- )->gather(1);
- }
- }
-
- if ($u->{uri}->isnew) {
- if ($new_uris_by_owner{$owner}) {
- $u->{uri} = $new_uris_by_owner{$owner};
- } else {
- $u->{uri} = $new_uris_by_owner{$owner} = $cstore->request(
- 'open-ils.cstore.direct.asset.uri.create' => $u->{uri}
- )->gather(1);
- }
- }
-
- # Check for an existing CN-URI map
- $tmp = $cstore->request(
- 'open-ils.cstore.direct.asset.uri_call_number_map.id_list',
- { call_number => $u->{call_number}->id, uri => $u->{uri}->id }
- )->gather(1);
-
- next if ($tmp);
-
- my $umap = Fieldmapper::asset::uri_call_number_map->new;
- $umap->uri($u->{uri}->id);
- $umap->call_number($u->{call_number}->id);
-
- $cstore->request( 'open-ils.cstore.direct.asset.uri_call_number_map.create' => $umap )->gather(1);
- }
-
- # update full_rec stuff ...
- $tmp = $cstore->request(
- 'open-ils.cstore.direct.metabib.full_rec.id_list.atomic',
- { record => $bib->id }
- )->gather(1);
-
- $cstore->request( 'open-ils.cstore.direct.metabib.full_rec.delete' => $_ )->gather(1) for (@$tmp);
- $cstore->request( 'open-ils.cstore.direct.metabib.full_rec.create' => $_ )->gather(1) for (@{ $blob->{full_rec} });
-
- # update rec_descriptor stuff ...
- $tmp = $cstore->request(
- 'open-ils.cstore.direct.metabib.record_descriptor.id_list.atomic',
- { record => $bib->id }
- )->gather(1);
-
- $cstore->request( 'open-ils.cstore.direct.metabib.record_descriptor.delete' => $_ )->gather(1) for (@$tmp);
- $cstore->request( 'open-ils.cstore.direct.metabib.record_descriptor.create' => $blob->{descriptor} )->gather(1);
-
- # deal with classed fields...
- for my $class ( qw/title author subject keyword series identifier/ ) {
- $tmp = $cstore->request(
- "open-ils.cstore.direct.metabib.${class}_field_entry.id_list.atomic",
- { source => $bib->id }
- )->gather(1);
-
- $cstore->request( "open-ils.cstore.direct.metabib.${class}_field_entry.delete" => $_ )->gather(1) for (@$tmp);
- }
- for my $obj ( @{ $blob->{field_entries} } ) {
- my $class = $obj->class_name;
- $class =~ s/^Fieldmapper:://o;
- $class =~ s/::/./go;
- $cstore->request( "open-ils.cstore.direct.$class.create" => $obj )->gather(1);
- }
-
- # update MR map ...
-
- $tmp = $cstore->request(
- 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
- { source => $bib->id }
- )->gather(1);
-
- $cstore->request( 'open-ils.cstore.direct.metabib.metarecord_source_map.delete' => $_->id )->gather(1) for (@$tmp);
-
- # get the old MRs
- my $old_mrs = $cstore->request(
- 'open-ils.cstore.direct.metabib.metarecord.search.atomic' => { id => [map { $_->metarecord } @$tmp] }
- )->gather(1) if (@$tmp);
-
- $old_mrs = [] if (!ref($old_mrs));
-
- my $mr;
- for my $m (@$old_mrs) {
- if ($m->fingerprint eq $bib->fingerprint) {
- $mr = $m;
- } else {
- my $others = $cstore->request(
- 'open-ils.cstore.direct.metabib.metarecord_source_map.id_list.atomic' => { metarecord => $m->id }
- )->gather(1);
-
- if (!@$others) {
- $cstore->request(
- 'open-ils.cstore.direct.metabib.metarecord.delete' => $m->id
- )->gather(1);
- }
-
- $m->isdeleted(1);
- }
- }
-
- my $holds;
- if (!$mr) {
- # Get the matchin MR, if any.
- $mr = $cstore->request(
- 'open-ils.cstore.direct.metabib.metarecord.search',
- { fingerprint => $bib->fingerprint }
- )->gather(1);
-
- $holds = $cstore->request(
- 'open-ils.cstore.direct.action.hold_request.search.atomic',
- { hold_type => 'M', target => [ map { $_->id } grep { $_->isdeleted } @$old_mrs ] }
- )->gather(1) if (@$old_mrs);
-
- if ($mr) {
- for my $h (@$holds) {
- $h->target($mr);
- $cstore->request( 'open-ils.cstore.direct.action.hold_request.update' => $h )->gather(1);
- $h->ischanged(1);
- }
- }
- }
-
- if (!$mr) {
- $mr = new Fieldmapper::metabib::metarecord;
- $mr->fingerprint( $bib->fingerprint );
- $mr->master_record( $bib->id );
- $mr->id(
- $cstore->request(
- "open-ils.cstore.direct.metabib.metarecord.create",
- $mr => { quiet => 'true' }
- )->gather(1)
- );
-
- for my $h (grep { !$_->ischanged } @$holds) {
- $h->target($mr);
- $cstore->request( 'open-ils.cstore.direct.action.hold_request.update' => $h )->gather(1);
- }
- } else {
- my $mrm = $cstore->request(
- 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
- { metarecord => $mr->id }
- )->gather(1);
-
- if (@$mrm) {
- my $best = $cstore->request(
- "open-ils.cstore.direct.biblio.record_entry.search",
- { id => [ map { $_->source } @$mrm ] },
- { 'select' => { bre => [ qw/id quality/ ] },
- order_by => { bre => "quality desc" },
- limit => 1,
- }
- )->gather(1);
-
- if ($best->quality > $bib->quality) {
- $mr->master_record($best->id);
- } else {
- $mr->master_record($bib->id);
- }
- } else {
- $mr->master_record($bib->id);
- }
-
- $mr->clear_mods;
-
- $cstore->request( 'open-ils.cstore.direct.metabib.metarecord.update' => $mr )->gather(1);
- }
-
- my $mrm = new Fieldmapper::metabib::metarecord_source_map;
- $mrm->source($bib->id);
- $mrm->metarecord($mr->id);
-
- $cstore->request( 'open-ils.cstore.direct.metabib.metarecord_source_map.create' => $mrm )->gather(1);
- $cstore->request( 'open-ils.cstore.direct.biblio.record_entry.update' => $bib )->gather(1);
-
- $cstore->request( 'open-ils.cstore.json_query.atomic' => { from => [ 'reporter.simple_rec_update', $bib->id ] } )->gather(1);
-
- $cstore->request( 'open-ils.cstore.transaction.commit' )->gather(1) || return undef;;
- $cstore->disconnect;
-
- return $bib->id;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.object",
- method => "rw_biblio_ingest_single_object",
- api_level => 1,
- argc => 1,
-);
-
-sub rw_biblio_ingest_single_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
- $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
-
- my $r = $cstore->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )->gather(1);
-
- $cstore->request('open-ils.cstore.transaction.rollback')->gather(1);
- $cstore->disconnect;
-
- return undef unless ($r and @$r);
-
- return ($self->method_lookup("open-ils.ingest.full.biblio.object")->run($r))[0];
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.record",
- method => "rw_biblio_ingest_single_record",
- api_level => 1,
- argc => 1,
-);
-
-sub rw_biblio_ingest_record_list {
- my $self = shift;
- my $client = shift;
- my @rec = ref($_[0]) ? @{ $_[0] } : @_ ;
-
- OpenILS::Application::Ingest->post_init();
- my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
- $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
-
- my $r = $cstore->request( 'open-ils.cstore.direct.biblio.record_entry.search.atomic' => { id => \@rec } )->gather(1);
-
- $cstore->request('open-ils.cstore.transaction.rollback')->gather(1);
- $cstore->disconnect;
-
- return undef unless ($r and @$r);
-
- my $count = 0;
- for (@$r) {
- if (($self->method_lookup("open-ils.ingest.full.biblio.object")->run($_))[0]) {
- $count++
- }
- }
- return $count;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.record_list",
- method => "rw_biblio_ingest_record_list",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_biblio_ingest_single_object {
- my $self = shift;
- my $client = shift;
- my $bib = shift;
- my $xml = OpenILS::Application::AppUtils->entityize($bib->marc);
- my $max_cn = shift;
- my $max_uri = shift;
-
- my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
-
- if (!$max_cn) {
- my $cn = $cstore->request( 'open-ils.cstore.direct.asset.call_number.search' => { id => { '!=' => undef } }, { limit => 1, order_by => { acn => 'id desc' } } )->gather(1);
- $max_cn = int($cn->id) + 1000;
- }
-
- if (!$max_uri) {
- my $cn = $cstore->request( 'open-ils.cstore.direct.asset.call_number.search' => { id => { '!=' => undef } }, { limit => 1, order_by => { acn => 'id desc' } } )->gather(1);
- $max_uri = int($cn->id) + 1000;
- }
-
- $cstore->disconnect;
-
- my $document = $parser->parse_string($xml);
-
- my @uris = $self->method_lookup("open-ils.ingest.856_uri.object")->run($bib, $max_cn, $max_uri);
- my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.biblio.xml")->run($document);
- my @mXfe = $self->method_lookup("open-ils.ingest.extract.field_entry.all.xml")->run($document);
- my ($fp) = $self->method_lookup("open-ils.ingest.fingerprint.xml")->run($xml);
- my ($rd) = $self->method_lookup("open-ils.ingest.descriptor.xml")->run($xml);
-
- $_->source($bib->id) for (@mXfe);
- $_->record($bib->id) for (@mfr);
- $rd->record($bib->id) if ($rd);
-
- return { full_rec => \@mfr, field_entries => \@mXfe, fingerprint => $fp, descriptor => $rd, uri => \@uris };
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.object.readonly",
- method => "ro_biblio_ingest_single_object",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_biblio_ingest_single_xml {
- my $self = shift;
- my $client = shift;
- my $xml = OpenILS::Application::AppUtils->entityize(shift);
-
- my $document = $parser->parse_string($xml);
-
- my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.biblio.xml")->run($document);
- my @mXfe = $self->method_lookup("open-ils.ingest.extract.field_entry.all.xml")->run($document);
- my ($fp) = $self->method_lookup("open-ils.ingest.fingerprint.xml")->run($xml);
- my ($rd) = $self->method_lookup("open-ils.ingest.descriptor.xml")->run($xml);
-
- return { full_rec => \@mfr, field_entries => \@mXfe, fingerprint => $fp, descriptor => $rd };
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.xml.readonly",
- method => "ro_biblio_ingest_single_xml",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_biblio_ingest_single_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )
- ->gather(1);
-
- return undef unless ($r and @$r);
-
- my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.xml.readonly")->run($r->marc);
-
- $_->source($rec) for (@{$res->{field_entries}});
- $_->record($rec) for (@{$res->{full_rec}});
- $res->{descriptor}->record($rec);
-
- return $res;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.record.readonly",
- method => "ro_biblio_ingest_single_record",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_biblio_ingest_stream_record {
- my $self = shift;
- my $client = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
-
- my $rec = $resp->content;
- last unless (defined $rec);
-
- $log->debug("Running open-ils.ingest.full.biblio.record.readonly ...");
- my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.record.readonly")->run($rec);
-
- $_->source($rec) for (@{$res->{field_entries}});
- $_->record($rec) for (@{$res->{full_rec}});
-
- $client->respond( $res );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.record_stream.readonly",
- method => "ro_biblio_ingest_stream_record",
- api_level => 1,
- stream => 1,
-);
-
-sub ro_biblio_ingest_stream_xml {
- my $self = shift;
- my $client = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
-
- my $xml = $resp->content;
- last unless (defined $xml);
-
- $log->debug("Running open-ils.ingest.full.biblio.xml.readonly ...");
- my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.xml.readonly")->run($xml);
-
- $client->respond( $res );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.xml_stream.readonly",
- method => "ro_biblio_ingest_stream_xml",
- api_level => 1,
- stream => 1,
-);
-
-sub rw_biblio_ingest_stream_import {
- my $self = shift;
- my $client = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
-
- my $bib = $resp->content;
- last unless (defined $bib);
-
- $log->debug("Running open-ils.ingest.full.biblio.xml.readonly ...");
- my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.xml.readonly")->run($bib->marc);
-
- $_->source($bib->id) for (@{$res->{field_entries}});
- $_->record($bib->id) for (@{$res->{full_rec}});
-
- $client->respond( $res );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.biblio.bib_stream.import",
- method => "rw_biblio_ingest_stream_import",
- api_level => 1,
- stream => 1,
-);
-
-
-# --------------------------------------------------------------------------------
-# Authority ingest
-
-package OpenILS::Application::Ingest::Authority;
-use base qw/OpenILS::Application::Ingest/;
-use Unicode::Normalize;
-
-sub rw_authority_ingest_single_object {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
-
- my ($blob) = $self->method_lookup("open-ils.ingest.full.authority.object.readonly")->run($auth);
- return undef unless ($blob);
-
- my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
-
- my $xact = $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
- my $tmp;
-
- # update full_rec stuff ...
- $tmp = $cstore->request(
- 'open-ils.cstore.direct.authority.full_rec.id_list.atomic',
- { record => $auth->id }
- )->gather(1);
-
- $cstore->request( 'open-ils.cstore.direct.authority.full_rec.delete' => $_ )->gather(1) for (@$tmp);
- $cstore->request( 'open-ils.cstore.direct.authority.full_rec.create' => $_ )->gather(1) for (@{ $blob->{full_rec} });
-
- # XXX when we start extracting authority descriptors and adding sources ...
- #
- # update rec_descriptor stuff ...
- #$tmp = $cstore->request(
- # 'open-ils.cstore.direct.authority.record_descriptor.id_list.atomic',
- # { record => $auth->id }
- #)->gather(1);
- #
- #$cstore->request( 'open-ils.cstore.direct.authority.record_descriptor.delete' => $_ )->gather(1) for (@$tmp);
- #$cstore->request( 'open-ils.cstore.direct.authority.record_descriptor.create' => $blob->{descriptor} )->gather(1);
- #$cstore->request( 'open-ils.cstore.direct.authority.record_entry.update' => $auth )->gather(1);
-
- $cstore->request( 'open-ils.cstore.transaction.commit' )->gather(1) || return undef;;
- $cstore->disconnect;
-
- return $auth->id;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.object",
- method => "rw_authority_ingest_single_object",
- api_level => 1,
- argc => 1,
-);
-
-sub rw_authority_ingest_single_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
- $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
-
- my $r = $cstore->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rec )->gather(1);
-
- $cstore->request('open-ils.cstore.transaction.rollback')->gather(1);
- $cstore->disconnect;
-
- return undef unless ($r and @$r);
-
- return ($self->method_lookup("open-ils.ingest.full.authority.object")->run($r))[0];
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.record",
- method => "rw_authority_ingest_single_record",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_authority_ingest_single_object {
- my $self = shift;
- my $client = shift;
- my $bib = shift;
- my $xml = OpenILS::Application::AppUtils->entityize($bib->marc);
-
- my $document = $parser->parse_string($xml);
-
- my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.authority.xml")->run($document);
-
- $_->record($bib->id) for (@mfr);
-
- return { full_rec => \@mfr };
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.object.readonly",
- method => "ro_authority_ingest_single_object",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_authority_ingest_single_xml {
- my $self = shift;
- my $client = shift;
- my $xml = OpenILS::Application::AppUtils->entityize(shift);
-
- my $document = $parser->parse_string($xml);
-
- my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.authority.xml")->run($document);
-
- return { full_rec => \@mfr };
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.xml.readonly",
- method => "ro_authority_ingest_single_xml",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_authority_ingest_single_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rec )
- ->gather(1);
-
- return undef unless ($r and @$r);
-
- my ($res) = $self->method_lookup("open-ils.ingest.full.authority.xml.readonly")->run($r->marc);
-
- $_->record($rec) for (@{$res->{full_rec}});
- $res->{descriptor}->record($rec);
-
- return $res;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.record.readonly",
- method => "ro_authority_ingest_single_record",
- api_level => 1,
- argc => 1,
-);
-
-sub ro_authority_ingest_stream_record {
- my $self = shift;
- my $client = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
-
- my $rec = $resp->content;
- last unless (defined $rec);
-
- $log->debug("Running open-ils.ingest.full.authority.record.readonly ...");
- my ($res) = $self->method_lookup("open-ils.ingest.full.authority.record.readonly")->run($rec);
-
- $_->record($rec) for (@{$res->{full_rec}});
-
- $client->respond( $res );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.record_stream.readonly",
- method => "ro_authority_ingest_stream_record",
- api_level => 1,
- stream => 1,
-);
-
-sub ro_authority_ingest_stream_xml {
- my $self = shift;
- my $client = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
-
- my $xml = $resp->content;
- last unless (defined $xml);
-
- $log->debug("Running open-ils.ingest.full.authority.xml.readonly ...");
- my ($res) = $self->method_lookup("open-ils.ingest.full.authority.xml.readonly")->run($xml);
-
- $client->respond( $res );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.xml_stream.readonly",
- method => "ro_authority_ingest_stream_xml",
- api_level => 1,
- stream => 1,
-);
-
-sub rw_authority_ingest_stream_import {
- my $self = shift;
- my $client = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
-
- my $bib = $resp->content;
- last unless (defined $bib);
-
- $log->debug("Running open-ils.ingest.full.authority.xml.readonly ...");
- my ($res) = $self->method_lookup("open-ils.ingest.full.authority.xml.readonly")->run($bib->marc);
-
- $_->record($bib->id) for (@{$res->{full_rec}});
-
- $client->respond( $res );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.full.authority.bib_stream.import",
- method => "rw_authority_ingest_stream_import",
- api_level => 1,
- stream => 1,
-);
-
-# --------------------------------------------------------------------------------
-# MARC index extraction
-
-package OpenILS::Application::Ingest::XPATH;
-use base qw/OpenILS::Application::Ingest/;
-use Unicode::Normalize;
-
-# give this an XML documentElement and an XPATH expression
-sub xpath_to_string {
- my $xml = shift;
- my $xpath = shift;
- my $ns_uri = shift;
- my $ns_prefix = shift;
- my $unique = shift;
-
- $xml->setNamespace( $ns_uri, $ns_prefix, 1 ) if ($ns_uri && $ns_prefix);
-
- my $string = "";
-
- # grab the set of matching nodes
- my @nodes = $xml->findnodes( $xpath );
- for my $value (@nodes) {
-
- # grab all children of the node
- my @children = $value->childNodes();
- for my $child (@children) {
-
- # add the childs content to the growing buffer
- my $content = quotemeta($child->textContent);
- next if ($unique && $string =~ /$content/); # uniquify the values
- $string .= $child->textContent . " ";
- }
- if( ! @children ) {
- $string .= $value->textContent . " ";
- }
- }
-
- $string =~ s/(\w+)\/(\w+)/$1 $2/sgo;
- # Split date ranges and ISSNs on the hyphen
- $string =~ s/(\d{4})-(\d{3,4}x?)/ $1 $2 /goi;
-
- return NFD($string);
-}
-
-sub class_index_string_xml {
- my $self = shift;
- my $client = shift;
- my $xml = shift;
- my @classes = @_;
-
- OpenILS::Application::Ingest->post_init();
- $xml = $parser->parse_string(OpenILS::Application::AppUtils->entityize($xml)) unless (ref $xml);
-
- my %transform_cache;
-
- for my $class (@classes) {
- my $class_constructor = "Fieldmapper::metabib::${class}_field_entry";
- for my $type ( keys %{ $xpathset->{$class} } ) {
-
- my $def = $xpathset->{$class}->{$type};
- my $sf = $OpenILS::Application::Ingest::supported_formats{$def->{format}};
-
- my $document = $xml;
-
- if ($sf->{xslt}) {
- $document = $transform_cache{$def->{format}} || $sf->{xslt}->transform($xml);
- $transform_cache{$def->{format}} = $document;
- }
-
- my $value = xpath_to_string(
- $document->documentElement => $def->{xpath},
- $sf->{ns} => $def->{format},
- 1
- );
-
- next unless $value;
-
- $value = NFD($value);
- $value =~ s/\pM+//sgo;
- $value =~ s/\pC+//sgo;
- $value =~ s/\W+$//sgo;
-
- # hack to normalize ratio-like strings
- while ($term =~ /\b\d{1}:[, ]?\d+(?:[ ,]\d+[^:])+/o) {
- $term = $` . join ('', split(/[, ]/, $&)) . $';
- }
-
- $value =~ s/\b\.+\b//sgo;
- $value = lc($value);
-
- my $fm = $class_constructor->new;
- $fm->value( $value );
- $fm->field( $xpathset->{$class}->{$type}->{id} );
- $client->respond($fm);
- }
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.field_entry.class.xml",
- method => "class_index_string_xml",
- api_level => 1,
- argc => 2,
- stream => 1,
-);
-
-sub class_index_string_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
- my @classes = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rec )
- ->gather(1);
-
- return undef unless ($r and @$r);
-
- for my $fm ($self->method_lookup("open-ils.ingest.field_entry.class.xml")->run($r->marc, @classes)) {
- $fm->source($rec);
- $client->respond($fm);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.field_entry.class.record",
- method => "class_index_string_record",
- api_level => 1,
- argc => 2,
- stream => 1,
-);
-
-sub all_index_string_xml {
- my $self = shift;
- my $client = shift;
- my $xml = shift;
-
- for my $fm ($self->method_lookup("open-ils.ingest.field_entry.class.xml")->run($xml, keys(%$xpathset))) {
- $client->respond($fm);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.extract.field_entry.all.xml",
- method => "all_index_string_xml",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-sub all_index_string_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )
- ->gather(1);
-
- return undef unless ($r and @$r);
-
- for my $fm ($self->method_lookup("open-ils.ingest.field_entry.class.xml")->run($r->marc, keys(%$xpathset))) {
- $fm->source($rec);
- $client->respond($fm);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.extract.field_entry.all.record",
- method => "all_index_string_record",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-# --------------------------------------------------------------------------------
-# Flat MARC
-
-package OpenILS::Application::Ingest::FlatMARC;
-use base qw/OpenILS::Application::Ingest/;
-use Unicode::Normalize;
-
-
-sub _marcxml_to_full_rows {
-
- my $marcxml = shift;
- my $xmltype = shift || 'metabib';
-
- my $type = "Fieldmapper::${xmltype}::full_rec";
-
- my @ns_list;
-
- my ($root) = $marcxml->findnodes('//*[local-name()="record"]');
-
- for my $tagline ( @{$root->getChildrenByTagName("leader")} ) {
- next unless $tagline;
- _special_tag_to_full_rows($type, $tagline, \@ns_list, 'LDR');
- }
-
- for my $tagline ( @{$root->getChildrenByTagName("controlfield")} ) {
- next unless $tagline;
- _special_tag_to_full_rows($type, $tagline, \@ns_list, $tagline->getAttribute( "tag" ));
- }
-
- for my $tagline ( @{$root->getChildrenByTagName("datafield")} ) {
- next unless $tagline;
- _data_tag_to_full_rows($type, $tagline, \@ns_list, $tagline->getAttribute( "tag" ));
-
- if ($xmltype eq 'metabib' and $tag eq '245') {
- _data_tag_to_full_rows($type, $tagline, \@ns_list, 'tnf');
- }
- }
-
- $log->debug("Returning ".scalar(@ns_list)." Fieldmapper nodes from $xmltype xml");
- return @ns_list;
-}
-
-=head2 _special_tag_to_full_rows
-
-Converts a leader or control field to a set of normalized values
-
-=cut
-
-sub _special_tag_to_full_rows {
- my $type = shift;
- my $tagline = shift;
- my $ns_list = shift;
- my $tagname = shift;
-
- my $ns = $type->new;
-
- $ns->tag( $tagname );
- my $val = $tagline->textContent;
- $val = NFD($val);
- $val =~ s/\pM+//sgo;
- $val =~ s/\pC+//sgo;
- $val =~ s/\W+$//sgo;
- $ns->value( $val );
-
- push @$ns_list, $ns;
-}
-
-=head2 _data_tag_to_full_rows
-
-Converts a data field to a set of normalized values
-
-=cut
-
-sub _data_tag_to_full_rows {
- my $type = shift;
- my $tagline = shift;
- my $ns_list = shift;
- my $tag = shift;
-
- my $ind1 = $tagline->getAttribute( "ind1" );
- my $ind2 = $tagline->getAttribute( "ind2" );
-
- for my $data ( @{$tagline->getChildrenByTagName('subfield')} ) {
- next unless $data;
-
- my $ns = $type->new;
-
- $ns->tag( $tag );
- $ns->ind1( $ind1 );
- $ns->ind2( $ind2 );
- $ns->subfield( $data->getAttribute( "code" ) );
- my $val = $data->textContent;
- $val = NFD($val);
- $val =~ s/\pM+//sgo;
- $val =~ s/\pC+//sgo;
- $val =~ s/\W+$//sgo;
- # Split date ranges and ISSNs on the hyphen
- $val =~ s/(\d{4})-(\d{3,4}x?)/ $1 $2 /goi;
- $val =~ s/(\w+)\/(\w+)/$1 $2/sgo;
- $ns->value( lc($val) );
-
- push @$ns_list, $ns;
- }
-}
-
-sub flat_marc_xml {
- my $self = shift;
- my $client = shift;
- my $xml = shift;
-
- $log->debug("processing [$xml]");
-
- $xml = $parser->parse_string(OpenILS::Application::AppUtils->entityize($xml)) unless (ref $xml);
-
- my $type = 'metabib';
- $type = 'authority' if ($self->api_name =~ /authority/o);
-
- OpenILS::Application::Ingest->post_init();
-
- $client->respond($_) for (_marcxml_to_full_rows($xml, $type));
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.flat_marc.authority.xml",
- method => "flat_marc_xml",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.flat_marc.biblio.xml",
- method => "flat_marc_xml",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-sub flat_marc_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- my $type = 'biblio';
- $type = 'authority' if ($self->api_name =~ /authority/o);
-
- OpenILS::Application::Ingest->post_init();
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( "open-ils.cstore.direct.${type}.record_entry.retrieve" => $rec )
- ->gather(1);
-
-
- return undef unless ($r and $r->marc);
-
- my @rows = $self->method_lookup("open-ils.ingest.flat_marc.$type.xml")->run($r->marc);
- for my $row (@rows) {
- $client->respond($row);
- $log->debug(OpenSRF::Utils::JSON->perl2JSON($row), DEBUG);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.flat_marc.biblio.record_entry",
- method => "flat_marc_record",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.flat_marc.authority.record_entry",
- method => "flat_marc_record",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-# --------------------------------------------------------------------------------
-# URI extraction
-
-package OpenILS::Application::Ingest::Biblio::URI;
-use base qw/OpenILS::Application::Ingest/;
-use Unicode::Normalize;
-use OpenSRF::EX qw/:try/;
-
-
-sub _extract_856_uris {
-
- my $rec = shift;
- my $max_cn = shift;
- my $max_uri = shift;
- my @objects;
-
- my $recid = $rec->id;
- my $marcxml = $rec->marc;
-
- my $document = $parser->parse_string($marcxml);
- my @nodes = $document->findnodes('//*[local-name()="datafield" and @tag="856" and (@ind1="4" or @ind1="1") and (@ind2="0" or @ind2="1")]');
-
- my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
-
- my %cn_cache;
-
- for my $node (@nodes) {
- # first, is there a URI?
- my $href = $node->findvalue('*[local-name()="subfield" and @code="u"]/text()');
- next unless ($href);
-
- # now, find the best possible label
- my $label = $node->findvalue('*[local-name()="subfield" and @code="y"]/text()');
- $label ||= $node->findvalue('*[local-name()="subfield" and @code="3"]/text()');
- $label ||= $href;
-
- # look for use info
- my $use = $node->findvalue('*[local-name()="subfield" and @code="z"]/text()');
- $use ||= $node->findvalue('*[local-name()="subfield" and @code="2"]/text()');
- $use ||= $node->findvalue('*[local-name()="subfield" and @code="n"]/text()');
-
- # moving on to the URI owner
- my $owner = $node->findvalue('*[local-name()="subfield" and @code="9"]/text()'); # Evergreen special sauce
- $owner ||= $node->findvalue('*[local-name()="subfield" and @code="w"]/text()');
- $owner ||= $node->findvalue('*[local-name()="subfield" and @code="n"]/text()');
-
- $owner =~ s/^.*?\((\w+)\).*$/$1/o; # unwrap first paren-enclosed string and then ...
-
- # no owner? skip it :(
- next unless ($owner);
-
- my $org = $cstore
- ->request( 'open-ils.cstore.direct.actor.org_unit.search' => { shortname => $owner} )
- ->gather(1);
-
- next unless ($org);
-
- # now we can construct the uri object
- my $uri = $cstore
- ->request( 'open-ils.cstore.direct.asset.uri.search' => { label => $label, href => $href, use_restriction => $use, active => 't' } )
- ->gather(1);
-
- if (!$uri) {
- $uri = Fieldmapper::asset::uri->new;
- $uri->isnew( 1 );
- $uri->id( $$max_uri++ );
- $uri->label($label);
- $uri->href($href);
- $uri->active('t');
- $uri->use_restriction($use);
- }
-
- # see if we need to create a call number
- my $cn = $cn_cache{$org->id};
- $cn = $cn->clone if ($cn);
- $cn->clear_isnew if ($cn);
-
- $cn ||= $cstore
- ->request( 'open-ils.cstore.direct.asset.call_number.search' => { owning_lib => $org->id, record => $recid, label => '##URI##' } )
- ->gather(1);
-
- if (!$cn) {
- $cn = Fieldmapper::asset::call_number->new;
- $cn->isnew( 1 );
- $cn->deleted('f');
- $cn->id( $$max_cn++ );
- $cn->owning_lib( $org->id );
- $cn->record( $recid );
- $cn->create_date( 'now' );
- $cn->creator( $rec->creator );
- $cn->editor( $rec->editor );
- $cn->edit_date( 'now' );
- $cn->label( '##URI##' );
- }
-
- $cn_cache{$org->id} = $cn;
-
- push @objects, { uri => $uri, call_number => $cn };
- }
-
- $log->debug("Returning ".scalar(@objects)." URI nodes for record $recid");
- $cstore->disconnect;
- return @objects;
-}
-
-sub get_uris_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( "open-ils.cstore.direct.biblio.record_entry.retrieve" => $rec )
- ->gather(1);
-
- return undef unless ($r and $r->marc);
-
- $client->respond($_) for (_extract_856_uris($r));
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.856_uri.record",
- method => "get_uris_record",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-sub get_uris_object {
- my $self = shift;
- my $client = shift;
- my $obj = shift;
- my $max_cn = shift;
- my $max_uri = shift;
-
- return undef unless ($obj and $obj->marc);
-
- $client->respond($_) for (_extract_856_uris($obj, \$max_cn, \$max_uri));
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.856_uri.object",
- method => "get_uris_object",
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-
-# --------------------------------------------------------------------------------
-# Fingerprinting
-
-package OpenILS::Application::Ingest::Biblio::Fingerprint;
-use base qw/OpenILS::Application::Ingest/;
-use Unicode::Normalize;
-use OpenSRF::EX qw/:try/;
-
-sub biblio_fingerprint_record {
- my $self = shift;
- my $client = shift;
- my $rec = shift;
-
- OpenILS::Application::Ingest->post_init();
-
- my $r = OpenSRF::AppSession
- ->create('open-ils.cstore')
- ->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )
- ->gather(1);
-
- return undef unless ($r and $r->marc);
-
- my ($fp) = $self->method_lookup('open-ils.ingest.fingerprint.xml')->run($r->marc);
- $log->debug("Returning [$fp] as fingerprint for record $rec", INFO);
- $fp->{quality} = int($fp->{quality});
- return $fp;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.fingerprint.record",
- method => "biblio_fingerprint_record",
- api_level => 1,
- argc => 1,
-);
-
-our $fp_script;
-sub biblio_fingerprint {
- my $self = shift;
- my $client = shift;
- my $xml = OpenILS::Application::AppUtils->entityize(shift);
-
- $log->internal("Got MARC [$xml]");
-
- if(!$fp_script) {
- my @pfx = ( "apps", "open-ils.ingest","app_settings" );
- my $conf = OpenSRF::Utils::SettingsClient->new;
-
- my $libs = $conf->config_value(@pfx, 'script_path');
- my $script_file = $conf->config_value(@pfx, 'scripts', 'biblio_fingerprint');
- my $script_libs = (ref($libs)) ? $libs : [$libs];
-
- $log->debug("Loading script $script_file for biblio fingerprinting...");
-
- $fp_script = new OpenILS::Utils::ScriptRunner
- ( file => $script_file,
- paths => $script_libs,
- reset_count => 100 );
- }
-
- $fp_script->insert('environment' => {marc => $xml} => 1);
-
- my $res = $fp_script->run || ($log->error( "Fingerprint script died! $@" ) && return undef);
- $log->debug("Script for biblio fingerprinting completed successfully...");
-
- return $res;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.fingerprint.xml",
- method => "biblio_fingerprint",
- api_level => 1,
- argc => 1,
-);
-
-our $rd_script;
-sub biblio_descriptor {
- my $self = shift;
- my $client = shift;
- my $xml = OpenILS::Application::AppUtils->entityize(shift);
-
- $log->internal("Got MARC [$xml]");
-
- if(!$rd_script) {
- my @pfx = ( "apps", "open-ils.ingest","app_settings" );
- my $conf = OpenSRF::Utils::SettingsClient->new;
-
- my $libs = $conf->config_value(@pfx, 'script_path');
- my $script_file = $conf->config_value(@pfx, 'scripts', 'biblio_descriptor');
- my $script_libs = (ref($libs)) ? $libs : [$libs];
-
- $log->debug("Loading script $script_file for biblio descriptor extraction...");
-
- $rd_script = new OpenILS::Utils::ScriptRunner
- ( file => $script_file,
- paths => $script_libs,
- reset_count => 100 );
- }
-
- $log->debug("Setting up environment for descriptor extraction script...");
- $rd_script->insert('environment.marc' => $xml => 1);
- $log->debug("Environment building complete...");
-
- my $res = $rd_script->run || ($log->error( "Descriptor script died! $@" ) && return undef);
- $log->debug("Script for biblio descriptor extraction completed successfully");
-
- my $d1 = $res->date1;
- if ($d1 && $d1 ne ' ') {
- $d1 =~ tr/ux/00/;
- $res->date1( $d1 );
- }
-
- my $d2 = $res->date2;
- if ($d2 && $d2 ne ' ') {
- $d2 =~ tr/ux/99/;
- $res->date2( $d2 );
- }
-
- return $res;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.ingest.descriptor.xml",
- method => "biblio_descriptor",
- api_level => 1,
- argc => 1,
-);
-
-
-1;
-
-# vim:et:ts=4:sw=4:
+++ /dev/null
-package OpenILS::Application::Penalty;
-use strict; use warnings;
-use OpenSRF::EX qw(:try);
-use OpenILS::Application;
-use OpenILS::Utils::Penalty;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use base 'OpenILS::Application';
-
-__PACKAGE__->register_method (
- method => 'patron_penalty',
- api_name => 'open-ils.penalty.patron_penalty.calculate',
- signature => q/
- Calculates the patron's standing penalties
- @param args An object of named params including:
- patronid The id of the patron
- update True if this call should update the database
- background True if this call should return immediately,
- then go on to process the penalties. This flag
- works only in conjunction with the 'update' flag.
- @return An object with keys 'fatal_penalties' and
- 'info_penalties' who are themeselves arrays of 0 or
- more penalties. Returns event on error.
- /
-);
-
-# --------------------------------------------------------------
-# if $args->{background} is true, immediately respond complete
-# to the caller, then finish the calculation
-# --------------------------------------------------------------
-sub patron_penalty {
- my( $self, $conn, $args ) = @_;
- $conn->respond_complete(1) if $$args{background};
- my $e = new_editor(xact => 1);
- OpenILS::Utils::Penalty->calculate_penalties($e, $args->{patronid}, $args->{context_org});
- my $p = OpenILS::Utils::Penalty->retrieve_penalties($e, $args->{patronid}, $args->{context_org});
- $e->commit;
- return $p
-}
-
-
-1;
+++ /dev/null
-# vim:et:ts=4:sw=4:
-
-package OpenILS::Application::PermaCrud;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use Unicode::Normalize;
-use OpenSRF::EX qw/:try/;
-
-use OpenSRF::AppSession;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/:level/;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::JSON;
-
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-
-use XML::LibXML;
-use XML::LibXML::XPathContext;
-use XML::LibXSLT;
-use OpenILS::Event;
-
-our %namespace_map = (
- oils_persist=> {ns => 'http://open-ils.org/spec/opensrf/IDL/persistence/v1'},
- oils_obj => {ns => 'http://open-ils.org/spec/opensrf/IDL/objects/v1'},
- idl => {ns => 'http://opensrf.org/spec/IDL/base/v1'},
- reporter => {ns => 'http://open-ils.org/spec/opensrf/IDL/reporter/v1'},
- perm => {ns => 'http://open-ils.org/spec/opensrf/IDL/permacrud/v1'},
-);
-
-
-my $log = 'OpenSRF::Utils::Logger';
-
-my $parser = XML::LibXML->new();
-my $xslt = XML::LibXSLT->new();
-
-my $xpc = XML::LibXML::XPathContext->new();
-$xpc->registerNs($_, $namespace_map{$_}{ns}) for ( keys %namespace_map );
-
-my $idl;
-
-sub initialize {
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $idl_file = $conf->config_value( 'IDL' );
-
- $idl = $parser->parse_file( $idl_file );
-
- $log->debug( 'IDL XML file loaded' );
-
- generate_methods();
-
-}
-sub child_init {}
-
-sub CRUD_action_object_permcheck {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $obj = shift;
-
- my $e = shift || new_editor(authtoken => $auth, xact => 1);
- return $e->event unless $e->checkauth;
-
- if (ref($obj) && $obj->json_hint ne $self->{class_hint}) {
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Class missmatch: $self->{class_hint} method called with " . $obj->json_hint,
- );
- }
-
- my $class_node;
- my $error = '';
- try {
- ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
- } catch Error with {
- $error = shift;
- $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
- );
- };
-
- if (!$class_node) {
- $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
- );
- }
-
- my $action_node;
- try {
- ($action_node) = $xpc->findnodes( "perm:permacrud/perm:actions/perm:$self->{action}", $class_node );
- } catch Error with {
- $error = shift;
- $log->error("Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]");
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]"
- );
- };
-
- if (!$action_node) {
- $log->error("Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]");
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]"
- );
- }
-
- my $all_perms = $action_node->getAttribute( 'all_perms' );
-
- my $fm_class = $xpc->findvalue( '@oils_obj:fieldmapper', $class_node );
- if (!ref($obj)) {
- my $retrieve_method = 'retrieve_' . $fm_class;
- $retrieve_method =~ s/::/_/go;
- $obj = $e->$retrieve_method( $obj ) or return $e->die_event;
- }
-
- (my $o_type = $fm_class) =~ s/::/./go;
-
- my $perm_field_value = $action_node->getAttribute('permission');
-
- if ($perm_field_value) {
- my @perms = split ' ', $perm_field_value;
-
- my @context_ous;
- if ($action_node->getAttribute('global_required')) {
- push @context_ous, $e->search_actor_org_unit( { parent_ou => undef } )->[0]->id;
-
- } else {
- my $context_field_value = $action_node->getAttribute('context_field');
-
- if ($context_field_value) {
- push @context_ous, $obj->$_ for ( split ' ', $context_field_value );
- } else {
- for my $context_node ( $xpc->findnodes( "perm:context", $action_node ) ) {
- my $context_field = $context_node->getAttribute('field');
- my $link_field = $context_node->getAttribute('link');
-
- if ($link_field) {
-
- my ($link_node) = $xpc->findnodes( "idl:links/idl:link[\@field='$link_field']", $class_node );
- my $link_class_hint = $link_node->getAttribute('class');
- my $remote_field = $link_node->getAttribute('key');
-
- my ($remote_class_node) = $xpc->findnodes( "//idl:class[\@id='$link_class_hint']", $idl->documentElement );
- my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $remote_class_node );
- $search_method =~ s/::/_/go;
-
- for my $remote_object ( @{$e->$search_method( { $remote_field => $obj->$link_field } )} ) {
- push @context_ous, $remote_object->$context_field;
- }
- } else {
- push @context_ous, $obj->$_ for ( split ' ', $context_field );
- }
- }
- }
- }
-
- my $pok = 0;
- for my $perm (@perms) {
- if (@context_ous) {
- for my $c_ou (@context_ous) {
- if ($e->allowed($perm => $c_ou => $obj)) {
- $pok++;
- last;
- }
- }
- } else {
- $pok++ if ($e->allowed($perm => undef => $obj));
- }
- }
-
- if ((lc($all_perms) eq 'true' && @perms != $pok) or !$pok) {
- return OpenILS::Event->new('PERM_FAILURE',
- ilsperm => "", # XXX add logic to report which perm failed
- ilspermloc => "",
- payload => "Perm failure -- action: $self->{action}, object type: $self->{json_hint}",
- );
- }
- }
-
- if ($self->{action} eq 'retrieve') {
- $e->rollback;
- return $obj;
- }
-
- $o_type =~ s/\./_/og;
- my $method = $self->{action} . "_$o_type";
- my $val = $e->$method($obj) or return $e->die_event;
- $e->commit;
-
- return $val;
-}
-
-sub search_permacrud {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my @args = @_;
-
- if (@args > 1) {
- delete $args[1]{flesh};
- delete $args[1]{flesh_fields};
- }
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->event unless $e->checkauth;
-
- my $class_node;
- try {
- ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
- } catch Error with {
- my $error = shift;
- $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
- );
- };
-
- my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $class_node );
- $search_method =~ s/::/_/go;
-
- $log->debug("Calling CStoreEditor search method: $search_method");
-
- my $obj_list = $e->$search_method( \@args );
-
- my $retriever = $self->method_lookup( $self->{retriever} );
- for my $o ( @$obj_list ) {
- try {
- ($o) = $retriever->run( $auth, $o, $e );
- $client->respond( $o ) if ($o);
- };
- }
-
- return undef;
-}
-
-sub generate_methods {
- try {
- for my $class_node ( $xpc->findnodes( '//idl:class[perm:permacrud]', $idl->documentElement ) ) {
- my $hint = $class_node->getAttribute('id');
- $log->debug("permacrud class_node $hint");
-
- for my $action_node ( $xpc->findnodes( "perm:permacrud/perm:actions/perm:*", $class_node ) ) {
- (my $method = $action_node->localname) =~ s/^.+:(.+)$/$1/o;
- $log->internal("permacrud method = $method");
-
- __PACKAGE__->register_method(
- method => 'CRUD_action_object_permcheck',
- api_name => 'open-ils.permacrud.' . $method . '.' . $hint,
- class_hint => $hint,
- action => $method,
- );
-
- if ($method eq 'retrieve') {
- __PACKAGE__->register_method(
- method => 'search_permacrud',
- api_name => 'open-ils.permacrud.search.' . $hint,
- class_hint => $hint,
- retriever => 'open-ils.permacrud.retrieve.' . $hint,
- stream => 1
- );
- }
- }
- }
- } catch Error with {
- my $e = shift;
- $log->error("error generating permacrud methods: $e");
- };
-}
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Proxy;
-use strict; use warnings;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use OpenSRF::EX qw(:try);
-
-
-__PACKAGE__->register_method(
- method => "proxy",
- api_name => "open-ils.proxy.proxy",
- stream => 1,
-);
-
-
-sub proxy {
- my($self, $client, $user_session,
- $server, $method, @params) = @_;
-
- warn "$user_session - $server - $method\n";
-
- throw OpenSRF::EX::ERROR ("Not enough args to proxy")
- unless ($user_session and $server and $method);
-
-
- my $session = OpenSRF::AppSession->create($server);
- my $request = $session->request( $method, @params );
- if(!$request) {
- throw OpenSRF::EX::ERROR
- ("No request built on call to session->request( $method, @params )");
- }
-
- $request->wait_complete;
-
- if( $request->failed() ) {
-
- throw OpenSRF::EX::ERROR
- ($request->failed()->stringify());
-
- } else {
-
- while( my $response = $request->recv ) {
- $client->respond( $response->content );
- }
- }
-
- $request->finish();
- $session->finish();
- $session->disconnect();
-
- return undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Reporter;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Application::AppUtils;
-my $U = "OpenILS::Application::AppUtils";
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.folder.create',
- method => 'create_folder'
-);
-
-sub create_folder {
- my( $self, $conn, $auth, $type, $folder ) = @_;
-
- my $e = new_rstore_editor(xact=>1, authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
-
- return 0 if $folder->owner ne $e->requestor->id;
-
- $folder->owner($e->requestor->id);
- my $meth = "create_reporter_${type}_folder";
- $e->$meth($folder) or return $e->die_event;
- $e->commit;
-
- return $folder->id;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report.exists',
- method => 'report_exists',
- notes => q/
- Returns 1 if a report with the given name and folder already exists.
- /
-);
-
-sub report_exists {
- my( $self, $conn, $auth, $report ) = @_;
-
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
-
- my $existing = $e->search_reporter_report(
- {folder=>$report->folder, name=>$report->name});
- return 1 if @$existing;
- return 0;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.folder.visible.retrieve',
- method => 'retrieve_visible_folders'
-);
-
-sub retrieve_visible_folders {
- my( $self, $conn, $auth, $type ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
-
- my $class = 'rrf';
- $class = 'rtf' if $type eq 'template';
- $class = 'rof' if $type eq 'output';
- my $flesh = {flesh => 1,flesh_fields => { $class => ['owner', 'share_with']}};
-
- my $meth = "search_reporter_${type}_folder";
- my $fs = $e->$meth( [{ owner => $e->requestor->id }, $flesh] );
-
- my @orgs;
- my $o = $U->storagereq(
- 'open-ils.storage.actor.org_unit.full_path.atomic', $e->requestor->ws_ou);
- push( @orgs, $_->id ) for @$o;
-
- my $fs2 = $e->$meth(
- [
- {
- shared => 't',
- share_with => \@orgs,
- owner => { '!=' => $e->requestor->id }
- },
- $flesh
- ]
- );
- push( @$fs, @$fs2);
- return $fs;
-}
-
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.folder_data.retrieve',
- method => 'retrieve_folder_data'
-);
-
-sub retrieve_folder_data {
- my( $self, $conn, $auth, $type, $folderid, $limit ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
- my $meth = "search_reporter_${type}";
- my $class = 'rr';
- $class = 'rt' if $type eq 'template';
- my $flesh = {
- flesh => 1,
- flesh_fields => { $class => ['owner']},
- order_by => { $class => 'create_time DESC'}
- };
- $flesh->{limit} = $limit if $limit;
- return $e->$meth([{ folder => $folderid }, $flesh]);
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.schedule.retrieve_by_folder',
- method => 'retrieve_schedules');
-sub retrieve_schedules {
- my( $self, $conn, $auth, $folderId, $limit, $complete ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
-
- my $search = { folder => $folderId };
- my $query = [
- { folder => $folderId },
- {
- order_by => { rs => 'run_time DESC' } ,
- flesh => 1,
- flesh_fields => { rs => ['report'] }
- }
- ];
-
- $query->[1]->{limit} = $limit if $limit;
- $query->[0]->{complete_time} = undef unless $complete;
- $query->[0]->{complete_time} = { '!=' => undef } if $complete;
-
- return $e->search_reporter_schedule($query);
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.schedule.retrieve',
- method => 'retrieve_schedules');
-sub retrieve_schedule {
- my( $self, $conn, $auth, $sched_id ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
- my $s = $e->retrieve_reporter_schedule($sched_id)
- or return $e->event;
- return $s;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.template.create',
- method => 'create_template');
-sub create_template {
- my( $self, $conn, $auth, $template ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- $template->owner($e->requestor->id);
-
- my $existing = $e->search_reporter_template( {owner=>$template->owner,
- folder=>$template->folder, name=>$template->name},{idlist=>1});
- return OpenILS::Event->new('REPORT_TEMPLATE_EXISTS') if @$existing;
-
- my $tmpl = $e->create_reporter_template($template)
- or return $e->die_event;
- $e->commit;
- return $tmpl;
-}
-
-
-
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report.create',
- method => 'create_report');
-sub create_report {
- my( $self, $conn, $auth, $report, $schedule ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- $report->owner($e->requestor->id);
-
- my $existing = $e->search_reporter_report( {owner=>$report->owner,
- folder=>$report->folder, name=>$report->name},{idlist=>1});
- return OpenILS::Event->new('REPORT_REPORT_EXISTS') if @$existing;
-
- my $rpt = $e->create_reporter_report($report)
- or return $e->die_event;
- $schedule->report($rpt->id);
- $schedule->runner($e->requestor->id);
- $e->create_reporter_schedule($schedule) or return $e->die_event;
- $e->commit;
- return $rpt;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.schedule.create',
- method => 'create_schedule');
-sub create_schedule {
- my( $self, $conn, $auth, $schedule ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $sched = $e->create_reporter_schedule($schedule)
- or return $e->die_event;
- $e->commit;
- return $sched;
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.template.retrieve',
- method => 'retrieve_template');
-sub retrieve_template {
- my( $self, $conn, $auth, $id ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
- my $t = $e->retrieve_reporter_template($id)
- or return $e->event;
- return $t;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report.retrieve',
- method => 'retrieve_report');
-sub retrieve_report {
- my( $self, $conn, $auth, $id ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
- my $r = $e->retrieve_reporter_report($id)
- or return $e->event;
- return $r;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.template.update',
- method => 'update_template');
-sub update_template {
- my( $self, $conn, $auth, $tmpl ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $t = $e->retrieve_reporter_template($tmpl->id)
- or return $e->die_event;
- return 0 if $t->owner ne $e->requestor->id;
- $e->update_reporter_template($tmpl)
- or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report.update',
- method => 'update_report');
-sub update_report {
- my( $self, $conn, $auth, $report ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $r = $e->retrieve_reporter_report($report->id)
- or return $e->die_event;
- if( $r->owner ne $e->requestor->id ) {
- $e->rollback;
- return 0;
- }
- $e->update_reporter_report($report)
- or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.schedule.update',
- method => 'update_schedule');
-sub update_schedule {
- my( $self, $conn, $auth, $schedule ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $s = $e->retrieve_reporter_schedule($schedule->id)
- or return $e->die_event;
- my $r = $e->retrieve_reporter_report($s->report)
- or return $e->die_event;
- if( $r->owner ne $e->requestor->id ) {
- $e->rollback;
- return 0;
- }
- $e->update_reporter_schedule($schedule)
- or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.folder.update',
- method => 'update_folder');
-sub update_folder {
- my( $self, $conn, $auth, $type, $folder ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $meth = "retrieve_reporter_${type}_folder";
- my $f = $e->$meth($folder->id) or return $e->die_event;
- return 0 if $f->owner ne $e->requestor->id;
- $meth = "update_reporter_${type}_folder";
- $e->$meth($folder) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.folder.delete',
- method => 'delete_folder');
-sub delete_folder {
- my( $self, $conn, $auth, $type, $folderId ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $meth = "retrieve_reporter_${type}_folder";
- my $f = $e->$meth($folderId) or return $e->die_event;
- return 0 if $f->owner ne $e->requestor->id;
- $meth = "delete_reporter_${type}_folder";
- $e->$meth($f) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.template.delete',
- method => 'delete_template');
-sub delete_template {
- my( $self, $conn, $auth, $templateId ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
-
- my $t = $e->retrieve_reporter_template($templateId)
- or return $e->die_event;
- return 0 if $t->owner ne $e->requestor->id;
- $e->delete_reporter_template($t) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.template.delete.cascade',
- method => 'cascade_delete_template');
-
-#__PACKAGE__->register_method(
-# api_name => 'open-ils.reporter.template.delete.cascade.force',
-# method => 'cascade_delete_template');
-
-sub cascade_delete_template {
- my( $self, $conn, $auth, $templateId ) = @_;
-
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
-
- my $ret = cascade_delete_template_impl(
- $e, $e->requestor->id, $templateId, ($self->api_name =~ /force/o) );
- return $ret if ref $ret; # some fatal event occurred
-
- $e->rollback if $ret == 0;
- $e->commit if $ret > 0;
- return $ret;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report.delete.cascade',
- method => 'cascade_delete_report');
-
-#__PACKAGE__->register_method(
-# api_name => 'open-ils.reporter.report.delete.cascade.force',
-# method => 'cascade_delete_report');
-
-sub cascade_delete_report {
- my( $self, $conn, $auth, $reportId ) = @_;
-
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
-
- my $ret = cascade_delete_report_impl($e, $e->requestor->id, $reportId);
- return $ret if ref $ret; # some fatal event occurred
-
- $e->rollback if $ret == 0;
- $e->commit if $ret > 0;
- return $ret;
-}
-
-
-# performs a cascading template delete
-# returns 2 if all data was deleted
-# returns 1 if some data was deleted
-# returns 0 if no data was deleted
-# returns event on error
-sub cascade_delete_template_impl {
- my( $e, $owner, $templateId ) = @_;
-
- # fetch the template to delete
- my $template = $e->search_reporter_template(
- {id=>$templateId, owner=>$owner})->[0] or return 0;
-
- # fetch he attached report IDs for this owner
- my $reports = $e->search_reporter_report(
- {template=>$templateId, owner=>$owner},{idlist=>1});
-
- # delete the attached reports
- my $all_rpts_deleted = 1;
- for my $r (@$reports) {
- my $evt = cascade_delete_report_impl($e, $owner, $r);
- return $evt if ref $evt;
- $all_rpts_deleted = 0 unless $evt == 2;
- }
-
- # fetch all reports attached to this template that
- # do not belong to $owner. If there are any, we can't
- # delete the template
- my $alt_reports = $e->search_reporter_report(
- {template=>$templateId, owner=>{"!=" => $owner}},{idlist=>1});
-
- # all_rpts_deleted will be false if a report has an
- # attached scheduled owned by a different user
- return 1 if @$alt_reports or not $all_rpts_deleted;
-
- $e->delete_reporter_template($template)
- or return $e->die_event;
- return 2;
-}
-
-# performs a cascading report delete
-# returns 2 if all data was deleted
-# returns 1 if some data was deleted
-# returns 0 if no data was deleted
-# returns event on error
-sub cascade_delete_report_impl {
- my( $e, $owner, $reportId ) = @_;
-
- # fetch the report to delete
- my $report = $e->search_reporter_report(
- {id=>$reportId, owner=>$owner})->[0] or return 0;
-
- # fetch the attached schedule IDs for this owner
- my $scheds = $e->search_reporter_schedule(
- {report=>$reportId, runner=>$owner},{idlist=>1});
-
- # delete the attached schedules
- for my $sched (@$scheds) {
- my $evt = delete_schedule_impl($e, $sched);
- return $evt if $evt;
- }
-
- # fetch all schedules attached to this report that
- # do not belong to $owner. If there are any, we can't
- # delete the report
- my $alt_scheds = $e->search_reporter_schedule(
- {report=>$reportId, runner=>{"!=" => $owner}},{idlist=>1});
-
- return 1 if @$alt_scheds;
-
- $e->delete_reporter_report($report)
- or return $e->die_event;
-
- return 2;
-}
-
-
-# deletes the requested schedule
-# returns undef on success, event on error
-sub delete_schedule_impl {
- my( $e, $schedId ) = @_;
- my $s = $e->retrieve_reporter_schedule($schedId)
- or return $e->die_event;
- $e->delete_reporter_schedule($s) or return $e->die_event;
- return undef;
-}
-
-
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report.delete',
- method => 'delete_report');
-sub delete_report {
- my( $self, $conn, $auth, $reportId ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
-
- my $t = $e->retrieve_reporter_report($reportId)
- or return $e->die_event;
- return 0 if $t->owner ne $e->requestor->id;
- $e->delete_reporter_report($t) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.schedule.delete',
- method => 'delete_schedule');
-sub delete_schedule {
- my( $self, $conn, $auth, $scheduleId ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
-
- my $t = $e->retrieve_reporter_schedule($scheduleId)
- or return $e->die_event;
- return 0 if $t->runner ne $e->requestor->id;
- $e->delete_reporter_schedule($t) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.template_has_reports',
- method => 'has_reports');
-sub has_reports {
- my( $self, $conn, $auth, $templateId ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $rpts = $e->search_reporter_report({template=>$templateId},{idlist=>1});
- return 1 if @$rpts;
- return 0;
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.reporter.report_has_output',
- method => 'has_output');
-sub has_output {
- my( $self, $conn, $auth, $reportId ) = @_;
- my $e = new_rstore_editor(authtoken=>$auth);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('RUN_REPORTS');
- my $outs = $e->search_reporter_schedule({report=>$reportId},{idlist=>1});
- return 1 if @$outs;
- return 0;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'org_full_path',
- api_name => 'open-ils.reporter.org_unit.full_path');
-
-sub org_full_path {
- my( $self, $conn, $orgid ) = @_;
- return $U->storagereq(
- 'open-ils.storage.actor.org_unit.full_path.atomic', $orgid );
-}
-
-
-
-
-__PACKAGE__->register_method(
- method => 'magic_fetch_all',
- api_name => 'open-ils.reporter.magic_fetch');
-sub magic_fetch_all {
- my( $self, $conn, $auth, $args ) = @_;
- my $e = new_editor(authtoken => $auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('RUN_REPORTS');
-
- my $hint = $$args{hint};
- my $org_col = $$args{org_column};
- my $orgs = $$args{org};
-
-# if ($orgs && !$$args{no_fetch}) {
-# ($orgs) = $self
-# ->method_lookup( 'open-ils.reporter.org_unit.full_path' )
-# ->run( @$orgs );
-# $orgs = [ map {$_->id} @$orgs ];
-# }
-
- # Find the class the iplements the given hint
- my ($class) = grep {
- $Fieldmapper::fieldmap->{$_}{hint} eq $hint } Fieldmapper->classes;
-
- return undef unless $class->Selector;
-
- $class =~ s/Fieldmapper:://og;
- $class =~ s/::/_/og;
-
- my $method;
- my $margs;
-
- if( $org_col ) {
- $method = "search_$class";
- $margs = { $org_col => $orgs };
- } else {
- $method = "retrieve_all_$class";
- }
-
- $logger->info("reporter.magic_fetch => $method");
-
- return $e->$method($margs);
-}
-
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-# Copyright (C) 2009-2010 Dan Scott <dscott@laurentian.ca>
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-
-=head1 NAME
-
-OpenILS::Application::ResolverResolver - retrieves holdings from OpenURL resolvers
-
-=head1 SYNOPSIS
-
-Via srfsh:
- request open-ils.resolver open-ils.resolver.resolve_holdings "issn", "0022-362X"
-or:
- request open-ils.resolver open-ils.resolver.resolve_holdings.raw "issn", "0022-362X"
-
-Via Perl:
- my $session = OpenSRF::AppSession->create("open-ils.resolver");
- my $request = $session->request("open-ils.resolver.resolve_holdings", [ "issn", "0022-362X" ] )->gather();
- $session->disconnect();
-
- # $request is a reference to the list of hashes
-
-=head1 DESCRIPTION
-
-OpenILS::Application::ResolverResolver caches responses from OpenURL resolvers
-to requests for full-text holdings. Currently integration with SFX is supported.
-
-Each org_unit can specify a different base URL as the third argument to
-resolve_holdings(). Eventually org_units will have org_unit settings to hold
-their resolver type and base URL.
-
-=head1 AUTHOR
-
-Dan Scott, dscott@laurentian.ca
-
-=cut
-
-package OpenILS::Application::ResolverResolver;
-
-use strict;
-use warnings;
-use LWP::UserAgent;
-use XML::LibXML;
-
-# All OpenSRF applications must be based on OpenSRF::Application or
-# a subclass thereof. Makes sense, eh?
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-# This is the client class, used for connecting to open-ils.storage
-use OpenSRF::AppSession;
-
-# This is an extension of Error.pm that supplies some error types to throw
-use OpenSRF::EX qw(:try);
-
-# This is a helper class for querying the OpenSRF Settings application ...
-use OpenSRF::Utils::SettingsClient;
-
-# ... and here we have the built in logging helper ...
-use OpenSRF::Utils::Logger qw($logger);
-
-# ... and this manages cached results for us ...
-use OpenSRF::Utils::Cache;
-
-# ... and this gives us access to the Fieldmapper
-use OpenILS::Utils::Fieldmapper;
-
-my $prefix = "open-ils.resolver_"; # Prefix for caching values
-my $cache;
-my $cache_timeout;
-my $default_url_base; # Default resolver location
-
-our ($ua, $parser);
-
-
-sub initialize {
- $cache = OpenSRF::Utils::Cache->new('global');
- my $sclient = OpenSRF::Utils::SettingsClient->new();
- $cache_timeout = $sclient->config_value(
- "apps", "open-ils.resolver", "app_settings", "cache_timeout" ) || 300;
- $default_url_base = $sclient->config_value(
- "apps", "open-ils.resolver", "app_settings", "default_url_base");
-}
-
-sub child_init {
- # We need a User Agent to speak to the SFX beast
- $ua = new LWP::UserAgent;
- $ua->agent('SameOrigin/1.0');
-
- # SFX returns XML to us; let us parse
- $parser = new XML::LibXML;
-}
-
-sub resolve_holdings {
- my $self = shift;
- my $conn = shift;
- my $id_type = shift; # keep it simple for now, either 'issn' or 'isbn'
- my $id_value = shift; # the normalized ISSN or ISBN
- my $url_base = shift || $default_url_base;
-
- # We'll use this in our cache key
- my $method = $self->api_name;
-
- # We might want to return raw JSON for speedier responses
- my $format = 'fieldmapper';
- if ($self->api_name =~ /raw$/) {
- $format = 'raw';
- }
-
- # Big ugly SFX OpenURL request
- my $url_args = '?url_ver=Z39.88-2004&url_ctx_fmt=infofi/fmt:kev:mtx:ctx&'
- . 'ctx_enc=UTF-8&ctx_ver=Z39.88-2004&rfr_id=info:sid/conifer&'
- . 'sfx.ignore_date_threshold=1&'
- . 'sfx.response_type=multi_obj_detailed_xml&__service_type=getFullTxt';
-
- if ($id_type eq 'issn') {
- $url_args .= "&rft.issn=$id_value";
- } elsif ($id_type eq 'isbn') {
- $url_args .= "&rft.isbn=$id_value";
- }
-
- my $ckey = $prefix . $method . $url_base . $id_type . $id_value;
-
- # Check the cache to see if we've already looked this up
- # If we have, shortcut our return value
- my $result = $cache->get_cache($ckey) || undef;
- if ($result) {
- $logger->info("Resolver found a cache hit");
- return $result;
- }
-
- # Otherwise, let's go and grab the info from the SFX server
- my $req = HTTP::Request->new('GET', "$url_base$url_args");
-
- # Let's see what we we're trying to request
- $logger->info("Resolving the following request: $url_base$url_args");
-
- my $res = $ua->request($req);
-
- my $xml = $res->content;
- my $parsed_sfx = $parser->parse_string($xml);
-
- my (@targets) = $parsed_sfx->findnodes('//target');
-
- my @sfx_result;
- foreach my $target (@targets) {
- if ($format eq 'raw') {
- push @sfx_result, {
- public_name => $target->findvalue('./target_public_name'),
- target_url => $target->findvalue('.//target_url'),
- target_coverage => $target->findvalue('.//coverage_statement'),
- target_embargo => $target->findvalue('.//embargo_statement'),
- };
- } else {
- my $rhr = Fieldmapper::resolver::holdings_record->new;
- $rhr->public_name($target->findvalue('./target_public_name'));
- $rhr->target_url($target->findvalue('.//target_url'));
- $rhr->target_coverage($target->findvalue('.//coverage_statement'));
- $rhr->target_embargo($target->findvalue('.//embargo_statement'));
- push @sfx_result, $rhr;
- }
- }
-
- # Stuff this into the cache
- $cache->put_cache($ckey, \@sfx_result, $cache_timeout);
-
- # Don't return the list unless it contains results
- if (scalar(@sfx_result)) {
- return \@sfx_result;
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'resolve_holdings',
- api_name => 'open-ils.resolver.resolve_holdings',
- api_level => 1,
- argc => 3,
- signature => {
- desc => <<" DESC",
-Returns a list of "rhr" objects representing the full-text holdings for a given ISBN or ISSN
- DESC
- 'params' => [ {
- name => 'id_type',
- desc => 'The type of identifier ("issn" or "isbn")',
- type => 'string'
- }, {
- name => 'id_value',
- desc => 'The identifier value',
- type => 'string'
- }, {
- name => 'url_base',
- desc => 'The base URL for the resolver and instance',
- type => 'string'
- },
- ],
- 'return' => {
- desc => 'Returns a list of "rhr" objects representing the full-text holdings for a given ISBN or ISSN',
- type => 'array'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'resolve_holdings',
- api_name => 'open-ils.resolver.resolve_holdings.raw',
- api_level => 1,
- argc => 3,
- signature => {
- desc => <<" DESC",
-Returns a list of raw JSON objects representing the full-text holdings for a given ISBN or ISSN
- DESC
- 'params' => [ {
- name => 'id_type',
- desc => 'The type of identifier ("issn" or "isbn")',
- type => 'string'
- }, {
- name => 'id_value',
- desc => 'The identifier value',
- type => 'string'
- }, {
- name => 'url_base',
- desc => 'The base URL for the resolver and instance',
- type => 'string'
- },
- ],
- 'return' => {
- desc => 'Returns a list of raw JSON objects representing the full-text holdings for a given ISBN or ISSN',
- type => 'array'
- }
- }
-);
-
-# Clear cache for specific lookups
-sub delete_cached_holdings {
- my $self = shift;
- my $conn = shift;
- my $id_type = shift; # keep it simple for now, either 'issn' or 'isbn'
- my $id_value = shift; # the normalized ISSN or ISBN
- my $url_base = shift || $default_url_base;
- my @deleted_keys;
-
- $logger->warn("Deleting value [$id_value]");
- # We'll use this in our cache key
- foreach my $method ('open-ils.resolver.resolve_holdings.raw', 'open-ils.resolver.resolve_holdings') {
- my $ckey = $prefix . $method . $url_base . $id_type . $id_value;
-
- $logger->warn("Deleted cache key [$ckey]");
- my $result = $cache->delete_cache($ckey);
-
- $logger->warn("Result of deleting cache key: [$result]");
- push @deleted_keys, $result;
- }
-
- return \@deleted_keys;
-}
-
-__PACKAGE__->register_method(
- method => 'delete_holdings_cache',
- api_name => 'open-ils.resolver.delete_cached_holdings',
- api_level => 1,
- argc => 3,
- signature => {
- desc => <<" DESC",
-Deletes the cached value of the full-text holdings for a given ISBN or ISSN
- DESC
- 'params' => [ {
- name => 'id_type',
- desc => 'The type of identifier ("issn" or "isbn")',
- type => 'string'
- }, {
- name => 'id_value',
- desc => 'The identifier value',
- type => 'string'
- }, {
- name => 'url_base',
- desc => 'The base URL for the resolver and instance',
- type => 'string'
- },
- ],
- 'return' => {
- desc => 'Deletes the cached value of the full-text holdings for a given ISBN or ISSN',
- type => 'array'
- }
- }
-);
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Search;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw(:logger);
-
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::ModsParser;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Cache;
-
-use OpenILS::Application::Search::Biblio;
-use OpenILS::Application::Search::Authority;
-use OpenILS::Application::Search::Z3950;
-use OpenILS::Application::Search::Zips;
-use OpenILS::Application::Search::CNBrowse;
-use OpenILS::Application::Search::Serial;
-
-
-use OpenILS::Application::AppUtils;
-
-use Time::HiRes qw(time);
-use OpenSRF::EX qw(:try);
-
-use Text::Aspell;
-
-# Houses generic search utilites
-
-sub initialize {
- OpenILS::Application::Search::Z3950->initialize();
- OpenILS::Application::Search::Zips->initialize();
- OpenILS::Application::Search::Biblio->initialize();
-}
-
-sub child_init {
- OpenILS::Application::Search::Z3950->child_init;
-}
-
-
-
-# ------------------------------------------------------------------
-# Create custom dictionaries like so:
-# aspell --lang=en create master ./oils_authority.dict < /tmp/words
-# where /tmp/words is a space separated list of words
-# ------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => "spellcheck",
- api_name => "open-ils.search.spellcheck",
- signature => {
- desc => 'Returns alternate spelling suggestions',
- param => [
- {
- name => 'phrase',
- desc => 'Word or phrase to return alternate spelling suggestions for',
- type => 'string'
- },
- {
- name => 'Dictionary class',
- desc => 'Alternate configured dictionary to use (optional)',
- type => 'string'
- },
- ],
- return => {
- desc => 'Array with a suggestions hash for each word in the phrase, like: '
- . q# [{ word: original_word, suggestions: [sug1, sug2, ...], found: 1 }, ... ] #
- . 'The "found" value will be 1 if the word was found in the dictionary, 0 otherwise.',
- type => 'array',
- }
- }
-);
-
-my $speller = Text::Aspell->new();
-
-sub spellcheck {
- my( $self, $client, $phrase, $class ) = @_;
-
- return [] unless $phrase; # nothing to check, abort.
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- $class ||= 'default';
-
- my @conf_path = (apps => 'open-ils.search' => app_settings => spelling_dictionary => $class);
-
- if( my $dict = $conf->config_value(@conf_path) ) {
- $speller->set_option('master', $dict);
- $logger->debug("spelling dictionary set to $dict");
- }
-
- my @resp;
-
- for my $word (split(/\s+/,$phrase) ) {
-
- my @suggestions = $speller->suggest($word);
- my @trimmed;
-
- for my $sug (@suggestions) {
-
- # suggestion matches alternate case of original word
- next if lc($sug) eq lc($word);
-
- # suggestion matches alternate case of already suggested word
- next if grep { lc($sug) eq lc($_) } @trimmed;
-
- push(@trimmed, $sug);
- }
-
- push( @resp,
- {
- word => $word,
- suggestions => (@trimmed) ? [@trimmed] : undef,
- found => $speller->check($word)
- }
- );
- }
- return \@resp;
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Search::AddedContent;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-sub initialize { return 1; }
-
-
-__PACKAGE__->register_method(
- method => "summary",
- api_name => "open-ils.search.added_content.summary.retrieve",
- notes => <<" NOTE");
- Returns an object like so:
- {
- Review : true/false
- Inventory : true/false
- Annotation : true/false
- Jacket : true/false
- TOC : true/false
- Product : true/false
- }
- This object indicates the existance of each type of added content for the given ISBN
- PARAMS( ISBN ),
- NOTE
-
-sub summary {
- return {
- Review => "false",
- Inventory => "false",
- Annotation => "false",
- Jacket => "false",
- TOC => "false",
- Product => "false",
- };
-}
-
-
-__PACKAGE__->register_method(
- method => "reviews",
- api_name => "open-ils.search.added_content.review.retrieve.random",
- notes => <<" NOTE");
- Returns a singe random review article object
- PARAMS( ISBN ),
- NOTE
-
-__PACKAGE__->register_method(
- method => "reviews",
- api_name => "open-ils.search.added_content.review.retrieve.all",
- notes => <<" NOTE");
- Returns an array review article objects
- PARAMS( ISBN ),
- NOTE
-
-sub reviews { return []; }
-
-
-__PACKAGE__->register_method(
- method => "toc",
- api_name => "open-ils.search.added_content.toc.retrieve",
- notes => <<" NOTE");
- Returns the table of contents for the given ISBN
- PARAMS( ISBN ),
- NOTE
-
-sub toc { return ""; }
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Search::Authority;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Application::AppUtils;
-use XML::LibXML;
-use XML::LibXSLT;
-use OpenILS::Utils::Editor q/:funcs/;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use OpenSRF::Utils::JSON;
-
-use Time::HiRes qw(time);
-use OpenSRF::EX qw(:try);
-use Digest::MD5 qw(md5_hex);
-
-my $cache;
-
-
-sub validate_authority {
- my $self = shift;
- my $client = shift;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- return $session->request( 'open-ils.storage.authority.validate.tag' => @_ )->gather(1);
-}
-__PACKAGE__->register_method(
- method => "validate_authority",
- api_name => "open-ils.search.authority.validate.tag",
- argc => 4,
- note => "Validates authority data from existing controlled terms",
-);
-
-sub validate_authority_return_records_by_id {
- my $self = shift;
- my $client = shift;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- return $session->request( 'open-ils.storage.authority.validate.tag.id_list' => @_ )->gather(1);
-}
-__PACKAGE__->register_method(
- method => "validate_authority_return_records_by_id",
- api_name => "open-ils.search.authority.validate.tag.id_list",
- argc => 4,
- note => "Validates authority data from existing controlled terms",
-);
-
-sub search_authority {
- my $self = shift;
- my $client = shift;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
- return $session->request( 'open-ils.storage.authority.search.marc.atomic' => @_ )->gather(1);
-}
-__PACKAGE__->register_method(
- method => "search_authority",
- api_name => "open-ils.search.authority.fts",
- argc => 2,
- note => "Searches authority data for existing controlled terms and crossrefs",
-);
-
-
-sub crossref_authority {
- my $self = shift;
- my $client = shift;
- my $class = shift;
- my $term = shift;
- my $limit = shift || 10;
-
- my $session = OpenSRF::AppSession->create("open-ils.storage");
-
- # Avoid generating spurious errors for more granular indexes, like author|personal
- $class =~ s/^(.*?)\|.*?$/$1/;
-
- $logger->info("authority xref search for $class=$term, limit=$limit");
- my $fr = $session->request(
- "open-ils.storage.authority.$class.see_from.controlled.atomic",$term, $limit)->gather(1);
- my $al = $session->request(
- "open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, $limit)->gather(1);
-
- my $data = _auth_flatten( $term, $fr, $al, 1 );
-
- return $data;
-}
-
-sub _auth_flatten {
- my $term = shift;
- my $fr = shift;
- my $al = shift;
- my $limit = shift;
-
- my %hash = ();
- for my $x (@$fr) {
- my $string = $$x[0];
- for my $i (1..10) {
- last unless ($$x[$i]);
- if ($string =~ /\W$/o) {
- $string .= ' '.$$x[$i];
- } else {
- $string .= ' -- '.$$x[$i];
- }
- }
- next if (lc($string) eq lc($term));
- $hash{$string}++;
- $hash{$string}++ if (lc($$x[0]) eq lc($term));
- }
- my $from = [keys %hash]; #[ sort { $hash{$b} <=> $hash{$a} || $a cmp $b } keys %hash ];
-
-# $from = [ @$from[0..4] ] if $limit;
-
- %hash = ();
- for my $x (@$al) {
- my $string = $$x[0];
- for my $i (1..10) {
- last unless ($$x[$i]);
- if ($string =~ /\W$/o) {
- $string .= ' '.$$x[$i];
- } else {
- $string .= ' -- '.$$x[$i];
- }
- }
- next if (lc($string) eq lc($term));
- $hash{$string}++;
- $hash{$string}++ if (lc($$x[0]) eq lc($term));
- }
- my $also = [keys %hash]; #[ sort { $hash{$b} <=> $hash{$a} || $a cmp $b } keys %hash ];
-
-# $also = [ @$also[0..4] ] if $limit;
-
- #warn Dumper( { from => $from, also => $also } );
-
- return { from => $from, also => $also };
-}
-
-__PACKAGE__->register_method(
- method => "crossref_authority",
- api_name => "open-ils.search.authority.crossref",
- argc => 2,
- note => "Searches authority data for existing controlled terms and crossrefs",
-);
-
-__PACKAGE__->register_method(
- #method => "new_crossref_authority_batch",
- method => "crossref_authority_batch2",
- api_name => "open-ils.search.authority.crossref.batch",
- argc => 1,
- note => <<" NOTE");
- Takes an array of class,term pair sub-arrays and performs an authority lookup for each
-
- PARAMS( [ ["subject", "earth"], ["author","shakespeare"] ] );
-
- Returns an object like so:
- {
- "classname" : {
- "term" : { "from" : [ ...], "also" : [...] }
- "term2" : { "from" : [ ...], "also" : [...] }
- }
- }
- NOTE
-
-sub new_crossref_authority_batch {
- my( $self, $client, $reqs ) = @_;
-
- my $response = {};
- my $lastr = [];
- my $session = OpenSRF::AppSession->create("open-ils.storage");
-
- for my $req (@$reqs) {
-
- my $class = $req->[0];
- my $term = $req->[1];
- next unless $class and $term;
- $logger->info("Sending authority request for $class : $term");
- my $fr = $session->request("open-ils.storage.authority.$class.see_from.controlled.atomic",$term, 10)->gather(1);
- my $al = $session->request("open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, 10)->gather(1);
-
- $response->{$class} = {} unless exists $response->{$class};
- $response->{$class}->{$term} = _auth_flatten( $term, $fr, $al, 1 );
-
- }
-
- #warn Dumper( $response );
- return $response;
-}
-
-sub crossref_authority_batch {
- my( $self, $client, $reqs ) = @_;
-
- my $response = {};
- my $lastr = [];
- my $session = OpenSRF::AppSession->create("open-ils.storage");
-
- for my $req (@$reqs) {
-
- my $class = $req->[0];
- my $term = $req->[1];
- next unless $class and $term;
- $logger->info("Sending authority request for $class : $term");
- my $freq = $session->request("open-ils.storage.authority.$class.see_from.controlled.atomic",$term, 10);
- my $areq = $session->request("open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, 10);
-
- if( $lastr->[0] ) { #process old data while waiting on new data
- my $cls = $lastr->[0];
- my $trm = $lastr->[1];
- my $fr = $lastr->[2];
- my $al = $lastr->[3];
- $response->{$cls} = {} unless exists $response->{$cls};
- $response->{$cls}->{$trm} = _auth_flatten( $trm, $fr, $al, 1 );
- }
-
- $lastr->[0] = $class;
- $lastr->[1] = $term;
- $lastr->[2] = $freq->gather(1);
- $lastr->[3] = $areq->gather(1);
- }
-
- if( $lastr->[0] ) { #process old data while waiting on new data
- my $cls = $lastr->[0];
- my $trm = $lastr->[1];
- my $fr = $lastr->[2];
- my $al = $lastr->[3];
- $response->{$cls} = {} unless exists $response->{$cls};
- $response->{$cls}->{$trm} = _auth_flatten( $trm, $fr, $al, 1);
- }
-
- return $response;
-}
-
-
-
-
-sub crossref_authority_batch2 {
- my( $self, $client, $reqs ) = @_;
-
- my $response = {};
- my $lastr = [];
- my $session = OpenSRF::AppSession->create("open-ils.storage");
-
- $cache = OpenSRF::Utils::Cache->new('global') unless $cache;
-
- for my $req (@$reqs) {
-
- my $class = $req->[0];
- my $term = $req->[1];
- next unless $class and $term;
-
- my $t = $term;
- $t =~ s/\s//og;
- my $cdata = $cache->get_cache("oils_authority_${class}_$t");
-
- if( $cdata ) {
- $logger->debug("returning authority response from cache..");
- $response->{$class} = {} unless exists $response->{$class};
- $response->{$class}->{$term} = $cdata;
- next;
- }
-
- $logger->debug("authority data not found in cache.. fetching from storage");
-
- $logger->info("Sending authority request for $class : $term");
- my $freq = $session->request("open-ils.storage.authority.$class.see_from.controlled.atomic",$term, 10);
- my $areq = $session->request("open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, 10);
- my $fr = $freq->gather(1);
- my $al = $areq->gather(1);
- $response->{$class} = {} unless exists $response->{$class};
- my $auth = _auth_flatten( $term, $fr, $al, 1 );
-
- my $timeout = 7200; #two hours
- $timeout = 300 if @{$auth->{from}} or @{$auth->{also}}; # 5 minutes
- $response->{$class}->{$term} = $auth;
- $logger->debug("adding authority lookup to cache with timeout $timeout");
- $cache->put_cache("oils_authority_${class}_$t", $auth, $timeout);
- }
- return $response;
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Search::Biblio;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-
-use OpenSRF::Utils::JSON;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::ModsParser;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Cache;
-use Encode;
-
-use OpenSRF::Utils::Logger qw/:logger/;
-
-
-use OpenSRF::Utils::JSON;
-
-use Time::HiRes qw(time);
-use OpenSRF::EX qw(:try);
-use Digest::MD5 qw(md5_hex);
-
-use XML::LibXML;
-use XML::LibXSLT;
-
-use Data::Dumper;
-$Data::Dumper::Indent = 0;
-
-use OpenILS::Const qw/:const/;
-
-use OpenILS::Application::AppUtils;
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-
-my $pfx = "open-ils.search_";
-
-my $cache;
-my $cache_timeout;
-my $superpage_size;
-my $max_superpages;
-
-sub initialize {
- $cache = OpenSRF::Utils::Cache->new('global');
- my $sclient = OpenSRF::Utils::SettingsClient->new();
- $cache_timeout = $sclient->config_value(
- "apps", "open-ils.search", "app_settings", "cache_timeout" ) || 300;
-
- $superpage_size = $sclient->config_value(
- "apps", "open-ils.search", "app_settings", "superpage_size" ) || 500;
-
- $max_superpages = $sclient->config_value(
- "apps", "open-ils.search", "app_settings", "max_superpages" ) || 20;
-
- $logger->info("Search cache timeout is $cache_timeout, ".
- " superpage_size is $superpage_size, max_superpages is $max_superpages");
-}
-
-
-
-# ---------------------------------------------------------------------------
-# takes a list of record id's and turns the docs into friendly
-# mods structures. Creates one MODS structure for each doc id.
-# ---------------------------------------------------------------------------
-sub _records_to_mods {
- my @ids = @_;
-
- my @results;
- my @marcxml_objs;
-
- my $session = OpenSRF::AppSession->create("open-ils.cstore");
- my $request = $session->request(
- "open-ils.cstore.direct.biblio.record_entry.search", { id => \@ids } );
-
- while( my $resp = $request->recv ) {
- my $content = $resp->content;
- next if $content->id == OILS_PRECAT_RECORD;
- my $u = OpenILS::Utils::ModsParser->new(); # FIXME: we really need a new parser for each object?
- $u->start_mods_batch( $content->marc );
- my $mods = $u->finish_mods_batch();
- $mods->doc_id($content->id());
- $mods->tcn($content->tcn_value);
- push @results, $mods;
- }
-
- $session->disconnect();
- return \@results;
-}
-
-__PACKAGE__->register_method(
- method => "record_id_to_mods",
- api_name => "open-ils.search.biblio.record.mods.retrieve",
- argc => 1,
- signature => {
- desc => "Provide ID, we provide the MODS object with copy count. "
- . "Note: this method does NOT take an array of IDs like mods_slim.retrieve", # FIXME: do it here too
- params => [
- { desc => 'Record ID', type => 'number' }
- ],
- return => {
- desc => 'MODS object', type => 'object'
- }
- }
-);
-
-# converts a record into a mods object with copy counts attached
-sub record_id_to_mods {
-
- my( $self, $client, $org_id, $id ) = @_;
-
- my $mods_list = _records_to_mods( $id );
- my $mods_obj = $mods_list->[0];
- my $cmethod = $self->method_lookup("open-ils.search.biblio.record.copy_count");
- my ($count) = $cmethod->run($org_id, $id);
- $mods_obj->copy_count($count);
-
- return $mods_obj;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "record_id_to_mods_slim",
- api_name => "open-ils.search.biblio.record.mods_slim.retrieve",
- argc => 1,
- authoritative => 1,
- signature => {
- desc => "Provide ID(s), we provide the MODS",
- params => [
- { desc => 'Record ID or array of IDs' }
- ],
- return => {
- desc => 'MODS object(s), event on error'
- }
- }
-);
-
-# converts a record into a mods object with NO copy counts attached
-sub record_id_to_mods_slim {
- my( $self, $client, $id ) = @_;
- return undef unless defined $id;
-
- if(ref($id) and ref($id) == 'ARRAY') {
- return _records_to_mods( @$id );
- }
- my $mods_list = _records_to_mods( $id );
- my $mods_obj = $mods_list->[0];
- return OpenILS::Event->new('BIBLIO_RECORD_ENTRY_NOT_FOUND') unless $mods_obj;
- return $mods_obj;
-}
-
-
-
-__PACKAGE__->register_method(
- method => "record_id_to_mods_slim_batch",
- api_name => "open-ils.search.biblio.record.mods_slim.batch.retrieve",
- stream => 1
-);
-sub record_id_to_mods_slim_batch {
- my($self, $conn, $id_list) = @_;
- $conn->respond(_records_to_mods($_)->[0]) for @$id_list;
- return undef;
-}
-
-
-# Returns the number of copies attached to a record based on org location
-__PACKAGE__->register_method(
- method => "record_id_to_copy_count",
- api_name => "open-ils.search.biblio.record.copy_count",
- signature => {
- desc => q/Returns a copy summary for the given record for the context org
- unit and all ancestor org units/,
- params => [
- {desc => 'Context org unit id', type => 'number'},
- {desc => 'Record ID', type => 'number'}
- ],
- return => {
- desc => q/summary object per org unit in the set, where the set
- includes the context org unit and all parent org units.
- Object includes the keys "transcendant", "count", "org_unit", "depth",
- "unshadow", "available". Each is a count, except "org_unit" which is
- the context org unit and "depth" which is the depth of the context org unit
- /,
- type => 'array'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "record_id_to_copy_count",
- api_name => "open-ils.search.biblio.record.copy_count.staff",
- authoritative => 1,
- signature => {
- desc => q/Returns a copy summary for the given record for the context org
- unit and all ancestor org units/,
- params => [
- {desc => 'Context org unit id', type => 'number'},
- {desc => 'Record ID', type => 'number'}
- ],
- return => {
- desc => q/summary object per org unit in the set, where the set
- includes the context org unit and all parent org units.
- Object includes the keys "transcendant", "count", "org_unit", "depth",
- "unshadow", "available". Each is a count, except "org_unit" which is
- the context org unit and "depth" which is the depth of the context org unit
- /,
- type => 'array'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "record_id_to_copy_count",
- api_name => "open-ils.search.biblio.metarecord.copy_count",
- signature => {
- desc => q/Returns a copy summary for the given record for the context org
- unit and all ancestor org units/,
- params => [
- {desc => 'Context org unit id', type => 'number'},
- {desc => 'Record ID', type => 'number'}
- ],
- return => {
- desc => q/summary object per org unit in the set, where the set
- includes the context org unit and all parent org units.
- Object includes the keys "transcendant", "count", "org_unit", "depth",
- "unshadow", "available". Each is a count, except "org_unit" which is
- the context org unit and "depth" which is the depth of the context org unit
- /,
- type => 'array'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => "record_id_to_copy_count",
- api_name => "open-ils.search.biblio.metarecord.copy_count.staff",
- signature => {
- desc => q/Returns a copy summary for the given record for the context org
- unit and all ancestor org units/,
- params => [
- {desc => 'Context org unit id', type => 'number'},
- {desc => 'Record ID', type => 'number'}
- ],
- return => {
- desc => q/summary object per org unit in the set, where the set
- includes the context org unit and all parent org units.
- Object includes the keys "transcendant", "count", "org_unit", "depth",
- "unshadow", "available". Each is a count, except "org_unit" which is
- the context org unit and "depth" which is the depth of the context org
- unit. "depth" is always -1 when the count from a lasso search is
- performed, since depth doesn't mean anything in a lasso context.
- /,
- type => 'array'
- }
- }
-);
-
-sub record_id_to_copy_count {
- my( $self, $client, $org_id, $record_id ) = @_;
-
- return [] unless $record_id;
-
- my $key = $self->api_name =~ /metarecord/ ? 'metarecord' : 'record';
- my $staff = $self->api_name =~ /staff/ ? 't' : 'f';
-
- my $data = $U->cstorereq(
- "open-ils.cstore.json_query.atomic",
- { from => ['asset.' . $key . '_copy_count' => $org_id => $record_id => $staff] }
- );
-
- my @count;
- for my $d ( @$data ) { # fix up the key name change required by stored-proc version
- $$d{count} = delete $$d{visible};
- push @count, $d;
- }
-
- return [ sort { $a->{depth} <=> $b->{depth} } @count ];
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_search_tcn",
- api_name => "open-ils.search.biblio.tcn",
- argc => 1,
- signature => {
- desc => "Retrieve related record ID(s) given a TCN",
- params => [
- { desc => 'TCN', type => 'string' },
- { desc => 'Flag indicating to include deleted records', type => 'string' }
- ],
- return => {
- desc => 'Results object like: { "count": $i, "ids": [...] }',
- type => 'object'
- }
- }
-
-);
-
-sub biblio_search_tcn {
-
- my( $self, $client, $tcn, $include_deleted ) = @_;
-
- $tcn =~ s/^\s+|\s+$//og;
-
- my $e = new_editor();
- my $search = {tcn_value => $tcn};
- $search->{deleted} = 'f' unless $include_deleted;
- my $recs = $e->search_biblio_record_entry( $search, {idlist =>1} );
-
- return { count => scalar(@$recs), ids => $recs };
-}
-
-
-# --------------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => "biblio_barcode_to_copy",
- api_name => "open-ils.search.asset.copy.find_by_barcode",
-);
-sub biblio_barcode_to_copy {
- my( $self, $client, $barcode ) = @_;
- my( $copy, $evt ) = $U->fetch_copy_by_barcode($barcode);
- return $evt if $evt;
- return $copy;
-}
-
-__PACKAGE__->register_method(
- method => "biblio_id_to_copy",
- api_name => "open-ils.search.asset.copy.batch.retrieve",
-);
-sub biblio_id_to_copy {
- my( $self, $client, $ids ) = @_;
- $logger->info("Fetching copies @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.asset.copy.search.atomic", { id => $ids } );
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_id_to_uris",
- api_name=> "open-ils.search.asset.uri.retrieve_by_bib",
- argc => 2,
- stream => 1,
- signature => q#
- @param BibID Which bib record contains the URIs
- @param OrgID Where to look for URIs
- @param OrgDepth Range adjustment for OrgID
- @return A stream or list of 'auri' objects
- #
-
-);
-sub biblio_id_to_uris {
- my( $self, $client, $bib, $org, $depth ) = @_;
- die "Org ID required" unless defined($org);
- die "Bib ID required" unless defined($bib);
-
- my @params;
- push @params, $depth if (defined $depth);
-
- my $ids = $U->cstorereq( "open-ils.cstore.json_query.atomic",
- { select => { auri => [ 'id' ] },
- from => {
- acn => {
- auricnm => {
- field => 'call_number',
- fkey => 'id',
- join => {
- auri => {
- field => 'id',
- fkey => 'uri',
- filter => { active => 't' }
- }
- }
- }
- }
- },
- where => {
- '+acn' => {
- record => $bib,
- owning_lib => {
- in => {
- select => { aou => [ { column => 'id', transform => 'actor.org_unit_descendants', params => \@params, result_field => 'id' } ] },
- from => 'aou',
- where => { id => $org },
- distinct=> 1
- }
- }
- }
- },
- distinct=> 1,
- }
- );
-
- my $uris = $U->cstorereq(
- "open-ils.cstore.direct.asset.uri.search.atomic",
- { id => [ map { (values %$_) } @$ids ] }
- );
-
- $client->respond($_) for (@$uris);
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "copy_retrieve",
- api_name => "open-ils.search.asset.copy.retrieve",
- argc => 1,
- signature => {
- desc => 'Retrieve a copy object based on the Copy ID',
- params => [
- { desc => 'Copy ID', type => 'number'}
- ],
- return => {
- desc => 'Copy object, event on error'
- }
- }
-);
-
-sub copy_retrieve {
- my( $self, $client, $cid ) = @_;
- my( $copy, $evt ) = $U->fetch_copy($cid);
- return $evt || $copy;
-}
-
-__PACKAGE__->register_method(
- method => "volume_retrieve",
- api_name => "open-ils.search.asset.call_number.retrieve"
-);
-sub volume_retrieve {
- my( $self, $client, $vid ) = @_;
- my $e = new_editor();
- my $vol = $e->retrieve_asset_call_number($vid) or return $e->event;
- return $vol;
-}
-
-__PACKAGE__->register_method(
- method => "fleshed_copy_retrieve_batch",
- api_name => "open-ils.search.asset.copy.fleshed.batch.retrieve",
- authoritative => 1,
-);
-
-sub fleshed_copy_retrieve_batch {
- my( $self, $client, $ids ) = @_;
- $logger->info("Fetching fleshed copies @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.asset.copy.search.atomic",
- { id => $ids },
- { flesh => 1,
- flesh_fields => { acp => [ qw/ circ_lib location status stat_cat_entries / ] }
- });
-}
-
-
-__PACKAGE__->register_method(
- method => "fleshed_copy_retrieve",
- api_name => "open-ils.search.asset.copy.fleshed.retrieve",
-);
-
-sub fleshed_copy_retrieve {
- my( $self, $client, $id ) = @_;
- my( $c, $e) = $U->fetch_fleshed_copy($id);
- return $e || $c;
-}
-
-
-__PACKAGE__->register_method(
- method => 'fleshed_by_barcode',
- api_name => "open-ils.search.asset.copy.fleshed2.find_by_barcode",
- authoritative => 1,
-);
-sub fleshed_by_barcode {
- my( $self, $conn, $barcode ) = @_;
- my $e = new_editor();
- my $copyid = $e->search_asset_copy(
- {barcode => $barcode, deleted => 'f'}, {idlist=>1})->[0]
- or return $e->event;
- return fleshed_copy_retrieve2( $self, $conn, $copyid);
-}
-
-
-__PACKAGE__->register_method(
- method => "fleshed_copy_retrieve2",
- api_name => "open-ils.search.asset.copy.fleshed2.retrieve",
- authoritative => 1,
-);
-
-sub fleshed_copy_retrieve2 {
- my( $self, $client, $id ) = @_;
- my $e = new_editor();
- my $copy = $e->retrieve_asset_copy(
- [
- $id,
- {
- flesh => 2,
- flesh_fields => {
- acp => [
- qw/ location status stat_cat_entry_copy_maps notes age_protect /
- ],
- ascecm => [qw/ stat_cat stat_cat_entry /],
- }
- }
- ]
- ) or return $e->event;
-
- # For backwards compatibility
- #$copy->stat_cat_entries($copy->stat_cat_entry_copy_maps);
-
- if( $copy->status->id == OILS_COPY_STATUS_CHECKED_OUT ) {
- $copy->circulations(
- $e->search_action_circulation(
- [
- { target_copy => $copy->id },
- {
- order_by => { circ => 'xact_start desc' },
- limit => 1
- }
- ]
- )
- );
- }
-
- return $copy;
-}
-
-
-__PACKAGE__->register_method(
- method => 'flesh_copy_custom',
- api_name => 'open-ils.search.asset.copy.fleshed.custom',
- authoritative => 1,
-);
-
-sub flesh_copy_custom {
- my( $self, $conn, $copyid, $fields ) = @_;
- my $e = new_editor();
- my $copy = $e->retrieve_asset_copy(
- [
- $copyid,
- {
- flesh => 1,
- flesh_fields => {
- acp => $fields,
- }
- }
- ]
- ) or return $e->event;
- return $copy;
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_barcode_to_title",
- api_name => "open-ils.search.biblio.find_by_barcode",
-);
-
-sub biblio_barcode_to_title {
- my( $self, $client, $barcode ) = @_;
-
- my $title = $apputils->simple_scalar_request(
- "open-ils.storage",
- "open-ils.storage.biblio.record_entry.retrieve_by_barcode", $barcode );
-
- return { ids => [ $title->id ], count => 1 } if $title;
- return { count => 0 };
-}
-
-__PACKAGE__->register_method(
- method => 'title_id_by_item_barcode',
- api_name => 'open-ils.search.bib_id.by_barcode',
- authoritative => 1,
- signature => {
- desc => 'Retrieve copy object with fleshed record, given the barcode',
- params => [
- { desc => 'Item barcode', type => 'string' }
- ],
- return => {
- desc => 'Asset copy object with fleshed record and callnumber, or event on error or null set'
- }
- }
-);
-
-sub title_id_by_item_barcode {
- my( $self, $conn, $barcode ) = @_;
- my $e = new_editor();
- my $copies = $e->search_asset_copy(
- [
- { deleted => 'f', barcode => $barcode },
- {
- flesh => 2,
- flesh_fields => {
- acp => [ 'call_number' ],
- acn => [ 'record' ]
- }
- }
- ]
- );
-
- return $e->event unless @$copies;
- return $$copies[0]->call_number->record->id;
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_copy_to_mods",
- api_name => "open-ils.search.biblio.copy.mods.retrieve",
-);
-
-# takes a copy object and returns it fleshed mods object
-sub biblio_copy_to_mods {
- my( $self, $client, $copy ) = @_;
-
- my $volume = $U->cstorereq(
- "open-ils.cstore.direct.asset.call_number.retrieve",
- $copy->call_number() );
-
- my $mods = _records_to_mods($volume->record());
- $mods = shift @$mods;
- $volume->copies([$copy]);
- push @{$mods->call_numbers()}, $volume;
-
- return $mods;
-}
-
-
-=head1 NAME
-
-OpenILS::Application::Search::Biblio
-
-=head1 DESCRIPTION
-
-=head2 API METHODS
-
-=head3 open-ils.search.biblio.multiclass.query (arghash, query, docache)
-
-For arghash and docache, see B<open-ils.search.biblio.multiclass>.
-
-The query argument is a string, but built like a hash with key: value pairs.
-Recognized search keys include:
-
- keyword (kw) - search keyword(s) *
- author (au) - search author(s) *
- name (au) - same as author *
- title (ti) - search title *
- subject (su) - search subject *
- series (se) - search series *
- lang - limit by language (specifiy multiple langs with lang:l1 lang:l2 ...)
- site - search at specified org unit, corresponds to actor.org_unit.shortname
- sort - sort type (title, author, pubdate)
- dir - sort direction (asc, desc)
- available - if set to anything other than "false" or "0", limits to available items
-
-* Searching keyword, author, title, subject, and series supports additional search
-subclasses, specified with a "|". For example, C<title|proper:gone with the wind>.
-
-For more, see B<config.metabib_field>.
-
-=cut
-
-foreach (qw/open-ils.search.biblio.multiclass.query
- open-ils.search.biblio.multiclass.query.staff
- open-ils.search.metabib.multiclass.query
- open-ils.search.metabib.multiclass.query.staff/)
-{
-__PACKAGE__->register_method(
- api_name => $_,
- method => 'multiclass_query',
- signature => {
- desc => 'Perform a search query. The .staff version of the call includes otherwise hidden hits.',
- params => [
- {name => 'arghash', desc => 'Arg hash (see open-ils.search.biblio.multiclass)', type => 'object'},
- {name => 'query', desc => 'Raw human-readable query (see perldoc '. __PACKAGE__ .')', type => 'string'},
- {name => 'docache', desc => 'Flag for caching (see open-ils.search.biblio.multiclass)', type => 'object'},
- ],
- return => {
- desc => 'Search results from query, like: { "count" : $count, "ids" : [ [ $id, $relevancy, $total ], ...] }',
- type => 'object', # TODO: update as miker's new elements are included
- }
- }
-);
-}
-
-sub multiclass_query {
- my($self, $conn, $arghash, $query, $docache) = @_;
-
- $logger->debug("initial search query => $query");
- my $orig_query = $query;
-
- $query =~ s/\+/ /go;
- $query =~ s/'/ /go;
- $query =~ s/^\s+//go;
-
- # convert convenience classes (e.g. kw for keyword) to the full class name
- # ensure that the convenience class isn't part of a word (e.g. 'playhouse')
- $query =~ s/(^|\s)kw(:|\|)/$1keyword$2/go;
- $query =~ s/(^|\s)ti(:|\|)/$1title$2/go;
- $query =~ s/(^|\s)au(:|\|)/$1author$2/go;
- $query =~ s/(^|\s)su(:|\|)/$1subject$2/go;
- $query =~ s/(^|\s)se(:|\|)/$1series$2/go;
- $query =~ s/(^|\s)name(:|\|)/$1author$2/og;
-
- $logger->debug("cleansed query string => $query");
- my $search = {};
-
- my $simple_class_re = qr/((?:\w+(?:\|\w+)?):[^:]+?)$/;
- my $class_list_re = qr/(?:keyword|title|author|subject|series)/;
- my $modifier_list_re = qr/(?:site|dir|sort|lang|available)/;
-
- my $tmp_value = '';
- while ($query =~ s/$simple_class_re//so) {
-
- my $qpart = $1;
- my $where = index($qpart,':');
- my $type = substr($qpart, 0, $where++);
- my $value = substr($qpart, $where);
-
- if ($type !~ /^(?:$class_list_re|$modifier_list_re)/o) {
- $tmp_value = "$qpart $tmp_value";
- next;
- }
-
- if ($type =~ /$class_list_re/o ) {
- $value .= $tmp_value;
- $tmp_value = '';
- }
-
- next unless $type and $value;
-
- $value =~ s/^\s*//og;
- $value =~ s/\s*$//og;
- $type = 'sort_dir' if $type eq 'dir';
-
- if($type eq 'site') {
- # 'site' is the org shortname. when using this, we also want
- # to search at the requested org's depth
- my $e = new_editor();
- if(my $org = $e->search_actor_org_unit({shortname => $value})->[0]) {
- $arghash->{org_unit} = $org->id if $org;
- $arghash->{depth} = $e->retrieve_actor_org_unit_type($org->ou_type)->depth;
- } else {
- $logger->warn("'site:' query used on invalid org shortname: $value ... ignoring");
- }
-
- } elsif($type eq 'available') {
- # limit to available
- $arghash->{available} = 1 unless $value eq 'false' or $value eq '0';
-
- } elsif($type eq 'lang') {
- # collect languages into an array of languages
- $arghash->{language} = [] unless $arghash->{language};
- push(@{$arghash->{language}}, $value);
-
- } elsif($type =~ /^sort/o) {
- # sort and sort_dir modifiers
- $arghash->{$type} = $value;
-
- } else {
- # append the search term to the term under construction
- $search->{$type} = {} unless $search->{$type};
- $search->{$type}->{term} =
- ($search->{$type}->{term}) ? $search->{$type}->{term} . " $value" : $value;
- }
- }
-
- $query .= " $tmp_value";
- $query =~ s/\s+/ /go;
- $query =~ s/^\s+//go;
- $query =~ s/\s+$//go;
-
- my $type = $arghash->{default_class} || 'keyword';
- $type = ($type eq '-') ? 'keyword' : $type;
- $type = ($type !~ /^(title|author|keyword|subject|series)(?:\|\w+)?$/o) ? 'keyword' : $type;
-
- if($query) {
- # This is the front part of the string before any special tokens were
- # parsed OR colon-separated strings that do not denote a class.
- # Add this data to the default search class
- $search->{$type} = {} unless $search->{$type};
- $search->{$type}->{term} =
- ($search->{$type}->{term}) ? $search->{$type}->{term} . " $query" : $query;
- }
- my $real_search = $arghash->{searches} = { $type => { term => $orig_query } };
-
- # capture the original limit because the search method alters the limit internally
- my $ol = $arghash->{limit};
-
- my $sclient = OpenSRF::Utils::SettingsClient->new;
-
- (my $method = $self->api_name) =~ s/\.query//o;
-
- $method =~ s/multiclass/multiclass.staged/
- if $sclient->config_value(apps => 'open-ils.search',
- app_settings => 'use_staged_search') =~ /true/i;
-
- # XXX This stops the session locale from doing the right thing.
- # XXX Revisit this and have it translate to a lang instead of a locale.
- #$arghash->{preferred_language} = $U->get_org_locale($arghash->{org_unit})
- # unless $arghash->{preferred_language};
-
- $method = $self->method_lookup($method);
- my ($data) = $method->run($arghash, $docache);
-
- $arghash->{searches} = $search if (!$data->{complex_query});
-
- $arghash->{limit} = $ol if $ol;
- $data->{compiled_search} = $arghash;
- $data->{query} = $orig_query;
-
- $logger->info("compiled search is " . OpenSRF::Utils::JSON->perl2JSON($arghash));
-
- return $data;
-}
-
-__PACKAGE__->register_method(
- method => 'cat_search_z_style_wrapper',
- api_name => 'open-ils.search.biblio.zstyle',
- stream => 1,
- signature => q/@see open-ils.search.biblio.multiclass/
-);
-
-__PACKAGE__->register_method(
- method => 'cat_search_z_style_wrapper',
- api_name => 'open-ils.search.biblio.zstyle.staff',
- stream => 1,
- signature => q/@see open-ils.search.biblio.multiclass/
-);
-
-sub cat_search_z_style_wrapper {
- my $self = shift;
- my $client = shift;
- my $authtoken = shift;
- my $args = shift;
-
- my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
-
- my $ou = $cstore->request(
- 'open-ils.cstore.direct.actor.org_unit.search',
- { parent_ou => undef }
- )->gather(1);
-
- my $result = { service => 'native-evergreen-catalog', records => [] };
- my $searchhash = { limit => $$args{limit}, offset => $$args{offset}, org_unit => $ou->id };
-
- $$searchhash{searches}{title}{term} = $$args{search}{title} if $$args{search}{title};
- $$searchhash{searches}{author}{term} = $$args{search}{author} if $$args{search}{author};
- $$searchhash{searches}{subject}{term} = $$args{search}{subject} if $$args{search}{subject};
- $$searchhash{searches}{keyword}{term} = $$args{search}{keyword} if $$args{search}{keyword};
-
- $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{tcn} if $$args{search}{tcn};
- $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{isbn} if $$args{search}{isbn};
- $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{issn} if $$args{search}{issn};
- $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{publisher} if $$args{search}{publisher};
- $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{pubdate} if $$args{search}{pubdate};
- $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{item_type} if $$args{search}{item_type};
-
- my $list = the_quest_for_knowledge( $self, $client, $searchhash );
-
- if ($list->{count} > 0) {
- $result->{count} = $list->{count};
-
- my $records = $cstore->request(
- 'open-ils.cstore.direct.biblio.record_entry.search.atomic',
- { id => [ map { ( $_->[0] ) } @{$list->{ids}} ] }
- )->gather(1);
-
- for my $rec ( @$records ) {
-
- my $u = OpenILS::Utils::ModsParser->new();
- $u->start_mods_batch( $rec->marc );
- my $mods = $u->finish_mods_batch();
-
- push @{ $result->{records} }, { mvr => $mods, marcxml => $rec->marc, bibid => $rec->id };
-
- }
-
- }
-
- $cstore->disconnect();
- return $result;
-}
-
-# ----------------------------------------------------------------------------
-# These are the main OPAC search methods
-# ----------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => 'the_quest_for_knowledge',
- api_name => 'open-ils.search.biblio.multiclass',
- signature => {
- desc => "Performs a multi class biblio or metabib search",
- params => [
- {
- desc => "A search hash with keys: "
- . "searches, org_unit, depth, limit, offset, format, sort, sort_dir. "
- . "See perldoc " . __PACKAGE__ . " for more detail",
- type => 'object',
- },
- {
- desc => "A flag to enable/disable searching and saving results in cache (default OFF)",
- type => 'string',
- }
- ],
- return => {
- desc => 'An object of the form: '
- . '{ "count" : $count, "ids" : [ [ $id, $relevancy, $total ], ...] }',
- }
- }
-);
-
-=head3 open-ils.search.biblio.multiclass (search-hash, docache)
-
-The search-hash argument can have the following elements:
-
- searches: { "$class" : "$value", ...} [REQUIRED]
- org_unit: The org id to focus the search at
- depth : The org depth
- limit : The search limit default: 10
- offset : The search offset default: 0
- format : The MARC format
- sort : What field to sort the results on? [ author | title | pubdate ]
- sort_dir: What direction do we sort? [ asc | desc ]
- tag_circulated_records : Boolean, if true, records that are in the user's visible checkout history
- will be tagged with an additional value ("1") as the last value in the record ID array for
- each record. Requires the 'authtoken'
- authtoken : Authentication token string; When actions are performed that require a user login
- (e.g. tagging circulated records), the authentication token is required
-
-The searches element is required, must have a hashref value, and the hashref must contain at least one
-of the following classes as a key:
-
- title
- author
- subject
- series
- keyword
-
-The value paired with a key is the associated search string.
-
-The docache argument enables/disables searching and saving results in cache (default OFF).
-
-The return object, if successful, will look like:
-
- { "count" : $count, "ids" : [ [ $id, $relevancy, $total ], ...] }
-
-=cut
-
-__PACKAGE__->register_method(
- method => 'the_quest_for_knowledge',
- api_name => 'open-ils.search.biblio.multiclass.staff',
- signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass/
-);
-__PACKAGE__->register_method(
- method => 'the_quest_for_knowledge',
- api_name => 'open-ils.search.metabib.multiclass',
- signature => q/@see open-ils.search.biblio.multiclass/
-);
-__PACKAGE__->register_method(
- method => 'the_quest_for_knowledge',
- api_name => 'open-ils.search.metabib.multiclass.staff',
- signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass/
-);
-
-sub the_quest_for_knowledge {
- my( $self, $conn, $searchhash, $docache ) = @_;
-
- return { count => 0 } unless $searchhash and
- ref $searchhash->{searches} eq 'HASH';
-
- my $method = 'open-ils.storage.biblio.multiclass.search_fts';
- my $ismeta = 0;
- my @recs;
-
- if($self->api_name =~ /metabib/) {
- $ismeta = 1;
- $method =~ s/biblio/metabib/o;
- }
-
- # do some simple sanity checking
- if(!$searchhash->{searches} or
- ( !grep { /^(?:title|author|subject|series|keyword)/ } keys %{$searchhash->{searches}} ) ) {
- return { count => 0 };
- }
-
- my $offset = $searchhash->{offset} || 0; # user value or default in local var now
- my $limit = $searchhash->{limit} || 10; # user value or default in local var now
- my $end = $offset + $limit - 1;
-
- my $maxlimit = 5000;
- $searchhash->{offset} = 0; # possible user value overwritten in hash
- $searchhash->{limit} = $maxlimit; # possible user value overwritten in hash
-
- return { count => 0 } if $offset > $maxlimit;
-
- my @search;
- push( @search, ($_ => $$searchhash{$_})) for (sort keys %$searchhash);
- my $s = OpenSRF::Utils::JSON->perl2JSON(\@search);
- my $ckey = $pfx . md5_hex($method . $s);
-
- $logger->info("bib search for: $s");
-
- $searchhash->{limit} -= $offset;
-
-
- my $trim = 0;
- my $result = ($docache) ? search_cache($ckey, $offset, $limit) : undef;
-
- if(!$result) {
-
- $method .= ".staff" if($self->api_name =~ /staff/);
- $method .= ".atomic";
-
- for (keys %$searchhash) {
- delete $$searchhash{$_}
- unless defined $$searchhash{$_};
- }
-
- $result = $U->storagereq( $method, %$searchhash );
- $trim = 1;
-
- } else {
- $docache = 0; # results came FROM cache, so we don't write back
- }
-
- return {count => 0} unless ($result && $$result[0]);
-
- @recs = @$result;
-
- my $count = ($ismeta) ? $result->[0]->[3] : $result->[0]->[2];
-
- if($docache) {
- # If we didn't get this data from the cache, put it into the cache
- # then return the correct offset of records
- $logger->debug("putting search cache $ckey\n");
- put_cache($ckey, $count, \@recs);
- }
-
- if($trim) {
- # if we have the full set of data, trim out
- # the requested chunk based on limit and offset
- my @t;
- for ($offset..$end) {
- last unless $recs[$_];
- push(@t, $recs[$_]);
- }
- @recs = @t;
- }
-
- return { ids => \@recs, count => $count };
-}
-
-
-__PACKAGE__->register_method(
- method => 'staged_search',
- api_name => 'open-ils.search.biblio.multiclass.staged',
- signature => {
- desc => 'Staged search filters out unavailable items. This means that it relies on an estimation strategy for determining ' .
- 'how big a "raw" search result chunk (i.e. a "superpage") to obtain prior to filtering. See "estimation_strategy" in your SRF config.',
- params => [
- {
- desc => "A search hash with keys: "
- . "searches, limit, offset. The others are optional, but the 'searches' key/value pair is required, with the value being a hashref. "
- . "See perldoc " . __PACKAGE__ . " for more detail",
- type => 'object',
- },
- {
- desc => "A flag to enable/disable searching and saving results in cache, including facets (default OFF)",
- type => 'string',
- }
- ],
- return => {
- desc => 'Hash with keys: count, core_limit, superpage_size, superpage_summary, facet_key, ids. '
- . 'The superpage_summary value is a hashref that includes keys: estimated_hit_count, visible.',
- type => 'object',
- }
- }
-);
-__PACKAGE__->register_method(
- method => 'staged_search',
- api_name => 'open-ils.search.biblio.multiclass.staged.staff',
- signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass.staged/
-);
-__PACKAGE__->register_method(
- method => 'staged_search',
- api_name => 'open-ils.search.metabib.multiclass.staged',
- signature => q/@see open-ils.search.biblio.multiclass.staged/
-);
-__PACKAGE__->register_method(
- method => 'staged_search',
- api_name => 'open-ils.search.metabib.multiclass.staged.staff',
- signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass.staged/
-);
-
-sub staged_search {
- my($self, $conn, $search_hash, $docache) = @_;
-
- my $IAmMetabib = ($self->api_name =~ /metabib/) ? 1 : 0;
-
- my $method = $IAmMetabib?
- 'open-ils.storage.metabib.multiclass.staged.search_fts':
- 'open-ils.storage.biblio.multiclass.staged.search_fts';
-
- $method .= '.staff' if $self->api_name =~ /staff$/;
- $method .= '.atomic';
-
- return {count => 0} unless (
- $search_hash and
- $search_hash->{searches} and
- scalar( keys %{$search_hash->{searches}} ));
-
- my $search_duration;
- my $user_offset = $search_hash->{offset} || 0; # user-specified offset
- my $user_limit = $search_hash->{limit} || 10;
- my $ignore_facet_classes = $search_hash->{ignore_facet_classes};
- $user_offset = ($user_offset >= 0) ? $user_offset : 0;
- $user_limit = ($user_limit >= 0) ? $user_limit : 10;
-
-
- # we're grabbing results on a per-superpage basis, which means the
- # limit and offset should coincide with superpage boundaries
- $search_hash->{offset} = 0;
- $search_hash->{limit} = $superpage_size;
-
- # force a well-known check_limit
- $search_hash->{check_limit} = $superpage_size;
- # restrict total tested to superpage size * number of superpages
- $search_hash->{core_limit} = $superpage_size * $max_superpages;
-
- # Set the configured estimation strategy, defaults to 'inclusion'.
- my $estimation_strategy = OpenSRF::Utils::SettingsClient
- ->new
- ->config_value(
- apps => 'open-ils.search', app_settings => 'estimation_strategy'
- ) || 'inclusion';
- $search_hash->{estimation_strategy} = $estimation_strategy;
-
- # pull any existing results from the cache
- my $key = search_cache_key($method, $search_hash);
- my $facet_key = $key.'_facets';
- my $cache_data = $cache->get_cache($key) || {};
-
- # keep retrieving results until we find enough to
- # fulfill the user-specified limit and offset
- my $all_results = [];
- my $page; # current superpage
- my $est_hit_count = 0;
- my $current_page_summary = {};
- my $global_summary = {checked => 0, visible => 0, excluded => 0, deleted => 0, total => 0};
- my $is_real_hit_count = 0;
- my $new_ids = [];
-
- for($page = 0; $page < $max_superpages; $page++) {
-
- my $data = $cache_data->{$page};
- my $results;
- my $summary;
-
- $logger->debug("staged search: analyzing superpage $page");
-
- if($data) {
- # this window of results is already cached
- $logger->debug("staged search: found cached results");
- $summary = $data->{summary};
- $results = $data->{results};
-
- } else {
- # retrieve the window of results from the database
- $logger->debug("staged search: fetching results from the database");
- $search_hash->{skip_check} = $page * $superpage_size;
- my $start = time;
- $results = $U->storagereq($method, %$search_hash);
- $search_duration = time - $start;
- $logger->info("staged search: DB call took $search_duration seconds and returned ".scalar(@$results)." rows, including summary");
- $summary = shift(@$results) if $results;
-
- unless($summary) {
- $logger->info("search timed out: duration=$search_duration: params=".
- OpenSRF::Utils::JSON->perl2JSON($search_hash));
- return {count => 0};
- }
-
- my $hc = $summary->{estimated_hit_count} || $summary->{visible};
- if($hc == 0) {
- $logger->info("search returned 0 results: duration=$search_duration: params=".
- OpenSRF::Utils::JSON->perl2JSON($search_hash));
- }
-
- # Create backwards-compatible result structures
- if($IAmMetabib) {
- $results = [map {[$_->{id}, $_->{rel}, $_->{record}]} @$results];
- } else {
- $results = [map {[$_->{id}]} @$results];
- }
-
- tag_circulated_records($search_hash->{authtoken}, $results, $IAmMetabib)
- if $search_hash->{tag_circulated_records} and $search_hash->{authtoken};
-
- push @$new_ids, grep {defined($_)} map {$_->[0]} @$results;
- $results = [grep {defined $_->[0]} @$results];
- cache_staged_search_page($key, $page, $summary, $results) if $docache;
- }
-
- $current_page_summary = $summary;
-
- # add the new set of results to the set under construction
- push(@$all_results, @$results);
-
- my $current_count = scalar(@$all_results);
-
- $est_hit_count = $summary->{estimated_hit_count} || $summary->{visible}
- if $page == 0;
-
- $logger->debug("staged search: located $current_count, with estimated hits=".
- $summary->{estimated_hit_count}." : visible=".$summary->{visible}.", checked=".$summary->{checked});
-
- if (defined($summary->{estimated_hit_count})) {
- foreach (qw/ checked visible excluded deleted /) {
- $global_summary->{$_} += $summary->{$_};
- }
- $global_summary->{total} = $summary->{total};
- }
-
- # we've found all the possible hits
- last if $current_count == $summary->{visible}
- and not defined $summary->{estimated_hit_count};
-
- # we've found enough results to satisfy the requested limit/offset
- last if $current_count >= ($user_limit + $user_offset);
-
- # we've scanned all possible hits
- if($summary->{checked} < $superpage_size) {
- $est_hit_count = scalar(@$all_results);
- # we have all possible results in hand, so we know the final hit count
- $is_real_hit_count = 1;
- last;
- }
- }
-
- my @results = grep {defined $_} @$all_results[$user_offset..($user_offset + $user_limit - 1)];
-
- # refine the estimate if we have more than one superpage
- if ($page > 0 and not $is_real_hit_count) {
- if ($global_summary->{checked} >= $global_summary->{total}) {
- $est_hit_count = $global_summary->{visible};
- } else {
- my $updated_hit_count = $U->storagereq(
- 'open-ils.storage.fts_paging_estimate',
- $global_summary->{checked},
- $global_summary->{visible},
- $global_summary->{excluded},
- $global_summary->{deleted},
- $global_summary->{total}
- );
- $est_hit_count = $updated_hit_count->{$estimation_strategy};
- }
- }
-
- $conn->respond_complete(
- {
- count => $est_hit_count,
- core_limit => $search_hash->{core_limit},
- superpage_size => $search_hash->{check_limit},
- superpage_summary => $current_page_summary,
- facet_key => $facet_key,
- ids => \@results
- }
- );
-
- cache_facets($facet_key, $new_ids, $IAmMetabib, $ignore_facet_classes) if $docache;
-
- return undef;
-}
-
-sub tag_circulated_records {
- my ($auth, $results, $metabib) = @_;
- my $e = new_editor(authtoken => $auth);
- return $results unless $e->checkauth;
-
- my $query = {
- select => { acn => [{ column => 'record', alias => 'tagme' }] },
- from => { acp => 'acn' },
- where => { id => { in => { from => ['action.usr_visible_circ_copies', $e->requestor->id] } } },
- distinct => 1
- };
-
- if ($metabib) {
- $query = {
- select => { mmsm => [{ column => 'metarecord', alias => 'tagme' }] },
- from => 'mmsm',
- where => { source => { in => $query } },
- distinct => 1
- };
- }
-
- # Give me the distinct set of bib records that exist in the user's visible circulation history
- my $circ_recs = $e->json_query( $query );
-
- # if the record appears in the circ history, push a 1 onto
- # the rec array structure to indicate truthiness
- for my $rec (@$results) {
- push(@$rec, 1) if grep { $_->{tagme} eq $$rec[0] } @$circ_recs;
- }
-
- $results
-}
-
-# creates a unique token to represent the query in the cache
-sub search_cache_key {
- my $method = shift;
- my $search_hash = shift;
- my @sorted;
- for my $key (sort keys %$search_hash) {
- push(@sorted, ($key => $$search_hash{$key}))
- unless $key eq 'limit' or
- $key eq 'offset' or
- $key eq 'skip_check';
- }
- my $s = OpenSRF::Utils::JSON->perl2JSON(\@sorted);
- return $pfx . md5_hex($method . $s);
-}
-
-sub retrieve_cached_facets {
- my $self = shift;
- my $client = shift;
- my $key = shift;
- my $limit = shift;
-
- return undef unless ($key and $key =~ /_facets$/);
-
- my $blob = $cache->get_cache($key) || {};
-
- my $facets = {};
- if ($limit) {
- for my $f ( keys %$blob ) {
- my @sorted = map{ { $$_[1] => $$_[0] } } sort {$$b[0] <=> $$a[0] || $$a[1] cmp $$b[1]} map { [$$blob{$f}{$_}, $_] } keys %{ $$blob{$f} };
- @sorted = @sorted[0 .. $limit - 1] if (scalar(@sorted) > $limit);
- for my $s ( @sorted ) {
- my ($k) = keys(%$s);
- my ($v) = values(%$s);
- $$facets{$f}{$k} = $v;
- }
- }
- } else {
- $facets = $blob;
- }
-
- return $facets;
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_cached_facets",
- api_name => "open-ils.search.facet_cache.retrieve",
- signature => {
- desc => 'Returns facet data derived from a specific search based on a key '.
- 'generated by open-ils.search.biblio.multiclass.staged and friends.',
- params => [
- {
- desc => "The facet cache key returned with the initial search as the facet_key hash value",
- type => 'string',
- }
- ],
- return => {
- desc => 'Two level hash of facet values. Top level key is the facet id defined on the config.metabib_field table. '.
- 'Second level key is a string facet value. Datum attached to each facet value is the number of distinct records, '.
- 'or metarecords for a metarecord search, which use that facet value and are visible to the search at the time of '.
- 'facet retrieval. These counts are calculated for all superpages that have been checked for visibility.',
- type => 'object',
- }
- }
-);
-
-
-sub cache_facets {
- # add facets for this search to the facet cache
- my($key, $results, $metabib, $ignore) = @_;
- my $data = $cache->get_cache($key);
- $data ||= {};
-
- if (!ref($ignore)) {
- $ignore = ['identifier']; # ignore the identifier class by default
- }
-
- return undef unless (@$results);
-
- # The query we're constructing
- #
- # select mfae.field as id,
- # mfae.value,
- # count(distinct mmrsm.appropriate-id-field )
- # from metabib.facet_entry mfae
- # join metabib.metarecord_sourc_map mmrsm on (mfae.source = mmrsm.source)
- # where mmrsm.appropriate-id-field in IDLIST
- # group by 1,2;
-
- my $count_field = $metabib ? 'metarecord' : 'source';
- my $facets = $U->cstorereq( "open-ils.cstore.json_query.atomic",
- { select => {
- mfae => [ { column => 'field', alias => 'id'}, 'value' ],
- mmrsm => [{
- transform => 'count',
- distinct => 1,
- column => $count_field,
- alias => 'count',
- aggregate => 1
- }]
- },
- from => {
- mfae => {
- mmrsm => { field => 'source', fkey => 'source' },
- cmf => { field => 'id', fkey => 'field' }
- }
- },
- where => {
- '+mmrsm' => { $count_field => $results },
- '+cmf' => { field_class => { 'not in' => $ignore } }
- }
- }
- );
-
- for my $facet (@$facets) {
- next unless ($facet->{value});
- $data->{$facet->{id}}->{$facet->{value}} += $facet->{count};
- }
-
- $logger->info("facet compilation: cached with key=$key");
-
- $cache->put_cache($key, $data, $cache_timeout);
-}
-
-sub cache_staged_search_page {
- # puts this set of results into the cache
- my($key, $page, $summary, $results) = @_;
- my $data = $cache->get_cache($key);
- $data ||= {};
- $data->{$page} = {
- summary => $summary,
- results => $results
- };
-
- $logger->info("staged search: cached with key=$key, superpage=$page, estimated=".
- $summary->{estimated_hit_count}.", visible=".$summary->{visible});
-
- $cache->put_cache($key, $data, $cache_timeout);
-}
-
-sub search_cache {
-
- my $key = shift;
- my $offset = shift;
- my $limit = shift;
- my $start = $offset;
- my $end = $offset + $limit - 1;
-
- $logger->debug("searching cache for $key : $start..$end\n");
-
- return undef unless $cache;
- my $data = $cache->get_cache($key);
-
- return undef unless $data;
-
- my $count = $data->[0];
- $data = $data->[1];
-
- return undef unless $offset < $count;
-
- my @result;
- for( my $i = $offset; $i <= $end; $i++ ) {
- last unless my $d = $$data[$i];
- push( @result, $d );
- }
-
- $logger->debug("search_cache found ".scalar(@result)." items for count=$count, start=$start, end=$end");
-
- return \@result;
-}
-
-
-sub put_cache {
- my( $key, $count, $data ) = @_;
- return undef unless $cache;
- $logger->debug("search_cache putting ".
- scalar(@$data)." items at key $key with timeout $cache_timeout");
- $cache->put_cache($key, [ $count, $data ], $cache_timeout);
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_mrid_to_modsbatch_batch",
- api_name => "open-ils.search.biblio.metarecord.mods_slim.batch.retrieve"
-);
-
-sub biblio_mrid_to_modsbatch_batch {
- my( $self, $client, $mrids) = @_;
- # warn "Performing mrid_to_modsbatch_batch..."; # unconditional warn
- my @mods;
- my $method = $self->method_lookup("open-ils.search.biblio.metarecord.mods_slim.retrieve");
- for my $id (@$mrids) {
- next unless defined $id;
- my ($m) = $method->run($id);
- push @mods, $m;
- }
- return \@mods;
-}
-
-
-foreach (qw /open-ils.search.biblio.metarecord.mods_slim.retrieve
- open-ils.search.biblio.metarecord.mods_slim.retrieve.staff/)
- {
- __PACKAGE__->register_method(
- method => "biblio_mrid_to_modsbatch",
- api_name => $_,
- signature => {
- desc => "Returns the mvr associated with a given metarecod. If none exists, it is created. "
- . "As usual, the .staff version of this method will include otherwise hidden records.",
- params => [
- { desc => 'Metarecord ID', type => 'number' },
- { desc => '(Optional) Search filters hash with possible keys: format, org, depth', type => 'object' }
- ],
- return => {
- desc => 'MVR Object, event on error',
- }
- }
- );
-}
-
-sub biblio_mrid_to_modsbatch {
- my( $self, $client, $mrid, $args) = @_;
-
- # warn "Grabbing mvr for $mrid\n"; # unconditional warn
-
- my ($mr, $evt) = _grab_metarecord($mrid);
- return $evt unless $mr;
-
- my $mvr = biblio_mrid_check_mvr($self, $client, $mr) ||
- biblio_mrid_make_modsbatch($self, $client, $mr);
-
- return $mvr unless ref($args);
-
- # Here we find the lead record appropriate for the given filters
- # and use that for the title and author of the metarecord
- my $format = $$args{format};
- my $org = $$args{org};
- my $depth = $$args{depth};
-
- return $mvr unless $format or $org or $depth;
-
- my $method = "open-ils.storage.ordered.metabib.metarecord.records";
- $method = "$method.staff" if $self->api_name =~ /staff/o;
-
- my $rec = $U->storagereq($method, $format, $org, $depth, 1);
-
- if( my $mods = $U->record_to_mvr($rec) ) {
-
- $mvr->title( $mods->title );
- $mvr->author($mods->author);
- $logger->debug("mods_slim updating title and ".
- "author in mvr with ".$mods->title." : ".$mods->author);
- }
-
- return $mvr;
-}
-
-# converts a metarecord to an mvr
-sub _mr_to_mvr {
- my $mr = shift;
- my $perl = OpenSRF::Utils::JSON->JSON2perl($mr->mods());
- return Fieldmapper::metabib::virtual_record->new($perl);
-}
-
-# checks to see if a metarecord has mods, if so returns true;
-
-__PACKAGE__->register_method(
- method => "biblio_mrid_check_mvr",
- api_name => "open-ils.search.biblio.metarecord.mods_slim.check",
- notes => "Takes a metarecord ID or a metarecord object and returns true "
- . "if the metarecord already has an mvr associated with it."
-);
-
-sub biblio_mrid_check_mvr {
- my( $self, $client, $mrid ) = @_;
- my $mr;
-
- my $evt;
- if(ref($mrid)) { $mr = $mrid; }
- else { ($mr, $evt) = _grab_metarecord($mrid); }
- return $evt if $evt;
-
- # warn "Checking mvr for mr " . $mr->id . "\n"; # unconditional warn
-
- return _mr_to_mvr($mr) if $mr->mods();
- return undef;
-}
-
-sub _grab_metarecord {
- my $mrid = shift;
- #my $e = OpenILS::Utils::Editor->new;
- my $e = new_editor();
- my $mr = $e->retrieve_metabib_metarecord($mrid) or return ( undef, $e->event );
- return ($mr);
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_mrid_make_modsbatch",
- api_name => "open-ils.search.biblio.metarecord.mods_slim.create",
- notes => "Takes either a metarecord ID or a metarecord object. "
- . "Forces the creations of an mvr for the given metarecord. "
- . "The created mvr is returned."
-);
-
-sub biblio_mrid_make_modsbatch {
- my( $self, $client, $mrid ) = @_;
-
- #my $e = OpenILS::Utils::Editor->new;
- my $e = new_editor();
-
- my $mr;
- if( ref($mrid) ) {
- $mr = $mrid;
- $mrid = $mr->id;
- } else {
- $mr = $e->retrieve_metabib_metarecord($mrid)
- or return $e->event;
- }
-
- my $masterid = $mr->master_record;
- $logger->info("creating new mods batch for metarecord=$mrid, master record=$masterid");
-
- my $ids = $U->storagereq(
- 'open-ils.storage.ordered.metabib.metarecord.records.staff.atomic', $mrid);
- return undef unless @$ids;
-
- my $master = $e->retrieve_biblio_record_entry($masterid)
- or return $e->event;
-
- # start the mods batch
- my $u = OpenILS::Utils::ModsParser->new();
- $u->start_mods_batch( $master->marc );
-
- # grab all of the sub-records and shove them into the batch
- my @ids = grep { $_ ne $masterid } @$ids;
- #my $subrecs = (@ids) ? $e->batch_retrieve_biblio_record_entry(\@ids) : [];
-
- my $subrecs = [];
- if(@$ids) {
- for my $i (@$ids) {
- my $r = $e->retrieve_biblio_record_entry($i);
- push( @$subrecs, $r ) if $r;
- }
- }
-
- for(@$subrecs) {
- $logger->debug("adding record ".$_->id." to mods batch for metarecord=$mrid");
- $u->push_mods_batch( $_->marc ) if $_->marc;
- }
-
-
- # finish up and send to the client
- my $mods = $u->finish_mods_batch();
- $mods->doc_id($mrid);
- $client->respond_complete($mods);
-
-
- # now update the mods string in the db
- my $string = OpenSRF::Utils::JSON->perl2JSON($mods->decast);
- $mr->mods($string);
-
- #$e = OpenILS::Utils::Editor->new(xact => 1);
- $e = new_editor(xact => 1);
- $e->update_metabib_metarecord($mr)
- or $logger->error("Error setting mods text on metarecord $mrid : " . Dumper($e->event));
- $e->finish;
-
- return undef;
-}
-
-
-# converts a mr id into a list of record ids
-
-foreach (qw/open-ils.search.biblio.metarecord_to_records
- open-ils.search.biblio.metarecord_to_records.staff/)
-{
- __PACKAGE__->register_method(
- method => "biblio_mrid_to_record_ids",
- api_name => $_,
- signature => {
- desc => "Fetch record IDs corresponding to a meta-record ID, with optional search filters. "
- . "As usual, the .staff version of this method will include otherwise hidden records.",
- params => [
- { desc => 'Metarecord ID', type => 'number' },
- { desc => '(Optional) Search filters hash with possible keys: format, org, depth', type => 'object' }
- ],
- return => {
- desc => 'Results object like {count => $i, ids =>[...]}',
- type => 'object'
- }
-
- }
- );
-}
-
-sub biblio_mrid_to_record_ids {
- my( $self, $client, $mrid, $args ) = @_;
-
- my $format = $$args{format};
- my $org = $$args{org};
- my $depth = $$args{depth};
-
- my $method = "open-ils.storage.ordered.metabib.metarecord.records.atomic";
- $method =~ s/atomic/staff\.atomic/o if $self->api_name =~ /staff/o;
- my $recs = $U->storagereq($method, $mrid, $format, $org, $depth);
-
- return { count => scalar(@$recs), ids => $recs };
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_record_to_marc_html",
- api_name => "open-ils.search.biblio.record.html"
-);
-
-__PACKAGE__->register_method(
- method => "biblio_record_to_marc_html",
- api_name => "open-ils.search.authority.to_html"
-);
-
-# Persistent parsers and setting objects
-my $parser = XML::LibXML->new();
-my $xslt = XML::LibXSLT->new();
-my $marc_sheet;
-my $slim_marc_sheet;
-my $settings_client = OpenSRF::Utils::SettingsClient->new();
-
-sub biblio_record_to_marc_html {
- my($self, $client, $recordid, $slim, $marcxml) = @_;
-
- my $sheet;
- my $dir = $settings_client->config_value("dirs", "xsl");
-
- if($slim) {
- unless($slim_marc_sheet) {
- my $xsl = $settings_client->config_value(
- "apps", "open-ils.search", "app_settings", 'marc_html_xsl_slim');
- if($xsl) {
- $xsl = $parser->parse_file("$dir/$xsl");
- $slim_marc_sheet = $xslt->parse_stylesheet($xsl);
- }
- }
- $sheet = $slim_marc_sheet;
- }
-
- unless($sheet) {
- unless($marc_sheet) {
- my $xsl_key = ($slim) ? 'marc_html_xsl_slim' : 'marc_html_xsl';
- my $xsl = $settings_client->config_value(
- "apps", "open-ils.search", "app_settings", 'marc_html_xsl');
- $xsl = $parser->parse_file("$dir/$xsl");
- $marc_sheet = $xslt->parse_stylesheet($xsl);
- }
- $sheet = $marc_sheet;
- }
-
- my $record;
- unless($marcxml) {
- my $e = new_editor();
- if($self->api_name =~ /authority/) {
- $record = $e->retrieve_authority_record_entry($recordid)
- or return $e->event;
- } else {
- $record = $e->retrieve_biblio_record_entry($recordid)
- or return $e->event;
- }
- $marcxml = $record->marc;
- }
-
- my $xmldoc = $parser->parse_string($marcxml);
- my $html = $sheet->transform($xmldoc);
- return $html->documentElement->toString();
-}
-
-__PACKAGE__->register_method(
- method => "format_biblio_record_entry",
- api_name => "open-ils.search.biblio.record.print",
- signature => {
- desc => 'Returns a printable version of the specified bib record',
- params => [
- { desc => 'Biblio record entry ID or array of IDs', type => 'number' },
- ],
- return => {
- desc => q/An action_trigger.event object or error event./,
- type => 'object',
- }
- }
-);
-__PACKAGE__->register_method(
- method => "format_biblio_record_entry",
- api_name => "open-ils.search.biblio.record.email",
- signature => {
- desc => 'Emails an A/T templated version of the specified bib records to the authorized user',
- params => [
- { desc => 'Authentication token', type => 'string'},
- { desc => 'Biblio record entry ID or array of IDs', type => 'number' },
- ],
- return => {
- desc => q/Undefined on success, otherwise an error event./,
- type => 'object',
- }
- }
-);
-
-sub format_biblio_record_entry {
- my($self, $conn, $arg1, $arg2) = @_;
-
- my $for_print = ($self->api_name =~ /print/);
- my $for_email = ($self->api_name =~ /email/);
-
- my $e; my $auth; my $bib_id; my $context_org;
-
- if ($for_print) {
- $bib_id = $arg1;
- $context_org = $arg2 || $U->fetch_org_tree->id;
- $e = new_editor(xact => 1);
- } elsif ($for_email) {
- $auth = $arg1;
- $bib_id = $arg2;
- $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- $context_org = $e->requestor->home_ou;
- }
-
- my $bib_ids;
- if (ref $bib_id ne 'ARRAY') {
- $bib_ids = [ $bib_id ];
- } else {
- $bib_ids = $bib_id;
- }
-
- my $bucket = Fieldmapper::container::biblio_record_entry_bucket->new;
- $bucket->btype('temp');
- $bucket->name('format_biblio_record_entry ' . $U->create_uuid_string);
- if ($for_email) {
- $bucket->owner($e->requestor)
- } else {
- $bucket->owner(1);
- }
- my $bucket_obj = $e->create_container_biblio_record_entry_bucket($bucket);
-
- for my $id (@$bib_ids) {
-
- my $bib = $e->retrieve_biblio_record_entry([$id]) or return $e->die_event;
-
- my $bucket_entry = Fieldmapper::container::biblio_record_entry_bucket_item->new;
- $bucket_entry->target_biblio_record_entry($bib);
- $bucket_entry->bucket($bucket_obj->id);
- $e->create_container_biblio_record_entry_bucket_item($bucket_entry);
- }
-
- $e->commit;
-
- if ($for_print) {
-
- return $U->fire_object_event(undef, 'biblio.format.record_entry.print', [ $bucket ], $context_org);
-
- } elsif ($for_email) {
-
- $U->create_events_for_hook('biblio.format.record_entry.email', $bucket, $context_org, undef, undef, 1);
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "retrieve_all_copy_statuses",
- api_name => "open-ils.search.config.copy_status.retrieve.all"
-);
-
-sub retrieve_all_copy_statuses {
- my( $self, $client ) = @_;
- return new_editor()->retrieve_all_config_copy_status();
-}
-
-
-__PACKAGE__->register_method(
- method => "copy_counts_per_org",
- api_name => "open-ils.search.biblio.copy_counts.retrieve"
-);
-
-__PACKAGE__->register_method(
- method => "copy_counts_per_org",
- api_name => "open-ils.search.biblio.copy_counts.retrieve.staff"
-);
-
-sub copy_counts_per_org {
- my( $self, $client, $record_id ) = @_;
-
- warn "Retreiveing copy copy counts for record $record_id and method " . $self->api_name . "\n";
-
- my $method = "open-ils.storage.biblio.record_entry.global_copy_count.atomic";
- if($self->api_name =~ /staff/) { $method =~ s/atomic/staff\.atomic/; }
-
- my $counts = $apputils->simple_scalar_request(
- "open-ils.storage", $method, $record_id );
-
- $counts = [ sort {$a->[0] <=> $b->[0]} @$counts ];
- return $counts;
-}
-
-
-__PACKAGE__->register_method(
- method => "copy_count_summary",
- api_name => "open-ils.search.biblio.copy_counts.summary.retrieve",
- notes => "returns an array of these: "
- . "[ org_id, callnumber_label, <status1_count>, <status2_count>,...] "
- . "where statusx is a copy status name. The statuses are sorted by ID.",
-);
-
-
-sub copy_count_summary {
- my( $self, $client, $rid, $org, $depth ) = @_;
- $org ||= 1;
- $depth ||= 0;
- my $data = $U->storagereq(
- 'open-ils.storage.biblio.record_entry.status_copy_count.atomic', $rid, $org, $depth );
-
- return [ sort { $a->[1] cmp $b->[1] } @$data ];
-}
-
-__PACKAGE__->register_method(
- method => "copy_location_count_summary",
- api_name => "open-ils.search.biblio.copy_location_counts.summary.retrieve",
- notes => "returns an array of these: "
- . "[ org_id, callnumber_label, copy_location, <status1_count>, <status2_count>,...] "
- . "where statusx is a copy status name. The statuses are sorted by ID.",
-);
-
-sub copy_location_count_summary {
- my( $self, $client, $rid, $org, $depth ) = @_;
- $org ||= 1;
- $depth ||= 0;
- my $data = $U->storagereq(
- 'open-ils.storage.biblio.record_entry.status_copy_location_count.atomic', $rid, $org, $depth );
-
- return [ sort { $a->[1] cmp $b->[1] || $a->[2] cmp $b->[2] } @$data ];
-}
-
-__PACKAGE__->register_method(
- method => "copy_count_location_summary",
- api_name => "open-ils.search.biblio.copy_counts.location.summary.retrieve",
- notes => "returns an array of these: "
- . "[ org_id, callnumber_label, <status1_count>, <status2_count>,...] "
- . "where statusx is a copy status name. The statuses are sorted by ID."
-);
-
-sub copy_count_location_summary {
- my( $self, $client, $rid, $org, $depth ) = @_;
- $org ||= 1;
- $depth ||= 0;
- my $data = $U->storagereq(
- 'open-ils.storage.biblio.record_entry.status_copy_location_count.atomic', $rid, $org, $depth );
- return [ sort { $a->[1] cmp $b->[1] } @$data ];
-}
-
-
-foreach (qw/open-ils.search.biblio.marc
- open-ils.search.biblio.marc.staff/)
-{
-__PACKAGE__->register_method(
- method => "marc_search",
- api_name => $_,
- signature => {
- desc => 'Fetch biblio IDs based on MARC record criteria. '
- . 'As usual, the .staff version of the search includes otherwise hidden records',
- params => [
- {
- desc => 'Search hash (required) with possible elements: searches, limit, offset, sort, sort_dir. ' .
- 'See perldoc ' . __PACKAGE__ . ' for more detail.',
- type => 'object'
- },
- {desc => 'limit (optional)', type => 'number'},
- {desc => 'offset (optional)', type => 'number'}
- ],
- return => {
- desc => 'Results object like: { "count": $i, "ids": [...] }',
- type => 'object'
- }
- }
-);
-}
-
-=head3 open-ils.search.biblio.marc (arghash, limit, offset)
-
-As elsewhere the arghash is the required argument, and must be a hashref. The keys are:
-
- searches: complex query object (required)
- org_unit: The org ID to focus the search at
- depth : The org depth
- limit : integer search limit default: 10
- offset : integer search offset default: 0
- sort : What field to sort the results on? [ author | title | pubdate ]
- sort_dir: In what direction do we sort? [ asc | desc ]
-
-Additional keys to refine search criteria:
-
- audience : Audience
- language : Language (code)
- lit_form : Literary form
- item_form: Item form
- item_type: Item type
- format : The MARC format
-
-Please note that the specific strings to be used in the "addtional keys" will be entirely
-dependent on your loaded data.
-
-All keys except "searches" are optional.
-The "searches" value must be an arrayref of hashref elements, including keys "term" and "restrict".
-
-For example, an arg hash might look like:
-
- $arghash = {
- searches => [
- {
- term => "harry",
- restrict => [
- {
- tag => 245,
- subfield => "a"
- }
- # ...
- ]
- }
- # ...
- ],
- org_unit => 1,
- limit => 5,
- sort => "author",
- item_type => "g"
- }
-
-The arghash is eventually passed to the SRF call:
-L<open-ils.storage.biblio.full_rec.multi_search[.staff].atomic>
-
-Presently, search uses the cache unconditionally.
-
-=cut
-
-# FIXME: that example above isn't actually tested.
-# TODO: docache option?
-sub marc_search {
- my( $self, $conn, $args, $limit, $offset ) = @_;
-
- my $method = 'open-ils.storage.biblio.full_rec.multi_search';
- $method .= ".staff" if $self->api_name =~ /staff/;
- $method .= ".atomic";
-
- $limit ||= 10; # FIXME: what about $args->{limit} ?
- $offset ||= 0; # FIXME: what about $args->{offset} ?
-
- my @search;
- push( @search, ($_ => $$args{$_}) ) for (sort keys %$args);
- my $ckey = $pfx . md5_hex($method . OpenSRF::Utils::JSON->perl2JSON(\@search));
-
- my $recs = search_cache($ckey, $offset, $limit);
-
- if(!$recs) {
- $recs = $U->storagereq($method, %$args) || [];
- if( $recs ) {
- put_cache($ckey, scalar(@$recs), $recs);
- $recs = [ @$recs[$offset..($offset + ($limit - 1))] ];
- } else {
- $recs = [];
- }
- }
-
- my $count = 0;
- $count = $recs->[0]->[2] if $recs->[0] and $recs->[0]->[2];
- my @recs = map { $_->[0] } @$recs;
-
- return { ids => \@recs, count => $count };
-}
-
-
-__PACKAGE__->register_method(
- method => "biblio_search_isbn",
- api_name => "open-ils.search.biblio.isbn",
- signature => {
- desc => 'Retrieve biblio IDs for a given ISBN',
- params => [
- {desc => 'ISBN', type => 'string'} # or number maybe? How normalized is our storage data?
- ],
- return => {
- desc => 'Results object like: { "count": $i, "ids": [...] }',
- type => 'object'
- }
- }
-);
-
-sub biblio_search_isbn {
- my( $self, $client, $isbn ) = @_;
- $logger->debug("Searching ISBN $isbn");
- my $recs = $U->storagereq('open-ils.storage.id_list.biblio.record_entry.search.isbn.atomic', $isbn);
- return { ids => $recs, count => scalar(@$recs) };
-}
-
-__PACKAGE__->register_method(
- method => "biblio_search_isbn_batch",
- api_name => "open-ils.search.biblio.isbn_list",
-);
-
-sub biblio_search_isbn_batch {
- my( $self, $client, $isbn_list ) = @_;
- $logger->debug("Searching ISBNs @$isbn_list");
- my @recs = (); my %rec_set = ();
- foreach my $isbn ( @$isbn_list ) {
- foreach my $rec ( @{ $U->storagereq(
- 'open-ils.storage.id_list.biblio.record_entry.search.isbn.atomic', $isbn )
- } ) {
- if (! $rec_set{ $rec }) {
- $rec_set{ $rec } = 1;
- push @recs, $rec;
- }
- }
- }
- return { ids => \@recs, count => scalar(@recs) };
-}
-
-__PACKAGE__->register_method(
- method => "biblio_search_issn",
- api_name => "open-ils.search.biblio.issn",
- signature => {
- desc => 'Retrieve biblio IDs for a given ISSN',
- params => [
- {desc => 'ISBN', type => 'string'}
- ],
- return => {
- desc => 'Results object like: { "count": $i, "ids": [...] }',
- type => 'object'
- }
- }
-);
-
-sub biblio_search_issn {
- my( $self, $client, $issn ) = @_;
- $logger->debug("Searching ISSN $issn");
- my $e = new_editor();
- $issn =~ s/-/ /g;
- my $recs = $U->storagereq(
- 'open-ils.storage.id_list.biblio.record_entry.search.issn.atomic', $issn );
- return { ids => $recs, count => scalar(@$recs) };
-}
-
-
-__PACKAGE__->register_method(
- method => "fetch_mods_by_copy",
- api_name => "open-ils.search.biblio.mods_from_copy",
- argc => 1,
- signature => {
- desc => 'Retrieve MODS record given an attached copy ID',
- params => [
- { desc => 'Copy ID', type => 'number' }
- ],
- returns => {
- desc => 'MODS record, event on error or uncataloged item'
- }
- }
-);
-
-sub fetch_mods_by_copy {
- my( $self, $client, $copyid ) = @_;
- my ($record, $evt) = $apputils->fetch_record_by_copy( $copyid );
- return $evt if $evt;
- return OpenILS::Event->new('ITEM_NOT_CATALOGED') unless $record->marc;
- return $apputils->record_to_mvr($record);
-}
-
-
-# -------------------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => "cn_browse",
- api_name => "open-ils.search.callnumber.browse.target",
- notes => "Starts a callnumber browse"
-);
-
-__PACKAGE__->register_method(
- method => "cn_browse",
- api_name => "open-ils.search.callnumber.browse.page_up",
- notes => "Returns the previous page of callnumbers",
-);
-
-__PACKAGE__->register_method(
- method => "cn_browse",
- api_name => "open-ils.search.callnumber.browse.page_down",
- notes => "Returns the next page of callnumbers",
-);
-
-
-# RETURNS array of arrays like so: label, owning_lib, record, id
-sub cn_browse {
- my( $self, $client, @params ) = @_;
- my $method;
-
- $method = 'open-ils.storage.asset.call_number.browse.target.atomic'
- if( $self->api_name =~ /target/ );
- $method = 'open-ils.storage.asset.call_number.browse.page_up.atomic'
- if( $self->api_name =~ /page_up/ );
- $method = 'open-ils.storage.asset.call_number.browse.page_down.atomic'
- if( $self->api_name =~ /page_down/ );
-
- return $apputils->simplereq( 'open-ils.storage', $method, @params );
-}
-# -------------------------------------------------------------------------------------
-
-__PACKAGE__->register_method(
- method => "fetch_cn",
- api_name => "open-ils.search.callnumber.retrieve",
- authoritative => 1,
- notes => "retrieves a callnumber based on ID",
-);
-
-sub fetch_cn {
- my( $self, $client, $id ) = @_;
- my( $cn, $evt ) = $apputils->fetch_callnumber( $id );
- return $evt if $evt;
- return $cn;
-}
-
-__PACKAGE__->register_method(
- method => "fetch_copy_by_cn",
- api_name => 'open-ils.search.copies_by_call_number.retrieve',
- signature => q/
- Returns an array of copy ID's by callnumber ID
- @param cnid The callnumber ID
- @return An array of copy IDs
- /
-);
-
-sub fetch_copy_by_cn {
- my( $self, $conn, $cnid ) = @_;
- return $U->cstorereq(
- 'open-ils.cstore.direct.asset.copy.id_list.atomic',
- { call_number => $cnid, deleted => 'f' } );
-}
-
-__PACKAGE__->register_method(
- method => 'fetch_cn_by_info',
- api_name => 'open-ils.search.call_number.retrieve_by_info',
- signature => q/
- @param label The callnumber label
- @param record The record the cn is attached to
- @param org The owning library of the cn
- @return The callnumber object
- /
-);
-
-
-sub fetch_cn_by_info {
- my( $self, $conn, $label, $record, $org ) = @_;
- return $U->cstorereq(
- 'open-ils.cstore.direct.asset.call_number.search',
- { label => $label, record => $record, owning_lib => $org, deleted => 'f' });
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'bib_extras',
- api_name => 'open-ils.search.biblio.lit_form_map.retrieve.all'
-);
-__PACKAGE__->register_method(
- method => 'bib_extras',
- api_name => 'open-ils.search.biblio.item_form_map.retrieve.all'
-);
-__PACKAGE__->register_method(
- method => 'bib_extras',
- api_name => 'open-ils.search.biblio.item_type_map.retrieve.all'
-);
-__PACKAGE__->register_method(
- method => 'bib_extras',
- api_name => 'open-ils.search.biblio.bib_level_map.retrieve.all'
-);
-__PACKAGE__->register_method(
- method => 'bib_extras',
- api_name => 'open-ils.search.biblio.audience_map.retrieve.all'
-);
-
-sub bib_extras {
- my $self = shift;
-
- my $e = new_editor();
-
- return $e->retrieve_all_config_lit_form_map()
- if( $self->api_name =~ /lit_form/ );
-
- return $e->retrieve_all_config_item_form_map()
- if( $self->api_name =~ /item_form_map/ );
-
- return $e->retrieve_all_config_item_type_map()
- if( $self->api_name =~ /item_type_map/ );
-
- return $e->retrieve_all_config_bib_level_map()
- if( $self->api_name =~ /bib_level_map/ );
-
- return $e->retrieve_all_config_audience_map()
- if( $self->api_name =~ /audience_map/ );
-
- return [];
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'fetch_slim_record',
- api_name => 'open-ils.search.biblio.record_entry.slim.retrieve',
- signature => {
- desc => "Retrieves one or more biblio.record_entry without the attached marcxml",
- params => [
- { desc => 'Array of Record IDs', type => 'array' }
- ],
- return => {
- desc => 'Array of biblio records, event on error'
- }
- }
-);
-
-sub fetch_slim_record {
- my( $self, $conn, $ids ) = @_;
-
-#my $editor = OpenILS::Utils::Editor->new;
- my $editor = new_editor();
- my @res;
- for( @$ids ) {
- return $editor->event unless
- my $r = $editor->retrieve_biblio_record_entry($_);
- $r->clear_marc;
- push(@res, $r);
- }
- return \@res;
-}
-
-
-
-__PACKAGE__->register_method(
- method => 'rec_to_mr_rec_descriptors',
- api_name => 'open-ils.search.metabib.record_to_descriptors',
- signature => q/
- specialized method...
- Given a biblio record id or a metarecord id,
- this returns a list of metabib.record_descriptor
- objects that live within the same metarecord
- @param args Object of args including:
- /
-);
-
-sub rec_to_mr_rec_descriptors {
- my( $self, $conn, $args ) = @_;
-
- my $rec = $$args{record};
- my $mrec = $$args{metarecord};
- my $item_forms = $$args{item_forms};
- my $item_types = $$args{item_types};
- my $item_lang = $$args{item_lang};
-
- my $e = new_editor();
- my $recs;
-
- if( !$mrec ) {
- my $map = $e->search_metabib_metarecord_source_map({source => $rec});
- return $e->event unless @$map;
- $mrec = $$map[0]->metarecord;
- }
-
- $recs = $e->search_metabib_metarecord_source_map({metarecord => $mrec});
- return $e->event unless @$recs;
-
- my @recs = map { $_->source } @$recs;
- my $search = { record => \@recs };
- $search->{item_form} = $item_forms if $item_forms and @$item_forms;
- $search->{item_type} = $item_types if $item_types and @$item_types;
- $search->{item_lang} = $item_lang if $item_lang;
-
- my $desc = $e->search_metabib_record_descriptor($search);
-
- return { metarecord => $mrec, descriptors => $desc };
-}
-
-
-__PACKAGE__->register_method(
- method => 'fetch_age_protect',
- api_name => 'open-ils.search.copy.age_protect.retrieve.all',
-);
-
-sub fetch_age_protect {
- return new_editor()->retrieve_all_config_rule_age_hold_protect();
-}
-
-
-__PACKAGE__->register_method(
- method => 'copies_by_cn_label',
- api_name => 'open-ils.search.asset.copy.retrieve_by_cn_label',
-);
-
-__PACKAGE__->register_method(
- method => 'copies_by_cn_label',
- api_name => 'open-ils.search.asset.copy.retrieve_by_cn_label.staff',
-);
-
-sub copies_by_cn_label {
- my( $self, $conn, $record, $label, $circ_lib ) = @_;
- my $e = new_editor();
- my $cns = $e->search_asset_call_number({record => $record, label => $label, deleted => 'f'}, {idlist=>1});
- return [] unless @$cns;
-
- # show all non-deleted copies in the staff client ...
- if ($self->api_name =~ /staff$/o) {
- return $e->search_asset_copy({call_number => $cns, circ_lib => $circ_lib, deleted => 'f'}, {idlist=>1});
- }
-
- # ... otherwise, grab the copies ...
- my $copies = $e->search_asset_copy(
- [ {call_number => $cns, circ_lib => $circ_lib, deleted => 'f', opac_visible => 't'},
- {flesh => 1, flesh_fields => { acp => [ qw/location status/] } }
- ]
- );
-
- # ... and test for location and status visibility
- return [ map { ($U->is_true($_->location->opac_visible) && $U->is_true($_->status->opac_visible)) ? ($_->id) : () } @$copies ];
-}
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Search::CNBrowse;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::EX qw(:try);
-use OpenILS::Application::AppUtils;
-use Data::Dumper;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenSRF::AppSession;
-my $U = "OpenILS::Application::AppUtils";
-
-
-__PACKAGE__->register_method(
- method => "cn_browse_start",
- api_name => "open-ils.search.callnumber.browse.target",
- notes => "Starts a callnumber browse"
- );
-
-__PACKAGE__->register_method(
- method => "cn_browse_up",
- api_name => "open-ils.search.callnumber.browse.page_up",
- notes => "Returns the previous page of callnumbers",
- );
-
-__PACKAGE__->register_method(
- method => "cn_browse_down",
- api_name => "open-ils.search.callnumber.browse.page_down",
- notes => "Returns the next page of callnumbers",
- );
-
-# XXX Deprecate me
-
-sub cn_browse_start {
- my( $self, $client, @params ) = @_;
- my $method;
- $method = 'open-ils.storage.asset.call_number.browse.target.atomic'
- if( $self->api_name =~ /target/ );
- $method = 'open-ils.storage.asset.call_number.browse.page_up'
- if( $self->api_name =~ /page_up/ );
- $method = 'open-ils.storage.asset.call_number.browse.page_down'
- if( $self->api_name =~ /page_down/ );
-
- return $U->simplereq( 'open-ils.storage', $method, @params );
-}
-
-
-__PACKAGE__->register_method(
- method => "cn_browse",
- api_name => "open-ils.search.callnumber.browse",
- signature => {
- desc => q/Paged call number browse/,
- params => [
- { name => 'label',
- desc => 'The target call number lable',
- type => 'string' },
- { name => 'org_unit',
- desc => 'The org unit shortname (or "-" or undef for global) to browse',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'offset',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- { name => 'statuses',
- desc => 'Array of statuses to filter copies by, optional and can be undef.',
- type => 'array' },
- { name => 'locations',
- desc => 'Array of copy locations to filter copies by, optional and can be undef.',
- type => 'array' },
- ],
- return => {
- type => 'array',
- desc => q/List of callnumber (acn) and record (mvr) objects/
- }
- }
-);
-
-sub cn_browse {
- my( $self, $conn, $cn, $orgid, $size, $offset, $copy_statuses, $copy_locations ) = @_;
- my $ses = OpenSRF::AppSession->create('open-ils.supercat');
-
- my $tree = $U->get_slim_org_tree;
- my $name = _find_shortname($orgid, $tree);
-
- $logger->debug("cn browse found or name $name");
-
- my $data = $ses->request(
- 'open-ils.supercat.call_number.browse',
- $cn, $name, $size, $offset, $copy_statuses, $copy_locations )->gather(1);
-
- return [] unless $data;
-
- my @res;
- for my $d (@$data) {
- my $mods = $U->record_to_mvr($d->record);
- $d->owning_lib( $d->owning_lib->id );
- $d->record($mods->doc_id);
- push( @res, { cn => $d, mods => $mods });
- }
-
- return \@res;
-}
-
-
-sub _find_shortname {
- my $id = shift;
- my $node = shift;
- return undef unless $node;
- return $node->shortname if $node->id == $id;
- if( $node->children ) {
- for my $c (@{$node->children()}) {
- my $d = _find_shortname($id, $c);
- return $d if $d;
- }
- }
- return undef;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Search::Serial;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-
-use OpenSRF::Utils::JSON;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::MFHDParser;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Cache;
-use Encode;
-
-use OpenSRF::Utils::Logger qw/:logger/;
-
-use Data::Dumper;
-
-use OpenSRF::Utils::JSON;
-
-use Time::HiRes qw(time);
-use OpenSRF::EX qw(:try);
-use Digest::MD5 qw(md5_hex);
-
-use XML::LibXML;
-use XML::LibXSLT;
-
-use OpenILS::Const qw/:const/;
-
-use OpenILS::Application::AppUtils;
-my $apputils = "OpenILS::Application::AppUtils";
-my $U = $apputils;
-
-my $pfx = "open-ils.search_";
-
-=over
-
-=item * mfhd_to_hash
-
-=back
-
-Takes an MFHD record ID and returns a hash of holdings statements
-
-=cut
-
-sub mfhd_to_hash {
- my ($self, $client, $id) = @_;
-
- my $session = OpenSRF::AppSession->create("open-ils.cstore");
- my $request = $session->request(
- "open-ils.cstore.direct.serial.record_entry.retrieve", $id )->gather(1);
-
- my $u = OpenILS::Utils::MFHDParser->new();
- my $mfhd_hash = $u->generate_svr( $request->id, $request->marc, $request->owning_lib );
-
- $session->disconnect();
- return $mfhd_hash;
-}
-
-__PACKAGE__->register_method(
- method => "mfhd_to_hash",
- api_name => "open-ils.search.serial.record.mfhd.retrieve",
- argc => 1,
- note => "Given a serial record ID, return MFHD holdings"
-);
-
-=over
-
-=item * bib_to_mfhd_hash
-
-=back
-
-Given a bib record ID, returns a hash of holdings statements
-
-=cut
-
-# DEFUNCT ?
-#sub bib_to_mfhd_hash {
-# my ($self, $client, $bib) = @_;
-#
-# my $mfhd_hash;
-#
-# # XXX perhaps this? --miker
-## my $e = OpenILS::Utils::CStoreEditor->new();
-## my $mfhd = $e->search_serial_record_entry({ record => $bib });
-## return $u->generate_svr( $mfhd->[0] ) if (ref $mfhd);
-## return undef;
-#
-# my @mfhd = $U->cstorereq( "open-ils.cstore.json_query.atomic", {
-# select => { sre => 'marc' },
-# from => 'sre',
-# where => { record => $bib, deleted => 'f' },
-# distinct => 1
-# });
-#
-# if (!@mfhd or scalar(@mfhd) == 0) {
-# return undef;
-# }
-#
-# my $u = OpenILS::Utils::MFHDParser->new();
-# $mfhd_hash = $u->generate_svr( $mfhd[0][0]->{id}, $mfhd[0][0]->{marc}, $mfhd[0][0]->{owning_lib} );
-#
-# return $mfhd_hash;
-#}
-#
-#__PACKAGE__->register_method(
-# method => "bib_to_mfhd_hash",
-# api_name => "open-ils.search.serial.record.bib_to_mfhd.retrieve",
-# argc => 1,
-# note => "Given a bibliographic record ID, return MFHD holdings"
-#);
-
-sub bib_to_svr {
- my ($self, $client, $bib) = @_;
-
- my $svrs = [];
-
- my $e = OpenILS::Utils::CStoreEditor->new();
- # TODO: 'deleted' ssub support
- my $sdists = $e->search_serial_distribution([{ "+ssub" => {"record_entry" => $bib} }, { "flesh" => 1, "flesh_fields" => {'sdist' => [ "record_entry", "holding_lib", "basic_summary", "supplement_summary", "index_summary" ]}, "join" => {"ssub" => {}} }]);
- my $sres = $e->search_serial_record_entry([{ record => $bib, deleted => 'f', "+sdist" => {"id" => undef} }, { "join" => {"sdist" => { 'type' => 'left' }} }]);
- if (!ref $sres and !ref $sdists) {
- return undef;
- }
-
- my $mfhd_parser = OpenILS::Utils::MFHDParser->new();
- foreach (@$sdists) {
- my $svr;
- if (ref $_->record_entry) {
- $svr = $mfhd_parser->generate_svr($_->record_entry->id, $_->record_entry->marc, $_->record_entry->owning_lib);
- } else {
- $svr = Fieldmapper::serial::virtual_record->new;
- $svr->sre_id(-1);
- $svr->location($_->holding_lib->name);
- $svr->owning_lib($_->holding_lib);
- $svr->basic_holdings([]);
- $svr->supplement_holdings([]);
- $svr->index_holdings([]);
- $svr->basic_holdings_add([]);
- $svr->supplement_holdings_add([]);
- $svr->index_holdings_add([]);
- $svr->online([]);
- $svr->missing([]);
- $svr->incomplete([]);
- }
- if (ref $_->basic_summary) { #TODO: 'show-generated' boolean on summaries
- if ($_->basic_summary->generated_coverage) {
- push(@{$svr->basic_holdings}, $_->basic_summary->generated_coverage);
- }
- if ($_->basic_summary->textual_holdings) {
- push(@{$svr->basic_holdings_add}, $_->basic_summary->textual_holdings);
- }
- }
- if (ref $_->supplement_summary) {
- if ($_->supplement_summary->generated_coverage) {
- push(@{$svr->supplement_holdings}, $_->supplement_summary->generated_coverage);
- }
- if ($_->supplement_summary->textual_holdings) {
- push(@{$svr->supplement_holdings_add}, $_->supplement_summary->textual_holdings);
- }
- }
- if (ref $_->index_summary) {
- if ($_->index_summary->generated_coverage) {
- push(@{$svr->index_holdings}, $_->index_summary->generated_coverage);
- }
- if ($_->index_summary->textual_holdings) {
- push(@{$svr->index_holdings_add}, $_->index_summary->textual_holdings);
- }
- }
- push(@$svrs, $svr);
- }
- foreach (@$sres) {
- push(@$svrs, $mfhd_parser->generate_svr($_->id, $_->marc, $_->owning_lib));
- }
-
- # do a basic location sort for simple predictability
- @$svrs = sort { $a->location cmp $b->location } @$svrs;
-
- return $svrs;
-}
-
-__PACKAGE__->register_method(
- method => "bib_to_svr",
- api_name => "open-ils.search.serial.record.bib.retrieve",
- argc => 1,
- note => "Given a bibliographic record ID, return holdings in svr form"
-);
-
-1;
+++ /dev/null
-package OpenILS::Application::Search::Z3950;
-use strict; use warnings;
-use base qw/OpenILS::Application/;
-
-use OpenILS::Utils::ZClient;
-use MARC::Record;
-use MARC::File::XML;
-use Unicode::Normalize;
-use XML::LibXML;
-
-use OpenILS::Event;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::ModsParser;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-
-my $output = "usmarc";
-my $U = 'OpenILS::Application::AppUtils';
-
-my $sclient;
-my %services;
-my $default_service;
-
-
-__PACKAGE__->register_method(
- method => 'do_class_search',
- api_name => 'open-ils.search.z3950.search_class',
- stream => 1,
- signature => q/
- Performs a class based Z search. The classes available
- are defined by the 'attr' fields in the config for the
- requested service.
- @param auth The login session key
- @param shash The search hash : { attr : value, attr2: value, ...}
- @param service The service to connect to
- @param username The username to use when connecting to the service
- @param password The password to use when connecting to the service
- /
-);
-
-__PACKAGE__->register_method(
- method => 'do_service_search',
- api_name => 'open-ils.search.z3950.search_service',
- signature => q/
- @param auth The login session key
- @param query The Z3950 search string to use
- @param service The service to connect to
- @param username The username to use when connecting to the service
- @param password The password to use when connecting to the service
- /
-);
-
-
-__PACKAGE__->register_method(
- method => 'do_service_search',
- api_name => 'open-ils.search.z3950.search_raw',
- signature => q/
- @param auth The login session key
- @param args An object of search params which must include:
- host, port, db and query.
- optional fields include username and password
- /
-);
-
-
-__PACKAGE__->register_method(
- method => "query_services",
- api_name => "open-ils.search.z3950.retrieve_services",
- signature => q/
- Returns a list of service names that we have config
- data for
- /
-);
-
-
-
-# -------------------------------------------------------------------
-# What services do we have config info for?
-# -------------------------------------------------------------------
-sub query_services {
- my( $self, $client, $auth ) = @_;
- my $e = new_editor(authtoken=>$auth);
- return $e->event unless $e->checkauth;
- return $e->event unless $e->allowed('REMOTE_Z3950_QUERY');
-
- return fetch_service_defs();
-}
-
-# -------------------------------------------------------------------
-# What services do we have config info for?
-# -------------------------------------------------------------------
-sub fetch_service_defs {
-
- my $hash = $sclient->config_value('z3950', 'services');
-
- # overlay config file values with in-db values
- my $e = new_editor();
- if($e->can('search_config_z3950_source')) {
-
- my $sources = $e->search_config_z3950_source(
- [ { name => { '!=' => undef } },
- { flesh => 1, flesh_fields => { czs => ['attrs'] } } ]
- );
-
- for my $s ( @$sources ) {
- $$hash{ $s->name } = {
- name => $s->name,
- label => $s->label,
- host => $s->host,
- port => $s->port,
- db => $s->db,
- record_format => $s->record_format,
- transmission_format => $s->transmission_format,
- auth => $s->auth,
- };
-
- for my $a ( @{ $s->attrs } ) {
- $$hash{ $a->source }{attrs}{ $a->name } = {
- name => $a->name,
- label => $a->label,
- code => $a->code,
- format => $a->format,
- source => $a->source,
- truncation => $a->truncation,
- };
- }
- }
- }
-
- # Define the set of native catalog services
- # XXX There are i18n problems here, but let's get the staff client working first
- # XXX Move into the DB?
- $hash->{'native-evergreen-catalog'} = {
- attrs => {
- title => {code => 'title', label => 'Title'},
- author => {code => 'author', label => 'Author'},
- subject => {code => 'subject', label => 'Subject'},
- keyword => {code => 'keyword', label => 'Keyword'},
- tcn => {code => 'tcn', label => 'TCN'},
- isbn => {code => 'isbn', label => 'ISBN'},
- issn => {code => 'issn', label => 'ISSN'},
- publisher => {code => 'publisher', label => 'Publisher'},
- pubdate => {code => 'pubdate', label => 'Pub Date'},
- item_type => {code => 'item_type', label => 'Item Type'},
- }
- };
-
- %services = %$hash; # cache these internally so we can actually use the db-configured sources
- return $hash;
-}
-
-
-
-# -------------------------------------------------------------------
-# Load the pre-defined Z server configs
-# -------------------------------------------------------------------
-sub child_init {
- $sclient = OpenSRF::Utils::SettingsClient->new();
- $default_service = $sclient->config_value("z3950", "default" );
-}
-
-
-# -------------------------------------------------------------------
-# High-level class based search.
-# -------------------------------------------------------------------
-sub do_class_search {
-
- fetch_service_defs() unless (scalar(keys(%services)));
-
- my $self = shift;
- my $conn = shift;
- my $auth = shift;
- my $args = shift;
-
- if (!ref($$args{service})) {
- $$args{service} = [$$args{service}];
- $$args{username} = [$$args{username}];
- $$args{password} = [$$args{password}];
- }
-
- $$args{async} = 1;
-
- my @connections;
- my @results;
- my @services;
- for (my $i = 0; $i < @{$$args{service}}; $i++) {
- my %tmp_args = %$args;
- $tmp_args{service} = $$args{service}[$i];
- $tmp_args{username} = $$args{username}[$i];
- $tmp_args{password} = $$args{password}[$i];
-
- $logger->debug("z3950: service: $tmp_args{service}, async: $tmp_args{async}");
-
- if ($tmp_args{service} eq 'native-evergreen-catalog') {
- my $method = $self->method_lookup('open-ils.search.biblio.zstyle.staff');
- $conn->respond(
- $self->method_lookup('open-ils.search.biblio.zstyle.staff')->run($auth, \%tmp_args)
- );
-
- } else {
-
- $tmp_args{query} = compile_query('and', $tmp_args{service}, $tmp_args{search});
-
- my $res = do_service_search( $self, $conn, $auth, \%tmp_args );
-
- if ($U->event_code($res)) {
- $conn->respond($res) if $U->event_code($res);
-
- } else {
- push @services, $tmp_args{service};
- push @results, $res->{result};
- push @connections, $res->{connection};
- }
- }
-
- $logger->debug("z3950: Result object: $results[$i], Connection object: $connections[$i]");
- }
-
- $logger->debug("z3950: Connections created");
-
- return undef unless (@connections);
- my @records;
-
- # local catalog search is not processed with other z39 results;
- $$args{service} = [grep {$_ ne 'native-evergreen-catalog'} @{$$args{service}}];
-
- @connections = grep {defined $_} @connections;
- return undef unless @connections;
-
- while ((my $index = OpenILS::Utils::ZClient::event( \@connections )) != 0) {
- my $ev = $connections[$index - 1]->last_event();
- $logger->debug("z3950: Received event $ev");
- if ($ev == OpenILS::Utils::ZClient::EVENT_END()) {
- my $munged = process_results( $results[$index - 1], $$args{limit}, $$args{offset}, $$args{service}[$index -1] );
- $$munged{service} = $$args{service}[$index - 1];
- $conn->respond($munged);
- }
- }
-
- $logger->debug("z3950: Search Complete");
- return undef;
-}
-
-
-# -------------------------------------------------------------------
-# This handles the host settings, but expects a fully formed z query
-# -------------------------------------------------------------------
-sub do_service_search {
-
- fetch_service_defs() unless (scalar(keys(%services)));
-
- my $self = shift;
- my $conn = shift;
- my $auth = shift;
- my $args = shift;
-
- my $info = $services{$$args{service}};
-
- $$args{host} = $$info{host};
- $$args{port} = $$info{port};
- $$args{db} = $$info{db};
- $logger->debug("z3950: do_search...");
-
- return do_search( $self, $conn, $auth, $args );
-}
-
-
-
-# -------------------------------------------------------------------
-# This is the low level search method. All config and query
-# data must be provided to this method
-# -------------------------------------------------------------------
-sub do_search {
-
- fetch_service_defs() unless (scalar(keys(%services)));
-
- my $self = shift;
- my $conn = shift;
- my $auth = shift;
- my $args = shift;
-
- my $host = $$args{host} or return undef;
- my $port = $$args{port} or return undef;
- my $db = $$args{db} or return undef;
- my $query = $$args{query} or return undef;
- my $async = $$args{async} || 0;
-
- my $limit = $$args{limit} || 10;
- my $offset = $$args{offset} || 0;
-
- my $username = $$args{username} || "";
- my $password = $$args{password} || "";
-
- my $tformat = $services{$args->{service}}->{transmission_format} || $output;
-
- my $editor = new_editor(authtoken => $auth);
- return $editor->event unless $editor->checkauth;
- return $editor->event unless $editor->allowed('REMOTE_Z3950_QUERY');
-
- $logger->info("z3950: connecting to server $host:$port:$db as $username");
-
- my $connection = OpenILS::Utils::ZClient->new(
- $host, $port,
- databaseName => $db,
- user => $username,
- password => $password,
- async => $async,
- preferredRecordSyntax => $tformat,
- );
-
- if( ! $connection ) {
- $logger->error("z3950: Unable to connect to Z server: ".
- "$host:$port:$db:$username:$password");
- return OpenILS::Event->new('Z3950_LOGIN_FAILED') unless $connection;
- }
-
- my $start = time;
- my $results;
- my $err;
-
- $logger->info("z3950: query => $query");
-
- try {
- $results = $connection->search_pqf( $query );
- } catch Error with { $err = shift; };
-
- return OpenILS::Event->new(
- 'Z3950_BAD_QUERY', payload => $query, debug => "$err") if $err;
-
- return OpenILS::Event->new('Z3950_SEARCH_FAILED',
- debug => $connection->errcode." => ".$connection->errmsg." : query = $query") unless $results;
-
- $logger->info("z3950: search [$query] took ".(time - $start)." seconds");
-
- return {result => $results, connection => $connection} if ($async);
-
- my $munged = process_results($results, $limit, $offset, $$args{service});
- $munged->{query} = $query;
-
- return $munged;
-}
-
-
-# -------------------------------------------------------------------
-# Takes a result batch and returns the hitcount and a list of xml
-# and mvr objects
-# -------------------------------------------------------------------
-sub process_results {
-
- fetch_service_defs() unless (scalar(keys(%services)));
-
- my $results = shift;
- my $limit = shift || 10;
- my $offset = shift || 0;
- my $service = shift;
-
- my $rformat = $services{$service}->{record_format};
- my $tformat = $services{$service}->{transmission_format} || $output;
-
- $results->option(elementSetName => $rformat);
- $results->option(preferredRecordSyntax => $tformat);
- $logger->info("z3950: using record format '$rformat' and transmission format '$tformat'");
-
- my @records;
- my $res = {};
- my $count = $$res{count} = $results->size;
-
- $logger->info("z3950: search returned $count hits");
-
- my $tend = $limit + $offset;
-
- my $end = ($tend <= $count) ? $tend : $count;
-
- for($offset..$end - 1) {
-
- my $err;
- my $mods;
- my $marc;
- my $marcs;
- my $marcxml;
-
- $logger->info("z3950: fetching record $_");
-
- try {
-
- my $rec = $results->record($_);
-
- if ($tformat eq 'usmarc') {
- $marc = MARC::Record->new_from_usmarc($rec->raw());
- } elsif ($tformat eq 'xml') {
- $marc = MARC::Record->new_from_xml($rec->raw());
- } else {
- die "Unsupported record transmission format $tformat"
- }
-
- $marcs = $U->entityize($marc->as_xml_record);
- $marcs = $U->strip_ctrl_chars($marcs);
- my $doc = XML::LibXML->new->parse_string($marcs);
- $marcxml = $U->entityize($doc->documentElement->toString);
- $marcxml = $U->strip_ctrl_chars($marcxml);
-
- my $u = OpenILS::Utils::ModsParser->new();
- $u->start_mods_batch( $marcxml );
- $mods = $u->finish_mods_batch();
-
-
- } catch Error with { $err = shift; };
-
- push @records, { 'mvr' => $mods, 'marcxml' => $marcxml } unless $err;
- $logger->error("z3950: bad XML : $err") if $err;
-
- if( $err ) {
- warn "\n\n$marcs\n\n";
- }
- }
-
- $res->{records} = \@records;
- return $res;
-}
-
-
-
-# -------------------------------------------------------------------
-# Compiles the class based search query
-# -------------------------------------------------------------------
-sub compile_query {
-
- fetch_service_defs() unless (scalar(keys(%services)));
-
- my $separator = shift;
- my $service = shift;
- my $hash = shift;
-
- my $count = scalar(keys %$hash);
-
- my $str = "";
- $str .= "\@$separator " for (1..$count-1);
-
- # -------------------------------------------------------------------
- # "code" is the bib-1 "use attribute", "format" is the bib-1
- # "structure attribute"
- # -------------------------------------------------------------------
- for( keys %$hash ) {
- next unless ( exists $services{$service}->{attrs}->{$_} );
- $str .= '@attr 1=' . $services{$service}->{attrs}->{$_}->{code} . # add the use attribute
- ' @attr 4=' . $services{$service}->{attrs}->{$_}->{format}; # add the structure attribute
- if (exists $services{$service}->{attrs}->{$_}->{truncation}
- && $services{$service}->{attrs}->{$_}->{truncation} >= 0) {
- $str .= ' @attr 5=' . $services{$service}->{attrs}->{$_}->{truncation};
- }
- $str .= " \"" . $$hash{$_} . "\" "; # add the search term
- }
- return $str;
-}
-
-1;
-# vim:et:ts=4:sw=4:
+++ /dev/null
-package OpenILS::Application::Search::Zips;
-use base qw/OpenILS::Application/;
-use strict; use warnings;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::Editor;
-use OpenSRF::Utils::SettingsClient;
-
-my %zips;
-
-# -----------------------------------------------------------------
-# Reads zip code information from a file. File format is :
-# ID|StateAbb|City|Zip|IsDefault|StateID|County|AreaCode
-# Currently, StateAbb, City, Zip, County, AreaCode are used.
-# IsDefault should be set to 1
-# -----------------------------------------------------------------
-
-sub initialize {
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $zfile = $conf->config_value(
- "apps", "open-ils.search", "app_settings", "zips_file");
- return 1 unless $zfile and -f $zfile;
-
- $logger->info("search loaded zips file $zfile");
- open(F,$zfile);
- my @data = <F>;
- close(F);
-
- for(@data) {
- chomp $_;
- my @items = split(/\|/, "$_");
- my $items = {
- state => $items[1],
- city => $items[2],
- zip => $items[3],
- stateid => $items[5],
- county => $items[6],
- areacode => $items[7],
- alert => $items[8]
- };
-
- next unless $items[4] eq '1';
- $zips{$$items{zip}} = $items;
- }
-}
-
-__PACKAGE__->register_method(
- method => 'search_zip',
- api_name => 'open-ils.search.zip',
- signature => q/
- Given a zip code, returns address info for the zip code
- @param auth the login session key
- @param zip The zip code to check
- @return On success, returns an object of the form:
- { state=>, city=>, zip=>, stateid=>, county=>, areacode=>}
- returns event on error
- /
-);
-sub search_zip {
- #my( $self, $conn, $auth, $zip ) = @_;
- #my $e = OpenILS::Utils::Editor->new(authtoken=>$auth);
- #return $e->event unless $e->checkauth;
- #return $e->event unless $e->allowed('VIEW_ZIP_DATA');
- my( $self, $conn, $zip ) = @_;
- $zip =~ s/(^\d{5}).*/$1/; # we don't care about the last 4 digits if they exist
- return $zips{$zip};
-}
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-
-=head1 NAME
-
-OpenILS::Application::Serial - Performs serials-related tasks such as receiving issues and generating predictions
-
-=head1 SYNOPSIS
-
-TBD
-
-=head1 DESCRIPTION
-
-TBD
-
-=head1 AUTHOR
-
-Dan Wells, dbw2@calvin.edu
-
-=cut
-
-package OpenILS::Application::Serial;
-
-use strict;
-use warnings;
-
-
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Event;
-use OpenSRF::AppSession;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::MFHD;
-use DateTime::Format::ISO8601;
-use MARC::File::XML (BinaryEncoding => 'utf8');
-my $U = 'OpenILS::Application::AppUtils';
-my @MFHD_NAMES = ('basic','supplement','index');
-my %MFHD_NAMES_BY_TAG = ( '853' => $MFHD_NAMES[0],
- '863' => $MFHD_NAMES[0],
- '854' => $MFHD_NAMES[1],
- '864' => $MFHD_NAMES[1],
- '855' => $MFHD_NAMES[2],
- '865' => $MFHD_NAMES[2] );
-my %MFHD_TAGS_BY_NAME = ( $MFHD_NAMES[0] => '853',
- $MFHD_NAMES[1] => '854',
- $MFHD_NAMES[2] => '855');
-my $_strp_date = new DateTime::Format::Strptime(pattern => '%F');
-
-# helper method for conforming dates to ISO8601
-sub _cleanse_dates {
- my $item = shift;
- my $fields = shift;
-
- foreach my $field (@$fields) {
- $item->$field(OpenSRF::Utils::clense_ISO8601($item->$field)) if $item->$field;
- }
- return 0;
-}
-
-sub _get_mvr {
- $U->simplereq(
- "open-ils.search",
- "open-ils.search.biblio.record.mods_slim.retrieve",
- @_
- );
-}
-
-
-##########################################################################
-# item methods
-#
-__PACKAGE__->register_method(
- method => "create_item_safely",
- api_name => "open-ils.serial.item.create",
- api_level => 1,
- stream => 1,
- argc => 3,
- signature => {
- desc => q/Creates any number of items, respecting only a few of the
- submitted fields, as the user shouldn't be able to freely set certain
- ones/,
- params => [
- {name=> "authtoken", desc => "Authtoken for current user session",
- type => "string"},
- {name => "item", desc => "serial item",
- type => "object", class => "sitem"},
- {name => "count",
- desc => "optional: how many items to make " .
- "(default 1; 1-100 permitted)",
- type => "number"}
- ],
- return => {
- desc => "created items (a stream of them)",
- type => "object", class => "sitem"
- }
- }
-);
-__PACKAGE__->register_method(
- method => "update_item_safely",
- api_name => "open-ils.serial.item.update",
- api_level => 1,
- stream => 1,
- argc => 2,
- signature => {
- desc => q/Edit a serial item, respecting only a few of the
- submitted fields, as the user shouldn't be able to freely set certain
- ones/,
- params => [
- {name=> "authtoken", desc => "Authtoken for current user session",
- type => "string"},
- {name => "item", desc => "serial item",
- type => "object", class => "sitem"},
- ],
- return => {
- desc => "created item", type => "object", class => "sitem"
- }
- }
-);
-
-sub _set_safe_item_fields {
- my $dest = shift;
- my $source = shift;
- my $requestor_id = shift;
- # extra fields remain in @_
-
- $dest->edit_date("now");
- $dest->editor($requestor_id);
-
- my @fields = qw/date_expected date_received status/;
-
- for my $field (@fields, @_) {
- $dest->$field($source->$field);
- }
-}
-
-sub update_item_safely {
- my ($self, $client, $auth, $item) = @_;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- $e->checkauth or return $e->die_event;
-
- my $orig = $e->retrieve_serial_item([
- $item->id, {
- "flesh" => 2, "flesh_fields" => {
- "sitem" => ["stream"], "sstr" => ["distribution"]
- }
- }
- ]) or return $e->die_event;
-
- return $e->die_event unless $e->allowed(
- "ADMIN_SERIAL_ITEM", $orig->stream->distribution->holding_lib
- );
-
- _set_safe_item_fields($orig, $item, $e->requestor->id);
- $e->update_serial_item($orig) or return $e->die_event;
-
- $client->respond($e->retrieve_serial_item($item->id));
- $e->commit or return $e->die_event;
- undef;
-}
-
-sub create_item_safely {
- my ($self, $client, $auth, $item, $count) = @_;
-
- $count = int $count;
- $count ||= 1;
- return new OpenILS::Event(
- "BAD_PARAMS", note => "Count should be from 1 to 100"
- ) unless $count >= 1 and $count <= 100;
-
- my $e = new_editor("xact" => 1, "authtoken" => $auth);
- $e->checkauth or return $e->die_event;
-
- my $stream = $e->retrieve_serial_stream([
- $item->stream, {
- "flesh" => 1, "flesh_fields" => {"sstr" => ["distribution"]}
- }
- ]) or return $e->die_event;
-
- return $e->die_event unless $e->allowed(
- "ADMIN_SERIAL_ITEM", $stream->distribution->holding_lib
- );
-
- for (my $i = 0; $i < $count; $i++) {
- my $actual = new Fieldmapper::serial::item;
- $actual->creator($e->requestor->id);
- _set_safe_item_fields(
- $actual, $item, $e->requestor->id, "issuance", "stream"
- );
-
- $e->create_serial_item($actual) or return $e->die_event;
- $client->respond($e->data);
- }
-
- $e->commit or return $e->die_event;
- undef;
-}
-
-__PACKAGE__->register_method(
- method => 'fleshed_item_alter',
- api_name => 'open-ils.serial.item.fleshed.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more items and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'items',
- desc => 'Array of fleshed items',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub fleshed_item_alter {
- my( $self, $conn, $auth, $items ) = @_;
- return 1 unless ref $items;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission check
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $item (@$items) {
-
- my $itemid = $item->id;
- $item->editor($editor->requestor->id);
- $item->edit_date('now');
-
- if( $item->isdeleted ) {
- $evt = _delete_sitem( $editor, $override, $item);
- } elsif( $item->isnew ) {
- # TODO: reconsider this
- # if the item has a new issuance, create the issuance first
- if (ref $item->issuance eq 'Fieldmapper::serial::issuance' and $item->issuance->isnew) {
- fleshed_issuance_alter($self, $conn, $auth, [$item->issuance]);
- }
- _cleanse_dates($item, ['date_expected','date_received']);
- $evt = _create_sitem( $editor, $item );
- } else {
- _cleanse_dates($item, ['date_expected','date_received']);
- $evt = _update_sitem( $editor, $override, $item );
- }
- }
-
- if( $evt ) {
- $logger->info("fleshed item-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("item-alter: done updating item batch");
- $editor->commit;
- $logger->info("fleshed item-alter successfully updated ".scalar(@$items)." items");
- return 1;
-}
-
-sub _delete_sitem {
- my ($editor, $override, $item) = @_;
- $logger->info("item-alter: delete item ".OpenSRF::Utils::JSON->perl2JSON($item));
- return $editor->event unless $editor->delete_serial_item($item);
- return 0;
-}
-
-sub _create_sitem {
- my ($editor, $item) = @_;
-
- $item->creator($editor->requestor->id);
- $item->create_date('now');
-
- $logger->info("item-alter: new item ".OpenSRF::Utils::JSON->perl2JSON($item));
- return $editor->event unless $editor->create_serial_item($item);
- return 0;
-}
-
-sub _update_sitem {
- my ($editor, $override, $item) = @_;
-
- $logger->info("item-alter: retrieving item ".$item->id);
- my $orig_item = $editor->retrieve_serial_item($item->id);
-
- $logger->info("item-alter: original item ".OpenSRF::Utils::JSON->perl2JSON($orig_item));
- $logger->info("item-alter: updated item ".OpenSRF::Utils::JSON->perl2JSON($item));
- return $editor->event unless $editor->update_serial_item($item);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "fleshed_serial_item_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.item.fleshed.batch.retrieve"
-);
-
-sub fleshed_serial_item_retrieve_batch {
- my( $self, $client, $ids ) = @_;
-# FIXME: permissions?
- $logger->info("Fetching fleshed serial items @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.item.search.atomic",
- { id => $ids },
- { flesh => 2,
- flesh_fields => {sitem => [ qw/issuance creator editor stream unit notes/ ], sstr => ["distribution"], sunit => ["call_number"], siss => [qw/creator editor subscription/]}
- });
-}
-
-
-##########################################################################
-# issuance methods
-#
-__PACKAGE__->register_method(
- method => 'fleshed_issuance_alter',
- api_name => 'open-ils.serial.issuance.fleshed.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more issuances and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'issuances',
- desc => 'Array of fleshed issuances',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub fleshed_issuance_alter {
- my( $self, $conn, $auth, $issuances ) = @_;
- return 1 unless ref $issuances;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission support
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $issuance (@$issuances) {
- my $issuanceid = $issuance->id;
- $issuance->editor($editor->requestor->id);
- $issuance->edit_date('now');
-
- if( $issuance->isdeleted ) {
- $evt = _delete_siss( $editor, $override, $issuance);
- } elsif( $issuance->isnew ) {
- _cleanse_dates($issuance, ['date_published']);
- $evt = _create_siss( $editor, $issuance );
- } else {
- _cleanse_dates($issuance, ['date_published']);
- $evt = _update_siss( $editor, $override, $issuance );
- }
- }
-
- if( $evt ) {
- $logger->info("fleshed issuance-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("issuance-alter: done updating issuance batch");
- $editor->commit;
- $logger->info("fleshed issuance-alter successfully updated ".scalar(@$issuances)." issuances");
- return 1;
-}
-
-sub _delete_siss {
- my ($editor, $override, $issuance) = @_;
- $logger->info("issuance-alter: delete issuance ".OpenSRF::Utils::JSON->perl2JSON($issuance));
- return $editor->event unless $editor->delete_serial_issuance($issuance);
- return 0;
-}
-
-sub _create_siss {
- my ($editor, $issuance) = @_;
-
- $issuance->creator($editor->requestor->id);
- $issuance->create_date('now');
-
- $logger->info("issuance-alter: new issuance ".OpenSRF::Utils::JSON->perl2JSON($issuance));
- return $editor->event unless $editor->create_serial_issuance($issuance);
- return 0;
-}
-
-sub _update_siss {
- my ($editor, $override, $issuance) = @_;
-
- $logger->info("issuance-alter: retrieving issuance ".$issuance->id);
- my $orig_issuance = $editor->retrieve_serial_issuance($issuance->id);
-
- $logger->info("issuance-alter: original issuance ".OpenSRF::Utils::JSON->perl2JSON($orig_issuance));
- $logger->info("issuance-alter: updated issuance ".OpenSRF::Utils::JSON->perl2JSON($issuance));
- return $editor->event unless $editor->update_serial_issuance($issuance);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "fleshed_serial_issuance_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.issuance.fleshed.batch.retrieve"
-);
-
-sub fleshed_serial_issuance_retrieve_batch {
- my( $self, $client, $ids ) = @_;
-# FIXME: permissions?
- $logger->info("Fetching fleshed serial issuances @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.issuance.search.atomic",
- { id => $ids },
- { flesh => 1,
- flesh_fields => {siss => [ qw/creator editor subscription/ ]}
- });
-}
-
-__PACKAGE__->register_method(
- method => "pub_fleshed_serial_issuance_retrieve_batch",
- api_name => "open-ils.serial.issuance.pub_fleshed.batch.retrieve",
- signature => {
- desc => q/
- Public (i.e. OPAC) call for getting at the sub and
- ultimately the record entry from an issuance
- /,
- params => [{name => 'ids', desc => 'Array of IDs', type => 'array'}],
- return => {
- desc => q/
- issuance objects, fleshed with subscriptions
- /,
- class => 'siss'
- }
- }
-);
-sub pub_fleshed_serial_issuance_retrieve_batch {
- my( $self, $client, $ids ) = @_;
- return [] unless $ids and @$ids;
- return new_editor()->search_serial_issuance([
- { id => $ids },
- {
- flesh => 1,
- flesh_fields => {siss => [ qw/subscription/ ]}
- }
- ]);
-}
-
-sub received_siss_by_bib {
- my $self = shift;
- my $client = shift;
- my $bib = shift;
-
- my $args = shift || {};
- $$args{order} ||= 'asc';
-
- my $global = $$args{global} == 0 ? 0 : 1;
-
- my $e = new_editor();
- my $issuances = $e->json_query({
- select => {
- siss => [
- $global ? { transform => "min", column => "id", aggregate => 1 } : "id",
- "label",
- "date_published"
- ],
- "sitem" => [
- # We're not really interested in the minimum here. This is
- # just a way to distinguish issuances whose items have units
- # from issuances whose items have no units, without altogether
- # excluding the latter type of issuances.
- {"transform" => "min", "alias" => "has_units",
- "column" => "unit", "aggregate" => 1}
- ]
- },
- from => {
- ssub => {
- siss => {
- field => 'subscription',
- fkey => 'id',
- join => {
- sitem => {
- field => 'issuance',
- fkey => 'id',
- $$args{ou} ? ( join => {
- sstr => {
- field => 'id',
- fkey => 'stream',
- join => {
- sdist => {
- field => 'id',
- fkey => 'distribution'
- }
- }
- }
- }) : ()
- }
- }
- }
- }
- },
- where => {
- '+ssub' => { record_entry => $bib },
- $$args{type} ? ( '+siss' => { 'holding_type' => $$args{type} } ) : (),
- '+sitem' => {
- # XXX should we also take specific item statuses into account?
- date_received => { '!=' => undef },
- $$args{status} ? ( 'status' => $$args{status} ) : ()
- },
- $$args{ou} ? ( '+sdist' => {
- holding_lib => {
- 'in' => $U->get_org_descendants($$args{ou}, $$args{depth})
- }
- }) : ()
- },
- $$args{limit} ? ( limit => $$args{limit} ) : (),
- $$args{offset} ? ( offset => $$args{offset} ) : (),
- order_by => [{ class => 'siss', field => 'date_published', direction => $$args{order} }],
- distinct => 1
- });
-
- $client->respond({
- "issuance" => $e->retrieve_serial_issuance($_->{"id"}),
- "has_units" => $_->{"has_units"} ? 1 : 0
- }) for @$issuances;
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'received_siss_by_bib',
- api_name => 'open-ils.serial.received_siss.retrieve.by_bib',
- api_level => 1,
- argc => 1,
- stream => 1,
- signature => {
- desc => 'Receives a Bib ID and other optional params and returns "siss" (issuance) objects',
- params => [
- { name => 'bibid',
- desc => 'id of the bre to which the issuances belong',
- type => 'number'
- },
- { name => 'args',
- desc =>
-q/A hash of optional arguments. Valid keys and their meanings:
- global := If true, return only one representative version of a conceptual issuance regardless of the number of subscriptions, otherwise return all issuance objects meeting the requested criteria, including conceptual duplicates. Valid values are 0 (false) and 1 (true, default).
- order := date_published sort direction, either "asc" (chronological, default) or "desc" (reverse chronological)
- limit := Number of issuances to return. Useful for paging results, or finding the oldest or newest
- offset := Number of issuance to skip before returning results. Useful for paging.
- orgid := OU id used to scope retrieval, based on distribution.holding_lib
- depth := OU depth used to range the scope of orgid
- type := Holding type filter. Valid values are "basic", "supplement" and "index". Can be a scalar (one) or arrayref (one or more).
- status := Item status filter. Valid values are "Bindery", "Bound", "Claimed", "Discarded", "Expected", "Not Held", "Not Published" and "Received". Can be a scalar (one) or arrayref (one or more).
-/
- }
- ]
- }
-);
-
-
-sub scoped_bib_holdings_summary {
- my $self = shift;
- my $client = shift;
- my $bibid = shift;
- my $args = shift || {};
-
- $args->{order} = 'asc';
-
- my ($issuances) = $self->method_lookup('open-ils.serial.received_siss.retrieve.by_bib.atomic')->run( $bibid => $args );
-
- # split into issuance type sets
- my %type_blob = (basic => [], supplement => [], index => []);
- push @{ $type_blob{ $_->{"issuance"}->holding_type } }, $_->{"issuance"}
- for (@$issuances);
-
- # generate a statement list for each type
- my %statement_blob;
- for my $type ( keys %type_blob ) {
- my ($mfhd,$list) = _summarize_contents(new_editor(), $type_blob{$type});
- $statement_blob{$type} = $list;
- }
-
- return \%statement_blob;
-}
-__PACKAGE__->register_method(
- method => 'scoped_bib_holdings_summary',
- api_name => 'open-ils.serial.bib.summary_statements',
- api_level => 1,
- argc => 1,
- signature => {
- desc => 'Receives a Bib ID and other optional params and returns set of holdings statements',
- params => [
- { name => 'bibid',
- desc => 'id of the bre to which the issuances belong',
- type => 'number'
- },
- { name => 'args',
- desc =>
-q/A hash of optional arguments. Valid keys and their meanings:
- orgid := OU id used to scope retrieval, based on distribution.holding_lib
- depth := OU depth used to range the scope of orgid
- type := Holding type filter. Valid values are "basic", "supplement" and "index". Can be a scalar (one) or arrayref (one or more).
- status := Item status filter. Valid values are "Bindery", "Bound", "Claimed", "Discarded", "Expected", "Not Held", "Not Published" and "Received". Can be a scalar (one) or arrayref (one or more).
-/
- }
- ]
- }
-);
-
-
-##########################################################################
-# unit methods
-#
-__PACKAGE__->register_method(
- method => 'fleshed_sunit_alter',
- api_name => 'open-ils.serial.sunit.fleshed.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more Units and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'sunits',
- desc => 'Array of fleshed Units',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub fleshed_sunit_alter {
- my( $self, $conn, $auth, $sunits ) = @_;
- return 1 unless ref $sunits;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission support
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $sunit (@$sunits) {
- if( $sunit->isdeleted ) {
- $evt = _delete_sunit( $editor, $override, $sunit );
- } else {
- $sunit->default_location( $sunit->default_location->id ) if ref $sunit->default_location;
-
- if( $sunit->isnew ) {
- $evt = _create_sunit( $editor, $sunit );
- } else {
- $evt = _update_sunit( $editor, $override, $sunit );
- }
- }
- }
-
- if( $evt ) {
- $logger->info("fleshed sunit-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("sunit-alter: done updating sunit batch");
- $editor->commit;
- $logger->info("fleshed sunit-alter successfully updated ".scalar(@$sunits)." Units");
- return 1;
-}
-
-sub _delete_sunit {
- my ($editor, $override, $sunit) = @_;
- $logger->info("sunit-alter: delete sunit ".OpenSRF::Utils::JSON->perl2JSON($sunit));
- return $editor->event unless $editor->delete_serial_unit($sunit);
- return 0;
-}
-
-sub _create_sunit {
- my ($editor, $sunit) = @_;
-
- $logger->info("sunit-alter: new Unit ".OpenSRF::Utils::JSON->perl2JSON($sunit));
- return $editor->event unless $editor->create_serial_unit($sunit);
- return 0;
-}
-
-sub _update_sunit {
- my ($editor, $override, $sunit) = @_;
-
- $logger->info("sunit-alter: retrieving sunit ".$sunit->id);
- my $orig_sunit = $editor->retrieve_serial_unit($sunit->id);
-
- $logger->info("sunit-alter: original sunit ".OpenSRF::Utils::JSON->perl2JSON($orig_sunit));
- $logger->info("sunit-alter: updated sunit ".OpenSRF::Utils::JSON->perl2JSON($sunit));
- return $editor->event unless $editor->update_serial_unit($sunit);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_unit_list",
- authoritative => 1,
- api_name => "open-ils.serial.unit_list.retrieve"
-);
-
-sub retrieve_unit_list {
-
- my( $self, $client, @sdist_ids ) = @_;
-
- if(ref($sdist_ids[0])) { @sdist_ids = @{$sdist_ids[0]}; }
-
- my $e = new_editor();
-
- my $query = {
- 'select' =>
- { 'sunit' => [ 'id', 'summary_contents', 'sort_key' ],
- 'sitem' => ['stream'],
- 'sstr' => ['distribution'],
- 'sdist' => [{'column' => 'label', 'alias' => 'sdist_label'}]
- },
- 'from' =>
- { 'sdist' =>
- { 'sstr' =>
- { 'join' =>
- { 'sitem' =>
- { 'join' => { 'sunit' => {} } }
- }
- }
- }
- },
- 'distinct' => 'true',
- 'where' => { '+sdist' => {'id' => \@sdist_ids} },
- 'order_by' => [{'class' => 'sunit', 'field' => 'sort_key'}]
- };
-
- my $unit_list_entries = $e->json_query($query);
-
- my @entries;
- foreach my $entry (@$unit_list_entries) {
- my $value = {'sunit' => $entry->{id}, 'sstr' => $entry->{stream}, 'sdist' => $entry->{distribution}};
- my $label = $entry->{summary_contents};
- if (length($label) > 100) {
- $label = substr($label, 0, 100) . '...'; # limited space in dropdown / menu
- }
- $label = "[$entry->{sdist_label}/$entry->{stream} #$entry->{id}] " . $label;
- push (@entries, [$label, OpenSRF::Utils::JSON->perl2JSON($value)]);
- }
-
- return \@entries;
-}
-
-
-
-##########################################################################
-# predict and receive methods
-#
-__PACKAGE__->register_method(
- method => 'make_predictions',
- api_name => 'open-ils.serial.make_predictions',
- api_level => 1,
- argc => 1,
- signature => {
- desc => 'Receives an ssub id and populates the issuance and item tables',
- 'params' => [ {
- name => 'ssub_id',
- desc => 'Serial Subscription ID',
- type => 'int'
- }
- ]
- }
-);
-
-sub make_predictions {
- my ($self, $conn, $authtoken, $args) = @_;
-
- my $editor = OpenILS::Utils::CStoreEditor->new();
- my $ssub_id = $args->{ssub_id};
- my $mfhd = MFHD->new(MARC::Record->new());
-
- my $ssub = $editor->retrieve_serial_subscription([$ssub_id]);
- my $scaps = $editor->search_serial_caption_and_pattern({ subscription => $ssub_id, active => 't'});
- my $sdists = $editor->search_serial_distribution( [{ subscription => $ssub->id }, { flesh => 1, flesh_fields => {sdist => [ qw/ streams / ]} }] ); #TODO: 'deleted' support?
-
- my $total_streams = 0;
- foreach (@$sdists) {
- $total_streams += scalar(@{$_->streams});
- }
- if ($total_streams < 1) {
- $editor->disconnect;
- # XXX TODO new event type
- return new OpenILS::Event(
- "BAD_PARAMS", note =>
- "There are no streams to direct items. Can't predict."
- );
- }
-
- unless (@$scaps) {
- $editor->disconnect;
- # XXX TODO new event type
- return new OpenILS::Event(
- "BAD_PARAMS", note =>
- "There are no active caption-and-pattern objects associated " .
- "with this subscription. Can't predict."
- );
- }
-
- my @predictions;
- my $link_id = 1;
- foreach my $scap (@$scaps) {
- my $caption_field = _revive_caption($scap);
- $caption_field->update('8' => $link_id);
- my $using_fake_chron = 0;
- # if we have no chronology, add one for prediction puposes
- if (!$caption_field->subfield('i') and !$caption_field->enumeration_is_chronology) {
- $using_fake_chron = 1;
- }
- $mfhd->append_fields($caption_field);
- my $options = {
- 'caption' => $caption_field,
- 'scap_id' => $scap->id,
- 'num_to_predict' => $args->{num_to_predict},
- 'end_date' => defined $args->{end_date} ?
- $_strp_date->parse_datetime($args->{end_date}) : undef
- };
- if ($args->{base_issuance}) { # predict from a given issuance
- $options->{predict_from} = _revive_holding($args->{base_issuance}->holding_code, $caption_field, 1); # fresh MFHD Record, so we simply default to 1 for seqno
- $options->{faked_chron_date} = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($args->{base_issuance}->date_published)) if $using_fake_chron;
- } else { # default to predicting from last published
- my $last_published = $editor->search_serial_issuance([
- {'caption_and_pattern' => $scap->id,
- 'subscription' => $ssub_id},
- {limit => 1, order_by => { siss => "date_published DESC" }}]
- );
- if ($last_published->[0]) {
- my $last_siss = $last_published->[0];
- unless ($last_siss->holding_code) {
- $editor->disconnect;
- # XXX TODO new event type
- return new OpenILS::Event(
- "BAD_PARAMS", note =>
- "Last issuance has no holding code. Can't predict."
- );
- }
- $options->{predict_from} = _revive_holding($last_siss->holding_code, $caption_field, 1);
- $options->{faked_chron_date} = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($last_siss->date_published)) if $using_fake_chron;
- } else {
- $editor->disconnect;
- # XXX TODO make a new event type instead of hijacking this one
- return new OpenILS::Event(
- "BAD_PARAMS", note => "No issuance from which to predict!"
- );
- }
- }
- push( @predictions, _generate_issuance_values($mfhd, $options) );
- $link_id++;
- }
-
- my @issuances;
- foreach my $prediction (@predictions) {
- my $issuance = new Fieldmapper::serial::issuance;
- $issuance->isnew(1);
- $issuance->label($prediction->{label});
- $issuance->date_published($prediction->{date_published}->strftime('%F'));
- $issuance->holding_code(OpenSRF::Utils::JSON->perl2JSON($prediction->{holding_code}));
- $issuance->holding_type($prediction->{holding_type});
- $issuance->caption_and_pattern($prediction->{caption_and_pattern});
- $issuance->subscription($ssub->id);
- push (@issuances, $issuance);
- }
-
- fleshed_issuance_alter($self, $conn, $authtoken, \@issuances); # FIXME: catch events
-
- my @items;
- for (my $i = 0; $i < @issuances; $i++) {
- my $date_expected = $predictions[$i]->{date_published}->add(seconds => interval_to_seconds($ssub->expected_date_offset))->strftime('%F');
- my $issuance = $issuances[$i];
- #$issuance->label(interval_to_seconds($ssub->expected_date_offset));
- foreach my $sdist (@$sdists) {
- my $streams = $sdist->streams;
- foreach my $stream (@$streams) {
- my $item = new Fieldmapper::serial::item;
- $item->isnew(1);
- $item->stream($stream->id);
- $item->date_expected($date_expected);
- $item->issuance($issuance->id);
- push (@items, $item);
- }
- }
- }
- fleshed_item_alter($self, $conn, $authtoken, \@items); # FIXME: catch events
- return \@items;
-}
-
-#
-# _generate_issuance_values() is an initial attempt at a function which can be used
-# to populate an issuance table with a list of predicted issues. It accepts
-# a hash ref of options initially defined as:
-# caption : the caption field to predict on
-# num_to_predict : the number of issues you wish to predict
-# last_rec_date : the date of the last received issue, to be used as an offset
-# for predicting future issues
-# faked_chron_date : if the serial does not actually have a chronology caption (but we need one for prediction's sake), base predictions on this date
-#
-# The basic method is to first convert to a single holding if compressed, then
-# increment the holding and save the resulting values to @issuances.
-#
-# returns @issuance_values, an array of hashrefs containing (formatted
-# label, formatted chronology date, formatted estimated arrival date, and an
-# array ref of holding subfields as (key, value, key, value ...)) (not a hash
-# to protect order and possible duplicate keys), and a holding type.
-#
-sub _generate_issuance_values {
- my ($mfhd, $options) = @_;
- my $caption = $options->{caption};
- my $scap_id = $options->{scap_id};
- my $num_to_predict = $options->{num_to_predict};
- my $end_date = $options->{end_date};
- my $predict_from = $options->{predict_from}; # issuance to predict from
- my $faked_chron_date = $options->{faked_chron_date}; # serial does not have a chronology caption, so add one (temporarily) based on this date
- #my $last_rec_date = $options->{last_rec_date}; # expected or actual
-
-
-# Only needed for 'real' MFHD records, not our temp records
-# my $link_id = $caption->link_id;
-# if(!$predict_from) {
-# my $htag = $caption->tag;
-# $htag =~ s/^85/86/;
-# my @holdings = $mfhd->holdings($htag, $link_id);
-# my $last_holding = $holdings[-1];
-#
-# #if ($last_holding->is_compressed) {
-# # $last_holding->compressed_to_last; # convert to last in range
-# #}
-# $predict_from = $last_holding;
-# }
-#
-
- $predict_from->notes('public', []);
-# add a note marker for system use (?)
- $predict_from->notes('private', ['AUTOGEN']);
-
- # our basic method for dealing with 'faked' chronologies will be to add it in, do the predicting, then take it back out
- my $orig_caption;
- my $faked_caption;
- if ($faked_chron_date) {
- $orig_caption = $predict_from->caption;
- # because of the way MFHD::Caption and Holding work, it is simplest
- # to recreate rather than try to update
- $faked_caption = new MFHD::Caption(new MARC::Field($orig_caption->tag, $orig_caption->indicator(1), $orig_caption->indicator(2), $orig_caption->subfields_list, 'i' => '(year)', 'j' => '(month)', 'k' => '(day)'));
- $predict_from = new MFHD::Holding($predict_from->seqno, new MARC::Field($predict_from->tag, $predict_from->indicator(1), $predict_from->indicator(2), $predict_from->subfields_list, 'i' => $faked_chron_date->year, 'j' => $faked_chron_date->month, 'k' => $faked_chron_date->day), $faked_caption);
- }
-
- my @predictions = $mfhd->generate_predictions({'base_holding' => $predict_from, 'num_to_predict' => $num_to_predict, 'end_date' => $end_date});
-
- my $pub_date;
- my @issuance_values;
- foreach my $prediction (@predictions) {
- $pub_date = $_strp_date->parse_datetime($prediction->chron_to_date);
- if ($faked_chron_date) { # get rid of the chronology portions and restore original caption
- $prediction->delete_subfield(code => ['i', 'j', 'k']);
- $prediction = new MFHD::Holding($prediction->seqno, new MARC::Field($prediction->tag, $prediction->indicator(1), $prediction->indicator(2), $prediction->subfields_list), $orig_caption);
- }
- push(
- @issuance_values,
- {
- #$link_id,
- label => $prediction->format,
- date_published => $pub_date,
- #date_expected => $date_expected->strftime('%F'),
- holding_code => [$prediction->indicator(1),$prediction->indicator(2),$prediction->subfields_list],
- holding_type => $MFHD_NAMES_BY_TAG{$caption->tag},
- caption_and_pattern => $scap_id
- }
- );
- }
-
- return @issuance_values;
-}
-
-sub _revive_caption {
- my $scap = shift;
-
- my $pattern_code = $scap->pattern_code;
-
- # build MARC::Field
- my $pattern_parts = OpenSRF::Utils::JSON->JSON2perl($pattern_code);
- unshift(@$pattern_parts, $MFHD_TAGS_BY_NAME{$scap->type});
- my $pattern_field = new MARC::Field(@$pattern_parts);
-
- # build MFHD::Caption
- return new MFHD::Caption($pattern_field);
-}
-
-sub _revive_holding {
- my $holding_code = shift;
- my $caption_field = shift;
- my $seqno = shift;
-
- # build MARC::Field
- my $holding_parts = OpenSRF::Utils::JSON->JSON2perl($holding_code);
- my $captag = $caption_field->tag;
- $captag =~ s/^85/86/;
- unshift(@$holding_parts, $captag);
- my $holding_field = new MARC::Field(@$holding_parts);
-
- # build MFHD::Holding
- return new MFHD::Holding($seqno, $holding_field, $caption_field);
-}
-
-__PACKAGE__->register_method(
- method => 'unitize_items',
- api_name => 'open-ils.serial.receive_items',
- api_level => 1,
- argc => 1,
- signature => {
- desc => 'Marks an item as received, updates the shelving unit (creating a new shelving unit if needed), and updates the summaries',
- 'params' => [ {
- name => 'items',
- desc => 'array of serial items',
- type => 'array'
- },
- {
- name => 'barcodes',
- desc => 'hash of item_ids => barcodes',
- type => 'hash'
- },
- {
- name => 'call_numbers',
- desc => 'hash of item_ids => call_numbers',
- type => 'hash'
- }
- ],
- 'return' => {
- desc => 'Returns number of received items (num_items) and new unit ID, if applicable (new_unit_id)',
- type => 'hashref'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'unitize_items',
- api_name => 'open-ils.serial.bind_items',
- api_level => 1,
- argc => 1,
- signature => {
- desc => 'Marks an item as bound, updates the shelving unit (creating a new shelving unit if needed)',
- 'params' => [ {
- name => 'items',
- desc => 'array of serial items',
- type => 'array'
- },
- {
- name => 'barcodes',
- desc => 'hash of item_ids => barcodes',
- type => 'hash'
- },
- {
- name => 'call_numbers',
- desc => 'hash of item_ids => call_numbers',
- type => 'hash'
- }
- ],
- 'return' => {
- desc => 'Returns number of bound items (num_items) and new unit ID, if applicable (new_unit_id)',
- type => 'hashref'
- }
- }
-);
-
-# TODO: reset/delete claims information once implemented
-# XXX: deal with emptied call numbers here?
-__PACKAGE__->register_method(
- method => 'unitize_items',
- api_name => 'open-ils.serial.reset_items',
- api_level => 1,
- argc => 1,
- signature => {
- desc => 'Resets the items to Expected, updates the shelving unit (deleting the shelving unit if empty), and updates the summaries',
- 'params' => [ {
- name => 'items',
- desc => 'array of serial items',
- type => 'array'
- }
- ],
- 'return' => {
- desc => 'Returns number of reset items (num_items)',
- type => 'hashref'
- }
- }
-);
-
-sub unitize_items {
- my ($self, $conn, $auth, $items, $barcodes, $call_numbers) = @_;
-
- my $editor = new_editor("authtoken" => $auth, "xact" => 1);
- return $editor->die_event unless $editor->checkauth;
- return $editor->die_event unless $editor->allowed("RECEIVE_SERIAL");
- $self->api_name =~ /serial\.(\w*)_items/;
- my $mode = $1;
-
- my %found_unit_ids;
- my %found_stream_ids;
- my %found_types;
-
- my %stream_ids_by_unit_id;
-
- my %unit_map;
- my %sdist_by_unit_id;
- my %call_number_by_unit_id;
- my %sdist_by_stream_id;
-
- my $new_unit_id; # id for '-2' units to share
- foreach my $item (@$items) {
- # for debugging only, TODO: delete
- if (!ref $item) { # hopefully we got an id instead
- $item = $editor->retrieve_serial_item($item);
- }
- # get ids
- my $unit_id = ref($item->unit) ? $item->unit->id : $item->unit;
- my $stream_id = ref($item->stream) ? $item->stream->id : $item->stream;
- my $issuance_id = ref($item->issuance) ? $item->issuance->id : $item->issuance;
- #TODO: evt on any missing ids
-
- if ($mode eq 'receive') {
- $item->date_received('now');
- $item->status('Received');
- } elsif ($mode eq 'reset') {
- # clear date_received
- $item->clear_date_received;
- # Set status to 'Expected'
- $item->status('Expected');
- # remove from unit
- $item->clear_unit;
- }
-
- # check for types to trigger summary updates
- my $scap;
- if (!ref $item->issuance) {
- my $scaps = $editor->search_serial_caption_and_pattern([{"+siss" => {"id" => $issuance_id}}, { "join" => {"siss" => {}} }]);
- $scap = $scaps->[0];
- } elsif (!ref $item->issuance->caption_and_pattern) {
- $scap = $editor->retrieve_serial_caption_and_pattern($item->issuance->caption_and_pattern);
- } else {
- $scap = $editor->issuance->caption_and_pattern;
- }
- if (!exists($found_types{$stream_id})) {
- $found_types{$stream_id} = {};
- }
- $found_types{$stream_id}->{$scap->type} = 1;
-
- # create unit if needed
- if ($unit_id == -1 or (!$new_unit_id and $unit_id == -2)) { # create unit per item
- my $unit;
- my $sdists = $editor->search_serial_distribution([
- {"+sstr" => {"id" => $stream_id}},
- {
- "join" => {"sstr" => {}},
- "flesh" => 1,
- "flesh_fields" => {"sdist" => ["subscription"]}
- }]);
- $unit = _build_unit($editor, $sdists->[0], $mode);
- # if _build_unit fails, $unit is an event, so return it
- if ($U->event_code($unit)) {
- $editor->rollback;
- $unit->{"note"} = "Item ID: " . $item->id;
- return $unit;
- }
- $unit->barcode($barcodes->{$item->id}) if exists($barcodes->{$item->id});
- my $evt = _create_sunit($editor, $unit);
- return $evt if $evt;
- if ($unit_id == -2) {
- $new_unit_id = $unit->id;
- $unit_id = $new_unit_id;
- } else {
- $unit_id = $unit->id;
- }
- $item->unit($unit_id);
-
- # get unit with 'DEFAULT's and save unit, sdist, and call number for later use
- $unit = $editor->retrieve_serial_unit($unit->id);
- $unit_map{$unit_id} = $unit;
- $sdist_by_unit_id{$unit_id} = $sdists->[0];
- $call_number_by_unit_id{$unit_id} = $call_numbers->{$item->id};
- $sdist_by_stream_id{$stream_id} = $sdists->[0];
- } elsif ($unit_id == -2) { # create one unit for all '-2' items
- $unit_id = $new_unit_id;
- $item->unit($unit_id);
- }
-
- $found_stream_ids{$stream_id} = 1;
-
- if (defined($unit_id)) {
- $found_unit_ids{$unit_id} = 1;
- # save the stream_id for this unit_id
- # TODO: prevent items from different streams in same unit? (perhaps in interface)
- $stream_ids_by_unit_id{$unit_id} = $stream_id;
- }
-
- my $evt = _update_sitem($editor, undef, $item);
- return $evt if $evt;
- }
-
- # cleanup 'dead' units (units which are now emptied of their items)
- my $dead_units = $editor->search_serial_unit([{'+sitem' => {'id' => undef}, 'deleted' => 'f'}, {'join' => {'sitem' => {'type' => 'left'}}}]);
- foreach my $unit (@$dead_units) {
- _delete_sunit($editor, undef, $unit);
- delete $found_unit_ids{$unit->id};
- }
-
- # deal with unit level contents
- foreach my $unit_id (keys %found_unit_ids) {
-
- # get all the needed issuances for unit
- # TODO remove 'Bindery' from this search (leaving it in for now for backwards compatibility with any current test environment data)
- my $issuances = $editor->search_serial_issuance([ {"+sitem" => {"unit" => $unit_id, "status" => ["Received", "Bindery"]}}, {"join" => {"sitem" => {}}, "order_by" => {"siss" => "date_published"}} ]);
- #TODO: evt on search failure
-
- # retrieve and update unit contents
- my $sunit;
- my $sdist;
- my $call_number_string;
- my $record_id;
- # if we just created the unit, we will already have it and the distribution stored, and we will need to assign the call number
- if (exists $unit_map{$unit_id}) {
- $sunit = $unit_map{$unit_id};
- $sdist = $sdist_by_unit_id{$unit_id};
- $call_number_string = $call_number_by_unit_id{$unit_id};
- $record_id = $sdist->subscription->record_entry;
- } else {
- $sunit = $editor->retrieve_serial_unit($unit_id);
- $sdist = $editor->search_serial_distribution([{"+sstr" => {"id" => $stream_ids_by_unit_id{$unit_id}}}, { "join" => {"sstr" => {}} }]);
- $sdist = $sdist->[0];
- }
-
- my $evt = _prepare_unit($editor, $sunit, $sdist, $issuances, $call_number_string, $record_id);
- if ($U->event_code($evt)) {
- $editor->rollback;
- return $evt;
- }
-
- $evt = _update_sunit($editor, undef, $sunit);
- if ($U->event_code($evt)) {
- $editor->rollback;
- return $evt;
- }
- }
-
- if ($mode ne 'bind') { # the summary holdings do not change when binding
- # deal with stream level summaries
- # summaries will be built from the "primary" stream only, that is, the stream with the lowest ID per distribution
- # (TODO: consider direct designation)
- my %primary_streams_by_sdist;
- my %streams_by_sdist;
-
- # see if we have primary streams, and if so, associate them with their distributions
- foreach my $stream_id (keys %found_stream_ids) {
- my $sdist;
- if (exists $sdist_by_stream_id{$stream_id}) {
- $sdist = $sdist_by_stream_id{$stream_id};
- } else {
- $sdist = $editor->search_serial_distribution([{"+sstr" => {"id" => $stream_id}}, { "join" => {"sstr" => {}} }]);
- $sdist = $sdist->[0];
- }
- my $streams;
- if (!exists($streams_by_sdist{$sdist->id})) {
- $streams = $editor->search_serial_stream([{"distribution" => $sdist->id}, {"order_by" => {"sstr" => "id"}}]);
- $streams_by_sdist{$sdist->id} = $streams;
- } else {
- $streams = $streams_by_sdist{$sdist->id};
- }
- $primary_streams_by_sdist{$sdist->id} = $streams->[0] if ($stream_id == $streams->[0]->id);
- }
-
- # retrieve and update summaries for each affected primary stream's distribution
- foreach my $sdist_id (keys %primary_streams_by_sdist) {
- my $stream = $primary_streams_by_sdist{$sdist_id};
- my $stream_id = $stream->id;
- # get all the needed issuances for stream
- # FIXME: search in Bindery/Bound/Not Published? as well as Received
- foreach my $type (keys %{$found_types{$stream_id}}) {
- my $issuances = $editor->search_serial_issuance([ {"+sitem" => {"stream" => $stream_id, "status" => "Received"}, "+scap" => {"type" => $type}}, {"join" => {"sitem" => {}, "scap" => {}}, "order_by" => {"siss" => "date_published"}} ]);
- #TODO: evt on search failure
- my $evt = _prepare_summaries($editor, $issuances, $sdist_id, $type);
- if ($U->event_code($evt)) {
- $editor->rollback;
- return $evt;
- }
- }
- }
- }
-
- $editor->commit;
- return {'num_items' => scalar @$items, 'new_unit_id' => $new_unit_id};
-}
-
-sub _find_or_create_call_number {
- my ($e, $lib, $cn_string, $record) = @_;
-
- my $existing = $e->search_asset_call_number({
- "owning_lib" => $lib,
- "label" => $cn_string,
- "record" => $record,
- "deleted" => "f"
- }) or return $e->die_event;
-
- if (@$existing) {
- return $existing->[0]->id;
- } else {
- return $e->die_event unless
- $e->allowed("CREATE_VOLUME", $lib);
-
- my $acn = new Fieldmapper::asset::call_number;
-
- $acn->creator($e->requestor->id);
- $acn->editor($e->requestor->id);
- $acn->record($record);
- $acn->label($cn_string);
- $acn->owning_lib($lib);
-
- $e->create_asset_call_number($acn) or return $e->die_event;
- return $e->data->id;
- }
-}
-
-sub _issuances_received {
- # XXX TODO: Add some caching or something. This is getting called
- # more often than it has to be.
- my ($e, $sitem) = @_;
-
- my $results = $e->json_query({
- "select" => {"sitem" => ["issuance"]},
- "from" => {"sitem" => {"sstr" => {}, "siss" => {}}},
- "where" => {
- "+sstr" => {"distribution" => $sitem->stream->distribution->id},
- "+siss" => {"holding_type" => $sitem->issuance->holding_type},
- "+sitem" => {"date_received" => {"!=" => undef}}
- },
- "order_by" => {
- "siss" => {"date_published" => {"direction" => "asc"}}
- }
- }) or return $e->die_event;
-
- my $uniq = +{map { $_->{"issuance"} => 1 } @$results};
- return [ map { $e->retrieve_serial_issuance($_) } keys %$uniq ];
-}
-
-# _prepare_unit populates the detailed_contents, summary_contents, and
-# sort_key fields for a given unit based on a given set of issuances
-# Also finds/creates call number as needed
-sub _prepare_unit {
- my ($e, $sunit, $sdist, $issuances, $call_number_string, $record_id) = @_;
-
- # Handle call number first if we have one
- if ($call_number_string) {
- my $org_unit_id = ref $sdist->holding_lib ? $sdist->holding_lib->id : $sdist->holding_lib;
- my $real_cn = _find_or_create_call_number(
- $e, $org_unit_id,
- $call_number_string, $record_id
- );
-
- if ($U->event_code($real_cn)) {
- return $real_cn;
- } else {
- $sunit->call_number($real_cn);
- }
- }
-
- my ($mfhd, $formatted_parts) = _summarize_contents($e, $issuances);
-
- # special case for single formatted_part (may have summarized version)
- if (@$formatted_parts == 1) {
- #TODO: MFHD.pm should have a 'format_summary' method for this
- }
-
- $sunit->detailed_contents(
- join(
- " ",
- $sdist->unit_label_prefix,
- join(", ", @$formatted_parts),
- $sdist->unit_label_suffix
- )
- );
-
- # TODO: change this when real summary contents are available
- $sunit->summary_contents($sunit->detailed_contents);
-
- # Create sort_key by left padding numbers to 6 digits.
- (my $sort_key = $sunit->detailed_contents) =~
- s/(\d+)/sprintf '%06d', $1/eg;
- $sunit->sort_key($sort_key);
-}
-
-# _prepare_summaries populates the generated_coverage field for a given summary
-# type ('basic', 'index', 'supplement') for a given distribution.
-# It also creates the summary if it doesn't yet exist.
-sub _prepare_summaries {
- my ($e, $issuances, $dist_id, $type) = @_;
-
- my ($mfhd, $formatted_parts) = _summarize_contents($e, $issuances);
-
- my $search_method = "search_serial_${type}_summary";
- my $summary = $e->$search_method([{"distribution" => $dist_id}]);
-
- my $cu_method = "update";
-
- if (@$summary) {
- $summary = $summary->[0];
- } else {
- my $class = "Fieldmapper::serial::${type}_summary";
- $summary = $class->new;
- $summary->distribution($dist_id);
- $cu_method = "create";
- }
-
- $summary->generated_coverage(join(", ", @$formatted_parts));
- my $method = "${cu_method}_serial_${type}_summary";
- return $e->die_event unless $e->$method($summary);
-}
-
-sub _unit_by_iss_and_str {
- my ($e, $issuance, $stream) = @_;
-
- my $unit = $e->json_query({
- "select" => {"sunit" => ["id"]},
- "from" => {"sitem" => {"sunit" => {}}},
- "where" => {
- "+sitem" => {
- "issuance" => $issuance->id,
- "stream" => $stream->id
- }
- }
- }) or return $e->die_event;
- return 0 if not @$unit;
-
- $e->retrieve_serial_unit($unit->[0]->{"id"}) or $e->die_event;
-}
-
-sub move_previous_unit {
- my ($e, $prev_iss, $curr_item, $new_loc) = @_;
-
- my $prev_unit = _unit_by_iss_and_str($e,$prev_iss,$curr_item->stream);
- return $prev_unit if defined $U->event_code($prev_unit);
- return 0 if not $prev_unit;
-
- if ($prev_unit->location != $new_loc) {
- $prev_unit->location($new_loc);
- $e->update_serial_unit($prev_unit) or return $e->die_event;
- }
- 0;
-}
-
-# _previous_issuance() assumes $existing is an ordered array
-sub _previous_issuance {
- my ($existing, $issuance) = @_;
-
- my $last = $existing->[-1];
- return undef unless $last;
- return ($last->id == $issuance->id ? $existing->[-2] : $last);
-}
-
-__PACKAGE__->register_method(
- "method" => "receive_items_one_unit_per",
- "api_name" => "open-ils.serial.receive_items.one_unit_per",
- "stream" => 1,
- "api_level" => 1,
- "argc" => 3,
- "signature" => {
- "desc" => "Marks items in a list as received, creates a new unit for each item if any unit is fleshed on, and updates summaries as needed",
- "params" => [
- {
- "name" => "auth",
- "desc" => "authtoken",
- "type" => "string"
- },
- {
- "name" => "items",
- "desc" => "array of serial items, possibly fleshed with units and definitely fleshed with stream->distribution",
- "type" => "array"
- },
- {
- "name" => "record",
- "desc" => "id of bib record these items are associated with
- (XXX could/should be derived from items)",
- "type" => "number"
- }
- ],
- "return" => {
- "desc" => "The item ID for each item successfully received",
- "type" => "int"
- }
- }
-);
-
-sub receive_items_one_unit_per {
- # XXX This function may be temporary, as it does some of what
- # unitize_items() does, just in a different way.
- my ($self, $client, $auth, $items, $record) = @_;
-
- my $e = new_editor("authtoken" => $auth, "xact" => 1);
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed("RECEIVE_SERIAL");
-
- my $prev_loc_setting_map = {};
- my $user_id = $e->requestor->id;
-
- # Get a list of all the non-virtual field names in a serial::unit for
- # merging given unit objects with template-built units later.
- # XXX move this somewhere global so it isn't re-run all the time
- my $all_unit_fields =
- $Fieldmapper::fieldmap->{"Fieldmapper::serial::unit"}->{"fields"};
- my @real_unit_fields = grep {
- not $all_unit_fields->{$_}->{"virtual"}
- } keys %$all_unit_fields;
-
- foreach my $item (@$items) {
- # Note that we expect a certain fleshing on the items we're getting.
- my $sdist = $item->stream->distribution;
-
- # Fetch a list of issuances with received copies already existing
- # on this distribution (and with the same holding type on the
- # issuance). This will be used in up to two places: once when building
- # a summary, once when changing the copy location of the previous
- # issuance's copy.
- my $issuances_received = _issuances_received($e, $item);
- if ($U->event_code($issuances_received)) {
- $e->rollback;
- return $issuances_received;
- }
-
- # Find out if we need to to deal with previous copy location changing.
- my $ou = $sdist->holding_lib->id;
- unless (exists $prev_loc_setting_map->{$ou}) {
- $prev_loc_setting_map->{$ou} = $U->ou_ancestor_setting_value(
- $ou, "serial.prev_issuance_copy_location", $e
- );
- }
-
- # If there is a previous copy location setting, we need the previous
- # issuance, from which we can in turn look up the item attached to the
- # same stream we're on now.
- if ($prev_loc_setting_map->{$ou}) {
- if (my $prev_iss =
- _previous_issuance($issuances_received, $item->issuance)) {
-
- # Now we can change the copy location of the previous unit,
- # if needed.
- return $e->event if defined $U->event_code(
- move_previous_unit(
- $e, $prev_iss, $item, $prev_loc_setting_map->{$ou}
- )
- );
- }
- }
-
- # Create unit if given by user
- if (ref $item->unit) {
- # detach from the item, as we need to create separately
- my $user_unit = $item->unit;
-
- # get a unit based on associated template
- my $template_unit = _build_unit($e, $sdist, "receive");
- if ($U->event_code($template_unit)) {
- $e->rollback;
- $template_unit->{"note"} = "Item ID: " . $item->id;
- return $template_unit;
- }
-
- # merge built unit with provided unit from user
- foreach (@real_unit_fields) {
- unless ($user_unit->$_) {
- $user_unit->$_($template_unit->$_);
- }
- }
-
- # Treat call number specially: the provided value from the
- # user will really be a string.
- my $call_number_string;
- if ($user_unit->call_number) {
- $call_number_string = $user_unit->call_number;
- # clear call number for now (replaced in _prepare_unit)
- $user_unit->clear_call_number;
- }
-
- my $evt = _prepare_unit(
- $e, $user_unit, $sdist, [$item->issuance],
- $call_number_string, $record
- );
- if ($U->event_code($evt)) {
- $e->rollback;
- return $evt;
- }
-
- # create/update summary objects related to this distribution
- # Make sure @$issuances_received contains current item's issuance
- unless (grep { $_->id == $item->issuance->id } @$issuances_received) {
- push @$issuances_received, $item->issuance;
- }
- $evt = _prepare_summaries($e, $issuances_received, $item->stream->distribution->id, $item->issuance->holding_type);
- if ($U->event_code($evt)) {
- $e->rollback;
- return $evt;
- }
-
- # set the incontrovertibles on the unit
- $user_unit->edit_date("now");
- $user_unit->create_date("now");
- $user_unit->editor($user_id);
- $user_unit->creator($user_id);
-
- return $e->die_event unless $e->create_serial_unit($user_unit);
-
- # save reference to new unit
- $item->unit($e->data->id);
- }
-
- # Create notes if given by user
- if (ref($item->notes) and @{$item->notes}) {
- foreach my $note (@{$item->notes}) {
- $note->creator($user_id);
- $note->create_date("now");
-
- return $e->die_event unless $e->create_serial_item_note($note);
- }
-
- $item->clear_notes; # They're saved; we no longer want them here.
- }
-
- # Set the incontrovertibles on the item
- $item->status("Received");
- $item->date_received("now");
- $item->edit_date("now");
- $item->editor($user_id);
-
- return $e->die_event unless $e->update_serial_item($item);
-
- # send client a response
- $client->respond($item->id);
- }
-
- $e->commit or return $e->die_event;
- undef;
-}
-
-sub _build_unit {
- my $editor = shift;
- my $sdist = shift;
- my $mode = shift;
- #my $skip_call_number = shift;
-
- my $attr = $mode . '_unit_template';
- my $template = $editor->retrieve_asset_copy_template($sdist->$attr) or
- return new OpenILS::Event("SERIAL_DISTRIBUTION_HAS_NO_COPY_TEMPLATE");
-
- my @parts = qw( status location loan_duration fine_level age_protect circulate deposit ref holdable deposit_amount price circ_modifier circ_as_type alert_message opac_visible floating mint_condition );
-
- my $unit = new Fieldmapper::serial::unit;
- foreach my $part (@parts) {
- my $value = $template->$part;
- next if !defined($value);
- $unit->$part($value);
- }
-
- # ignore circ_lib in template, set to distribution holding_lib
- $unit->circ_lib($sdist->holding_lib);
- $unit->creator($editor->requestor->id);
- $unit->editor($editor->requestor->id);
-
-# XXX: this feature has been pushed back until after 2.0 at least
-# unless ($skip_call_number) {
-# $attr = $mode . '_call_number';
-# my $cn = $sdist->$attr or
-# return new OpenILS::Event("SERIAL_DISTRIBUTION_HAS_NO_CALL_NUMBER");
-#
-# $unit->call_number($cn);
-# }
- $unit->call_number('-1'); # default to the dummy call number
- $unit->barcode('@@PLACEHOLDER'); # generic unit will start with a generated placeholder barcode
- $unit->sort_key('');
- $unit->summary_contents('');
- $unit->detailed_contents('');
-
- return $unit;
-}
-
-
-sub _summarize_contents {
- my $editor = shift;
- my $issuances = shift;
-
- # create MFHD record
- my $mfhd = MFHD->new(MARC::Record->new());
- my %scaps;
- my %scap_fields;
- my @scap_fields_ordered;
- my $seqno = 1;
- my $link_id = 1;
- foreach my $issuance (@$issuances) {
- my $scap_id = $issuance->caption_and_pattern;
- next if (!$scap_id); # skip issuances with no caption/pattern
-
- my $scap;
- my $scap_field;
- # if this is the first appearance of this scap, retrieve it and add it to the temporary record
- if (!exists $scaps{$issuance->caption_and_pattern}) {
- $scaps{$scap_id} = $editor->retrieve_serial_caption_and_pattern($scap_id);
- $scap = $scaps{$scap_id};
- $scap_field = _revive_caption($scap);
- $scap_fields{$scap_id} = $scap_field;
- push(@scap_fields_ordered, $scap_field);
- $scap_field->update('8' => $link_id);
- $mfhd->append_fields($scap_field);
- $link_id++;
- } else {
- $scap = $scaps{$scap_id};
- $scap_field = $scap_fields{$scap_id};
- }
-
- $mfhd->append_fields(_revive_holding($issuance->holding_code, $scap_field, $seqno));
- $seqno++;
- }
-
- my @formatted_parts;
- foreach my $scap_field (@scap_fields_ordered) { #TODO: use generic MFHD "summarize" method, once available
- my @updated_holdings = $mfhd->get_compressed_holdings($scap_field);
- foreach my $holding (@updated_holdings) {
- push(@formatted_parts, $holding->format);
- }
- }
-
- return ($mfhd, \@formatted_parts);
-}
-
-##########################################################################
-# note methods
-#
-__PACKAGE__->register_method(
- method => 'fetch_notes',
- api_name => 'open-ils.serial.item_note.retrieve.all',
- signature => q/
- Returns an array of copy note objects.
- @param args A named hash of parameters including:
- authtoken : Required if viewing non-public notes
- item_id : The id of the item whose notes we want to retrieve
- pub : True if all the caller wants are public notes
- @return An array of note objects
- /
-);
-
-__PACKAGE__->register_method(
- method => 'fetch_notes',
- api_name => 'open-ils.serial.subscription_note.retrieve.all',
- signature => q/
- Returns an array of copy note objects.
- @param args A named hash of parameters including:
- authtoken : Required if viewing non-public notes
- subscription_id : The id of the item whose notes we want to retrieve
- pub : True if all the caller wants are public notes
- @return An array of note objects
- /
-);
-
-__PACKAGE__->register_method(
- method => 'fetch_notes',
- api_name => 'open-ils.serial.distribution_note.retrieve.all',
- signature => q/
- Returns an array of copy note objects.
- @param args A named hash of parameters including:
- authtoken : Required if viewing non-public notes
- distribution_id : The id of the item whose notes we want to retrieve
- pub : True if all the caller wants are public notes
- @return An array of note objects
- /
-);
-
-# TODO: revisit this method to consider replacing cstore direct calls
-sub fetch_notes {
- my( $self, $connection, $args ) = @_;
-
- $self->api_name =~ /serial\.(\w*)_note/;
- my $type = $1;
-
- my $id = $$args{object_id};
- my $authtoken = $$args{authtoken};
- my( $r, $evt);
-
- if( $$args{pub} ) {
- return $U->cstorereq(
- 'open-ils.cstore.direct.serial.'.$type.'_note.search.atomic',
- { $type => $id, pub => 't' } );
- } else {
- # FIXME: restore perm check
- # ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_COPY_NOTES');
- # return $evt if $evt;
- return $U->cstorereq(
- 'open-ils.cstore.direct.serial.'.$type.'_note.search.atomic', {$type => $id} );
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'create_note',
- api_name => 'open-ils.serial.item_note.create',
- signature => q/
- Creates a new item note
- @param authtoken The login session key
- @param note The note object to create
- @return The id of the new note object
- /
-);
-
-__PACKAGE__->register_method(
- method => 'create_note',
- api_name => 'open-ils.serial.subscription_note.create',
- signature => q/
- Creates a new subscription note
- @param authtoken The login session key
- @param note The note object to create
- @return The id of the new note object
- /
-);
-
-__PACKAGE__->register_method(
- method => 'create_note',
- api_name => 'open-ils.serial.distribution_note.create',
- signature => q/
- Creates a new distribution note
- @param authtoken The login session key
- @param note The note object to create
- @return The id of the new note object
- /
-);
-
-sub create_note {
- my( $self, $connection, $authtoken, $note ) = @_;
-
- $self->api_name =~ /serial\.(\w*)_note/;
- my $type = $1;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->event unless $e->checkauth;
-
- # FIXME: restore permission support
-# my $item = $e->retrieve_serial_item(
-# [
-# $note->item
-# ]
-# );
-#
-# return $e->event unless
-# $e->allowed('CREATE_COPY_NOTE', $item->call_number->owning_lib);
-
- $note->create_date('now');
- $note->creator($e->requestor->id);
- $note->pub( ($U->is_true($note->pub)) ? 't' : 'f' );
- $note->clear_id;
-
- my $method = "create_serial_${type}_note";
- $e->$method($note) or return $e->event;
- $e->commit;
- return $note->id;
-}
-
-__PACKAGE__->register_method(
- method => 'delete_note',
- api_name => 'open-ils.serial.item_note.delete',
- signature => q/
- Deletes an existing item note
- @param authtoken The login session key
- @param noteid The id of the note to delete
- @return 1 on success - Event otherwise.
- /
-);
-
-__PACKAGE__->register_method(
- method => 'delete_note',
- api_name => 'open-ils.serial.subscription_note.delete',
- signature => q/
- Deletes an existing subscription note
- @param authtoken The login session key
- @param noteid The id of the note to delete
- @return 1 on success - Event otherwise.
- /
-);
-
-__PACKAGE__->register_method(
- method => 'delete_note',
- api_name => 'open-ils.serial.distribution_note.delete',
- signature => q/
- Deletes an existing distribution note
- @param authtoken The login session key
- @param noteid The id of the note to delete
- @return 1 on success - Event otherwise.
- /
-);
-
-sub delete_note {
- my( $self, $conn, $authtoken, $noteid ) = @_;
-
- $self->api_name =~ /serial\.(\w*)_note/;
- my $type = $1;
-
- my $e = new_editor(xact=>1, authtoken=>$authtoken);
- return $e->die_event unless $e->checkauth;
-
- my $method = "retrieve_serial_${type}_note";
- my $note = $e->$method([
- $noteid,
- ]) or return $e->die_event;
-
-# FIXME: restore permissions check
-# if( $note->creator ne $e->requestor->id ) {
-# return $e->die_event unless
-# $e->allowed('DELETE_COPY_NOTE', $note->item->call_number->owning_lib);
-# }
-
- $method = "delete_serial_${type}_note";
- $e->$method($note) or return $e->die_event;
- $e->commit;
- return 1;
-}
-
-
-##########################################################################
-# subscription methods
-#
-__PACKAGE__->register_method(
- method => 'fleshed_ssub_alter',
- api_name => 'open-ils.serial.subscription.fleshed.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more subscriptions and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'subscriptions',
- desc => 'Array of fleshed subscriptions',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub fleshed_ssub_alter {
- my( $self, $conn, $auth, $ssubs ) = @_;
- return 1 unless ref $ssubs;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission check
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $ssub (@$ssubs) {
-
- my $ssubid = $ssub->id;
-
- if( $ssub->isdeleted ) {
- $evt = _delete_ssub( $editor, $override, $ssub);
- } elsif( $ssub->isnew ) {
- _cleanse_dates($ssub, ['start_date','end_date']);
- $evt = _create_ssub( $editor, $ssub );
- } else {
- _cleanse_dates($ssub, ['start_date','end_date']);
- $evt = _update_ssub( $editor, $override, $ssub );
- }
- }
-
- if( $evt ) {
- $logger->info("fleshed subscription-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("subscription-alter: done updating subscription batch");
- $editor->commit;
- $logger->info("fleshed subscription-alter successfully updated ".scalar(@$ssubs)." subscriptions");
- return 1;
-}
-
-sub _delete_ssub {
- my ($editor, $override, $ssub) = @_;
- $logger->info("subscription-alter: delete subscription ".OpenSRF::Utils::JSON->perl2JSON($ssub));
- my $sdists = $editor->search_serial_distribution(
- { subscription => $ssub->id }, { limit => 1 } ); #TODO: 'deleted' support?
- my $cps = $editor->search_serial_caption_and_pattern(
- { subscription => $ssub->id }, { limit => 1 } ); #TODO: 'deleted' support?
- my $sisses = $editor->search_serial_issuance(
- { subscription => $ssub->id }, { limit => 1 } ); #TODO: 'deleted' support?
- return OpenILS::Event->new(
- 'SERIAL_SUBSCRIPTION_NOT_EMPTY', payload => $ssub->id ) if (@$sdists or @$cps or @$sisses);
-
- return $editor->event unless $editor->delete_serial_subscription($ssub);
- return 0;
-}
-
-sub _create_ssub {
- my ($editor, $ssub) = @_;
-
- $logger->info("subscription-alter: new subscription ".OpenSRF::Utils::JSON->perl2JSON($ssub));
- return $editor->event unless $editor->create_serial_subscription($ssub);
- return 0;
-}
-
-sub _update_ssub {
- my ($editor, $override, $ssub) = @_;
-
- $logger->info("subscription-alter: retrieving subscription ".$ssub->id);
- my $orig_ssub = $editor->retrieve_serial_subscription($ssub->id);
-
- $logger->info("subscription-alter: original subscription ".OpenSRF::Utils::JSON->perl2JSON($orig_ssub));
- $logger->info("subscription-alter: updated subscription ".OpenSRF::Utils::JSON->perl2JSON($ssub));
- return $editor->event unless $editor->update_serial_subscription($ssub);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "fleshed_serial_subscription_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.subscription.fleshed.batch.retrieve"
-);
-
-sub fleshed_serial_subscription_retrieve_batch {
- my( $self, $client, $ids ) = @_;
-# FIXME: permissions?
- $logger->info("Fetching fleshed subscriptions @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.subscription.search.atomic",
- { id => $ids },
- { flesh => 1,
- flesh_fields => {ssub => [ qw/owning_lib notes/ ]}
- });
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_sub_tree",
- authoritative => 1,
- api_name => "open-ils.serial.subscription_tree.retrieve"
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_sub_tree",
- api_name => "open-ils.serial.subscription_tree.global.retrieve"
-);
-
-sub retrieve_sub_tree {
-
- my( $self, $client, $user_session, $docid, @org_ids ) = @_;
-
- if(ref($org_ids[0])) { @org_ids = @{$org_ids[0]}; }
-
- $docid = "$docid";
-
- # TODO: permission support
- if(!@org_ids and $user_session) {
- my $user_obj =
- OpenILS::Application::AppUtils->check_user_session( $user_session ); #throws EX on error
- @org_ids = ($user_obj->home_ou);
- }
-
- if( $self->api_name =~ /global/ ) {
- return _build_subs_list( { record_entry => $docid } ); # TODO: filter for !deleted, or active?
-
- } else {
-
- my @all_subs;
- for my $orgid (@org_ids) {
- my $subs = _build_subs_list(
- { record_entry => $docid, owning_lib => $orgid } );# TODO: filter for !deleted, or active?
- push( @all_subs, @$subs );
- }
-
- return \@all_subs;
- }
-
- return undef;
-}
-
-sub _build_subs_list {
- my $search_hash = shift;
-
- #$search_hash->{deleted} = 'f';
- my $e = new_editor();
-
- my $subs = $e->search_serial_subscription([$search_hash, { 'order_by' => {'ssub' => 'id'} }]);
-
- my @built_subs;
-
- for my $sub (@$subs) {
-
- # TODO: filter on !deleted?
- my $dists = $e->search_serial_distribution(
- [{ subscription => $sub->id }, { 'order_by' => {'sdist' => 'label'} }]
- );
-
- #$dists = [ sort { $a->label cmp $b->label } @$dists ];
-
- $sub->distributions($dists);
-
- # TODO: filter on !deleted?
- my $issuances = $e->search_serial_issuance(
- [{ subscription => $sub->id }, { 'order_by' => {'siss' => 'label'} }]
- );
-
- #$issuances = [ sort { $a->label cmp $b->label } @$issuances ];
- $sub->issuances($issuances);
-
- # TODO: filter on !deleted?
- my $scaps = $e->search_serial_caption_and_pattern(
- [{ subscription => $sub->id }, { 'order_by' => {'scap' => 'id'} }]
- );
-
- #$scaps = [ sort { $a->id cmp $b->id } @$scaps ];
- $sub->scaps($scaps);
- push( @built_subs, $sub );
- }
-
- return \@built_subs;
-
-}
-
-__PACKAGE__->register_method(
- method => "subscription_orgs_for_title",
- authoritative => 1,
- api_name => "open-ils.serial.subscription.retrieve_orgs_by_title"
-);
-
-sub subscription_orgs_for_title {
- my( $self, $client, $record_id ) = @_;
-
- my $subs = $U->simple_scalar_request(
- "open-ils.cstore",
- "open-ils.cstore.direct.serial.subscription.search.atomic",
- { record_entry => $record_id }); # TODO: filter on !deleted?
-
- my $orgs = { map {$_->owning_lib => 1 } @$subs };
- return [ keys %$orgs ];
-}
-
-
-##########################################################################
-# distribution methods
-#
-__PACKAGE__->register_method(
- method => 'fleshed_sdist_alter',
- api_name => 'open-ils.serial.distribution.fleshed.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more distributions and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'distributions',
- desc => 'Array of fleshed distributions',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub fleshed_sdist_alter {
- my( $self, $conn, $auth, $sdists ) = @_;
- return 1 unless ref $sdists;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission check
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $sdist (@$sdists) {
- my $sdistid = $sdist->id;
-
- if( $sdist->isdeleted ) {
- $evt = _delete_sdist( $editor, $override, $sdist);
- } elsif( $sdist->isnew ) {
- $evt = _create_sdist( $editor, $sdist );
- } else {
- $evt = _update_sdist( $editor, $override, $sdist );
- }
- }
-
- if( $evt ) {
- $logger->info("fleshed distribution-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("distribution-alter: done updating distribution batch");
- $editor->commit;
- $logger->info("fleshed distribution-alter successfully updated ".scalar(@$sdists)." distributions");
- return 1;
-}
-
-sub _delete_sdist {
- my ($editor, $override, $sdist) = @_;
- $logger->info("distribution-alter: delete distribution ".OpenSRF::Utils::JSON->perl2JSON($sdist));
- return $editor->event unless $editor->delete_serial_distribution($sdist);
- return 0;
-}
-
-sub _create_sdist {
- my ($editor, $sdist) = @_;
-
- $logger->info("distribution-alter: new distribution ".OpenSRF::Utils::JSON->perl2JSON($sdist));
- return $editor->event unless $editor->create_serial_distribution($sdist);
-
- # create summaries too
- my $summary = new Fieldmapper::serial::basic_summary;
- $summary->distribution($sdist->id);
- $summary->generated_coverage('');
- return $editor->event unless $editor->create_serial_basic_summary($summary);
- $summary = new Fieldmapper::serial::supplement_summary;
- $summary->distribution($sdist->id);
- $summary->generated_coverage('');
- return $editor->event unless $editor->create_serial_supplement_summary($summary);
- $summary = new Fieldmapper::serial::index_summary;
- $summary->distribution($sdist->id);
- $summary->generated_coverage('');
- return $editor->event unless $editor->create_serial_index_summary($summary);
-
- # create a starter stream (TODO: reconsider this)
- my $stream = new Fieldmapper::serial::stream;
- $stream->distribution($sdist->id);
- return $editor->event unless $editor->create_serial_stream($stream);
-
- return 0;
-}
-
-sub _update_sdist {
- my ($editor, $override, $sdist) = @_;
-
- $logger->info("distribution-alter: retrieving distribution ".$sdist->id);
- my $orig_sdist = $editor->retrieve_serial_distribution($sdist->id);
-
- $logger->info("distribution-alter: original distribution ".OpenSRF::Utils::JSON->perl2JSON($orig_sdist));
- $logger->info("distribution-alter: updated distribution ".OpenSRF::Utils::JSON->perl2JSON($sdist));
- return $editor->event unless $editor->update_serial_distribution($sdist);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "fleshed_serial_distribution_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.distribution.fleshed.batch.retrieve"
-);
-
-sub fleshed_serial_distribution_retrieve_batch {
- my( $self, $client, $ids ) = @_;
-# FIXME: permissions?
- $logger->info("Fetching fleshed distributions @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.distribution.search.atomic",
- { id => $ids },
- { flesh => 1,
- flesh_fields => {sdist => [ qw/ holding_lib receive_call_number receive_unit_template bind_call_number bind_unit_template streams / ]}
- });
-}
-
-__PACKAGE__->register_method(
- method => "retrieve_dist_tree",
- authoritative => 1,
- api_name => "open-ils.serial.distribution_tree.retrieve"
-);
-
-__PACKAGE__->register_method(
- method => "retrieve_dist_tree",
- api_name => "open-ils.serial.distribution_tree.global.retrieve"
-);
-
-sub retrieve_dist_tree {
- my( $self, $client, $user_session, $docid, @org_ids ) = @_;
-
- if(ref($org_ids[0])) { @org_ids = @{$org_ids[0]}; }
-
- $docid = "$docid";
-
- # TODO: permission support
- if(!@org_ids and $user_session) {
- my $user_obj =
- OpenILS::Application::AppUtils->check_user_session( $user_session ); #throws EX on error
- @org_ids = ($user_obj->home_ou);
- }
-
- my $e = new_editor();
-
- if( $self->api_name =~ /global/ ) {
- return $e->search_serial_distribution([{'+ssub' => { record_entry => $docid }},
- { flesh => 1,
- flesh_fields => {sdist => [ qw/ holding_lib receive_call_number receive_unit_template bind_call_number bind_unit_template streams basic_summary supplement_summary index_summary / ]},
- order_by => {'sdist' => 'id'},
- 'join' => {'ssub' => {}}
- }
- ]); # TODO: filter for !deleted?
-
- } else {
- my @all_dists;
- for my $orgid (@org_ids) {
- my $dists = $e->search_serial_distribution([{'+ssub' => { record_entry => $docid }, holding_lib => $orgid},
- { flesh => 1,
- flesh_fields => {sdist => [ qw/ holding_lib receive_call_number receive_unit_template bind_call_number bind_unit_template streams basic_summary supplement_summary index_summary / ]},
- order_by => {'sdist' => 'id'},
- 'join' => {'ssub' => {}}
- }
- ]); # TODO: filter for !deleted?
- push( @all_dists, @$dists ) if $dists;
- }
-
- return \@all_dists;
- }
-
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- method => "distribution_orgs_for_title",
- authoritative => 1,
- api_name => "open-ils.serial.distribution.retrieve_orgs_by_title"
-);
-
-sub distribution_orgs_for_title {
- my( $self, $client, $record_id ) = @_;
-
- my $dists = $U->cstorereq(
- "open-ils.cstore.direct.serial.distribution.search.atomic",
- { '+ssub' => { record_entry => $record_id } },
- { 'join' => {'ssub' => {}} }); # TODO: filter on !deleted?
-
- my $orgs = { map {$_->holding_lib => 1 } @$dists };
- return [ keys %$orgs ];
-}
-
-
-##########################################################################
-# caption and pattern methods
-#
-__PACKAGE__->register_method(
- method => 'scap_alter',
- api_name => 'open-ils.serial.caption_and_pattern.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more caption and patterns and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'scaps',
- desc => 'Array of caption and patterns',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub scap_alter {
- my( $self, $conn, $auth, $scaps ) = @_;
- return 1 unless ref $scaps;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission check
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $scap (@$scaps) {
- my $scapid = $scap->id;
-
- if( $scap->isdeleted ) {
- $evt = _delete_scap( $editor, $override, $scap);
- } elsif( $scap->isnew ) {
- $evt = _create_scap( $editor, $scap );
- } else {
- $evt = _update_scap( $editor, $override, $scap );
- }
- }
-
- if( $evt ) {
- $logger->info("caption_and_pattern-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("caption_and_pattern-alter: done updating caption_and_pattern batch");
- $editor->commit;
- $logger->info("caption_and_pattern-alter successfully updated ".scalar(@$scaps)." caption_and_patterns");
- return 1;
-}
-
-sub _delete_scap {
- my ($editor, $override, $scap) = @_;
- $logger->info("caption_and_pattern-alter: delete caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($scap));
- my $sisses = $editor->search_serial_issuance(
- { caption_and_pattern => $scap->id }, { limit => 1 } ); #TODO: 'deleted' support?
- return OpenILS::Event->new(
- 'SERIAL_CAPTION_AND_PATTERN_HAS_ISSUANCES', payload => $scap->id ) if (@$sisses);
-
- return $editor->event unless $editor->delete_serial_caption_and_pattern($scap);
- return 0;
-}
-
-sub _create_scap {
- my ($editor, $scap) = @_;
-
- $logger->info("caption_and_pattern-alter: new caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($scap));
- return $editor->event unless $editor->create_serial_caption_and_pattern($scap);
- return 0;
-}
-
-sub _update_scap {
- my ($editor, $override, $scap) = @_;
-
- $logger->info("caption_and_pattern-alter: retrieving caption_and_pattern ".$scap->id);
- my $orig_scap = $editor->retrieve_serial_caption_and_pattern($scap->id);
-
- $logger->info("caption_and_pattern-alter: original caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($orig_scap));
- $logger->info("caption_and_pattern-alter: updated caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($scap));
- return $editor->event unless $editor->update_serial_caption_and_pattern($scap);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "serial_caption_and_pattern_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.caption_and_pattern.batch.retrieve"
-);
-
-sub serial_caption_and_pattern_retrieve_batch {
- my( $self, $client, $ids ) = @_;
- $logger->info("Fetching caption_and_patterns @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.caption_and_pattern.search.atomic",
- { id => $ids }
- );
-}
-
-##########################################################################
-# stream methods
-#
-__PACKAGE__->register_method(
- method => 'sstr_alter',
- api_name => 'open-ils.serial.stream.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more streams and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'sstrs',
- desc => 'Array of streams',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub sstr_alter {
- my( $self, $conn, $auth, $sstrs ) = @_;
- return 1 unless ref $sstrs;
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission check
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $sstr (@$sstrs) {
- my $sstrid = $sstr->id;
-
- if( $sstr->isdeleted ) {
- $evt = _delete_sstr( $editor, $override, $sstr);
- } elsif( $sstr->isnew ) {
- $evt = _create_sstr( $editor, $sstr );
- } else {
- $evt = _update_sstr( $editor, $override, $sstr );
- }
- }
-
- if( $evt ) {
- $logger->info("stream-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("stream-alter: done updating stream batch");
- $editor->commit;
- $logger->info("stream-alter successfully updated ".scalar(@$sstrs)." streams");
- return 1;
-}
-
-sub _delete_sstr {
- my ($editor, $override, $sstr) = @_;
- $logger->info("stream-alter: delete stream ".OpenSRF::Utils::JSON->perl2JSON($sstr));
- my $sitems = $editor->search_serial_item(
- { stream => $sstr->id }, { limit => 1 } ); #TODO: 'deleted' support?
- return OpenILS::Event->new(
- 'SERIAL_STREAM_HAS_ITEMS', payload => $sstr->id ) if (@$sitems);
-
- return $editor->event unless $editor->delete_serial_stream($sstr);
- return 0;
-}
-
-sub _create_sstr {
- my ($editor, $sstr) = @_;
-
- $logger->info("stream-alter: new stream ".OpenSRF::Utils::JSON->perl2JSON($sstr));
- return $editor->event unless $editor->create_serial_stream($sstr);
- return 0;
-}
-
-sub _update_sstr {
- my ($editor, $override, $sstr) = @_;
-
- $logger->info("stream-alter: retrieving stream ".$sstr->id);
- my $orig_sstr = $editor->retrieve_serial_stream($sstr->id);
-
- $logger->info("stream-alter: original stream ".OpenSRF::Utils::JSON->perl2JSON($orig_sstr));
- $logger->info("stream-alter: updated stream ".OpenSRF::Utils::JSON->perl2JSON($sstr));
- return $editor->event unless $editor->update_serial_stream($sstr);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "serial_stream_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.stream.batch.retrieve"
-);
-
-sub serial_stream_retrieve_batch {
- my( $self, $client, $ids ) = @_;
- $logger->info("Fetching streams @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.stream.search.atomic",
- { id => $ids }
- );
-}
-
-
-##########################################################################
-# summary methods
-#
-__PACKAGE__->register_method(
- method => 'sum_alter',
- api_name => 'open-ils.serial.basic_summary.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more summaries and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'sbsums',
- desc => 'Array of basic summaries',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'sum_alter',
- api_name => 'open-ils.serial.supplement_summary.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more summaries and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'sbsums',
- desc => 'Array of supplement summaries',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-__PACKAGE__->register_method(
- method => 'sum_alter',
- api_name => 'open-ils.serial.index_summary.batch.update',
- api_level => 1,
- argc => 2,
- signature => {
- desc => 'Receives an array of one or more summaries and updates the database as needed',
- 'params' => [ {
- name => 'authtoken',
- desc => 'Authtoken for current user session',
- type => 'string'
- },
- {
- name => 'sbsums',
- desc => 'Array of index summaries',
- type => 'array'
- }
-
- ],
- 'return' => {
- desc => 'Returns 1 if successful, event if failed',
- type => 'mixed'
- }
- }
-);
-
-sub sum_alter {
- my( $self, $conn, $auth, $sums ) = @_;
- return 1 unless ref $sums;
-
- $self->api_name =~ /serial\.(\w*)_summary/;
- my $type = $1;
-
- my( $reqr, $evt ) = $U->checkses($auth);
- return $evt if $evt;
- my $editor = new_editor(requestor => $reqr, xact => 1);
- my $override = $self->api_name =~ /override/;
-
-# TODO: permission check
-# return $editor->event unless
-# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
-
- for my $sum (@$sums) {
- my $sumid = $sum->id;
-
- # XXX: (for now, at least) summaries should be created/deleted by the distribution functions
- if( $sum->isdeleted ) {
- $evt = OpenILS::Event->new('SERIAL_SUMMARIES_NOT_INDEPENDENT');
- } elsif( $sum->isnew ) {
- $evt = OpenILS::Event->new('SERIAL_SUMMARIES_NOT_INDEPENDENT');
- } else {
- $evt = _update_sum( $editor, $override, $sum, $type );
- }
- }
-
- if( $evt ) {
- $logger->info("${type}_summary-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
- $editor->rollback;
- return $evt;
- }
- $logger->debug("${type}_summary-alter: done updating ${type}_summary batch");
- $editor->commit;
- $logger->info("${type}_summary-alter successfully updated ".scalar(@$sums)." ${type}_summaries");
- return 1;
-}
-
-sub _update_sum {
- my ($editor, $override, $sum, $type) = @_;
-
- $logger->info("${type}_summary-alter: retrieving ${type}_summary ".$sum->id);
- my $retrieve_method = "retrieve_serial_${type}_summary";
- my $orig_sum = $editor->$retrieve_method($sum->id);
-
- $logger->info("${type}_summary-alter: original ${type}_summary ".OpenSRF::Utils::JSON->perl2JSON($orig_sum));
- $logger->info("${type}_summary-alter: updated ${type}_summary ".OpenSRF::Utils::JSON->perl2JSON($sum));
- my $update_method = "update_serial_${type}_summary";
- return $editor->event unless $editor->$update_method($sum);
- return 0;
-}
-
-__PACKAGE__->register_method(
- method => "serial_summary_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.basic_summary.batch.retrieve"
-);
-
-__PACKAGE__->register_method(
- method => "serial_summary_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.supplement_summary.batch.retrieve"
-);
-
-__PACKAGE__->register_method(
- method => "serial_summary_retrieve_batch",
- authoritative => 1,
- api_name => "open-ils.serial.index_summary.batch.retrieve"
-);
-
-sub serial_summary_retrieve_batch {
- my( $self, $client, $ids ) = @_;
-
- $self->api_name =~ /serial\.(\w*)_summary/;
- my $type = $1;
-
- $logger->info("Fetching ${type}_summaries @$ids");
- return $U->cstorereq(
- "open-ils.cstore.direct.serial.".$type."_summary.search.atomic",
- { id => $ids }
- );
-}
-
-
-##########################################################################
-# other methods
-#
-__PACKAGE__->register_method(
- "method" => "bre_by_identifier",
- "api_name" => "open-ils.serial.biblio.record_entry.by_identifier",
- "stream" => 1,
- "signature" => {
- "desc" => "Find instances of biblio.record_entry given a search token" .
- " that could be a value for any identifier defined in " .
- "config.metabib_field",
- "params" => [
- {"desc" => "Search token", "type" => "string"},
- {"desc" => "Options: require_subscriptions, add_mvr, is_actual_id" .
- ", id_list (all boolean)", "type" => "object"}
- ],
- "return" => {
- "desc" => "Any matching BREs, or if the add_mvr option is true, " .
- "objects with a 'bre' key/value pair, and an 'mvr' " .
- "key-value pair. BREs have subscriptions fleshed on.",
- "type" => "object"
- }
- }
-);
-
-sub bre_by_identifier {
- my ($self, $client, $term, $options) = @_;
-
- return new OpenILS::Event("BAD_PARAMS") unless $term;
-
- $options ||= {};
- my $e = new_editor();
-
- my @ids;
-
- if ($options->{"is_actual_id"}) {
- @ids = ($term);
- } else {
- my $cmf =
- $e->search_config_metabib_field({"field_class" => "identifier"})
- or return $e->die_event;
-
- my @identifiers = map { $_->name } @$cmf;
- my $query = join(" || ", map { "id|$_: $term" } @identifiers);
-
- my $search = create OpenSRF::AppSession("open-ils.search");
- my $search_result = $search->request(
- "open-ils.search.biblio.multiclass.query.staff", {}, $query
- )->gather(1);
- $search->disconnect;
-
- # Un-nest results. They tend to look like [[1],[2],[3]] for some reason.
- @ids = map { @{$_} } @{$search_result->{"ids"}};
-
- unless (@ids) {
- $e->disconnect;
- return undef;
- }
-
- if ($options->{"id_list"}) {
- $e->disconnect;
- $client->respond($_) foreach (@ids);
- return undef;
- }
- }
-
- my $bre = $e->search_biblio_record_entry([
- {"id" => \@ids}, {
- "flesh" => 2, "flesh_fields" => {
- "bre" => ["subscriptions"],
- "ssub" => ["owning_lib"]
- }
- }
- ]) or return $e->die_event;
-
- if (@$bre && $options->{"require_subscriptions"}) {
- $bre = [ grep { @{$_->subscriptions} } @$bre ];
- }
-
- $e->disconnect;
-
- if (@$bre) { # re-evaluate after possible grep
- if ($options->{"add_mvr"}) {
- $client->respond(
- {"bre" => $_, "mvr" => _get_mvr($_->id)}
- ) foreach (@$bre);
- } else {
- $client->respond($_) foreach (@$bre);
- }
- }
-
- undef;
-}
-
-__PACKAGE__->register_method(
- "method" => "get_items_by",
- "api_name" => "open-ils.serial.items.receivable.by_subscription",
- "stream" => 1,
- "signature" => {
- "desc" => "Return all receivable items under a given subscription",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Subscription ID", "type" => "number"},
- ],
- "return" => {
- "desc" => "All receivable items under a given subscription",
- "type" => "object", "class" => "sitem"
- }
- }
-);
-
-__PACKAGE__->register_method(
- "method" => "get_items_by",
- "api_name" => "open-ils.serial.items.receivable.by_issuance",
- "stream" => 1,
- "signature" => {
- "desc" => "Return all receivable items under a given issuance",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Issuance ID", "type" => "number"},
- ],
- "return" => {
- "desc" => "All receivable items under a given issuance",
- "type" => "object", "class" => "sitem"
- }
- }
-);
-
-__PACKAGE__->register_method(
- "method" => "get_items_by",
- "api_name" => "open-ils.serial.items.by_issuance",
- "stream" => 1,
- "signature" => {
- "desc" => "Return all items under a given issuance",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Issuance ID", "type" => "number"},
- ],
- "return" => {
- "desc" => "All items under a given issuance",
- "type" => "object", "class" => "sitem"
- }
- }
-);
-
-sub get_items_by {
- my ($self, $client, $auth, $term, $opts) = @_;
-
- # Not to be used in the json_query, but after limiting by perm check.
- $opts = {} unless ref $opts eq "HASH";
- $opts->{"limit"} ||= 10000; # some existing users may want all results
- $opts->{"offset"} ||= 0;
- $opts->{"limit"} = int($opts->{"limit"});
- $opts->{"offset"} = int($opts->{"offset"});
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $by = ($self->api_name =~ /by_(\w+)$/)[0];
- my $receivable = ($self->api_name =~ /receivable/);
-
- my %where = (
- "issuance" => {"issuance" => $term},
- "subscription" => {"+siss" => {"subscription" => $term}}
- );
-
- my $item_rows = $e->json_query(
- {
- "select" => {"sitem" => ["id"], "sdist" => ["holding_lib"]},
- "from" => {
- "sitem" => {
- "siss" => {},
- "sstr" => {"join" => {"sdist" => {}}}
- }
- },
- "where" => {
- %{$where{$by}}, $receivable ? ("date_received" => undef) : ()
- },
- "order_by" => {"sitem" => ["id"]}
- }
- ) or return $e->die_event;
-
- return undef unless @$item_rows;
-
- my $skipped = 0;
- my $returned = 0;
- foreach (@$item_rows) {
- last if $returned >= $opts->{"limit"};
- next unless $e->allowed("RECEIVE_SERIAL", $_->{"holding_lib"});
- if ($skipped < $opts->{"offset"}) {
- $skipped++;
- next;
- }
-
- $client->respond(
- $e->retrieve_serial_item([
- $_->{"id"}, {
- "flesh" => 3,
- "flesh_fields" => {
- "sitem" => [qw/stream issuance unit creator editor/],
- "sstr" => ["distribution"],
- "sdist" => ["holding_lib"]
- }
- }
- ])
- );
- $returned++;
- }
-
- $e->disconnect;
- undef;
-}
-
-__PACKAGE__->register_method(
- "method" => "get_receivable_issuances",
- "api_name" => "open-ils.serial.issuances.receivable",
- "stream" => 1,
- "signature" => {
- "desc" => "Return all issuances with receivable items given " .
- "a subscription ID",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Subscription ID", "type" => "number"},
- ],
- "return" => {
- "desc" => "All issuances with receivable items " .
- "(but not the items themselves)", "type" => "object"
- }
- }
-);
-
-sub get_receivable_issuances {
- my ($self, $client, $auth, $sub_id) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- # XXX permissions
-
- my $issuance_ids = $e->json_query({
- "select" => {
- "siss" => [
- {"transform" => "distinct", "column" => "id"},
- "date_published"
- ]
- },
- "from" => {"siss" => "sitem"},
- "where" => {
- "subscription" => $sub_id,
- "+sitem" => {"date_received" => undef}
- },
- "order_by" => {
- "siss" => {"date_published" => {"direction" => "asc"}}
- }
-
- }) or return $e->die_event;
-
- $client->respond($e->retrieve_serial_issuance($_->{"id"}))
- foreach (@$issuance_ids);
-
- $e->disconnect;
- undef;
-}
-
-
-__PACKAGE__->register_method(
- "method" => "get_routing_list_users",
- "api_name" => "open-ils.serial.routing_list_users.fleshed_and_ordered",
- "stream" => 1,
- "signature" => {
- "desc" => "Return all routing list users with reader fleshed " .
- "(with card and home_ou) for a given stream ID, sorted by pos",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Stream ID (int or array of ints)", "type" => "mixed"},
- ],
- "return" => {
- "desc" => "Stream of routing list users", "type" => "object",
- "class" => "srlu"
- }
- }
-);
-
-sub get_routing_list_users {
- my ($self, $client, $auth, $stream_id) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $users = $e->search_serial_routing_list_user([
- {"stream" => $stream_id}, {
- "order_by" => {"srlu" => "pos"},
- "flesh" => 2,
- "flesh_fields" => {
- "srlu" => [qw/reader stream/],
- "au" => [qw/card home_ou/],
- "sstr" => ["distribution"]
- }
- }
- ]) or return $e->die_event;
-
- return undef unless @$users;
-
- # The ADMIN_SERIAL_STREAM permission is used simply to avoid the
- # need for any new permission. The context OU will be the same
- # for every result of the above query, so we need only check once.
- return $e->die_event unless $e->allowed(
- "ADMIN_SERIAL_STREAM", $users->[0]->stream->distribution->holding_lib
- );
-
- $e->disconnect;
-
- my @users = map { $_->stream($_->stream->id); $_ } @$users;
- @users = sort { $a->stream cmp $b->stream } @users if
- ref $stream_id eq "ARRAY";
-
- $client->respond($_) for @users;
-
- undef;
-}
-
-
-__PACKAGE__->register_method(
- "method" => "replace_routing_list_users",
- "api_name" => "open-ils.serial.routing_list_users.replace",
- "signature" => {
- "desc" => "Replace all routing list users on the specified streams " .
- "with those in the list argument",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "List of srlu objects", "type" => "array"},
- ],
- "return" => {
- "desc" => "event on failure, undef on success"
- }
- }
-);
-
-sub replace_routing_list_users {
- my ($self, $client, $auth, $users) = @_;
-
- return undef unless ref $users eq "ARRAY";
-
- if (grep { ref $_ ne "Fieldmapper::serial::routing_list_user" } @$users) {
- return new OpenILS::Event("BAD_PARAMS", "note" => "Only srlu objects");
- }
-
- my $e = new_editor("authtoken" => $auth, "xact" => 1);
- return $e->die_event unless $e->checkauth;
-
- my %streams_ok = ();
- my $pos = 0;
-
- foreach my $user (@$users) {
- unless (exists $streams_ok{$user->stream}) {
- my $stream = $e->retrieve_serial_stream([
- $user->stream, {
- "flesh" => 1,
- "flesh_fields" => {"sstr" => ["distribution"]}
- }
- ]) or return $e->die_event;
- $e->allowed(
- "ADMIN_SERIAL_STREAM", $stream->distribution->holding_lib
- ) or return $e->die_event;
-
- my $to_delete = $e->search_serial_routing_list_user(
- {"stream" => $user->stream}
- ) or return $e->die_event;
-
- $logger->info(
- "Deleting srlu: [" .
- join(", ", map { $_->id; } @$to_delete) .
- "]"
- );
-
- foreach (@$to_delete) {
- $e->delete_serial_routing_list_user($_) or
- return $e->die_event;
- }
-
- $streams_ok{$user->stream} = 1;
- }
-
- next if $user->isdeleted;
-
- $user->clear_id;
- $user->pos($pos++);
- $e->create_serial_routing_list_user($user) or return $e->die_event;
- }
-
- $e->commit or return $e->die_event;
- undef;
-}
-
-__PACKAGE__->register_method(
- "method" => "get_records_with_marc_85x",
- "api_name"=>"open-ils.serial.caption_and_pattern.find_legacy_by_bib_record",
- "stream" => 1,
- "signature" => {
- "desc" => "Return the specified BRE itself and/or any related SRE ".
- "whenever they have 853-855 tags",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "bib record ID", "type" => "number"},
- ],
- "return" => {
- "desc" => "objects, either bre or sre", "type" => "object"
- }
- }
-);
-
-sub get_records_with_marc_85x { # specifically, 853-855
- my ($self, $client, $auth, $bre_id) = @_;
-
- my $e = new_editor("authtoken" => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $bre = $e->search_biblio_record_entry([
- {"id" => $bre_id, "deleted" => "f"}, {
- "flesh" => 1,
- "flesh_fields" => {"bre" => [qw/creator editor owner/]}
- }
- ]) or return $e->die_event;
-
- return undef unless @$bre;
- $bre = $bre->[0];
-
- my $record = MARC::Record->new_from_xml($bre->marc);
- $client->respond($bre) if $record->field("85[3-5]");
- # XXX Is passing a regex to ->field() an abuse of MARC::Record ?
-
- my $sres = $e->search_serial_record_entry([
- {"record" => $bre_id, "deleted" => "f"}, {
- "flesh" => 1,
- "flesh_fields" => {"sre" => [qw/creator editor owning_lib/]}
- }
- ]) or return $e->die_event;
-
- $e->disconnect;
-
- foreach my $sre (@$sres) {
- $client->respond($sre) if
- MARC::Record->new_from_xml($sre->marc)->field("85[3-5]");
- }
-
- undef;
-}
-
-__PACKAGE__->register_method(
- "method" => "create_scaps_from_marcxml",
- "api_name" => "open-ils.serial.caption_and_pattern.create_from_records",
- "stream" => 1,
- "signature" => {
- "desc" => "Create caption and pattern objects from 853-855 tags " .
- "in MARCXML documents",
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Subscription ID", "type" => "number"},
- {"desc" => "list of MARCXML documents as strings",
- "type" => "array"},
- ],
- "return" => {
- "desc" => "Newly created caption and pattern objects",
- "type" => "object", "class" => "scap"
- }
- }
-);
-
-sub create_scaps_from_marcxml {
- my ($self, $client, $auth, $sub_id, $docs) = @_;
-
- return undef unless ref $docs eq "ARRAY";
-
- my $e = new_editor("authtoken" => $auth, "xact" => 1);
- return $e->die_event unless $e->checkauth;
-
- # Retrieve the subscription just for perm checking (whether we can create
- # scaps at the owning lib).
- my $sub = $e->retrieve_serial_subscription($sub_id) or return $e->die_event;
- return $e->die_event unless
- $e->allowed("ADMIN_SERIAL_CAPTION_PATTERN", $sub->owning_lib);
-
- foreach my $record (map { MARC::Record->new_from_xml($_) } @$docs) {
- foreach my $field ($record->field("85[3-5]")) {
- my $scap = new Fieldmapper::serial::caption_and_pattern;
- $scap->subscription($sub_id);
- $scap->type($MFHD_NAMES_BY_TAG{$field->tag});
- $scap->pattern_code(
- OpenSRF::Utils::JSON->perl2JSON(
- [ $field->indicator(1), $field->indicator(2),
- map { @$_ } $field->subfields ] # flattens nested array
- )
- );
- $e->create_serial_caption_and_pattern($scap) or
- return $e->die_event;
- $client->respond($e->data);
- }
- }
-
- $e->commit or return $e->die_event;
- undef;
-}
-
-# All these _clone_foo() functions could possibly have been consolidated into
-# one clever function, but it's faster to get things working this way.
-sub _clone_subscription {
- my ($sub, $bib_id, $e) = @_;
-
- # clone sub itself
- my $new_sub = $sub->clone;
- $new_sub->record_entry(int $bib_id) if $bib_id;
- $new_sub->clear_id;
- $new_sub->clear_distributions;
- $new_sub->clear_notes;
- $new_sub->clear_scaps;
-
- $e->create_serial_subscription($new_sub) or return $e->die_event;
-
- my $new_sub_id = $e->data->id;
- # clone dists
- foreach my $dist (@{$sub->distributions}) {
- my $r = _clone_distribution($dist, $new_sub_id, $e);
- return $r if $U->event_code($r);
- }
-
- # clone sub notes
- foreach my $note (@{$sub->notes}) {
- my $r = _clone_subscription_note($note, $new_sub_id, $e);
- return $r if $U->event_code($r);
- }
-
- # clone scaps
- foreach my $scap (@{$sub->scaps}) {
- my $r = _clone_caption_and_pattern($scap, $new_sub_id, $e);
- return $r if $U->event_code($r);
- }
-
- return $new_sub_id;
-}
-
-sub _clone_distribution {
- my ($dist, $sub_id, $e) = @_;
-
- my $new_dist = $dist->clone;
- $new_dist->clear_id;
- $new_dist->clear_notes;
- $new_dist->clear_streams;
- $new_dist->subscription($sub_id);
-
- $e->create_serial_distribution($new_dist) or return $e->die_event;
- my $new_dist_id = $e->data->id;
-
- # clone streams
- foreach my $stream (@{$dist->streams}) {
- my $r = _clone_stream($stream, $new_dist_id, $e);
- return $r if $U->event_code($r);
- }
-
- # clone distribution notes
- foreach my $note (@{$dist->notes}) {
- my $r = _clone_distribution_note($note, $new_dist_id, $e);
- return $r if $U->event_code($r);
- }
-
- return $new_dist_id;
-}
-
-sub _clone_subscription_note {
- my ($note, $sub_id, $e) = @_;
-
- my $new_note = $note->clone;
- $new_note->clear_id;
- $new_note->creator($e->requestor->id);
- $new_note->create_date("now");
- $new_note->subscription($sub_id);
-
- $e->create_serial_subscription_note($new_note) or return $e->die_event;
- return $e->data->id;
-}
-
-sub _clone_caption_and_pattern {
- my ($scap, $sub_id, $e) = @_;
-
- my $new_scap = $scap->clone;
- $new_scap->clear_id;
- $new_scap->subscription($sub_id);
-
- $e->create_serial_caption_and_pattern($new_scap) or return $e->die_event;
- return $e->data->id;
-}
-
-sub _clone_distribution_note {
- my ($note, $dist_id, $e) = @_;
-
- my $new_note = $note->clone;
- $new_note->clear_id;
- $new_note->creator($e->requestor->id);
- $new_note->create_date("now");
- $new_note->distribution($dist_id);
-
- $e->create_serial_distribution_note($new_note) or return $e->die_event;
- return $e->data->id;
-}
-
-sub _clone_stream {
- my ($stream, $dist_id, $e) = @_;
-
- my $new_stream = $stream->clone;
- $new_stream->clear_id;
- $new_stream->clear_routing_list_users;
- $new_stream->distribution($dist_id);
-
- $e->create_serial_stream($new_stream) or return $e->die_event;
- my $new_stream_id = $e->data->id;
-
- # clone routing list users
- foreach my $user (@{$stream->routing_list_users}) {
- my $r = _clone_routing_list_user($user, $new_stream_id, $e);
- return $r if $U->event_code($r);
- }
-
- return $new_stream_id;
-}
-
-sub _clone_routing_list_user {
- my ($user, $stream_id, $e) = @_;
-
- my $new_user = $user->clone;
- $new_user->clear_id;
- $new_user->stream($stream_id);
-
- $e->create_serial_routing_list_user($new_user) or return $e->die_event;
- return $e->data->id;
-}
-
-__PACKAGE__->register_method(
- "method" => "clone_subscription",
- "api_name" => "open-ils.serial.subscription.clone",
- "signature" => {
- "desc" => q{Clone a subscription, including its attending distributions,
- streams, captions and patterns, routing list users, distribution
- notes and subscription notes. Do not include holdings-specific
- things, like issuances, items, units, summaries. Attach the
- clone either to the same bib record as the original, or to one
- specified by ID.},
- "params" => [
- {"desc" => "Authtoken", "type" => "string"},
- {"desc" => "Subscription ID", "type" => "number"},
- {"desc" => "Bib Record ID (optional)", "type" => "number"}
- ],
- "return" => {
- "desc" => "ID of the new subscription", "type" => "number"
- }
- }
-);
-
-sub clone_subscription {
- my ($self, $client, $auth, $sub_id, $bib_id) = @_;
-
- my $e = new_editor("authtoken" => $auth, "xact" => 1);
- return $e->die_event unless $e->checkauth;
-
- my $sub = $e->retrieve_serial_subscription([
- int $sub_id, {
- "flesh" => 3,
- "flesh_fields" => {
- "ssub" => [qw/distributions notes scaps/],
- "sdist" => [qw/streams notes/],
- "sstr" => ["routing_list_users"]
- }
- }
- ]) or return $e->die_event;
-
- # ADMIN_SERIAL_SUBSCRIPTION will have to be good enough as a
- # catch-all permisison for this operation.
- return $e->die_event unless
- $e->allowed("ADMIN_SERIAL_SUBSCRIPTION", $sub->owning_lib);
-
- my $result = _clone_subscription($sub, $bib_id, $e);
-
- return $e->die_event($result) if $U->event_code($result);
-
- $e->commit or return $e->die_event;
- return $result;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils::Logger qw/:level/;
-
-# Pull this in so we can adjust it's @ISA
-use OpenILS::Application::Storage::CDBI (1);
-use OpenILS::Application::Storage::FTS;
-
-
-# the easy way to get to the logger...
-my $log = "OpenSRF::Utils::Logger";
-
-our $QParser;
-our $WRITE = 0;
-our $IGNORE_XACT_ID_FAILURE = 0;
-
-sub DESTROY {};
-
-sub initialize {
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
-
- $log->debug('Initializing ' . __PACKAGE__ . '...', DEBUG);
-
- my $db_driver = $conf->config_value( apps => 'open-ils.storage' => app_settings => databases => 'driver');
- my $driver = "OpenILS::Application::Storage::Driver::$db_driver";
-
- $log->debug("Attempting to load $driver ...", DEBUG);
-
- $driver->use;
- if ($@) {
- $log->debug( "Can't load $driver! : $@", ERROR );
- $log->error( "Can't load $driver! : $@");
- throw OpenSRF::EX::PANIC ( "Can't load $driver! : $@" );
- }
-
- $log->debug("$driver loaded successfully", DEBUG);
-
- # Suck in the method publishing modules
- @OpenILS::Application::Storage::CDBI::ISA = ( $driver );
-
- OpenILS::Application::Storage::Publisher->use;
- if ($@) {
- $log->debug("FAILURE LOADING Publisher! $@", ERROR);
- throw OpenSRF::EX::PANIC ( "FAILURE LOADING Publisher! : $@" );
- }
-
- $log->debug("We seem to be OK...",DEBUG);
-}
-
-sub child_init {
-
- $log->debug('Running child_init for ' . __PACKAGE__ . '...', DEBUG);
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
-
- $log->debug('Calling the Driver child_init', DEBUG);
- OpenILS::Application::Storage::CDBI->child_init(
- $conf->config_value( apps => 'open-ils.storage' => app_settings => databases => 'database')
- );
-
- if (OpenILS::Application::Storage::CDBI->db_Main()) {
- $log->debug("Success initializing driver!", DEBUG);
-
- my $db_driver = $conf->config_value( apps => 'open-ils.storage' => app_settings => databases => 'driver');
- $QParser = 'OpenILS::Application::Storage::Driver::'.$db_driver.'::QueryParser';
- $QParser->use;
-
- if($@) {
- $log->debug( "Can't load $QParser! : $@", ERROR );
- $log->error( "Can't load $QParser! : $@");
- } else {
- return 1;
- }
- }
-
- $log->debug("FAILURE initializing driver!", ERROR);
- return 0;
-}
-
-sub begin_xaction {
- my $self = shift;
- my $client = shift;
-
- local $WRITE = 1;
-
- $log->debug(" XACT --> 'BEGIN'ing transaction for session ".$client->session->session_id,DEBUG);
- try {
- OpenILS::Application::Storage::CDBI->db_Main->begin_work;
- $client->session->session_data( xact_id => $client->session->session_id );
- } catch Error with {
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Could not BEGIN transaction!",
- );
- };
- return 1;
-
-}
-__PACKAGE__->register_method(
- method => 'begin_xaction',
- api_name => 'open-ils.storage.transaction.begin',
- api_level => 1,
- argc => 0,
-);
-
-sub savepoint_placeholder {
- return 1;
-}
-__PACKAGE__->register_method(
- method => 'savepoint_placeholder',
- api_name => 'open-ils.storage.savepoint.set',
- api_level => 1,
- argc => 1,
-);
-__PACKAGE__->register_method(
- method => 'savepoint_placeholder',
- api_name => 'open-ils.storage.savepoint.release',
- api_level => 1,
- argc => 1,
-);
-__PACKAGE__->register_method(
- method => 'savepoint_placeholder',
- api_name => 'open-ils.storage.savepoint.rollback',
- api_level => 1,
- argc => 1,
-);
-
-sub commit_xaction {
- my $self = shift;
- my $client = shift;
-
- local $WRITE = 1;
-
- try {
- OpenILS::Application::Storage::CDBI->db_Main->commit;
- $client->session->session_data( xact_id => '' );
- } catch Error with {
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Could not COMMIT transaction!",
- );
- };
- return 1;
-}
-__PACKAGE__->register_method(
- method => 'commit_xaction',
- api_name => 'open-ils.storage.transaction.commit',
- api_level => 1,
- argc => 0,
-);
-
-
-sub current_xact {
- my $self = shift;
- my $client = shift;
-
- return $client->session->session_data( 'xact_id' );
-}
-__PACKAGE__->register_method(
- method => 'current_xact',
- api_name => 'open-ils.storage.transaction.current',
- api_level => 1,
- argc => 0,
-);
-
-sub rollback_xaction {
- my $self = shift;
- my $client = shift;
-
- local $WRITE = 1;
-
- $log->debug(" XACT --> 'ROLLBACK'ing transaction for session ".$client->session->session_id,DEBUG);
- $client->session->session_data( xact_id => '' );
- return OpenILS::Application::Storage::CDBI->db_Main->rollback;
-}
-__PACKAGE__->register_method(
- method => 'rollback_xaction',
- api_name => 'open-ils.storage.transaction.rollback',
- api_level => 1,
- argc => 0,
-);
-
-
-sub _cdbi2Hash {
- my $self = shift;
- my $obj = shift;
- return { map { ( $_ => $obj->$_ ) } ($obj->columns('All')) };
-}
-
-sub _cdbi_list2AoH {
- my $self = shift;
- my @objs = @_;
- return [ map { $self->_cdbi2Hash($_) } @objs ];
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::CDBI;
-use UNIVERSAL::require;
-BEGIN {
- 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
-}
-use base qw/Class::DBI/;
-use Class::DBI::AbstractSearch;
-
-use OpenILS::Application::Storage::CDBI::actor;
-use OpenILS::Application::Storage::CDBI::action;
-use OpenILS::Application::Storage::CDBI::booking;
-use OpenILS::Application::Storage::CDBI::asset;
-use OpenILS::Application::Storage::CDBI::serial;
-use OpenILS::Application::Storage::CDBI::authority;
-use OpenILS::Application::Storage::CDBI::biblio;
-use OpenILS::Application::Storage::CDBI::config;
-use OpenILS::Application::Storage::CDBI::metabib;
-use OpenILS::Application::Storage::CDBI::money;
-use OpenILS::Application::Storage::CDBI::permission;
-use OpenILS::Application::Storage::CDBI::container;
-
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw(:level);
-use OpenSRF::EX qw/:try/;
-
-our $VERSION = 1;
-my $log = 'OpenSRF::Utils::Logger';
-
-if ($Class::DBI::VERSION gt '3.0.1') {
- $log->error("Your version of Class::DBI, $Class::DBI::VERSION, is too new and incompatible with Evergreen. You will need to downgrade to version 3.0.1 or install Class::DBI::Frozen::301");
- die("Your version of Class::DBI, $Class::DBI::VERSION, is too new and incompatible with Evergreen. You will need to downgrade to version 3.0.1 or install Class::DBI::Frozen::301");
-}
-
-sub child_init {
- my $self = shift;
-
- $log->debug("Creating ImaDBI Querys", DEBUG);
- __PACKAGE__->set_sql( 'OILSFastSearch', <<" SQL", 'Main');
- SELECT %s
- FROM %s
- WHERE %s = ?
- SQL
-
- __PACKAGE__->set_sql( 'OILSFastOrderedSearchLike', <<" SQL", 'Main');
- SELECT %s
- FROM %s
- WHERE %s LIKE ?
- ORDER BY %s
- SQL
-
- __PACKAGE__->set_sql( 'OILSFastOrderedSearch', <<" SQL", 'Main');
- SELECT %s
- FROM %s
- WHERE %s = ?
- ORDER BY %s
- SQL
-
- $log->debug("Calling Driver child_init", DEBUG);
- $self->SUPER::child_init(@_);
-
-}
-
-sub fast_flesh_sth {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $field = shift;
- my $value = shift;
- my $order = shift;
- my $like = shift;
-
-
- if (!(defined($order) and ref($order) and ref($order) eq 'HASH')) {
- if (defined($value) and ref($value) and ref($value) eq 'HASH') {
- $order = $value;
- $value = undef;
- } else {
- $order = { order_by => $class->columns('Primary') }
- }
- }
-
- unless (defined $value) {
- $value = $field;
- ($field) = $class->columns('Primary');
- }
-
- unless (defined $field) {
- ($field) = $class->columns('Primary');
- }
-
- unless ($order->{order_by}) {
- $order = { order_by => $class->columns('Primary') }
- }
-
- my $fm_class = 'Fieldmapper::'.$class;
- my $field_list = join ',', $class->columns('Essential');
-
- my $sth;
- if (!$like) {
- $sth = $class->sql_OILSFastOrderedSearch( $field_list, $class->table, $field, $order->{order_by});
- } else {
- $sth = $class->sql_OILSFastOrderedSearchLike( $field_list, $class->table, $field, $order->{order_by});
- }
- $sth->execute($value);
- return $sth;
-}
-
-sub fast_flesh {
- my $self = shift;
- return map $class->construct($_), $self->fast_flesh_sth(@_)->fetchall_hash;
-}
-
-sub fast_fieldmapper {
- my $self = shift;
- my $id = shift;
- my $col = shift;
- my $like = shift;
- my $options = shift;
- my $class = ref($self) || $self;
- my $fm_class = 'Fieldmapper::'.$class;
- my @fms;
- $log->debug("fast_fieldmapper() ==> Retrieving $fm_class", INTERNAL);
- if ($like < 2) {
- for my $hash ($self->fast_flesh_sth( $col, "$id", { order_by => $col }, $like )->fetchall_hash) {
- my $fm = $fm_class->new;
- for my $field ( $fm_class->real_fields ) {
- $fm->$field( $$hash{$field} );
- }
- push @fms, $fm;
- }
- } else {
- my $search_type = 'search';
- if ($like == 2) {
- $search_type = 'search_fts'
- } elsif ($like == 3) {
- $search_type = 'search_regex'
- }
-
- for my $obj ($class->$search_type({ $col => $id}, $options)) {
- push @fms, $obj->to_fieldmapper;
- }
- }
- return @fms;
-}
-
-sub retrieve {
- my $self = shift;
- my $arg = shift;
- if (ref($arg) &&
- (UNIVERSAL::isa($arg => 'Fieldmapper') ||
- UNIVERSAL::isa($arg => 'Class::DBI')) ) {
- my ($col) = $self->primary_column;
- $log->debug("Using field $col as the primary key", INTERNAL);
- $arg = $arg->$col;
- } elsif (ref $arg) {
- my ($col) = $self->primary_column;
- $log->debug("Using field $col as the primary key", INTERNAL);
- $arg = $arg->{$col};
- }
-
- $log->debug("Retrieving $self with $arg", INTERNAL);
- my $rec;
- try {
- $rec = $self->SUPER::retrieve("$arg");
- } catch Error with {
- $log->debug("Could not retrieve $self with $arg! -- ".shift(), DEBUG);
- return undef;
- };
- return $rec;
-}
-
-sub to_fieldmapper {
- my $obj = shift;
- my $class = ref($obj) || $obj;
-
- my $fm_class = 'Fieldmapper::'.$class;
- my $fm = $fm_class->new;
-
- if (ref($obj)) {
- for my $field ( $fm->real_fields ) {
- $fm->$field( ''.$obj->$field );
- }
- }
-
- return $fm;
-}
-
-sub merge {
- my $self = shift;
- my $search = shift;
- my $arg = shift;
-
- delete $$arg{$_} for (keys %$search);
-
- $log->debug("CDBI->merge: \$search is $search (".ref($search)." : ".join(',',map{"$_ => $$search{$_}"}keys(%$search)).")",DEBUG);
- $log->debug("CDBI->merge: \$arg is $arg (".ref($arg)." : ".join(',',map{"$_ => $$arg{$_}"}keys(%$arg)).")",DEBUG);
-
- my @objs = ($self);
- @objs = $self->search_where($search) unless (ref $self);
-
- if (@objs == 1) {
- $objs[0]->update($arg);
- return $objs[0];
- } elsif (@objs == 0) {
- return $self->create({%$search,%$arg});
- } else {
- throw OpenSRF::EX::WARN ("Non-unique search key for merge. Perhaps you meant to use remote_update?");
- }
-}
-
-sub remote_update {
- my $self = shift;
- my $search = shift;
- my $arg = shift;
-
- delete $$arg{$_} for (keys %$search);
-
- $log->debug("CDBI->remote_update: \$search is $search (".ref($search)." : ".join(',',map{"$_ => $$search{$_}"}keys(%$search)).")",DEBUG);
- $log->debug("CDBI->remote_update: \$arg is $arg (".ref($arg)." : ".join(',',map{"$_ => $$arg{$_}"}keys(%$arg)).")",DEBUG);
-
-# my @objs = $self->search_where($search);
-# throw OpenSRF::EX::WARN ("No objects found for remote_update. Perhaps you meant to use merge?")
-# if (@objs == 0);
-
-# $_->update($arg) for (@objs);
-# return scalar(@objs);
-
- my @finds = sort keys %$search;
- my @sets = sort keys %$arg;
-
- my @find_vals = @$search{@finds};
- my @set_vals = @$arg{@sets};
-
- my $sql = 'UPDATE %s SET %s WHERE %s';
-
- my $table = $self->table;
- my $set = join(', ', map { "$_=?" } @sets);
- my $where = join(', ', map { "$_=?" } @finds);
-
- my $sth = $self->db_Main->prepare(sprintf($sql, $table, $set, $where));
- $sth->execute(@set_vals,@find_vals);
- return $sth->rows;
-
-}
-
-sub create {
- my $self = shift;
- my $arg = shift;
-
- $log->debug("CDBI->create: \$arg is $arg (".ref($arg)." : ".OpenSRF::Utils::JSON->perl2JSON($arg).")",DEBUG);
-
- if (ref($arg) && UNIVERSAL::isa($arg => 'Fieldmapper')) {
- return $self->create_from_fieldmapper($arg,@_);
- }
-
- return $self->SUPER::create($arg,@_);
-}
-
-sub create_from_fieldmapper {
- my $obj = shift;
- my $fm = shift;
- my @params = @_;
-
- $log->debug("Creating node of type ".ref($fm), DEBUG);
-
- my $class = ref($obj) || $obj;
- my ($primary) = $class->columns('Primary');
-
- if (ref($fm) &&UNIVERSAL::isa($fm => 'Fieldmapper')) {
- my %hash = map { defined $fm->$_ ?
- ($_ => $fm->$_) :
- ()
- } grep { $_ ne $primary } $class->columns('Essential');
-
- if ($class->find_column( 'last_xact_id' )) {
- if ($OpenILS::Application::Storage::IGNORE_XACT_ID_FAILURE) {
- $hash{last_xact_id} = 'unknown.'.time.'.'.$$.'.'.rand($$);
- } else {
- my $xact_id = $class->current_xact_id;
- throw Error unless ($xact_id);
- $hash{last_xact_id} = $xact_id;
- }
- }
-
- return $class->create( \%hash, @params );
- } else {
- return undef;
- }
-}
-
-sub delete {
- my $self = shift;
- my $arg = shift;
- my $orig = $self;
-
- my $class = ref($self) || $self;
-
- $self = $self->retrieve($arg) if (!ref($self));
- unless (defined $self) {
- $log->debug("ARG! Couldn't retrieve record ".$arg->id, DEBUG);
- throw OpenSRF::EX::WARN ("ARG! Couldn't retrieve record ");
- }
-
- if ($class->find_column( 'last_xact_id' )) {
- my $xact_id = $self->current_xact_id;
-
- throw Error ("Deleting from $class requires a transaction be established")
- unless ($xact_id);
-
- throw Error ("The row you are attempting to delete has been changed since you read it")
- unless ( $orig->last_xact_id eq $self->last_xact_id);
-
- $self->last_xact_id( $class->current_xact_id );
- $self->SUPER::update;
- }
-
- $self->SUPER::delete;
-
- return 1;
-}
-
-sub debug_object {
- my $obj = shift;
- my $string = '';
-
- $string .= "Object type:\t".ref($obj)."\n";
- $string .= "Object string:\t$obj\n";
-
- if (ref($obj) && UNIVERSAL::isa($obj => 'Fieldmapper')) {
- $string .= "Object fields:\n";
- for my $col ($obj->real_fields()) {
- $string .= "\t$col\t=> ".$obj->$col."\n";
- }
- } elsif (ref($obj) && UNIVERSAL::isa($obj => 'Class::DBI')) {
- $string .= "Object cols:\n";
- for my $col ($obj->columns('All')) {
- $string .= "\t$col\t=> ".$obj->$col."\n";
- }
- } elsif (ref($obj) && UNIVERSAL::isa($obj => 'HASH')) {
- $string .= "Object keys and vals:\n";
- for my $col (keys %$obj) {
- $string .= "\t$col\t=> $$obj{$col}\n";
- }
- }
-
- $string .= "\n";
-
- $log->debug($string,DEBUG);
-}
-
-
-sub update {
- my $self = shift;
- my $arg = shift;
-
- $log->debug("Attempting to update using $arg", DEBUG) if ($arg);
-
- if (ref($arg)) {
- $self = $self->modify_from_fieldmapper($arg);
- unless (defined $self) {
- $log->debug("Modification of $arg seems to have failed....", DEBUG);
- return undef;
- }
- }
-
- $log->debug("Calling Class::DBI->update on modified object $self", DEBUG);
-
- #debug_object($self);
-
- return $self->SUPER::update if ($self->is_changed);
- return 0;
-}
-
-sub modify_from_fieldmapper {
- my $obj = shift;
- my $fm = shift;
- my $orig = $obj;
-
- #debug_object($obj);
- #debug_object($fm);
-
- $log->debug("Modifying object using fieldmapper", DEBUG);
-
- my $class = ref($obj) || $obj;
- my ($primary) = $class->columns('Primary');
-
-
- if (!ref($obj)) {
- $obj = $class->retrieve($fm);
- #debug_object($obj);
- unless ($obj) {
- $log->debug("Retrieve of $class using $fm (".$fm->id.") failed! -- ".shift(), ERROR);
- throw OpenSRF::EX::WARN ("No $class with id of ".$fm->id."!!");
- }
- }
-
- my %hash;
-
- if (ref($fm) and UNIVERSAL::isa($fm => 'Fieldmapper')) {
- %hash = map { ($_ => $fm->$_) } grep { $_ ne $primary } $class->columns('Essential');
- delete $hash{passwd} if ($fm->isa('Fieldmapper::actor::user'));
- } else {
- %hash = %{$fm};
- }
-
- my $au = $obj->autoupdate;
- $obj->autoupdate(0);
-
- #debug_object($obj);
-
- for my $field ( keys %hash ) {
- $obj->$field( $hash{$field} ) if ($obj->$field ne $hash{$field});
- $log->debug("Setting field $field on $obj to $hash{$field}",INTERNAL);
- }
-
- if ($class->find_column( 'last_xact_id' ) and $obj->is_changed) {
- my ($xact_id) = OpenILS::Application::Storage->method_lookup('open-ils.storage.transaction.current')->run();
- throw Error ("Updating $class requires a transaction be established")
- unless ($xact_id);
- throw Error ("The row you are attempting to delete has been changed since you read it")
- unless ( $fm->last_xact_id eq $obj->last_xact_id);
- $obj->last_xact_id( $xact_id );
- } else {
- $obj->autoupdate($au)
- }
-
- return $obj;
-}
-
-
-
- #-------------------------------------------------------------------------------
- actor::user->has_a( home_ou => 'actor::org_unit' );
- actor::user->has_a( card => 'actor::card' );
- actor::user->has_a( standing => 'config::standing' );
- actor::user->has_a( profile => 'permission::grp_tree' );
- actor::user->has_a( mailing_address => 'actor::user_address' );
- actor::user->has_a( billing_address => 'actor::user_address' );
- actor::user->has_a( ident_type => 'config::identification_type' );
- actor::user->has_a( ident_type2 => 'config::identification_type' );
- actor::user->has_a( net_access_level => 'config::net_access_level' );
-
- actor::user_address->has_a( usr => 'actor::user' );
-
- actor::card->has_a( usr => 'actor::user' );
-
- actor::workstation->has_a( owning_lib => 'actor::org_unit' );
- actor::org_unit::closed_date->has_a( org_unit => 'actor::org_unit' );
- actor::org_unit_setting->has_a( org_unit => 'actor::org_unit' );
-
- actor::usr_note->has_a( usr => 'actor::user' );
- actor::user->has_many( notes => 'actor::usr_note' );
-
- actor::user_standing_penalty->has_a( usr => 'actor::user' );
- actor::user->has_many( standing_penalties => 'actor::user_standing_penalty' );
-
- actor::org_unit->has_a( parent_ou => 'actor::org_unit' );
- actor::org_unit->has_a( ou_type => 'actor::org_unit_type' );
- actor::org_unit->has_a( ill_address => 'actor::org_address' );
- actor::org_unit->has_a( holds_address => 'actor::org_address' );
- actor::org_unit->has_a( mailing_address => 'actor::org_address' );
- actor::org_unit->has_a( billing_address => 'actor::org_address' );
- actor::org_unit->has_many( children => 'actor::org_unit' => 'parent_ou' );
- actor::org_unit->has_many( workstations => 'actor::workstation' );
- actor::org_unit->has_many( closed_dates => 'actor::org_unit::closed_date' );
- actor::org_unit->has_many( settings => 'actor::org_unit_setting' );
- #actor::org_unit->might_have( hours_of_operation => 'actor::org_unit::hours_of_operation' );
-
- actor::org_unit_type->has_a( parent => 'actor::org_unit_type' );
- actor::org_unit_type->has_many( children => 'actor::org_unit_type' => 'parent' );
-
- actor::org_address->has_a( org_unit => 'actor::org_unit' );
- actor::org_unit->has_many( addresses => 'actor::org_address' );
-
- action::transit_copy->has_a( source => 'actor::org_unit' );
- action::transit_copy->has_a( dest => 'actor::org_unit' );
- action::transit_copy->has_a( copy_status => 'config::copy_status' );
-
- action::hold_transit_copy->has_a( source => 'actor::org_unit' );
- action::hold_transit_copy->has_a( dest => 'actor::org_unit' );
- action::hold_transit_copy->has_a( copy_status => 'config::copy_status' );
- action::hold_transit_copy->has_a( hold => 'action::hold_request' );
-
- action::hold_request->has_many( transits => 'action::hold_transit_copy' );
-
- actor::stat_cat_entry->has_a( stat_cat => 'actor::stat_cat' );
- actor::stat_cat->has_a( owner => 'actor::org_unit' );
- actor::stat_cat->has_many( entries => 'actor::stat_cat_entry' );
- actor::stat_cat_entry_user_map->has_a( stat_cat => 'actor::stat_cat' );
- actor::stat_cat_entry_user_map->has_a( stat_cat_entry => 'actor::stat_cat_entry' );
- actor::stat_cat_entry_user_map->has_a( target_usr => 'actor::user' );
-
- asset::stat_cat_entry->has_a( stat_cat => 'asset::stat_cat' );
- asset::stat_cat->has_a( owner => 'actor::org_unit' );
- asset::stat_cat->has_many( entries => 'asset::stat_cat_entry' );
- asset::stat_cat_entry_copy_map->has_a( stat_cat => 'asset::stat_cat' );
- asset::stat_cat_entry_copy_map->has_a( stat_cat_entry => 'asset::stat_cat_entry' );
- asset::stat_cat_entry_copy_map->has_a( owning_copy => 'asset::copy' );
-
- action::survey_response->has_a( usr => 'actor::user' );
- action::survey_response->has_a( survey => 'action::survey' );
- action::survey_response->has_a( question => 'action::survey_question' );
- action::survey_response->has_a( answer => 'action::survey_answer' );
-
- action::survey_question->has_a( survey => 'action::survey' );
-
- action::survey_answer->has_a( question => 'action::survey_question' );
-
- asset::copy_note->has_a( owning_copy => 'asset::copy' );
- asset::copy_note->has_a( creator => 'actor::user' );
-
- actor::user->has_many( stat_cat_entries => [ 'actor::stat_cat_entry_user_map' => 'stat_cat_entry' ] );
- actor::user->has_many( stat_cat_entry_user_maps => 'actor::stat_cat_entry_user_map' );
-
- asset::copy->has_many( stat_cat_entries => [ 'asset::stat_cat_entry_copy_map' => 'stat_cat_entry' ] );
- asset::copy->has_many( stat_cat_entry_copy_maps => 'asset::stat_cat_entry_copy_map' );
-
- asset::copy->has_a( call_number => 'asset::call_number' );
- asset::copy->has_a( creator => 'actor::user' );
- asset::copy->has_a( editor => 'actor::user' );
- asset::copy->has_a( status => 'config::copy_status' );
- asset::copy->has_a( location => 'asset::copy_location' );
- asset::copy->has_a( circ_lib => 'actor::org_unit' );
-
- serial::unit->has_a( call_number => 'asset::call_number' );
- serial::unit->has_a( creator => 'actor::user' );
- serial::unit->has_a( editor => 'actor::user' );
- serial::unit->has_a( status => 'config::copy_status' );
- serial::unit->has_a( location => 'asset::copy_location' );
- serial::unit->has_a( circ_lib => 'actor::org_unit' );
-
- serial::item->has_a( unit => 'serial::unit' );
- serial::item->has_a( issuance => 'serial::issuance' );
- serial::item->has_a( uri => 'asset::uri' );
-
- serial::unit->has_many( items => 'serial::item' );
-
- serial::issuance->has_a( subscription => 'serial::subscription' );
- serial::issuance->has_many( items => 'serial::item' );
-
- serial::subscription->has_a( record_entry => 'biblio::record_entry' );
- serial::subscription->has_many( issuances => 'serial::issuance' );
-
- asset::call_number_note->has_a( call_number => 'asset::call_number' );
-
- asset::call_number->has_a( record => 'biblio::record_entry' );
- asset::call_number->has_a( creator => 'actor::user' );
- asset::call_number->has_a( editor => 'actor::user' );
- asset::call_number->has_a( owning_lib => 'actor::org_unit' );
-
- authority::record_note->has_a( record => 'authority::record_entry' );
- biblio::record_note->has_a( record => 'biblio::record_entry' );
-
- authority::record_entry->has_a( creator => 'actor::user' );
- authority::record_entry->has_a( editor => 'actor::user' );
- biblio::record_entry->has_a( creator => 'actor::user' );
- biblio::record_entry->has_a( editor => 'actor::user' );
-
- metabib::metarecord->has_a( master_record => 'biblio::record_entry' );
-
- authority::record_descriptor->has_a( record => 'authority::record_entry' );
- metabib::record_descriptor->has_a( record => 'biblio::record_entry' );
-
- authority::full_rec->has_a( record => 'authority::record_entry' );
- metabib::full_rec->has_a( record => 'biblio::record_entry' );
-
- metabib::title_field_entry->has_a( source => 'biblio::record_entry' );
- metabib::title_field_entry->has_a( field => 'config::metabib_field' );
-
- metabib::identifier_field_entry->has_a( source => 'biblio::record_entry' );
- metabib::identifier_field_entry->has_a( field => 'config::metabib_field' );
-
- metabib::author_field_entry->has_a( source => 'biblio::record_entry' );
- metabib::author_field_entry->has_a( field => 'config::metabib_field' );
-
- metabib::subject_field_entry->has_a( source => 'biblio::record_entry' );
- metabib::subject_field_entry->has_a( field => 'config::metabib_field' );
-
- metabib::keyword_field_entry->has_a( source => 'biblio::record_entry' );
- metabib::keyword_field_entry->has_a( field => 'config::metabib_field' );
-
- metabib::series_field_entry->has_a( source => 'biblio::record_entry' );
- metabib::series_field_entry->has_a( field => 'config::metabib_field' );
-
- metabib::metarecord_source_map->has_a( metarecord => 'metabib::metarecord' );
- metabib::metarecord_source_map->has_a( source => 'biblio::record_entry' );
-
- action::circulation->has_a( usr => 'actor::user' );
- actor::user->has_many( circulations => 'action::circulation' => 'usr' );
-
- booking::resource_attr_map->has_a( resource => 'booking::resource' );
-
- booking::resource->has_a( owner => 'actor::org_unit' );
- booking::resource->has_a( type => 'booking::resource_type' );
- booking::resource_type->has_a( owner => 'actor::org_unit' );
-
- booking::reservation->has_a( usr => 'actor::user' );
- actor::user->has_many( reservations => 'booking::reservation' => 'usr' );
-
- action::circulation->has_a( circ_staff => 'actor::user' );
- actor::user->has_many( performed_circulations => 'action::circulation' => 'circ_staff' );
-
- action::circulation->has_a( checkin_staff => 'actor::user' );
- actor::user->has_many( checkins => 'action::circulation' => 'checkin_staff' );
-
- action::circulation->has_a( target_copy => 'asset::copy' );
- asset::copy->has_many( circulations => 'action::circulation' => 'target_copy' );
- serial::unit->has_many( circulations => 'action::circulation' => 'target_copy' );
-
- booking::reservation->has_a( pickup_lib => 'actor::org_unit' );
-
- action::circulation->has_a( circ_lib => 'actor::org_unit' );
- actor::org_unit->has_many( circulations => 'action::circulation' => 'circ_lib' );
-
- action::circulation->has_a( checkin_lib => 'actor::org_unit' );
- actor::org_unit->has_many( checkins => 'action::circulation' => 'checkin_lib' );
-
- money::billable_transaction->has_a( usr => 'actor::user' );
- #money::billable_transaction->might_have( circulation => 'action::circulation' );
- #money::billable_transaction->might_have( grocery => 'money::grocery' );
- actor::user->has_many( billable_transactions => 'action::circulation' => 'usr' );
-
-
- #-------------------------------------------------------------------------------
- actor::user->has_many( survey_responses => 'action::survey_response' );
- actor::user->has_many( addresses => 'actor::user_address' );
- actor::user->has_many( cards => 'actor::card' );
-
- actor::org_unit->has_many( users => 'actor::user' );
-
- action::survey->has_many( questions => 'action::survey_question' );
- action::survey->has_many( responses => 'action::survey_response' );
-
- action::survey_question->has_many( answers => 'action::survey_answer' );
- action::survey_question->has_many( responses => 'action::survey_response' );
-
- action::survey_answer->has_many( responses => 'action::survey_response' );
-
- asset::copy->has_many( notes => 'asset::copy_note' );
- asset::call_number->has_many( copies => 'asset::copy' );
- asset::call_number->has_many( notes => 'asset::call_number_note' );
-
- authority::record_entry->has_many( record_descriptor => 'authority::record_descriptor' );
- authority::record_entry->has_many( notes => 'authority::record_note' );
-
- biblio::record_entry->has_many( record_descriptor => 'metabib::record_descriptor' );
- biblio::record_entry->has_many( notes => 'biblio::record_note' );
- biblio::record_entry->has_many( call_numbers => 'asset::call_number' );
- biblio::record_entry->has_many( full_record_entries => 'metabib::full_rec' );
- biblio::record_entry->has_many( title_field_entries => 'metabib::title_field_entry' );
- biblio::record_entry->has_many( identifier_field_entries => 'metabib::identifier_field_entry' );
- biblio::record_entry->has_many( author_field_entries => 'metabib::author_field_entry' );
- biblio::record_entry->has_many( subject_field_entries => 'metabib::subject_field_entry' );
- biblio::record_entry->has_many( keyword_field_entries => 'metabib::keyword_field_entry' );
- biblio::record_entry->has_many( series_field_entries => 'metabib::series_field_entry' );
-
- metabib::metarecord->has_many( source_records => [ 'metabib::metarecord_source_map' => 'source'] );
- biblio::record_entry->has_many( metarecords => [ 'metabib::metarecord_source_map' => 'metarecord'] );
-
- money::billing->has_a( xact => 'money::billable_transaction' );
- money::payment->has_a( xact => 'money::billable_transaction' );
-
- money::billable_transaction->has_many( billings => 'money::billing' );
- money::billable_transaction->has_many( payments => 'money::payment' );
-
- action::circulation->has_many( billings => 'money::billing' => 'xact' );
- action::circulation->has_many( payments => 'money::payment' => 'xact' );
- #action::circulation->might_have( billable_transaction => 'money::billable_transaction' );
- #action::open_circulation->might_have( circulation => 'action::circulation' );
-
- booking::reservation->has_many( billings => 'money::billing' => 'xact' );
- booking::reservation->has_many( payments => 'money::payment' => 'xact' );
-
- action::in_house_use->has_a( org_unit => 'actor::org_unit' );
- action::in_house_use->has_a( staff => 'actor::user' );
- action::in_house_use->has_a( item => 'asset::copy' );
-
- action::non_cataloged_circulation->has_a( circ_lib => 'actor::org_unit' );
- action::non_cataloged_circulation->has_a( item_type => 'config::non_cataloged_type' );
- action::non_cataloged_circulation->has_a( patron => 'actor::user' );
- action::non_cataloged_circulation->has_a( staff => 'actor::user' );
-
- money::grocery->has_many( billings => 'money::billing' => 'xact' );
- money::grocery->has_many( payments => 'money::payment' => 'xact' );
- #money::grocery->might_have( billable_transaction => 'money::billable_transaction' );
-
- #money::payment->might_have( cash_payment => 'money::cash_payment' );
- #money::payment->might_have( check_payment => 'money::check_payment' );
- #money::payment->might_have( credit_card_payment => 'money::credit_card_payment' );
- #money::payment->might_have( forgive_payment => 'money::forgive_payment' );
- #money::payment->might_have( work_payment => 'money::work_payment' );
- #money::payment->might_have( credit_payment => 'money::credit_payment' );
-
- money::cash_payment->has_a( xact => 'money::billable_transaction' );
- money::cash_payment->has_a( accepting_usr => 'actor::user' );
- #money::cash_payment->might_have( payment => 'money::payment' );
-
- money::check_payment->has_a( xact => 'money::billable_transaction' );
- money::check_payment->has_a( accepting_usr => 'actor::user' );
- #money::check_payment->might_have( payment => 'money::payment' );
-
- money::credit_card_payment->has_a( xact => 'money::billable_transaction' );
- money::credit_card_payment->has_a( accepting_usr => 'actor::user' );
- #money::credit_card_payment->might_have( payment => 'money::payment' );
-
- money::forgive_payment->has_a( xact => 'money::billable_transaction' );
- money::forgive_payment->has_a( accepting_usr => 'actor::user' );
- #money::forgive_payment->might_have( payment => 'money::payment' );
-
- money::work_payment->has_a( xact => 'money::billable_transaction' );
- money::work_payment->has_a( accepting_usr => 'actor::user' );
- #money::work_payment->might_have( payment => 'money::payment' );
-
- money::goods_payment->has_a( xact => 'money::billable_transaction' );
- money::goods_payment->has_a( accepting_usr => 'actor::user' );
- #money::goods_payment->might_have( payment => 'money::payment' );
-
- money::credit_payment->has_a( xact => 'money::billable_transaction' );
- money::credit_payment->has_a( accepting_usr => 'actor::user' );
- #money::credit_payment->might_have( payment => 'money::payment' );
-
- permission::grp_tree->has_a( parent => 'permission::grp_tree' );
- permission::grp_tree->has_many( children => 'permission::grp_tree' => 'parent' );
-
- permission::grp_perm_map->has_a( grp => 'permission::grp_tree' );
- permission::grp_perm_map->has_a( perm => 'permission::perm_list' );
- permission::grp_perm_map->has_a( depth => 'actor::org_unit_type' );
-
- permission::usr_perm_map->has_a( usr => 'actor::user' );
- permission::usr_perm_map->has_a( perm => 'permission::perm_list' );
- permission::usr_perm_map->has_a( depth => 'actor::org_unit_type' );
-
- permission::usr_grp_map->has_a( usr => 'actor::user' );
- permission::usr_grp_map->has_a( grp => 'permission::grp_tree' );
-
- action::hold_notification->has_a( hold => 'action::hold_request' );
-
- action::hold_copy_map->has_a( hold => 'action::hold_request' );
- action::hold_copy_map->has_a( target_copy => 'asset::copy' );
-
- action::unfulfilled_hold_list->has_a( current_copy => 'asset::copy' );
- action::unfulfilled_hold_list->has_a( hold => 'action::hold_request' );
- action::unfulfilled_hold_list->has_a( circ_lib => 'actor::org_unit' );
-
- action::hold_request->has_a( current_copy => 'asset::copy' );
- action::hold_request->has_a( requestor => 'actor::user' );
- action::hold_request->has_a( usr => 'actor::user' );
- action::hold_request->has_a( fulfillment_staff => 'actor::user' );
- action::hold_request->has_a( pickup_lib => 'actor::org_unit' );
- action::hold_request->has_a( request_lib => 'actor::org_unit' );
- action::hold_request->has_a( fulfillment_lib => 'actor::org_unit' );
- action::hold_request->has_a( selection_ou => 'actor::org_unit' );
-
- action::hold_request->has_many( notifications => 'action::hold_notification' );
- action::hold_request->has_many( eligible_copies => [ 'action::hold_copy_map' => 'target_copy' ] );
-
- asset::copy->has_many( holds => [ 'action::hold_copy_map' => 'hold' ] );
- serial::unit->has_many( holds => [ 'action::hold_copy_map' => 'hold' ] );
-
- container::biblio_record_entry_bucket->has_a( owner => 'actor::user' );
- container::biblio_record_entry_bucket_item->has_a( bucket => 'container::biblio_record_entry_bucket' );
- container::biblio_record_entry_bucket_item->has_a( target_biblio_record_entry => 'biblio::record_entry' );
- container::biblio_record_entry_bucket->has_many( items => 'container::biblio_record_entry_bucket_item' );
-
- container::user_bucket->has_a( owner => 'actor::user' );
- container::user_bucket_item->has_a( bucket => 'container::user_bucket' );
- container::user_bucket_item->has_a( target_user => 'actor::user' );
- container::user_bucket->has_many( items => 'container::user_bucket_item' );
-
- container::call_number_bucket->has_a( owner => 'actor::user' );
- container::call_number_bucket_item->has_a( bucket => 'container::call_number_bucket' );
- container::call_number_bucket_item->has_a( target_call_number => 'asset::call_number' );
- container::call_number_bucket->has_many( items => 'container::call_number_bucket_item' );
-
- container::copy_bucket->has_a( owner => 'actor::user' );
- container::copy_bucket_item->has_a( bucket => 'container::copy_bucket' );
- container::copy_bucket_item->has_a( target_copy => 'asset::copy' );
- container::copy_bucket->has_many( items => 'container::copy_bucket_item' );
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::action;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package action;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-
-package action::in_house_use;
-use base qw/action/;
-__PACKAGE__->table('action_in_house_use');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/item staff org_unit use_time/);
-#-------------------------------------------------------------------------------
-
-package action::non_cat_in_house_use;
-use base qw/action/;
-__PACKAGE__->table('action_non_cat_in_house_use');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/item_type staff org_unit use_time/);
-#-------------------------------------------------------------------------------
-
-package action::non_cataloged_circulation;
-use base qw/action/;
-__PACKAGE__->table('action_non_cataloged_circulation');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/patron staff circ_lib item_type circ_time/);
-#-------------------------------------------------------------------------------
-
-package action::survey;
-use base qw/action/;
-__PACKAGE__->table('action_survey');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name description owner start_date
- end_date usr_summary opac poll required/);
-#-------------------------------------------------------------------------------
-
-package action::survey_question;
-use base qw/action/;
-__PACKAGE__->table('action_survey_question');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/survey question/);
-#-------------------------------------------------------------------------------
-
-
-package action::survey_answer;
-use base qw/action/;
-__PACKAGE__->table('action_survey_answer');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/question answer/);
-#-------------------------------------------------------------------------------
-
-package action::survey_response;
-use base qw/action/;
-__PACKAGE__->table('action_survey_response');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/response_group_id usr survey question
- answer answer_date effective_date/);
-#-------------------------------------------------------------------------------
-
-package action::circulation;
-use base qw/action/;
-__PACKAGE__->table('action_circulation');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr target_copy circ_lib
- duration duration_rule renewal_remaining
- recurring_fine_rule recurring_fine stop_fines
- max_fine max_fine_rule fine_interval
- stop_fines xact_finish due_date opac_renewal
- checkin_staff circ_staff circ_lib checkin_lib
- stop_fines_time checkin_time desk_renewal
- phone_renewal create_time/);
-
-#-------------------------------------------------------------------------------
-
-package action::open_circulation;
-use base qw/action/;
-__PACKAGE__->table('action_open_circulation');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr target_copy circ_lib
- duration duration_rule renewal_remaining
- recurring_fine_rule recurring_fine stop_fines
- max_fine max_fine_rule fine_interval
- stop_fines xact_finish due_date opac_renewal
- checkin_staff circ_staff circ_lib checkin_lib
- stop_fines_time checkin_time desk_renewal
- phone_renewal/);
-
-#-------------------------------------------------------------------------------
-
-package action::hold_request;
-use base qw/action/;
-__PACKAGE__->table('action_hold_request');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/request_time capture_time fulfillment_time
- prev_check_time expire_time requestor usr cancel_cause
- hold_type holdable_formats target cancel_time shelf_time
- phone_notify email_notify selection_depth cancel_note
- pickup_lib current_copy request_lib frozen thaw_date mint_condition
- fulfillment_staff fulfillment_lib selection_ou cut_in_line/);
-
-#-------------------------------------------------------------------------------
-
-package action::hold_notification;
-use base qw/action/;
-__PACKAGE__->table('action_hold_notification');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/hold method notify_time note notify_staff/);
-
-#-------------------------------------------------------------------------------
-
-package action::hold_copy_map;
-use base qw/action/;
-__PACKAGE__->table('action_hold_copy_map');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/hold target_copy/);
-
-#-------------------------------------------------------------------------------
-
-package action::hold_transit_copy;
-use base qw/action/;
-__PACKAGE__->table('action_hold_transit_copy');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/source dest persistant_transfer target_copy
- source_send_time dest_recv_time prev_hop prev_dest
- copy_status hold/);
-
-#-------------------------------------------------------------------------------
-
-package action::reservation_transit_copy;
-use base qw/action/;
-__PACKAGE__->table('action_reservation_transit_copy');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/source dest persistant_transfer target_copy
- source_send_time dest_recv_time prev_hop prev_dest
- copy_status reservation/);
-
-#-------------------------------------------------------------------------------
-
-package action::transit_copy;
-use base qw/action/;
-__PACKAGE__->table('action_transit_copy');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/source dest persistant_transfer target_copy
- source_send_time dest_recv_time prev_hop prev_dest
- copy_status/);
-
-#-------------------------------------------------------------------------------
-
-package action::unfulfilled_hold_list;
-use base qw/action/;
-__PACKAGE__->table('action_unfulfilled_hold_list');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/hold current_copy circ_lib fail_time /);
-
-#-------------------------------------------------------------------------------
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::actor;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package actor;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package actor::user;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_usr' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/usrname email first_given_name
- second_given_name family_name billing_address
- claims_returned_count home_ou dob deleted juvenile
- active master_account ident_type ident_value
- ident_type2 ident_value2 net_access_level alias
- photo_url create_date expire_date credit_forward_balance
- super_user usrgroup passwd card last_xact_id
- standing barred profile prefix suffix alert_message
- day_phone evening_phone other_phone mailing_address/ );
-
-#-------------------------------------------------------------------------------
-package actor::usr_org_unit_opt_in;
-use base qw/actor/;
-__PACKAGE__->table( 'actor_usr_org_unit_opt_in' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/org_unit usr staff opt_in_ts opt_in_ws/ );
-
-#-------------------------------------------------------------------------------
-package actor::org_unit_proximity;
-use base qw/actor/;
-__PACKAGE__->table( 'actor_org_unit_proximity' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/from_org to_org prox/ );
-
-#-------------------------------------------------------------------------------
-package actor::usr_note;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_usr_note' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/usr title creator create_date value pub/ );
-
-#-------------------------------------------------------------------------------
-package actor::workstation;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_workstation' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/name owning_lib/);
-
-#-------------------------------------------------------------------------------
-package actor::user_standing_penalty;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_user_standing_penalty' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/usr penalty_type/);
-
-#-------------------------------------------------------------------------------
-package actor::user_setting;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_user_setting' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/usr name value/);
-
-#-------------------------------------------------------------------------------
-package actor::org_unit_type;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_org_unit_type' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/name opac_label depth parent can_have_vols can_have_users/);
-
-#-------------------------------------------------------------------------------
-package actor::org_unit;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_org_unit' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/parent_ou ou_type mailing_address billing_address
- ill_address holds_address shortname name email phone opac_visible fiscal_calendar/);
-
-#-------------------------------------------------------------------------------
-package actor::org_unit::hours_of_operation;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_hours_of_operation' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/dow_0_open dow_0_close dow_1_open dow_1_close dow_2_open dow_2_close
- dow_3_open dow_3_close dow_4_open dow_4_close dow_5_open dow_5_close
- dow_6_open dow_6_close/);
-
-#-------------------------------------------------------------------------------
-package actor::org_unit::closed_date;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_org_unit_closed' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/org_unit close_start close_end reason/);
-
-
-#-------------------------------------------------------------------------------
-package actor::org_unit_setting;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_org_unit_setting' );
-__PACKAGE__->columns( Primary => qw/id/);
-__PACKAGE__->columns( Essential => qw/org_unit name value/);
-
-
-#-------------------------------------------------------------------------------
-package actor::stat_cat;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_stat_cat' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/owner name opac_visible usr_summary/ );
-
-#-------------------------------------------------------------------------------
-package actor::stat_cat_entry;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_stat_cat_entry' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/stat_cat owner value/ );
-
-#-------------------------------------------------------------------------------
-package actor::stat_cat_entry_user_map;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_stat_cat_entry_usr_map' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/stat_cat stat_cat_entry target_usr/ );
-
-#-------------------------------------------------------------------------------
-package actor::card;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_card' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/usr barcode active/ );
-
-#-------------------------------------------------------------------------------
-package actor::user_access_entry;
-use base qw/actor/;
-#-------------------------------------------------------------------------------
-package actor::perm_group;
-use base qw/actor/;
-#-------------------------------------------------------------------------------
-package actor::permission;
-use base qw/actor/;
-#-------------------------------------------------------------------------------
-package actor::perm_group_permission_map;
-use base qw/actor/;
-#-------------------------------------------------------------------------------
-package actor::perm_group_user_map;
-use base qw/actor/;
-#-------------------------------------------------------------------------------
-package actor::user_address;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_usr_address' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/valid address_type usr street1 street2
- city county state country post_code
- within_city_limits/ );
-
-#-------------------------------------------------------------------------------
-package actor::org_address;
-use base qw/actor/;
-
-__PACKAGE__->table( 'actor_org_address' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/valid address_type org_unit street1 street2
- city county state country post_code/ );
-
-#-------------------------------------------------------------------------------
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::asset;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package asset;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package asset::copy_location;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_copy_location' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/name owning_lib holdable hold_verify opac_visible circulate label_prefix label_suffix/ );
-
-#-------------------------------------------------------------------------------
-package asset::copy_location_order;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_copy_location_order' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/location org position/ );
-
-#-------------------------------------------------------------------------------
-package asset::call_number_class;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_call_number_class' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/name normalizer field/ );
-
-#-------------------------------------------------------------------------------
-package asset::call_number;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_call_number' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/record label creator create_date editor
- edit_date record label owning_lib deleted label_class label_sortkey/ );
-
-#-------------------------------------------------------------------------------
-package asset::call_number_note;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_call_number_note' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/call_number title creator create_date value pub/ );
-
-#-------------------------------------------------------------------------------
-package asset::copy;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_copy' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/call_number barcode creator create_date editor
- edit_date copy_number status loan_duration circ_lib dummy_isbn
- fine_level circulate deposit price ref opac_visible
- circ_as_type circ_modifier deposit_amount location mint_condition
- holdable dummy_title dummy_author deleted alert_message
- age_protect floating cost status_changed_time/ );
-
-#-------------------------------------------------------------------------------
-package asset::stat_cat;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_stat_cat' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/owner name opac_visible required/ );
-
-#-------------------------------------------------------------------------------
-package asset::stat_cat_entry;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_stat_cat_entry' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/stat_cat owner value/ );
-
-#-------------------------------------------------------------------------------
-package asset::stat_cat_entry_copy_map;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_stat_cat_entry_copy_map' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/stat_cat stat_cat_entry owning_copy/ );
-
-#-------------------------------------------------------------------------------
-package asset::copy_note;
-use base qw/asset/;
-
-__PACKAGE__->table( 'asset_copy_note' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/owning_copy title creator create_date value pub/ );
-
-#-------------------------------------------------------------------------------
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::authority;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package authority;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package authority::record_entry;
-use base qw/authority/;
-
-authority::record_entry->table( 'authority_record_entry' );
-authority::record_entry->columns( Primary => qw/id/ );
-authority::record_entry->columns( Essential => qw/creator editor
- create_date edit_date source active
- deleted marc last_xact_id/ );
-
-#-------------------------------------------------------------------------------
-package authority::record_note;
-use base qw/authority/;
-
-authority::record_note->table( 'authority_record_note' );
-authority::record_note->columns( Primary => qw/id/ );
-authority::record_note->columns( Essential => qw/record value creator
- editor create_date edit_date/ );
-#-------------------------------------------------------------------------------
-package authority::full_rec;
-use base qw/authority/;
-
-authority::full_rec->table( 'authority_full_rec' );
-authority::full_rec->columns( Primary => qw/id/ );
-authority::full_rec->columns( Essential => qw/record tag ind1 ind2 subfield value/ );
-
-#-------------------------------------------------------------------------------
-package authority::record_descriptor;
-use base qw/authority/;
-#use OpenILS::Application::Storage::CDBI::asset;
-
-authority::record_descriptor->table( 'authority_rec_descriptor' );
-authority::record_descriptor->columns( Primary => qw/id/ );
-authority::record_descriptor->columns( Essential => qw/record record_status
- char_encoding/ );
-
-#-------------------------------------------------------------------------------
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::biblio;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package biblio;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package biblio::record_entry;
-use base qw/biblio/;
-
-biblio::record_entry->table( 'biblio_record_entry' );
-biblio::record_entry->columns( Essential => qw/id tcn_source tcn_value creator editor
- create_date edit_date source active quality owner share_depth
- deleted marc last_xact_id fingerprint/ );
-
-#-------------------------------------------------------------------------------
-package biblio::record_note;
-use base qw/biblio/;
-
-biblio::record_note->table( 'biblio_record_note' );
-biblio::record_note->columns( Essential => qw/id record value creator
- editor create_date edit_date pub/ );
-#-------------------------------------------------------------------------------
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::booking;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package booking;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-
-package booking::resource_type;
-use base qw/booking/;
-__PACKAGE__->table('booking_resource_type');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name fine_interval fine_amount
- max_fine owner catalog_item record transferable elbow_room/);
-
-#-------------------------------------------------------------------------------
-
-package booking::resource;
-use base qw/booking/;
-__PACKAGE__->table('booking_resource');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/owner type overbook barcode deposit
- deposit_amount user_fee/);
-
-#-------------------------------------------------------------------------------
-
-package booking::reservation;
-use base qw/booking/;
-__PACKAGE__->table('booking_reservation');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr current_resource
- fine_amount max_fine fine_interval xact_finish
- capture_staff pickup_lib request_time start_time end_time
- capture_time cancel_time pickup_time return_time
- booking_interval target_resource_type target_resource
- current_resource request_lib/);
-
-#-------------------------------------------------------------------------------
-
-package booking::resource_attr_map;
-use base qw/booking/;
-__PACKAGE__->table('booking_resource_attr_map');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/resource resource_attr value/);
-
-#-------------------------------------------------------------------------------
-
-package booking::reservation_attr_value_map;
-use base qw/booking/;
-__PACKAGE__->table('booking_reservation_attr_value_map');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/reservation attr_value/);
-
-#-------------------------------------------------------------------------------
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::config;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package config;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-
-package config::non_cataloged_type;
-use base qw/config/;
-__PACKAGE__->table('config_non_cataloged_type');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/owning_lib name circ_duration in_house/);
-#-------------------------------------------------------------------------------
-
-package config::standing;
-use base qw/config/;
-__PACKAGE__->table('config_standing');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/value/);
-#-------------------------------------------------------------------------------
-
-package config::bib_source;
-use base qw/config/;
-__PACKAGE__->table('config_bib_source');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/quality source transcendant/);
-#-------------------------------------------------------------------------------
-
-package config::metabib_field;
-use base qw/config/;
-__PACKAGE__->table('config_metabib_field');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/field_class name xpath weight format search_field facet_field/);
-#-------------------------------------------------------------------------------
-
-package config::identification_type;
-use base qw/config/;
-__PACKAGE__->table('config_identification_type');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name/);
-#-------------------------------------------------------------------------------
-
-package config::rules::circ_duration;
-use base qw/config/;
-__PACKAGE__->table('config_rule_circ_duration');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name extended normal shrt max_renewals/);
-#-------------------------------------------------------------------------------
-
-package config::rules::max_fine;
-use base qw/config/;
-__PACKAGE__->table('config_rule_max_fine');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name amount is_percent/);
-#-------------------------------------------------------------------------------
-
-package config::rules::recurring_fine;
-use base qw/config/;
-__PACKAGE__->table('config_rule_recurring_fine');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name high normal low recurrence_interval/);
-#-------------------------------------------------------------------------------
-
-package config::rules::age_hold_protect;
-use base qw/config/;
-__PACKAGE__->table('config_rule_age_hold_protect');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name age prox/);
-#-------------------------------------------------------------------------------
-
-package config::copy_status;
-use base qw/config/;
-__PACKAGE__->table('config_copy_status');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name holdable opac_visible/);
-#-------------------------------------------------------------------------------
-
-package config::net_access_level;
-use base qw/config/;
-__PACKAGE__->table('config_net_access_level');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/name/);
-#-------------------------------------------------------------------------------
-
-package config::audience_map;
-use base qw/config/;
-__PACKAGE__->table('config_audience_map');
-__PACKAGE__->columns(Primary => 'code');
-__PACKAGE__->columns(Essential => qw/value description/);
-#-------------------------------------------------------------------------------
-
-package config::lit_form_map;
-use base qw/config/;
-__PACKAGE__->table('config_lit_form_map');
-__PACKAGE__->columns(Primary => 'code');
-__PACKAGE__->columns(Essential => qw/value description/);
-#-------------------------------------------------------------------------------
-
-package config::item_form_map;
-use base qw/config/;
-__PACKAGE__->table('config_lit_form_map');
-__PACKAGE__->columns(Primary => 'code');
-__PACKAGE__->columns(Essential => qw/value/);
-#-------------------------------------------------------------------------------
-
-package config::item_type_map;
-use base qw/config/;
-__PACKAGE__->table('config_lit_form_map');
-__PACKAGE__->columns(Primary => 'code');
-__PACKAGE__->columns(Essential => qw/value/);
-#-------------------------------------------------------------------------------
-
-package config::language_map;
-use base qw/config/;
-__PACKAGE__->table('config_language_map');
-__PACKAGE__->columns(Primary => 'code');
-__PACKAGE__->columns(Essential => qw/value/);
-#-------------------------------------------------------------------------------
-
-package config::i18n_locale;
-use base qw/config/;
-__PACKAGE__->table('config_i18n_locale');
-__PACKAGE__->columns(Primary => 'code');
-__PACKAGE__->columns(Essential => qw/marc_code name description/);
-#-------------------------------------------------------------------------------
-
-package config::i18n_core;
-use base qw/config/;
-__PACKAGE__->table('config_i18n_core');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/fq_field identity_value translation string/);
-#-------------------------------------------------------------------------------
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::container;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package container;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package container::user_bucket;
-use base qw/container/;
-
-container::user_bucket->table( 'container_user_bucket' );
-container::user_bucket->columns( Primary => qw/id/ );
-container::user_bucket->columns( Essential => qw/owner name btype pub/ );
-
-#-------------------------------------------------------------------------------
-package container::user_bucket_item;
-use base qw/container/;
-
-container::user_bucket_item->table( 'container_user_bucket_item' );
-container::user_bucket_item->columns( Primary => qw/id/ );
-container::user_bucket_item->columns( Essential => qw/bucket target_user/ );
-
-#-------------------------------------------------------------------------------
-package container::copy_bucket;
-use base qw/container/;
-
-container::copy_bucket->table( 'container_copy_bucket' );
-container::copy_bucket->columns( Primary => qw/id/ );
-container::copy_bucket->columns( Essential => qw/owner name btype pub/ );
-
-#-------------------------------------------------------------------------------
-package container::copy_bucket_item;
-use base qw/container/;
-
-container::copy_bucket_item->table( 'container_copy_bucket_item' );
-container::copy_bucket_item->columns( Primary => qw/id/ );
-container::copy_bucket_item->columns( Essential => qw/bucket target_copy/ );
-
-#-------------------------------------------------------------------------------
-package container::biblio_record_entry_bucket;
-use base qw/container/;
-
-container::biblio_record_entry_bucket->table( 'container_biblio_record_entry_bucket' );
-container::biblio_record_entry_bucket->columns( Primary => qw/id/ );
-container::biblio_record_entry_bucket->columns( Essential => qw/owner name btype pub/ );
-
-#-------------------------------------------------------------------------------
-package container::biblio_record_entry_bucket_item;
-use base qw/container/;
-
-container::biblio_record_entry_bucket_item->table( 'container_biblio_record_entry_bucket_item' );
-container::biblio_record_entry_bucket_item->columns( Primary => qw/id/ );
-container::biblio_record_entry_bucket_item->columns( Essential => qw/bucket target_biblio_record_entry/ );
-
-#-------------------------------------------------------------------------------
-package container::call_number_bucket;
-use base qw/container/;
-
-container::call_number_bucket->table( 'container_call_number_bucket' );
-container::call_number_bucket->columns( Primary => qw/id/ );
-container::call_number_bucket->columns( Essential => qw/owner name btype pub/ );
-
-#-------------------------------------------------------------------------------
-package container::call_number_bucket_item;
-use base qw/container/;
-
-container::call_number_bucket_item->table( 'container_call_number_bucket_item' );
-container::call_number_bucket_item->columns( Primary => qw/id/ );
-container::call_number_bucket_item->columns( Essential => qw/bucket target_call_number/ );
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::metabib;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package metabib;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package metabib::metarecord;
-use base qw/metabib/;
-
-metabib::metarecord->table( 'metabib_metarecord' );
-metabib::metarecord->columns( Primary => qw/id/ );
-metabib::metarecord->columns( Essential => qw/fingerprint master_record mods/ );
-
-#-------------------------------------------------------------------------------
-package metabib::identifier_field_entry;
-use base qw/metabib/;
-
-metabib::identifier_field_entry->table( 'metabib_identifier_field_entry' );
-metabib::identifier_field_entry->columns( Primary => qw/id/ );
-metabib::identifier_field_entry->columns( Essential => qw/field value source/ );
-
-
-#-------------------------------------------------------------------------------
-package metabib::title_field_entry;
-use base qw/metabib/;
-
-metabib::title_field_entry->table( 'metabib_title_field_entry' );
-metabib::title_field_entry->columns( Primary => qw/id/ );
-metabib::title_field_entry->columns( Essential => qw/field value source/ );
-
-
-#-------------------------------------------------------------------------------
-package metabib::author_field_entry;
-use base qw/metabib/;
-
-metabib::author_field_entry->table( 'metabib_author_field_entry' );
-metabib::author_field_entry->columns( Primary => qw/id/ );
-metabib::author_field_entry->columns( Essential => qw/field value source/ );
-
-
-#-------------------------------------------------------------------------------
-package metabib::subject_field_entry;
-use base qw/metabib/;
-
-metabib::subject_field_entry->table( 'metabib_subject_field_entry' );
-metabib::subject_field_entry->columns( Primary => qw/id/ );
-metabib::subject_field_entry->columns( Essential => qw/field value source/ );
-
-
-#-------------------------------------------------------------------------------
-package metabib::keyword_field_entry;
-use base qw/metabib/;
-
-metabib::keyword_field_entry->table( 'metabib_keyword_field_entry' );
-metabib::keyword_field_entry->columns( Primary => qw/id/ );
-metabib::keyword_field_entry->columns( Essential => qw/field value source/ );
-
-#-------------------------------------------------------------------------------
-package metabib::series_field_entry;
-use base qw/metabib/;
-
-metabib::series_field_entry->table( 'metabib_series_field_entry' );
-metabib::series_field_entry->columns( Primary => qw/id/ );
-metabib::series_field_entry->columns( Essential => qw/field value source/ );
-
-#-------------------------------------------------------------------------------
-package metabib::metarecord_source_map;
-use base qw/metabib/;
-
-metabib::metarecord_source_map->table( 'metabib_metarecord_source_map' );
-metabib::metarecord_source_map->columns( Primary => qw/id/ );
-metabib::metarecord_source_map->columns( Essential => qw/metarecord source/ );
-
-#-------------------------------------------------------------------------------
-package metabib::full_rec;
-use base qw/metabib/;
-
-metabib::full_rec->table( 'metabib_full_rec' );
-metabib::full_rec->columns( Primary => qw/id/ );
-metabib::full_rec->columns( Essential => qw/record tag ind1 ind2 subfield value/ );
-
-#-------------------------------------------------------------------------------
-package metabib::record_descriptor;
-use base qw/metabib/;
-#use OpenILS::Application::Storage::CDBI::asset;
-
-metabib::record_descriptor->table( 'metabib_rec_descriptor' );
-metabib::record_descriptor->columns( Primary => qw/id/ );
-metabib::record_descriptor->columns( Essential => qw/record item_type item_form bib_level
- control_type char_encoding enc_level lit_form vr_format
- cat_form pub_status item_lang audience type_mat date1 date2/ );
-
-#-------------------------------------------------------------------------------
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::money;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package money;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-
-package money::collections_tracker;
-use base qw/money/;
-__PACKAGE__->table('money_collections_tracker');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/usr collector location enter_time/);
-#-------------------------------------------------------------------------------
-
-package money::billable_transaction;
-use base qw/money/;
-__PACKAGE__->table('money_billable_xact');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr xact_finish unrecovered/);
-#-------------------------------------------------------------------------------
-
-package money::grocery;
-use base qw/money/;
-__PACKAGE__->table('money_grocery');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr billing_location note xact_finish/);
-#-------------------------------------------------------------------------------
-
-package money::open_user_summary;
-use base qw/money/;
-__PACKAGE__->table('money_open_user_summary');
-__PACKAGE__->columns(Primary => 'usr');
-__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
-#-------------------------------------------------------------------------------
-
-package money::user_summary;
-use base qw/money/;
-__PACKAGE__->table('money_user_summary');
-__PACKAGE__->columns(Primary => 'usr');
-__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
-#-------------------------------------------------------------------------------
-
-package money::open_user_circulation_summary;
-use base qw/money/;
-__PACKAGE__->table('money_open_user_circulation_summary');
-__PACKAGE__->columns(Primary => 'usr');
-__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
-#-------------------------------------------------------------------------------
-
-package money::user_circulation_summary;
-use base qw/money/;
-__PACKAGE__->table('money_user_circulation_summary');
-__PACKAGE__->columns(Primary => 'usr');
-__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
-#-------------------------------------------------------------------------------
-
-package money::open_billable_transaction_summary;
-use base qw/money/;
-__PACKAGE__->table('money_open_billable_transaction_summary');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr xact_finish total_paid
- last_payment_ts total_owed last_billing_ts
- balance_owed xact_type last_billing_note last_billing_type
- last_payment_note last_payment_type/);
-#-------------------------------------------------------------------------------
-
-package money::billable_transaction_summary;
-use base qw/money/;
-__PACKAGE__->table('money_billable_transaction_summary');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact_start usr xact_finish total_paid
- last_payment_ts total_owed last_billing_ts
- balance_owed xact_type last_billing_note last_billing_type
- last_payment_note last_payment_type/);
-#-------------------------------------------------------------------------------
-
-package money::billing;
-use base qw/money/;
-__PACKAGE__->table('money_billing');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount billing_ts billing_type note
- voided voider void_time btype/);
-#-------------------------------------------------------------------------------
-
-package money::payment;
-use base qw/money/;
-__PACKAGE__->table('money_payment');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount payment_ts payment_type note voided/);
-#-------------------------------------------------------------------------------
-
-package money::desk_payment;
-use base qw/money/;
-__PACKAGE__->table('money_desk_payment');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount payment_ts voided amount_collected accepting_usr cash_drawer payment_type note/);
-#-------------------------------------------------------------------------------
-
-package money::cash_payment;
-use base qw/money/;
-__PACKAGE__->table('money_cash_payment');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount payment_ts cash_drawer accepting_usr amount_collected note/);
-#-------------------------------------------------------------------------------
-
-package money::check_payment;
-use base qw/money/;
-__PACKAGE__->table('money_check_payment');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount payment_ts cash_drawer check_number accepting_usr amount_collected note/);
-#-------------------------------------------------------------------------------
-
-package money::credit_card_payment;
-use base qw/money/;
-__PACKAGE__->table('money_credit_card_payment');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount payment_ts cash_drawer
- accepting_usr amount_collected cc_type
- cc_number expire_month expire_year
- approval_code note/);
-#-------------------------------------------------------------------------------
-
-package money::forgive_payment;
-use base qw/money/;
-__PACKAGE__->table('money_forgive_payment');
-__PACKAGE__->columns(Primary => 'id');
-__PACKAGE__->columns(Essential => qw/xact amount payment_ts accepting_usr amount_collected note/);
-#-------------------------------------------------------------------------------
-
-package money::work_payment;
-use base qw/money::forgive_payment/;
-__PACKAGE__->table('money_work_payment');
-#-------------------------------------------------------------------------------
-
-package money::goods_payment;
-use base qw/money::forgive_payment/;
-__PACKAGE__->table('money_goods_payment');
-#-------------------------------------------------------------------------------
-
-package money::credit_payment;
-use base qw/money::forgive_payment/;
-__PACKAGE__->table('money_credit_payment');
-
-#-------------------------------------------------------------------------------
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::permission;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package permission;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package permission::perm_list;
-use base qw/permission/;
-__PACKAGE__->table('permission_perm_list');
-__PACKAGE__->columns(Primary => qw/id/);
-__PACKAGE__->columns(Essential => qw/code description/);
-#-------------------------------------------------------------------------------
-package permission::grp_tree;
-use base qw/permission/;
-__PACKAGE__->table('permission_grp_tree');
-__PACKAGE__->columns(Primary => qw/id/);
-__PACKAGE__->columns(Essential => qw/name parent description perm_interval
- application_perm usergroup hold_priority/);
-#-------------------------------------------------------------------------------
-package permission::usr_grp_map;
-use base qw/permission/;
-__PACKAGE__->table('permission_usr_grp_map');
-__PACKAGE__->columns(Primary => qw/id/);
-__PACKAGE__->columns(Essential => qw/usr grp/);
-#-------------------------------------------------------------------------------
-package permission::usr_perm_map;
-use base qw/permission/;
-__PACKAGE__->table('permission_usr_perm_map');
-__PACKAGE__->columns(Primary => qw/id/);
-__PACKAGE__->columns(Essential => qw/usr perm depth grantable/);
-#-------------------------------------------------------------------------------
-package permission::grp_perm_map;
-use base qw/permission/;
-__PACKAGE__->table('permission_grp_perm_map');
-__PACKAGE__->columns(Primary => qw/id/);
-__PACKAGE__->columns(Essential => qw/grp perm depth grantable/);
-#-------------------------------------------------------------------------------
-package permission::usr_work_ou_map;
-use base qw/permission/;
-__PACKAGE__->table('permission_usr_work_ou_map');
-__PACKAGE__->columns(Primary => qw/id/);
-__PACKAGE__->columns(Essential => qw/usr work_ou/);
-#-------------------------------------------------------------------------------
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::CDBI::serial;
-our $VERSION = 1;
-
-#-------------------------------------------------------------------------------
-package serial;
-use base qw/OpenILS::Application::Storage::CDBI/;
-#-------------------------------------------------------------------------------
-package serial::subscription;
-use base qw/serial/;
-
-__PACKAGE__->table( 'serial_subscription' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/record_entry start_date end_date
- expected_date_offset owning_lib/ );
-
-#-------------------------------------------------------------------------------
-package serial::issuance;
-use base qw/serial/;
-
-__PACKAGE__->table( 'serial_issuance' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/creator editor create_date edit_date
- subscription label date_published
- caption_and_pattern holding_code
- holding_type holding_link_id/ );
-
-#-------------------------------------------------------------------------------
-package serial::item;
-use base qw/serial/;
-
-__PACKAGE__->table( 'serial_item' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/creator editor create_date edit_date
- issuance stream unit uri date_expected
- date_received/ );
-
-#-------------------------------------------------------------------------------
-package serial::unit;
-use base qw/serial/;
-
-__PACKAGE__->table( 'serial_unit' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/call_number barcode creator create_date editor
- edit_date copy_number status loan_duration circ_lib
- fine_level circulate deposit price ref opac_visible dummy_isbn
- circ_as_type circ_modifier deposit_amount location mint_condition
- holdable dummy_title dummy_author deleted alert_message
- age_protect floating summary_contents detailed_contents/ );
-
-#-------------------------------------------------------------------------------
-package serial::record_entry;
-use base qw/serial/;
-
-__PACKAGE__->table( 'serial_record_entry' );
-__PACKAGE__->columns( Primary => qw/id/ );
-__PACKAGE__->columns( Essential => qw/active record create_date creator
- deleted edit_date editor id last_xact_id marc source
- owning_lib/ );
-
-
-1;
-
+++ /dev/null
-
-{ # The driver package itself just needs a db_Main method (or db_Slaves if
- #Class::DBI::Replication is in use) for Class::DBI to call.
- #
- # Any other fixups can go in here too... Also, the drivers should subclass the
- # DBI driver that they are wrapping, or provide a 'quote()' method that calls
- # the DBD::xxx::quote() method on FTI's behalf.
- #
- # The dirver MUST be a subclass of Class::DBI(::Replication) and
- # OpenILS::Application::Storage.
- #-------------------------------------------------------------------------------
- package OpenILS::Application::Storage::Driver::Pg;
- use OpenILS::Application::Storage::Driver::Pg::cdbi;
- use OpenILS::Application::Storage::Driver::Pg::fts;
- use OpenILS::Application::Storage::Driver::Pg::storage;
- use OpenILS::Application::Storage::Driver::Pg::dbi;
- use UNIVERSAL::require;
- BEGIN {
- 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
- }
- use base qw/Class::DBI OpenILS::Application::Storage/;
- use DBI;
- use OpenSRF::EX qw/:try/;
- use OpenSRF::DomainObject::oilsResponse;
- use OpenSRF::Utils::Logger qw/:level/;
- my $log = 'OpenSRF::Utils::Logger';
-
- __PACKAGE__->set_sql( retrieve_limited => 'SELECT * FROM __TABLE__ ORDER BY id LIMIT ?' );
- __PACKAGE__->set_sql( copy_start => 'COPY %s (%s) FROM STDIN;' );
- __PACKAGE__->set_sql( copy_end => '\.' );
-
- my $master_db;
- my @slave_dbs;
- my $_db_params;
-
- sub db_Handles {
- return ($master_db, @slave_dbs);
- }
-
- sub child_init {
- my $self = shift;
- $_db_params = shift;
-
- $log->debug("Running child_init inside ".__PACKAGE__, INTERNAL);
-
- $_db_params = [ $_db_params ] unless (ref($_db_params) eq 'ARRAY');
-
- my %attrs = ( %{$self->_default_attributes},
- RootClass => 'DBIx::ContextualFetch',
- ShowErrorStatement => 1,
- RaiseError => 1,
- AutoCommit => 1,
- PrintError => 1,
- Taint => 1,
- #TraceLevel => "1|SQL",
- pg_enable_utf8 => 1,
- pg_server_prepare => 0,
- FetchHashKeyName => 'NAME_lc',
- ChopBlanks => 1,
- );
-
- my $master = shift @$_db_params;
- $$master{port} ||= '5432';
- $$master{host} ||= 'localhost';
- $$master{db} ||= 'openils';
-
- $log->debug("Attempting to connect to $$master{db} at $$master{host}", INFO);
-
- try {
- $master_db = DBI->connect(
- "dbi:Pg:".
- "host=$$master{host};".
- "port=$$master{port};".
- "dbname=$$master{db}",
- $$master{user},
- $$master{pw},
- \%attrs)
- || do { sleep(1);
- DBI->connect(
- "dbi:Pg:".
- "host=$$master{host};".
- "port=$$master{port};".
- "dbname=$$master{db}",
- $$master{user},
- $$master{pw},
- \%attrs) }
- || throw OpenSRF::EX::ERROR
- ("Couldn't connect to $$master{db}".
- " on $$master{host}::$$master{port}".
- " as $$master{user}!!");
- } catch Error with {
- my $e = shift;
- $log->debug("Error connecting to database:\n\t$e\n\t$DBI::errstr", ERROR);
- throw $e;
- };
-
- $log->debug("Connected to MASTER db $$master{db} at $$master{host}", INFO);
-
- $master_db->do("SET NAMES '$$master{client_encoding}';") if ($$master{client_encoding});
-
- for my $db (@$_db_params) {
- try {
- push @slave_dbs, DBI->connect("dbi:Pg:host=$$db{host};port=$$db{port};dbname=$$db{db}",$$db{user},$$db{pw}, \%attrs)
- || do { sleep(1); DBI->connect("dbi:Pg:host=$$db{host};port=$$db{port};dbname=$$db{db}",$$db{user},$$db{pw}, \%attrs) }
- || throw OpenSRF::EX::ERROR
- ("Couldn't connect to $$db{db}".
- " on $$db{host}::$$db{port}".
- " as $$db{user}!!");
- } catch Error with {
- my $e = shift;
- $log->debug("Error connecting to database:\n\t$e\n\t$DBI::errstr", ERROR);
- throw $e;
- };
-
- $slave_dbs[-1]->do("SET NAMES '$$db{client_encoding}';") if ($$master{client_encoding});
-
- $log->debug("Connected to MASTER db '$$master{db} at $$master{host}", INFO);
- }
-
- $log->debug("All is well on the western front", INTERNAL);
- }
-
- sub db_Main {
- my $self = shift;
- return $master_db if ($self->current_xact_session || $OpenILS::Application::Storage::WRITE);
- return $master_db unless (@slave_dbs);
- return ($master_db, @slave_dbs)[rand(scalar(@slave_dbs))];
- }
-
- sub quote {
- my $self = shift;
- return $self->db_Main->quote(@_)
- }
-
-# sub tsearch2_trigger {
-# my $self = shift;
-# return unless ($self->value);
-# $self->index_vector(
-# $self->db_Slaves->selectrow_array(
-# "SELECT to_tsvector('default',?);",
-# {},
-# $self->value
-# )
-# );
-# }
-
- my $_xact_session;
-
- sub current_xact_session {
- my $self = shift;
- if (defined($_xact_session)) {
- return $_xact_session;
- }
- return undef;
- }
-
- sub current_xact_is_auto {
- my $self = shift;
- my $auto = shift;
- if (defined($_xact_session) and ref($_xact_session)) {
- if (defined $auto) {
- $_xact_session->session_data(autocommit => $auto);
- }
- return $_xact_session->session_data('autocommit');
- }
- }
-
- sub current_xact_id {
- my $self = shift;
- if (defined($_xact_session) and ref($_xact_session)) {
- return $_xact_session->session_id;
- }
- return undef;
- }
-
- sub set_xact_session {
- my $self = shift;
- my $ses = shift;
- if (!defined($ses)) {
- return undef;
- }
- $_xact_session = $ses;
- return $_xact_session;
- }
-
- sub unset_xact_session {
- my $self = shift;
- my $ses = $_xact_session;
- undef $_xact_session;
- return $ses;
- }
-
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Driver::Pg::QueryParser;
-use OpenILS::Application::Storage::QueryParser;
-use base 'QueryParser';
-use OpenSRF::Utils::JSON;
-use OpenILS::Application::AppUtils;
-my $U = 'OpenILS::Application::AppUtils';
-
-sub quote_value {
- my $self = shift;
- my $value = shift;
-
- if ($value =~ /^\d/) { # may have to use non-$ quoting
- $value =~ s/'/''/g;
- $value =~ s/\\/\\\\/g;
- return "E'$value'";
- }
- return "\$_$$\$$value\$_$$\$";
-}
-
-sub quote_phrase_value {
- my $self = shift;
- my $value = shift;
-
- my $left_anchored = $value =~ m/^\^/;
- my $right_anchored = $value =~ m/\$$/;
- $value =~ s/\^// if $left_anchored;
- $value =~ s/\$$// if $right_anchored;
- $value =~ quotemeta($value);
- $value = '^' . $value if $left_anchored;
- $value = "$value\$" if $right_anchored;
- return $self->quote_value($value);
-}
-
-sub init {
- my $class = shift;
-
-}
-
-sub default_preferred_language {
- my $self = shift;
- my $lang = shift;
-
- $self->custom_data->{default_preferred_language} = $lang if ($lang);
- return $self->custom_data->{default_preferred_language};
-}
-
-sub default_preferred_language_multiplier {
- my $self = shift;
- my $lang = shift;
-
- $self->custom_data->{default_preferred_language_multiplier} = $lang if ($lang);
- return $self->custom_data->{default_preferred_language_multiplier};
-}
-
-sub simple_plan {
- my $self = shift;
-
- return 0 unless $self->parse_tree;
- return 0 if @{$self->parse_tree->filters};
- return 0 if @{$self->parse_tree->modifiers};
- for my $node ( @{ $self->parse_tree->query_nodes } ) {
- return 0 if (!ref($node) && $node eq '|');
- next unless (ref($node));
- return 0 if ($node->isa('QueryParser::query_plan'));
- }
-
- return 1;
-}
-
-sub toSQL {
- my $self = shift;
- return $self->parse_tree->toSQL;
-}
-
-sub facet_field_id_map {
- my $self = shift;
- my $map = shift;
-
- $self->custom_data->{facet_field_id_map} ||= {};
- $self->custom_data->{facet_field_id_map} = $map if ($map);
- return $self->custom_data->{facet_field_id_map};
-}
-
-sub add_facet_field_id_map {
- my $self = shift;
- my $class = shift;
- my $field = shift;
- my $id = shift;
- my $weight = shift;
-
- $self->add_facet_field( $class => $field );
- $self->facet_field_id_map->{by_id}{$id} = { classname => $class, field => $field, weight => $weight };
- $self->facet_field_id_map->{by_class}{$class}{$field} = $id;
-
- return {
- by_id => { $id => { classname => $class, field => $field, weight => $weight } },
- by_class => { $class => { $field => $id } }
- };
-}
-
-sub facet_field_class_by_id {
- my $self = shift;
- my $id = shift;
-
- return $self->facet_field_id_map->{by_id}{$id};
-}
-
-sub facet_field_ids_by_class {
- my $self = shift;
- my $class = shift;
- my $field = shift;
-
- return undef unless ($class);
-
- if ($field) {
- return [$self->facet_field_id_map->{by_class}{$class}{$field}];
- }
-
- return [values( %{ $self->facet_field_id_map->{by_class}{$class} } )];
-}
-
-sub search_field_id_map {
- my $self = shift;
- my $map = shift;
-
- $self->custom_data->{search_field_id_map} ||= {};
- $self->custom_data->{search_field_id_map} = $map if ($map);
- return $self->custom_data->{search_field_id_map};
-}
-
-sub add_search_field_id_map {
- my $self = shift;
- my $class = shift;
- my $field = shift;
- my $id = shift;
- my $weight = shift;
-
- $self->add_search_field( $class => $field );
- $self->search_field_id_map->{by_id}{$id} = { classname => $class, field => $field, weight => $weight };
- $self->search_field_id_map->{by_class}{$class}{$field} = $id;
-
- return {
- by_id => { $id => { classname => $class, field => $field, weight => $weight } },
- by_class => { $class => { $field => $id } }
- };
-}
-
-sub search_field_class_by_id {
- my $self = shift;
- my $id = shift;
-
- return $self->search_field_id_map->{by_id}{$id};
-}
-
-sub search_field_ids_by_class {
- my $self = shift;
- my $class = shift;
- my $field = shift;
-
- return undef unless ($class);
-
- if ($field) {
- return [$self->search_field_id_map->{by_class}{$class}{$field}];
- }
-
- return [values( %{ $self->search_field_id_map->{by_class}{$class} } )];
-}
-
-sub relevance_bumps {
- my $self = shift;
- my $bumps = shift;
-
- $self->custom_data->{rel_bumps} ||= {};
- $self->custom_data->{rel_bumps} = $bumps if ($bumps);
- return $self->custom_data->{rel_bumps};
-}
-
-sub find_relevance_bumps {
- my $self = shift;
- my $class = shift;
- my $field = shift;
-
- return $self->relevance_bumps->{$class}{$field};
-}
-
-sub add_relevance_bump {
- my $self = shift;
- my $class = shift;
- my $field = shift;
- my $type = shift;
- my $multiplier = shift;
- my $active = shift;
-
- $active = 1 if (!defined($active));
-
- $self->relevance_bumps->{$class}{$field}{$type} = { multiplier => $multiplier, active => $active };
-
- return { $class => { $field => { $type => { multiplier => $multiplier, active => $active } } } };
-}
-
-
-sub initialize_search_field_id_map {
- my $self = shift;
- my $cmf_list = shift;
-
- for my $cmf (@$cmf_list) {
- __PACKAGE__->add_search_field_id_map( $cmf->field_class, $cmf->name, $cmf->id, $cmf->weight ) if ($U->is_true($cmf->search_field));
- __PACKAGE__->add_facet_field_id_map( $cmf->field_class, $cmf->name, $cmf->id, $cmf->weight ) if ($U->is_true($cmf->facet_field));
- }
-
- return $self->search_field_id_map;
-}
-
-sub initialize_aliases {
- my $self = shift;
- my $cmsa_list = shift;
-
- for my $cmsa (@$cmsa_list) {
- if (!$cmsa->field) {
- __PACKAGE__->add_search_class_alias( $cmsa->field_class, $cmsa->alias );
- } else {
- my $c = $self->search_field_class_by_id( $cmsa->field );
- __PACKAGE__->add_search_field_alias( $cmsa->field_class, $c->{field}, $cmsa->alias );
- }
- }
-}
-
-sub initialize_relevance_bumps {
- my $self = shift;
- my $sra_list = shift;
-
- for my $sra (@$sra_list) {
- my $c = $self->search_field_class_by_id( $sra->field );
- __PACKAGE__->add_relevance_bump( $c->{classname}, $c->{field}, $sra->bump_type, $sra->multiplier );
- }
-
- return $self->relevance_bumps;
-}
-
-sub initialize_normalizers {
- my $self = shift;
- my $tree = shift; # open-ils.cstore.direct.config.metabib_field_index_norm_map.search.atomic { "id" : { "!=" : null } }, { "flesh" : 1, "flesh_fields" : { "cmfinm" : ["norm"] }, "order_by" : [{ "class" : "cmfinm", "field" : "pos" }] }
-
- for my $cmfinm ( @$tree ) {
- my $field_info = $self->search_field_class_by_id( $cmfinm->field );
- __PACKAGE__->add_query_normalizer( $field_info->{classname}, $field_info->{field}, $cmfinm->norm->func, OpenSRF::Utils::JSON->JSON2perl($cmfinm->params) );
- }
-}
-
-our $_complete = 0;
-sub initialization_complete {
- return $_complete;
-}
-
-sub initialize {
- my $self = shift;
- my %args = @_;
-
- return $_complete if ($_complete);
-
- $self->initialize_search_field_id_map( $args{config_metabib_field} )
- if ($args{config_metabib_field});
-
- $self->initialize_aliases( $args{config_metabib_search_alias} )
- if ($args{config_metabib_search_alias});
-
- $self->initialize_relevance_bumps( $args{search_relevance_adjustment} )
- if ($args{search_relevance_adjustment});
-
- $self->initialize_normalizers( $args{config_metabib_field_index_norm_map} )
- if ($args{config_metabib_field_index_norm_map});
-
- $_complete = 1 if (
- $args{config_metabib_field_index_norm_map} &&
- $args{search_relevance_adjustment} &&
- $args{config_metabib_search_alias} &&
- $args{config_metabib_field}
- );
-
- return $_complete;
-}
-
-sub TEST_SETUP {
-
- __PACKAGE__->add_search_field_id_map( series => seriestitle => 1 => 1 );
-
- __PACKAGE__->add_search_field_id_map( series => seriestitle => 1 => 1 );
- __PACKAGE__->add_relevance_bump( series => seriestitle => first_word => 1.5 );
- __PACKAGE__->add_relevance_bump( series => seriestitle => full_match => 20 );
-
- __PACKAGE__->add_search_field_id_map( title => abbreviated => 2 => 1 );
- __PACKAGE__->add_relevance_bump( title => abbreviated => first_word => 1.5 );
- __PACKAGE__->add_relevance_bump( title => abbreviated => full_match => 20 );
-
- __PACKAGE__->add_search_field_id_map( title => translated => 3 => 1 );
- __PACKAGE__->add_relevance_bump( title => translated => first_word => 1.5 );
- __PACKAGE__->add_relevance_bump( title => translated => full_match => 20 );
-
- __PACKAGE__->add_search_field_id_map( title => proper => 6 => 1 );
- __PACKAGE__->add_query_normalizer( title => proper => 'naco_normalize' );
- __PACKAGE__->add_relevance_bump( title => proper => first_word => 1.5 );
- __PACKAGE__->add_relevance_bump( title => proper => full_match => 20 );
- __PACKAGE__->add_relevance_bump( title => proper => word_order => 10 );
-
- __PACKAGE__->add_search_field_id_map( author => coporate => 7 => 1 );
- __PACKAGE__->add_relevance_bump( author => coporate => first_word => 1.5 );
- __PACKAGE__->add_relevance_bump( author => coporate => full_match => 20 );
-
- __PACKAGE__->add_facet_field_id_map( author => personal => 8 => 1 );
-
- __PACKAGE__->add_search_field_id_map( author => personal => 8 => 1 );
- __PACKAGE__->add_relevance_bump( author => personal => first_word => 1.5 );
- __PACKAGE__->add_relevance_bump( author => personal => full_match => 20 );
- __PACKAGE__->add_query_normalizer( author => personal => 'naco_normalize' );
- __PACKAGE__->add_query_normalizer( author => personal => 'split_date_range' );
-
- __PACKAGE__->add_facet_field_id_map( subject => topic => 14 => 1 );
-
- __PACKAGE__->add_search_field_id_map( subject => topic => 14 => 1 );
- __PACKAGE__->add_relevance_bump( subject => topic => first_word => 1 );
- __PACKAGE__->add_relevance_bump( subject => topic => full_match => 1 );
-
- __PACKAGE__->add_search_field_id_map( subject => complete => 16 => 1 );
- __PACKAGE__->add_relevance_bump( subject => complete => first_word => 1 );
- __PACKAGE__->add_relevance_bump( subject => complete => full_match => 1 );
-
- __PACKAGE__->add_search_field_id_map( keyword => keyword => 15 => 1 );
- __PACKAGE__->add_relevance_bump( keyword => keyword => first_word => 1 );
- __PACKAGE__->add_relevance_bump( keyword => keyword => full_match => 1 );
-
-
- __PACKAGE__->add_search_class_alias( keyword => 'kw' );
- __PACKAGE__->add_search_class_alias( title => 'ti' );
- __PACKAGE__->add_search_class_alias( author => 'au' );
- __PACKAGE__->add_search_class_alias( author => 'name' );
- __PACKAGE__->add_search_class_alias( author => 'dc.contributor' );
- __PACKAGE__->add_search_class_alias( subject => 'su' );
- __PACKAGE__->add_search_class_alias( subject => 'bib.subject(?:Title|Place|Occupation)' );
- __PACKAGE__->add_search_class_alias( series => 'se' );
- __PACKAGE__->add_search_class_alias( keyword => 'dc.identifier' );
-
- __PACKAGE__->add_query_normalizer( author => corporate => 'naco_normalize' );
- __PACKAGE__->add_query_normalizer( keyword => keyword => 'naco_normalize' );
-
- __PACKAGE__->add_search_field_alias( subject => name => 'bib.subjectName' );
-
-}
-
-__PACKAGE__->default_search_class( 'keyword' );
-
-__PACKAGE__->add_search_filter( 'audience' );
-__PACKAGE__->add_search_filter( 'vr_format' );
-__PACKAGE__->add_search_filter( 'format' );
-__PACKAGE__->add_search_filter( 'item_type' );
-__PACKAGE__->add_search_filter( 'item_form' );
-__PACKAGE__->add_search_filter( 'lit_form' );
-__PACKAGE__->add_search_filter( 'locations' );
-__PACKAGE__->add_search_filter( 'site' );
-__PACKAGE__->add_search_filter( 'lasso' );
-__PACKAGE__->add_search_filter( 'my_lasso' );
-__PACKAGE__->add_search_filter( 'depth' );
-__PACKAGE__->add_search_filter( 'sort' );
-__PACKAGE__->add_search_filter( 'language' );
-__PACKAGE__->add_search_filter( 'preferred_language' );
-__PACKAGE__->add_search_filter( 'preferred_language_weight' );
-__PACKAGE__->add_search_filter( 'preferred_language_multiplier' );
-__PACKAGE__->add_search_filter( 'statuses' );
-__PACKAGE__->add_search_filter( 'bib_level' );
-__PACKAGE__->add_search_filter( 'before' );
-__PACKAGE__->add_search_filter( 'after' );
-__PACKAGE__->add_search_filter( 'between' );
-__PACKAGE__->add_search_filter( 'during' );
-__PACKAGE__->add_search_filter( 'offset' );
-__PACKAGE__->add_search_filter( 'limit' );
-__PACKAGE__->add_search_filter( 'core_limit' );
-__PACKAGE__->add_search_filter( 'check_limit' );
-__PACKAGE__->add_search_filter( 'skip_check' );
-__PACKAGE__->add_search_filter( 'superpage' );
-__PACKAGE__->add_search_filter( 'superpage_size' );
-__PACKAGE__->add_search_filter( 'estimation_strategy' );
-
-__PACKAGE__->add_search_modifier( 'available' );
-__PACKAGE__->add_search_modifier( 'descending' );
-__PACKAGE__->add_search_modifier( 'ascending' );
-__PACKAGE__->add_search_modifier( 'metarecord' );
-__PACKAGE__->add_search_modifier( 'metabib' );
-__PACKAGE__->add_search_modifier( 'staff' );
-
-
-#-------------------------------
-package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan;
-use base 'QueryParser::query_plan';
-use OpenSRF::Utils::Logger qw($logger);
-use Data::Dumper;
-
-sub toSQL {
- my $self = shift;
-
- my %filters;
- my ($format) = $self->find_filter('format');
- if ($format) {
- my ($t,$f) = split('-', $format->args->[0]);
- $self->new_filter( item_type => [ split '', $t ] ) if ($t);
- $self->new_filter( item_form => [ split '', $f ] ) if ($f);
- }
-
- for my $f ( qw/preferred_language preferred_language_multiplier preferred_language_weight core_limit check_limit skip_check superpage superpage_size/ ) {
- my $col = $f;
- $col = 'preferred_language_multiplier' if ($f eq 'preferred_language_weight');
- my ($filter) = $self->find_filter($f);
- if ($filter and @{$filter->args}) {
- $filters{$col} = $filter->args->[0];
- }
- }
-
- $self->QueryParser->superpage($filters{superpage}) if ($filters{superpage});
- $self->QueryParser->superpage_size($filters{superpage_size}) if ($filters{superpage_size});
- $self->QueryParser->core_limit($filters{core_limit}) if ($filters{core_limit});
-
- $logger->debug("Query plan:\n".Dumper($self));
-
- my $flat_plan = $self->flatten;
-
- # generate the relevance ranking
- my $rel = "AVG(\n\t\t(" . join(")+\n\t\t(", @{$$flat_plan{rank_list}}) . ")\n\t)";
-
- # find any supplied sort option
- my ($sort_filter) = $self->find_filter('sort');
- if ($sort_filter) {
- $sort_filter = $sort_filter->args->[0];
- } else {
- $sort_filter = 'rel';
- }
-
- if (($filters{preferred_language} || $self->QueryParser->default_preferred_language) && ($filters{preferred_language_multiplier} || $self->QueryParser->default_preferred_language_multiplier)) {
- my $pl = $self->QueryParser->quote_value( $filters{preferred_language} ? $filters{preferred_language} : $self->QueryParser->default_preferred_language );
- my $plw = $filters{preferred_language_multiplier} ? $filters{preferred_language_multiplier} : $self->QueryParser->default_preferred_language_multiplier;
- $rel = "($rel * COALESCE( NULLIF( FIRST(mrd.item_lang) = $pl , FALSE )::INT * $plw, 1))";
- }
- $rel .= '::NUMERIC';
-
- for my $f ( qw/audience vr_format item_type item_form lit_form language bib_level/ ) {
- my $col = $f;
- $col = 'item_lang' if ($f eq 'language');
- $filters{$f} = '';
- my ($filter) = $self->find_filter($f);
- if ($filter) {
- $filters{$f} = "AND mrd.$col in (" . join(",",map { $self->QueryParser->quote_value($_) } @{$filter->args}) . ")";
- }
- }
-
- my $audience = $filters{audience};
- my $vr_format = $filters{vr_format};
- my $item_type = $filters{item_type};
- my $item_form = $filters{item_form};
- my $lit_form = $filters{lit_form};
- my $language = $filters{language};
- my $bib_level = $filters{bib_level};
-
- my $rank = $rel;
-
- my $desc = 'ASC';
- $desc = 'DESC' if ($self->find_modifier('descending'));
-
- if ($sort_filter eq 'rel') { # relevance ranking flips sort dir
- if ($desc eq 'ASC') {
- $desc = 'DESC';
- } else {
- $desc = 'ASC';
- }
- } else {
- if ($sort_filter eq 'title') {
- $rank = "FIRST((SELECT frt.value FROM metabib.full_rec frt WHERE frt.record = m.source AND frt.tag = 'tnf' AND frt.subfield = 'a' LIMIT 1))";
- } elsif ($sort_filter eq 'pubdate') {
- $rank = "FIRST(mrd.date1)::NUMERIC";
- } elsif ($sort_filter eq 'create_date') {
- $rank = "FIRST((SELECT create_date FROM biblio.record_entry rbr WHERE rbr.id = m.source))";
- } elsif ($sort_filter eq 'edit_date') {
- $rank = "FIRST((SELECT edit_date FROM biblio.record_entry rbr WHERE rbr.id = m.source))";
- } elsif ($sort_filter eq 'author') {
- $rank = "FIRST((SELECT fra.value FROM metabib.full_rec fra WHERE fra.record = m.source AND fra.tag LIKE '1%' AND fra.subfield = 'a' ORDER BY fra.tag LIMIT 1))";
- } else {
- # default to rel ranking
- $rank = $rel;
- }
- }
-
- my $key = 'm.source';
- $key = 'm.metarecord' if (grep {$_->name eq 'metarecord' or $_->name eq 'metabib'} @{$self->modifiers});
-
- my ($before) = $self->find_filter('before');
- my ($after) = $self->find_filter('after');
- my ($during) = $self->find_filter('during');
- my ($between) = $self->find_filter('between');
-
- if ($before and @{$before->args} == 1) {
- $before = "AND mrd.date1 <= " . $self->QueryParser->quote_value($before->args->[0]);
- } else {
- $before = '';
- }
-
- if ($after and @{$after->args} == 1) {
- $after = "AND mrd.date1 >= " . $self->QueryParser->quote_value($after->args->[0]);
- } else {
- $after = '';
- }
-
- if ($during and @{$during->args} == 1) {
- $during = "AND " . $self->QueryParser->quote_value($during->args->[0]) . " BETWEEN mrd.date1 AND mrd.date2";
- } else {
- $during = '';
- }
-
- if ($between and @{$between->args} == 2) {
- $between = "AND mrd.date1 BETWEEN " . $self->QueryParser->quote_value($between->args->[0]) . " AND " . $self->QueryParser->quote_value($between->args->[1]);
- } else {
- $between = '';
- }
-
- my $core_limit = $self->QueryParser->core_limit || 25000;
-
- my $sql = <<SQL;
-SELECT $key AS id,
- ARRAY_ACCUM(DISTINCT m.source) AS records,
- $rel AS rel,
- $rank AS rank,
- FIRST(mrd.date1) AS tie_break
- FROM metabib.metarecord_source_map m
- JOIN metabib.rec_descriptor mrd ON (m.source = mrd.record)
- $$flat_plan{from}
- WHERE 1=1
- $before
- $after
- $during
- $between
- $audience
- $vr_format
- $item_type
- $item_form
- $lit_form
- $language
- $bib_level
- AND $$flat_plan{where}
- GROUP BY 1
- ORDER BY 4 $desc NULLS LAST, 5 DESC NULLS LAST, 3 DESC
- LIMIT $core_limit
-SQL
-
- warn $sql if $self->QueryParser->debug;
- return $sql;
-
-}
-
-
-sub rel_bump {
- my $self = shift;
- my $node = shift;
- my $bump = shift;
- my $multiplier = shift;
-
- my $only_atoms = $node->only_atoms;
- return '' if (!@$only_atoms);
-
- if ($bump eq 'first_word') {
- return " /* first_word */ COALESCE(NULLIF( (naco_normalize(".$node->table_alias.".value) ~ ('^'||naco_normalize(".$self->QueryParser->quote_value($only_atoms->[0]->content)."))), FALSE )::INT * $multiplier, 1)";
- } elsif ($bump eq 'full_match') {
- return " /* full_match */ COALESCE(NULLIF( (naco_normalize(".$node->table_alias.".value) ~ ('^'||".
- join( "||' '||", map { "naco_normalize(".$self->QueryParser->quote_value($_->content).")" } @$only_atoms )."||'\$')), FALSE )::INT * $multiplier, 1)";
- } elsif ($bump eq 'word_order') {
- return " /* word_order */ COALESCE(NULLIF( (naco_normalize(".$node->table_alias.".value) ~ (".
- join( "||'.*'||", map { "naco_normalize(".$self->QueryParser->quote_value($_->content).")" } @$only_atoms ).")), FALSE )::INT * $multiplier, 1)";
- }
-
- return '';
-}
-
-sub flatten {
- my $self = shift;
-
- my $from = shift || '';
- my $where = shift || '(';
-
- my @rank_list;
- for my $node ( @{$self->query_nodes} ) {
- if (ref($node)) {
- if ($node->isa( 'QueryParser::query_plan::node' )) {
-
- unless (@{$node->only_atoms}) {
- push @rank_list, '1';
- $where .= 'TRUE';
- next;
- }
-
- my $table = $node->table;
- my $talias = $node->table_alias;
-
- my $node_rank = $node->rank . " * ${talias}.weight";
-
- my $core_limit = $self->QueryParser->core_limit || 25000;
- $from .= "\n\tLEFT JOIN (\n\t\tSELECT fe.*, fe_weight.weight, x.tsq /* search */\n\t\t FROM $table AS fe";
- $from .= "\n\t\t\tJOIN config.metabib_field AS fe_weight ON (fe_weight.id = fe.field)";
- $from .= "\n\t\t\tJOIN (SELECT ".$node->tsquery ." AS tsq ) AS x ON (fe.index_vector @@ x.tsq)";
-
- my @bump_fields;
- if (@{$node->fields} > 0) {
- @bump_fields = @{$node->fields};
-
- my @field_ids;
- push(@field_ids, $self->QueryParser->search_field_ids_by_class( $node->classname, $_ )->[0]) for (@bump_fields);
- $from .= "\n\t\t\tWHERE fe_weight.id IN (". join(',', @field_ids) .")";
-
- } else {
- @bump_fields = @{$self->QueryParser->search_fields->{$node->classname}};
- }
-
- ###$from .= "\n\t\tLIMIT $core_limit";
- $from .= "\n\t) AS $talias ON (m.source = ${talias}.source)";
-
-
- my %used_bumps;
- for my $field ( @bump_fields ) {
- my $bumps = $self->QueryParser->find_relevance_bumps( $node->classname => $field );
- for my $b (keys %$bumps) {
- next if (!$$bumps{$b}{active});
- next if ($used_bumps{$b});
- $used_bumps{$b} = 1;
-
- next if ($$bumps{$b}{multiplier} == 1); # optimization to remove unneeded bumps
-
- my $bump_case = $self->rel_bump( $node, $b, $$bumps{$b}{multiplier} );
- $node_rank .= "\n\t\t\t\t * " . $bump_case if ($bump_case);
- }
- }
-
- $where .= '(' . $talias . ".id IS NOT NULL";
- $where .= ' AND ' . join(' AND ', map {"${talias}.value ~* ".$self->QueryParser->quote_phrase_value($_)} @{$node->phrases}) if (@{$node->phrases});
- $where .= ')';
-
- push @rank_list, $node_rank;
-
- } elsif ($node->isa( 'QueryParser::query_plan::facet' )) {
-
- my $table = $node->table;
- my $talias = $node->table_alias;
-
- my @field_ids;
- if (@{$node->fields} > 0) {
- push(@field_ids, $self->QueryParser->facet_field_ids_by_class( $node->classname, $_ )->[0]) for (@{$node->fields});
- } else {
- @field_ids = @{ $self->QueryParser->facet_field_ids_by_class( $node->classname ) };
- }
-
- $from .= "\n\tJOIN /* facet */ metabib.facet_entry $talias ON (\n\t\tm.source = ${talias}.source\n\t\t".
- "AND SUBSTRING(${talias}.value,1,1024) IN (" . join(",", map { $self->QueryParser->quote_value($_) } @{$node->values}) . ")\n\t\t".
- "AND ${talias}.field IN (". join(',', @field_ids) . ")\n\t)";
-
- $where .= 'TRUE';
-
- } else {
- my $subnode = $node->flatten;
-
- push(@rank_list, @{$$subnode{rank_list}});
- $from .= $$subnode{from};
- $where .= "($$subnode{where})";
- }
- } else {
- $where .= ' AND ' if ($node eq '&');
- $where .= ' OR ' if ($node eq '|');
- # ... stitching the WHERE together ...
- }
- }
-
- return { rank_list => \@rank_list, from => $from, where => $where.')' };
-
-}
-
-
-#-------------------------------
-package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::filter;
-use base 'QueryParser::query_plan::filter';
-
-#-------------------------------
-package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::facet;
-use base 'QueryParser::query_plan::facet';
-
-sub classname {
- my $self = shift;
- my ($classname) = split '\|', $self->name;
- return $classname;
-}
-
-sub table {
- my $self = shift;
- return 'metabib.' . $self->classname . '_field_entry';
-}
-
-sub fields {
- my $self = shift;
- my ($classname,@fields) = split '\|', $self->name;
- return \@fields;
-}
-
-sub table_alias {
- my $self = shift;
-
- my $table_alias = "$self";
- $table_alias =~ s/^.*\(0(x[0-9a-fA-F]+)\)$/$1/go;
- $table_alias .= '_' . $self->name;
- $table_alias =~ s/\|/_/go;
-
- return $table_alias;
-}
-
-
-#-------------------------------
-package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::modifier;
-use base 'QueryParser::query_plan::modifier';
-
-#-------------------------------
-package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::node::atom;
-use base 'QueryParser::query_plan::node::atom';
-
-sub sql {
- my $self = shift;
- my $sql = shift;
-
- $self->{sql} = $sql if ($sql);
-
- return $self->{sql} if ($self->{sql});
- return $self->buildSQL;
-}
-
-sub buildSQL {
- my $self = shift;
-
- my $classname = $self->node->classname;
-
- my $normalizers = $self->node->plan->QueryParser->query_normalizers( $classname );
- my $fields = $self->node->fields;
-
- $fields = $self->node->plan->QueryParser->search_fields->{$classname} if (!@$fields);
-
- my %norms;
- my $pos = 0;
- for my $field (@$fields) {
- for my $nfield (keys %$normalizers) {
- for my $nizer ( @{$$normalizers{$nfield}} ) {
- if ($field eq $nfield) {
- if (!exists($norms{$nizer->{function}})) {
- $norms{$nizer->{function}} = {p=>$pos++,n=>$nizer};
- }
- }
- }
- }
- }
-
- my $sql = $self->node->plan->QueryParser->quote_value($self->content);
-
- for my $n ( map { $$_{n} } sort { $$a{p} <=> $$b{p} } values %norms ) {
- $sql = join(', ', $sql, map { $self->node->plan->QueryParser->quote_value($_) } @{ $n->{params} });
- $sql = $n->{function}."($sql)";
- }
-
- my $prefix = $self->prefix || '';
- my $suffix = $self->suffix || '';
-
- $prefix = "'$prefix' ||" if $prefix;
- my $suffix_op = ":$suffix" if $suffix;
- my $suffix_after = "|| '$suffix_op'" if $suffix;
-
- $sql = "to_tsquery('$classname', COALESCE(NULLIF($prefix '(' || btrim(regexp_replace($sql,E'(?:\\\\s+|:)','$suffix_op&','g'),'&|') $suffix_after || ')', '()'), ''))";
-
- return $self->sql($sql);
-}
-
-#-------------------------------
-package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::node;
-use base 'QueryParser::query_plan::node';
-
-sub only_atoms {
- my $self = shift;
-
- my $atoms = $self->query_atoms;
- my @only_atoms;
- for my $a (@$atoms) {
- push(@only_atoms, $a) if (ref($a) && $a->isa('QueryParser::query_plan::node::atom'));
- }
-
- return \@only_atoms;
-}
-
-sub table {
- my $self = shift;
- my $table = shift;
- $self->{table} = $table if ($table);
- return $self->{table} if $self->{table};
- return $self->table( 'metabib.' . $self->classname . '_field_entry' );
-}
-
-sub table_alias {
- my $self = shift;
- my $table_alias = shift;
- $self->{table_alias} = $table_alias if ($table_alias);
- return $self->{table_alias} if ($self->{table_alias});
-
- $table_alias = "$self";
- $table_alias =~ s/^.*\(0(x[0-9a-fA-F]+)\)$/$1/go;
- $table_alias .= '_' . $self->requested_class;
- $table_alias =~ s/\|/_/go;
-
- return $self->table_alias( $table_alias );
-}
-
-sub tsquery {
- my $self = shift;
- return $self->{tsquery} if ($self->{tsquery});
-
- for my $atom (@{$self->query_atoms}) {
- if (ref($atom)) {
- $self->{tsquery} .= "\n\t\t\t" .$atom->sql;
- } else {
- $self->{tsquery} .= $atom x 2;
- }
- }
-
- return $self->{tsquery};
-}
-
-sub rank {
- my $self = shift;
- return $self->{rank} if ($self->{rank});
- return $self->{rank} = 'rank(' . $self->table_alias . '.index_vector, ' . $self->table_alias . '.tsq)';
-}
-
-
-1;
-
+++ /dev/null
-{ # Based on the change to Class::DBI in OpenILS::Application::Storage. This will
- # allow us to use TSearch2 via a simple cdbi "search" interface.
- #-------------------------------------------------------------------------------
- use UNIVERSAL::require;
- BEGIN {
- 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
- }
- package Class::DBI;
-
- sub search_fts {
- my $self = shift;
- my @args = @_;
-
- if (ref($args[-1]) eq 'HASH' && @args > 1) {
- $args[-1]->{_placeholder} = "to_tsquery('default',?)";
- } else {
- push @args, {_placeholder => "to_tsquery('default',?)"};
- }
-
- $self->_do_search("@@" => @args);
- }
-
- sub search_regex {
- my $self = shift;
- my @args = @_;
- $self->_do_search("~*" => @args);
- }
-
- sub search_ilike {
- my $self = shift;
- my @args = @_;
- $self->_do_search("ILIKE" => @args);
- }
-
-}
-
-1;
+++ /dev/null
-{
-
- #-------------------------------------------------------------------------------
- package container::user_bucket;
-
- container::user_bucket->table( 'container.user_bucket' );
- container::user_bucket->sequence( 'container.user_bucket_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::user_bucket_item;
-
- container::user_bucket_item->table( 'container.user_bucket_item' );
- container::user_bucket_item->sequence( 'container.user_bucket_item_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::copy_bucket;
-
- container::copy_bucket->table( 'container.copy_bucket' );
- container::copy_bucket->sequence( 'container.copy_bucket_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::copy_bucket_item;
-
- container::copy_bucket_item->table( 'container.copy_bucket_item' );
- container::copy_bucket_item->sequence( 'container.copy_bucket_item_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::call_number_bucket;
-
- container::call_number_bucket->table( 'container.call_number_bucket' );
- container::call_number_bucket->sequence( 'container.call_number_bucket_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::call_number_bucket_item;
-
- container::call_number_bucket_item->table( 'container.call_number_bucket_item' );
- container::call_number_bucket_item->sequence( 'container.call_number_bucket_item_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::biblio_record_entry_bucket;
-
- container::biblio_record_entry_bucket->table( 'container.biblio_record_entry_bucket' );
- container::biblio_record_entry_bucket->sequence( 'container.biblio_record_entry_bucket_id_seq' );
-
- #-------------------------------------------------------------------------------
- package container::biblio_record_entry_bucket_item;
-
- container::biblio_record_entry_bucket_item->table( 'container.biblio_record_entry_bucket_item' );
- container::biblio_record_entry_bucket_item->sequence( 'container.biblio_record_entry_bucket_item_id_seq' );
-
- #---------------------------------------------------------------------
- package money::grocery;
-
- money::grocery->table( 'money.grocery' );
- money::grocery->sequence( 'money.billable_xact_id_seq' );
-
- #---------------------------------------------------------------------
- package money::collections_tracker;
-
- money::collections_tracker->table( 'money.collections_tracker' );
- money::collections_tracker->sequence( 'money.collections_tracker_id_seq' );
-
- #---------------------------------------------------------------------
- package money::billable_transaction;
-
- money::billable_transaction->table( 'money.billable_xact' );
- money::billable_transaction->sequence( 'money.billable_xact_id_seq' );
-
- #---------------------------------------------------------------------
- package money::billing;
-
- money::billing->table( 'money.billing' );
- money::billing->sequence( 'money.billing_id_seq' );
-
- #---------------------------------------------------------------------
- package money::desk_payment;
-
- money::desk_payment->table( 'money.desk_payment_view' );
-
- #---------------------------------------------------------------------
- package money::payment;
-
- money::payment->table( 'money.payment_view' );
-
- #---------------------------------------------------------------------
- package money::cash_payment;
-
- money::cash_payment->table( 'money.cash_payment' );
- money::cash_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::check_payment;
-
- money::check_payment->table( 'money.check_payment' );
- money::check_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::credit_payment;
-
- money::credit_payment->table( 'money.credit_payment' );
- money::credit_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::credit_card_payment;
-
- money::credit_card_payment->table( 'money.credit_card_payment' );
- money::credit_card_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::work_payment;
-
- money::work_payment->table( 'money.work_payment' );
- money::work_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::goods_payment;
-
- money::goods_payment->table( 'money.goods_payment' );
- money::goods_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::forgive_payment;
-
- money::forgive_payment->table( 'money.forgive_payment' );
- money::forgive_payment->sequence( 'money.payment_id_seq' );
-
- #---------------------------------------------------------------------
- package money::open_billable_transaction_summary;
-
- money::open_billable_transaction_summary->table( 'money.open_billable_xact_summary' );
-
- #---------------------------------------------------------------------
- package money::billable_transaction_summary;
-
- money::billable_transaction_summary->table( 'money.billable_xact_summary' );
-
- #---------------------------------------------------------------------
- package money::open_user_summary;
-
- money::open_user_summary->table( 'money.open_usr_summary' );
-
- #---------------------------------------------------------------------
- package money::user_summary;
-
- money::user_summary->table( 'money.usr_summary' );
-
- #---------------------------------------------------------------------
- package money::open_user_circulation_summary;
-
- money::open_user_circulation_summary->table( 'money.open_usr_circulation_summary' );
-
- #---------------------------------------------------------------------
- package money::user_circulation_summary;
-
- money::user_circulation_summary->table( 'money.usr_circulation_summary' );
-
- #---------------------------------------------------------------------
- package action::circulation;
-
- action::circulation->table( 'action.circulation' );
- action::circulation->sequence( 'money.billable_xact_id_seq' );
-
- #---------------------------------------------------------------------
- package booking::resource_type;
-
- booking::resource_type->table( 'booking.resource_type' );
- booking::resource_type->sequence( 'booking.resource_type_id_seq' );
-
- #---------------------------------------------------------------------
- package booking::resource;
-
- booking::resource->table( 'booking.resource' );
- booking::resource->sequence( 'booking.resource_id_seq' );
-
- #---------------------------------------------------------------------
- package booking::reservation;
-
- booking::reservation->table( 'booking.reservation' );
- booking::reservation->sequence( 'money.billable_xact_id_seq' );
-
- #---------------------------------------------------------------------
- package booking::reservation_attr_value_map;
-
- booking::reservation_attr_value_map->table( 'booking.reservation_attr_value_map' );
- booking::reservation_attr_value_map->sequence( 'booking.reservation_attr_value_map_id_seq' );
-
- #---------------------------------------------------------------------
- package booking::resource_attr_map;
-
- booking::resource_attr_map->table( 'booking.resource_attr_map' );
- booking::resource_attr_map->sequence( 'booking.resource_attr_map_id_seq' );
-
- #---------------------------------------------------------------------
- package action::non_cat_in_house_use;
-
- action::non_cat_in_house_use->table( 'action.non_cat_in_house_use' );
- action::non_cat_in_house_use->sequence( 'action.non_cat_in_house_use_id_seq' );
-
- #---------------------------------------------------------------------
- package action::in_house_use;
-
- action::in_house_use->table( 'action.in_house_use' );
- action::in_house_use->sequence( 'action.in_house_use_id_seq' );
-
- #---------------------------------------------------------------------
- package action::non_cataloged_circulation;
-
- action::non_cataloged_circulation->table( 'action.non_cataloged_circulation' );
- action::non_cataloged_circulation->sequence( 'action.non_cataloged_circulation_id_seq' );
-
- #---------------------------------------------------------------------
- package action::open_circulation;
-
- action::open_circulation->table( 'action.open_circulation' );
-
- #---------------------------------------------------------------------
- package action::survey;
-
- action::survey->table( 'action.survey' );
- action::survey->sequence( 'action.survey_id_seq' );
-
- #---------------------------------------------------------------------
- package action::survey_question;
-
- action::survey_question->table( 'action.survey_question' );
- action::survey_question->sequence( 'action.survey_question_id_seq' );
-
- #---------------------------------------------------------------------
- package action::survey_answer;
-
- action::survey_answer->table( 'action.survey_answer' );
- action::survey_answer->sequence( 'action.survey_answer_id_seq' );
-
- #---------------------------------------------------------------------
- package action::survey_response;
-
- action::survey_response->table( 'action.survey_response' );
- action::survey_response->sequence( 'action.survey_response_id_seq' );
-
- #---------------------------------------------------------------------
- package config::non_cataloged_type;
-
- config::non_cataloged_type->table( 'config.non_cataloged_type' );
- config::non_cataloged_type->sequence( 'config.non_cataloged_type_id_seq' );
-
- #---------------------------------------------------------------------
- package config::copy_status;
-
- config::copy_status->table( 'config.copy_status' );
- config::copy_status->sequence( 'config.copy_status_id_seq' );
-
- #---------------------------------------------------------------------
- package config::rules::circ_duration;
-
- config::rules::circ_duration->table( 'config.rule_circ_duration' );
- config::rules::circ_duration->sequence( 'config.rule_circ_duration_id_seq' );
-
- #---------------------------------------------------------------------
- package config::rules::age_hold_protect;
-
- config::rules::age_hold_protect->table( 'config.rule_age_hold_protect' );
- config::rules::age_hold_protect->sequence( 'config.rule_age_hold_protect_id_seq' );
-
- #---------------------------------------------------------------------
- package config::rules::max_fine;
-
- config::rules::max_fine->table( 'config.rule_max_fine' );
- config::rules::max_fine->sequence( 'config.rule_max_fine_id_seq' );
-
- #---------------------------------------------------------------------
- package config::rules::recurring_fine;
-
- config::rules::recurring_fine->table( 'config.rule_recurring_fine' );
- config::rules::recurring_fine->sequence( 'config.rule_recurring_fine_id_seq' );
-
- #---------------------------------------------------------------------
- package config::net_access_level;
-
- config::net_access_level->table( 'config.net_access_level' );
- config::net_access_level->sequence( 'config.net_access_level_id_seq' );
-
- #---------------------------------------------------------------------
- package config::standing;
-
- config::standing->table( 'config.standing' );
- config::standing->sequence( 'config.standing_id_seq' );
-
- #---------------------------------------------------------------------
- package config::metabib_field;
-
- config::metabib_field->table( 'config.metabib_field' );
- config::metabib_field->sequence( 'config.metabib_field_id_seq' );
-
- #---------------------------------------------------------------------
- package config::bib_source;
-
- config::bib_source->table( 'config.bib_source' );
- config::bib_source->sequence( 'config.bib_source_id_seq' );
-
- #---------------------------------------------------------------------
- package config::identification_type;
-
- config::identification_type->table( 'config.identification_type' );
- config::identification_type->sequence( 'config.identification_type_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::call_number_note;
-
- asset::call_number_note->table( 'asset.call_number_note' );
- asset::call_number_note->sequence( 'asset.call_number_note_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::copy_note;
-
- asset::copy_note->table( 'asset.copy_note' );
- asset::copy_note->sequence( 'asset.copy_note_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::call_number;
-
- asset::call_number->table( 'asset.call_number' );
- asset::call_number->sequence( 'asset.call_number_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::call_number_class;
-
- asset::call_number_class->table( 'asset.call_number_class' );
- asset::call_number_class->sequence( 'asset.call_number_class_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::copy_location_order;
-
- asset::copy_location_order->table( 'asset.copy_location_order' );
- asset::copy_location_order->sequence( 'asset.copy_location_order_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::copy_location;
-
- asset::copy_location->table( 'asset.copy_location' );
- asset::copy_location->sequence( 'asset.copy_location_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::copy;
-
- asset::copy->table( 'asset.copy' );
- asset::copy->sequence( 'asset.copy_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::stat_cat;
-
- asset::stat_cat->table( 'asset.stat_cat' );
- asset::stat_cat->sequence( 'asset.stat_cat_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::stat_cat_entry;
-
- asset::stat_cat_entry->table( 'asset.stat_cat_entry' );
- asset::stat_cat_entry->sequence( 'asset.stat_cat_entry_id_seq' );
-
- #---------------------------------------------------------------------
- package asset::stat_cat_entry_copy_map;
-
- asset::stat_cat_entry_copy_map->table( 'asset.stat_cat_entry_copy_map' );
- asset::stat_cat_entry_copy_map->sequence( 'asset.stat_cat_entry_copy_map_id_seq' );
-
- #---------------------------------------------------------------------
- package authority::record_entry;
-
- authority::record_entry->table( 'authority.record_entry' );
- authority::record_entry->sequence( 'authority.record_entry_id_seq' );
-
- #---------------------------------------------------------------------
- package biblio::record_entry;
-
- biblio::record_entry->table( 'biblio.record_entry' );
- biblio::record_entry->sequence( 'biblio.record_entry_id_seq' );
-
- #---------------------------------------------------------------------
- #package biblio::record_marc;
- #
- #biblio::record_marc->table( 'biblio.record_marc' );
- #biblio::record_marc->sequence( 'biblio.record_marc_id_seq' );
- #
- #---------------------------------------------------------------------
- package authority::record_note;
-
- authority::record_note->table( 'authority.record_note' );
- authority::record_note->sequence( 'authority.record_note_id_seq' );
-
- #---------------------------------------------------------------------
- package biblio::record_note;
-
- biblio::record_note->table( 'biblio.record_note' );
- biblio::record_note->sequence( 'biblio.record_note_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::workstation;
-
- actor::workstation->table( 'actor.workstation' );
- actor::workstation->sequence( 'actor.workstation_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::user;
-
- actor::user->table( 'actor.usr' );
- actor::user->sequence( 'actor.usr_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::org_unit::closed_date;
-
- actor::org_unit::closed_date->table( 'actor.org_unit_closed' );
- actor::org_unit::closed_date->sequence( 'actor.org_unit_closed_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::org_unit_setting;
-
- actor::org_unit_setting->table( 'actor.org_unit_setting' );
- actor::org_unit_setting->sequence( 'actor.org_unit_setting_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::user_standing_penalty;
-
- actor::user_standing_penalty->table( 'actor.usr_standing_penalty' );
- actor::user_standing_penalty->sequence( 'actor.usr_standing_penalty_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::user_setting;
-
- actor::user_setting->table( 'actor.usr_setting' );
- actor::user_setting->sequence( 'actor.usr_setting_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::user_address;
-
- actor::user_address->table( 'actor.usr_address' );
- actor::user_address->sequence( 'actor.usr_address_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::org_address;
-
- actor::org_address->table( 'actor.org_address' );
- actor::org_address->sequence( 'actor.org_address_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::usr_org_unit_opt_in;
-
- actor::usr_org_unit_opt_in->table( 'actor.usr_org_unit_opt_in' );
- actor::usr_org_unit_opt_in->sequence( 'actor.usr_org_unit_opt_in_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::org_unit_proximity;
-
- actor::org_unit_proximity->table( 'actor.org_unit_proximity' );
- actor::org_unit_proximity->sequence( 'actor.org_unit_proximity_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::org_unit_type;
-
- actor::org_unit_type->table( 'actor.org_unit_type' );
- actor::org_unit_type->sequence( 'actor.org_unit_type_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::org_unit::hours_of_operation;
-
- actor::org_unit::hours_of_operation->table( 'actor.hours_of_operation' );
-
- #---------------------------------------------------------------------
- package actor::org_unit;
-
- actor::org_unit->table( 'actor.org_unit' );
- actor::org_unit->sequence( 'actor.org_unit_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::stat_cat;
-
- actor::stat_cat->table( 'actor.stat_cat' );
- actor::stat_cat->sequence( 'actor.stat_cat_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::stat_cat_entry;
-
- actor::stat_cat_entry->table( 'actor.stat_cat_entry' );
- actor::stat_cat_entry->sequence( 'actor.stat_cat_entry_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::stat_cat_entry_user_map;
-
- actor::stat_cat_entry_user_map->table( 'actor.stat_cat_entry_usr_map' );
- actor::stat_cat_entry_user_map->sequence( 'actor.stat_cat_entry_usr_map_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::card;
-
- actor::card->table( 'actor.card' );
- actor::card->sequence( 'actor.card_id_seq' );
-
- #---------------------------------------------------------------------
- package actor::usr_note;
-
- actor::usr_note->table( 'actor.usr_note' );
- actor::usr_note->sequence( 'actor.usr_note_id_seq' );
-
- #---------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::metarecord;
-
- metabib::metarecord->table( 'metabib.metarecord' );
- metabib::metarecord->sequence( 'metabib.metarecord_id_seq' );
-
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::identifier_field_entry;
-
- metabib::identifier_field_entry->table( 'metabib.identifier_field_entry' );
- metabib::identifier_field_entry->sequence( 'metabib.identifier_field_entry_id_seq' );
- metabib::identifier_field_entry->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::title_field_entry;
-
- metabib::title_field_entry->table( 'metabib.title_field_entry' );
- metabib::title_field_entry->sequence( 'metabib.title_field_entry_id_seq' );
- metabib::title_field_entry->columns( 'FTS' => 'index_vector' );
-
-# metabib::title_field_entry->add_trigger(
-# before_create => \&OpenILS::Application::Storage::Driver::Pg::tsearch2_trigger
-# );
-# metabib::title_field_entry->add_trigger(
-# before_update => \&OpenILS::Application::Storage::Driver::Pg::tsearch2_trigger
-# );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::author_field_entry;
-
- metabib::author_field_entry->table( 'metabib.author_field_entry' );
- metabib::author_field_entry->sequence( 'metabib.author_field_entry_id_seq' );
- metabib::author_field_entry->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::subject_field_entry;
-
- metabib::subject_field_entry->table( 'metabib.subject_field_entry' );
- metabib::subject_field_entry->sequence( 'metabib.subject_field_entry_id_seq' );
- metabib::subject_field_entry->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::keyword_field_entry;
-
- metabib::keyword_field_entry->table( 'metabib.keyword_field_entry' );
- metabib::keyword_field_entry->sequence( 'metabib.keyword_field_entry_id_seq' );
- metabib::keyword_field_entry->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
- package metabib::series_field_entry;
-
- metabib::series_field_entry->table( 'metabib.series_field_entry' );
- metabib::series_field_entry->sequence( 'metabib.series_field_entry_id_seq' );
- metabib::series_field_entry->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- #package metabib::title_field_entry_source_map;
-
- #metabib::title_field_entry_source_map->table( 'metabib.title_field_entry_source_map' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- #package metabib::author_field_entry_source_map;
-
- #metabib::author_field_entry_source_map->table( 'metabib.author_field_entry_source_map' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- #package metabib::subject_field_entry_source_map;
-
- #metabib::subject_field_entry_source_map->table( 'metabib.subject_field_entry_source_map' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- #package metabib::keyword_field_entry_source_map;
-
- #metabib::keyword_field_entry_source_map->table( 'metabib.keyword_field_entry_source_map' );
-
- #-------------------------------------------------------------------------------
-
- #-------------------------------------------------------------------------------
- package metabib::metarecord_source_map;
-
- metabib::metarecord_source_map->table( 'metabib.metarecord_source_map' );
- metabib::metarecord_source_map->sequence( 'metabib.metarecord_source_map_id_seq' );
-
- #-------------------------------------------------------------------------------
- package authority::record_descriptor;
-
- authority::record_descriptor->table( 'authority.rec_descriptor' );
- authority::record_descriptor->sequence( 'authority.rec_descriptor_id_seq' );
-
- #-------------------------------------------------------------------------------
- package metabib::record_descriptor;
-
- metabib::record_descriptor->table( 'metabib.rec_descriptor' );
- metabib::record_descriptor->sequence( 'metabib.rec_descriptor_id_seq' );
-
- #-------------------------------------------------------------------------------
-
-
- #-------------------------------------------------------------------------------
- package authority::full_rec;
-
- authority::full_rec->table( 'authority.full_rec' );
- authority::full_rec->sequence( 'authority.full_rec_id_seq' );
- authority::full_rec->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
- package metabib::full_rec;
-
- metabib::full_rec->table( 'metabib.full_rec' );
- metabib::full_rec->sequence( 'metabib.full_rec_id_seq' );
- metabib::full_rec->columns( 'FTS' => 'index_vector' );
-
- #-------------------------------------------------------------------------------
-
- package permission::perm_list;
-
- permission::perm_list->sequence( 'permission.perm_list_id_seq' );
- permission::perm_list->table('permission.perm_list');
-
- #-------------------------------------------------------------------------------
-
- package permission::grp_tree;
-
- permission::grp_tree->sequence( 'permission.grp_tree_id_seq' );
- permission::grp_tree->table('permission.grp_tree');
-
- #-------------------------------------------------------------------------------
-
- package permission::usr_grp_map;
-
- permission::usr_grp_map->sequence( 'permission.usr_grp_map_id_seq' );
- permission::usr_grp_map->table('permission.usr_grp_map');
-
- #-------------------------------------------------------------------------------
-
- package permission::usr_work_ou_map;
- permission::usr_work_ou_map->sequence('permission.usr_work_ou_map_id_seq');
- permission::usr_work_ou_map->table('permission.usr_work_ou_map');
-
- #-------------------------------------------------------------------------------
-
- package permission::usr_perm_map;
-
- permission::usr_perm_map->sequence( 'permission.usr_perm_map_id_seq' );
- permission::usr_perm_map->table('permission.usr_perm_map');
-
- #-------------------------------------------------------------------------------
-
- package permission::grp_perm_map;
-
- permission::grp_perm_map->sequence( 'permission.grp_perm_map_id_seq' );
- permission::grp_perm_map->table('permission.grp_perm_map');
-
- #-------------------------------------------------------------------------------
-
- package action::hold_request;
-
- action::hold_request->sequence( 'action.hold_request_id_seq' );
- action::hold_request->table('action.hold_request');
-
- #-------------------------------------------------------------------------------
-
- package action::hold_notification;
-
- action::hold_notification->sequence( 'action.hold_notification_id_seq' );
- action::hold_notification->table('action.hold_notification');
-
- #-------------------------------------------------------------------------------
-
- package action::hold_copy_map;
-
- action::hold_copy_map->sequence( 'action.hold_copy_map_id_seq' );
- action::hold_copy_map->table('action.hold_copy_map');
-
- #-------------------------------------------------------------------------------
-
- package action::hold_transit_copy;
-
- action::hold_transit_copy->sequence( 'action.transit_copy_id_seq' );
- action::hold_transit_copy->table('action.hold_transit_copy');
-
- #-------------------------------------------------------------------------------
-
- package action::reservation_transit_copy;
-
- action::reservation_transit_copy->sequence( 'action.transit_copy_id_seq' );
- action::reservation_transit_copy->table('action.reservation_transit_copy');
-
- #-------------------------------------------------------------------------------
-
- package action::transit_copy;
-
- action::transit_copy->sequence( 'action.transit_copy_id_seq' );
- action::transit_copy->table('action.transit_copy');
-
- #-------------------------------------------------------------------------------
-
- package action::unfulfilled_hold_list;
-
- action::unfulfilled_hold_list->sequence( 'action.unfulfilled_hold_list_id_seq' );
- action::unfulfilled_hold_list->table('action.unfulfilled_hold_list');
-
- #-------------------------------------------------------------------------------
-
- package serial::subscription;
-
- serial::subscription->sequence( 'serial.subscription_id_seq' );
- serial::subscription->table('serial.subscription');
-
- #-------------------------------------------------------------------------------
-
- package serial::issuance;
-
- serial::issuance->sequence( 'serial.issuance_id_seq' );
- serial::issuance->table('serial.issuance');
-
- #-------------------------------------------------------------------------------
-
- package serial::item;
-
- serial::item->sequence( 'serial.item_id_seq' );
- serial::item->table('serial.item');
-
- #-------------------------------------------------------------------------------
-
- package serial::unit;
-
- serial::unit->sequence( 'asset.copy_id_seq' );
- serial::unit->table('serial.unit');
-
- #-------------------------------------------------------------------------------
-
- package config::language_map;
- config::language_map->table('config.language_map');
-
- #-------------------------------------------------------------------------------
-
- package config::i18n_locale;
- config::i18n_locale->table('config.i18n_locale');
-
- #-------------------------------------------------------------------------------
-
- package config::i18n_core;
- config::i18n_core->sequence( 'config.i18n_core_id_seq' );
- config::i18n_core->table('config.i18n_core');
-
- #-------------------------------------------------------------------------------
-
- package config::item_form_map;
- config::item_form_map->table('config.item_form_map');
-
- #-------------------------------------------------------------------------------
-
- package config::lit_form_map;
- config::lit_form_map->table('config.lit_form_map');
-
- #-------------------------------------------------------------------------------
-
- package config::item_type_map;
- config::item_type_map->table('config.item_type_map');
-
- #-------------------------------------------------------------------------------
- package config::audience_map;
- config::audience_map->table('config.audience_map');
-
- #-------------------------------------------------------------------------------
-
-
-}
-
-for my $class ( qw/
- biblio::record_entry
- metabib::metarecord
- metabib::title_field_entry
- metabib::author_field_entry
- metabib::subject_field_entry
- metabib::keyword_field_entry
- metabib::series_field_entry
- metabib::metarecord_source_map
- metabib::record_descriptor
- metabib::full_rec
- authority::record_descriptor
- authority::full_rec
- / ) {
-
- (my $method_class = $class) =~ s/::/./go;
-
- for my $type ( qw/create create_start create_push create_finish/ ) {
- my ($name,$part) = split('_', $type);
-
- my $apiname = "open-ils.storage.direct.$method_class.batch.$name";
- $apiname .= ".$part" if ($part);
-
- OpenILS::Application::Storage->register_method(
- api_name => $apiname,
- method => "copy_$type",
- api_level => 1,
- 'package' => 'OpenILS::Application::Storage',
- cdbi => $class,
- );
- }
-}
-
-
-1;
+++ /dev/null
-{ # Every driver needs to provide a 'compile()' method to OpenILS::Application::Storage::FTS.
- # If that driver wants to support FTI, that is...
- #-------------------------------------------------------------------------------
- package OpenILS::Application::Storage::FTS;
- use OpenSRF::Utils::Logger qw/:level/;
- use Unicode::Normalize;
- my $log = 'OpenSRF::Utils::Logger';
-
- sub compile {
- my $self = shift;
- my $class = shift;
- my $term = NFD(shift());
-
- $log->debug("Raw term: $term",DEBUG);
- $log->debug("Search class: $class",DEBUG);
-
- $term =~ s/\&//go;
- $term =~ s/\|//go;
-
- $self = ref($self) || $self;
- $self = bless {} => $self;
- $self->{class} = $class;
-
- $term =~ s/(\pM+)//gos;
- $term =~ s/(\b\.\b)//gos;
-
- # hack to normalize ratio-like strings
- while ($term =~ /\b\d{1}:[, ]?\d+(?:[ ,]\d+[^:])+/o) {
- $term = $` . join ('', split(/[, ]/, $&)) . $';
- }
-
- $self->decompose($term);
-
- my $newterm = '';
- $newterm = join('&', $self->words) if ($self->words);
-
- if (@{$self->nots}) {
- $newterm = '('.$newterm.')&' if ($newterm);
- $newterm .= '!('. join('|', $self->nots) . ')';
- }
-
- $log->debug("Compiled term is [$newterm]", DEBUG);
- $newterm = OpenILS::Application::Storage::Driver::Pg->quote($newterm);
- $log->debug("Quoted term is [$newterm]", DEBUG);
-
- $self->{fts_query} = ["to_tsquery('$$self{class}',$newterm)"];
- $self->{fts_query_nots} = [];
- $self->{fts_op} = '@@';
- $self->{text_col} = shift;
- $self->{fts_col} = shift;
-
- return $self;
- }
-
- sub sql_where_clause {
- my $self = shift;
- my $column = $self->fts_col;
- my @output;
-
- my @ranks;
- for my $fts ( $self->fts_query ) {
- push @output, join(' ', $self->fts_col, $self->{fts_op}, $fts);
- push @ranks, "rank($column, $fts)";
- }
- $self->{fts_rank} = \@ranks;
-
- my $phrase_match = $self->sql_exact_phrase_match();
- return join(' AND ', @output) . $phrase_match;
- }
-
- sub sql_exact_phrase_match {
- my $self = shift;
- my $column = $self->text_col;
- my $output = '';
- for my $phrase ( $self->phrases ) {
- $phrase =~ s/\*/\\*/go;
- $phrase =~ s/\./\\./go;
- $phrase =~ s/'/\\'/go;
- $phrase =~ s/\s+/\\s+/go;
- $log->debug("Adding phrase [$phrase] to the match list", DEBUG);
- $output .= " AND $column ~* \$\$(^|\\W+)$phrase(\\W+|\$)\$\$";
- }
- $log->debug("Phrase list is [$output]", DEBUG);
- return $output;
- }
-
-}
-
-1;
+++ /dev/null
-
-{
- package OpenILS::Application::Storage;
- use OpenSRF::Utils::Logger;
-
- our $NOPRIMARY = 0;
- my $log = 'OpenSRF::Utils::Logger';
- my $pg = 'OpenILS::Application::Storage::Driver::Pg';
-
- sub child_exit {
- $_->disconnect for $pg->db_Handles;
- }
-
- sub current_xact {
- my $self = shift;
- my $client = shift;
- return $pg->current_xact_id;
- }
- __PACKAGE__->register_method(
- method => 'current_xact',
- api_name => 'open-ils.storage.transaction.current',
- api_level => 1,
- argc => 0,
- );
-
-
- sub pg_begin_xaction {
- my $self = shift;
- my $client = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- if (my $old_xact = $pg->current_xact_session) {
- if ($pg->current_xact_is_auto) {
- $log->debug("Commiting old autocommit transaction with Open-ILS XACT-ID [$old_xact]", INFO);
- $self->method_lookup("open-ils.storage.transaction.commit")->run();
- } else {
- $log->debug("Rolling back old NON-autocommit transaction with Open-ILS XACT-ID [$old_xact]", INFO);
- $self->method_lookup("open-ils.storage.transaction.rollback")->run();
- throw OpenSRF::DomainObject::oilsException->new(
- statusCode => 500,
- status => "Previous transaction rolled back!",
- );
- }
- }
-
- $pg->set_xact_session( $client->session );
- my $xact_id = $pg->current_xact_id;
-
- $log->debug("Beginning a new transaction with Open-ILS XACT-ID [$xact_id]", INFO);
-
- my $dbh = OpenILS::Application::Storage::CDBI->db_Main;
-
- try {
- $dbh->begin_work;
-
- } catch Error with {
- my $e = shift;
- $log->debug("Failed to begin a new transaction with Open-ILS XACT-ID [$xact_id]: ".$e, INFO);
- throw $e;
- };
-
-
- my $death_cb = $client->session->register_callback(
- death => sub {
- __PACKAGE__->pg_rollback_xaction;
- }
- );
-
- $log->debug("Registered 'death' callback [$death_cb] for new transaction with Open-ILS XACT-ID [$xact_id]", DEBUG);
-
- $client->session->session_data( death_cb => $death_cb );
-
- if ($self->api_name =~ /autocommit$/o) {
- $pg->current_xact_is_auto(1);
- my $dc_cb = $client->session->register_callback(
- disconnect => sub {
- my $ses = shift;
- $ses->unregister_callback(death => $death_cb);
- __PACKAGE__->pg_commit_xaction;
- }
- );
- $log->debug("Registered 'disconnect' callback [$dc_cb] for new transaction with Open-ILS XACT-ID [$xact_id]", DEBUG);
- if ($client and $client->session) {
- $client->session->session_data( disconnect_cb => $dc_cb );
- }
- }
-
- return 1;
-
- }
- __PACKAGE__->register_method(
- method => 'pg_begin_xaction',
- api_name => 'open-ils.storage.transaction.begin',
- api_level => 1,
- argc => 0,
- );
- __PACKAGE__->register_method(
- method => 'pg_begin_xaction',
- api_name => 'open-ils.storage.transaction.begin.autocommit',
- api_level => 1,
- argc => 0,
- );
-
- sub pg_commit_xaction {
- my $self = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $xact_id = $pg->current_xact_id;
-
- my $success = 1;
- try {
- $log->debug("Committing transaction with Open-ILS XACT-ID [$xact_id]", INFO) if ($xact_id);
- my $dbh = OpenILS::Application::Storage::CDBI->db_Main;
- $dbh->commit;
-
- } catch Error with {
- my $e = shift;
- $log->debug("Failed to commit transaction with Open-ILS XACT-ID [$xact_id]: ".$e, INFO);
- $success = 0;
- };
-
- $pg->current_xact_session->unregister_callback( death =>
- $pg->current_xact_session->session_data( 'death_cb' )
- ) if ($pg->current_xact_session);
-
- if ($pg->current_xact_is_auto) {
- $pg->current_xact_session->unregister_callback( disconnect =>
- $pg->current_xact_session->session_data( 'disconnect_cb' )
- );
- }
-
- $pg->unset_xact_session;
-
- return $success;
-
- }
- __PACKAGE__->register_method(
- method => 'pg_commit_xaction',
- api_name => 'open-ils.storage.transaction.commit',
- api_level => 1,
- argc => 0,
- );
-
- sub pg_rollback_xaction {
- my $self = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $xact_id = $pg->current_xact_id;
-
- my $success = 1;
- try {
- my $dbh = OpenILS::Application::Storage::CDBI->db_Main;
- $log->debug("Rolling back a transaction with Open-ILS XACT-ID [$xact_id]", INFO);
- $dbh->rollback;
-
- } catch Error with {
- my $e = shift;
- $log->debug("Failed to roll back transaction with Open-ILS XACT-ID [$xact_id]: ".$e, INFO);
- $success = 0;
- };
-
- $pg->current_xact_session->unregister_callback( death =>
- $pg->current_xact_session->session_data( 'death_cb' )
- ) if ($pg->current_xact_session);
-
- if ($pg->current_xact_is_auto) {
- $pg->current_xact_session->unregister_callback( disconnect =>
- $pg->current_xact_session->session_data( 'disconnect_cb' )
- );
- }
-
- $pg->unset_xact_session;
-
- return $success;
- }
- __PACKAGE__->register_method(
- method => 'pg_rollback_xaction',
- api_name => 'open-ils.storage.transaction.rollback',
- api_level => 1,
- argc => 0,
- );
-
- sub set_savepoint {
- my $self = shift;
- my $client = shift;
- my $sp = shift || 'osrf_savepoint';
- return OpenILS::Application::Storage::CDBI->db_Main->pg_savepoint($sp);
- }
- __PACKAGE__->register_method(
- method => 'set_savepoint',
- api_name => 'open-ils.storage.savepoint.set',
- api_level => 1,
- argc => 1,
- );
-
- sub release_savepoint {
- my $self = shift;
- my $client = shift;
- my $sp = shift || 'osrf_savepoint';
- return OpenILS::Application::Storage::CDBI->db_Main->pg_release($sp);
- }
- __PACKAGE__->register_method(
- method => 'release_savepoint',
- api_name => 'open-ils.storage.savepoint.release',
- api_level => 1,
- argc => 1,
- );
-
- sub rollback_to_savepoint {
- my $self = shift;
- my $client = shift;
- my $sp = shift || 'osrf_savepoint';
- return OpenILS::Application::Storage::CDBI->db_Main->pg_rollback_to($sp);
- }
- __PACKAGE__->register_method(
- method => 'rollback_to_savepoint',
- api_name => 'open-ils.storage.savepoint.rollback',
- api_level => 1,
- argc => 1,
- );
-
-
- sub copy_create_start {
- my $self = shift;
- my $client = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- #return undef unless ($pg->current_xact_session);
-
- my @cols = $self->{cdbi}->columns('Essential');
- if ($NOPRIMARY) {
- my ($p) = $self->{cdbi}->columns('Primary');
- @cols = grep { $_ ne $p } @cols;
- }
-
- my $col_list = join ',', @cols;
-
- $log->debug('Starting COPY import for '.$self->{cdbi}->table." ($col_list)", DEBUG);
- $self->{cdbi}->sql_copy_start($self->{cdbi}->table, $col_list)->execute;
-
- return 1;
- }
-
- sub copy_create_push {
- my $self = shift;
- my $client = shift;
- my @fm_nodes = @_;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- #return undef unless ($pg->current_xact_session);
-
- my @cols = $self->{cdbi}->columns('Essential');
- if ($NOPRIMARY) {
- my ($p) = $self->{cdbi}->columns('Primary');
- @cols = grep { $_ ne $p } @cols;
- }
-
- my $dbh = $self->{cdbi}->db_Main;
- for my $node ( @fm_nodes ) {
- next unless ($node);
- my $line = join("\t", map { defined($node->$_()) ? $node->$_() : '\N' } @cols);
- $log->debug("COPY line: [$line]",DEBUG);
- $dbh->pg_putline($line."\n");
- }
-
- return scalar(@fm_nodes);
- }
-
- sub copy_create_finish {
- my $self = shift;
- my $client = shift;
- my @fm_nodes = @_;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- #return undef unless ($pg->current_xact_session);
-
- my $dbh = $self->{cdbi}->db_Main;
-
- $dbh->pg_endcopy || $log->debug("Could not end COPY with pg_endcopy", WARN);
-
- $log->debug('COPY import for '.$self->{cdbi}->table." ($col_list) complete", DEBUG);
-
- return 1;
- }
-
- sub copy_create {
- my $self = shift;
- my $client = shift;
- my @fm_nodes = @_;
-
- local $NOPRIMARY = 1;
-
- copy_create_start( $self => $client );
- copy_create_push( $self => $client => @fm_nodes );
- copy_create_finish( $self => $client );
-
- return scalar(@fm_nodes);
- }
-
- sub autoprimary {
- my $class = shift;
- my $val = shift;
- $NOPRIMARY = $val if (defined $val);
- return $NOPRIMARY;
- }
-
-}
-
-1;
+++ /dev/null
-use OpenSRF::Utils::Logger qw/:level/;
-my $log = 'OpenSRF::Utils::Logger';
-
-#-------------------------------------------------------------------------------
-package OpenILS::Application::Storage::FTS;
-use OpenSRF::Utils::Logger qw/:level/;
-use Parse::RecDescent;
-use OpenILS::Utils::Normalize qw( naco_normalize );
-
-my $_default_grammar_parser = new Parse::RecDescent ( <<'GRAMMAR' );
-
-<autotree>
-
-search_expression: or_expr(s) | and_expr(s) | expr(s)
-or_expr: lexpr '||' rexpr
-and_expr: lexpr '&&' rexpr
-lexpr: expr
-rexpr: expr
-expr: phrase(s) | group(s) | word(s)
-joiner: '||' | '&&'
-phrase: '"' token(s) '"'
-group : '(' search_expression ')'
-word: numeric_range | negative_token | token
-negative_token: '-' .../\D+/ token
-token: /[-\w]+/
-numeric_range: /\d+-\d*/
-
-GRAMMAR
-
-sub compile {
-
- $log->debug("You must override me somewhere, or I will make searching really slow!!!!",ERROR);;
-
- my $self = shift;
- my $class = shift;
- my $term = shift;
-
- $self = ref($self) || $self;
- $self = bless {} => $self;
-
- $self->decompose($term);
-
- for my $part ( $self->words, $self->phrases ) {
- $part = OpenILS::Application::Storage::CDBI->quote($part);
- push @{ $self->{ fts_query } }, "'\%$part\%'";
- }
-
- for my $part ( $self->nots ) {
- $part = OpenILS::Application::Storage::CDBI->quote($part);
- push @{ $self->{ fts_query_not } }, "'\%$part\%'";
- }
-}
-
-sub decompose {
- my $self = shift;
- my $term = shift;
- my $parser = shift || $_default_grammar_parser;
-
- $term =~ s/:/ /go;
- $term =~ s/\s+--\s+/ /go;
- $term =~ s/(?:&[^;]+;)//go;
- $term =~ s/\s+/ /go;
- $term =~ s/(^|\s+)-(\w+)/$1!$2/go;
- $term =~ s/\b(\+)(\w+)/$2/go;
- $term =~ s/^\s*\b(.+)\b\s*$/$1/o;
- $term =~ s/(\d{4})-(\d{4})/$1 $2/go;
- #$term =~ s/^(?:an?|the)\b(.*)/$1/o;
-
- $log->debug("Stripped search term string is [$term]",DEBUG);
-
- my $parsetree = $parser->search_expression( $term );
- my @words = $term =~ /\b((?<!!)\w+)\b/go;
- my @nots = $term =~ /\b(?<=!)(\w+)\b/go;
-
- $log->debug("Stripped words are[".join(', ',@words)."]",DEBUG);
- $log->debug("Stripped nots are[".join(', ',@nots)."]",DEBUG);
-
- my @parts;
- while ($term =~ s/ ((?<!\\)"{1}) (.*?) ((?<!\\)"){1} //x) {
- my $part = $2;
- $part =~ s/^\s*//o;
- $part =~ s/\s*$//o;
- next unless $part;
- push @parts, lc($part);
- }
-
- $self->{ fts_op } = 'ILIKE';
- $self->{ fts_col } = $self->{ text_col } = 'value';
- $self->{ raw } = $term;
- $self->{ parsetree } = $parsetree;
- $self->{ words } = \@words;
- $self->{ nots } = \@nots;
- $self->{ phrases } = \@parts;
-
- return $self;
-}
-
-sub fts_query_not {
- my $self = shift;
- return wantarray ? @{ $self->{fts_query_not} } : $self->{fts_query_not};
-}
-
-sub fts_rank {
- my $self = shift;
- return wantarray ? @{ $self->{fts_rank} } : $self->{fts_rank};
-}
-
-sub fts_query {
- my $self = shift;
- return wantarray ? @{ $self->{fts_query} } : $self->{fts_query};
-}
-
-sub raw {
- my $self = shift;
- return $self->{raw};
-}
-
-sub parse_tree {
- my $self = shift;
- return $self->{parsetree};
-}
-
-sub fts_col {
- my $self = shift;
- return $self->{fts_col};
-}
-
-sub text_col {
- my $self = shift;
- return $self->{text_col};
-}
-
-sub phrases {
- my $self = shift;
- return wantarray ? @{ $self->{phrases} } : $self->{phrases};
-}
-
-sub words {
- my $self = shift;
- return wantarray ? @{ $self->{words} } : $self->{words};
-}
-
-sub nots {
- my $self = shift;
- return wantarray ? @{ $self->{nots} } : $self->{nots};
-}
-
-sub sql_exact_phrase_match {
- my $self = shift;
- my $column = $self->text_col;
- my $output = '';
- for my $phrase ( $self->phrases ) {
- $phrase =~ s/%/\\%/go;
- $phrase =~ s/_/\\_/go;
- $phrase =~ s/'/\\'/go;
- $log->debug("Adding phrase [$phrase] to the match list", DEBUG);
- $output .= " AND $column ILIKE '\%$phrase\%'";
- }
- $log->debug("Phrase list is [$output]", DEBUG);
- return $output;
-}
-
-sub sql_exact_word_bump {
- my $self = shift;
- my $bump = shift || '0.1';
-
- my $column = $self->text_col;
- my $output = '';
- for my $word ( $self->words ) {
- $word =~ s/%/\\%/go;
- $word =~ s/_/\\_/go;
- $word =~ s/'/''/go;
- $log->debug("Adding word [$word] to the relevancy bump list", DEBUG);
- $output .= " + CASE WHEN $column ILIKE '\%$word\%' THEN $bump ELSE 0 END";
- }
- $log->debug("Word bump list is [$output]", DEBUG);
- return $output;
-}
-
-sub sql_where_clause {
- my $self = shift;
- my @output;
-
- for my $fts ( $self->fts_query ) {
- push @output, join(' ', $self->fts_col, $self->{fts_op}, $fts);
- }
-
- for my $fts ( $self->fts_query_not ) {
- push @output, 'NOT (' . join(' ', $self->fts_col, $self->{fts_op}, $fts) . ')';
- }
-
- my $phrase_match = $self->sql_exact_phrase_match();
- return join(' AND ', @output);
-}
-
-#-------------------------------------------------------------------------------
-use UNIVERSAL::require;
-BEGIN {
- 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
-}
-
-package Class::DBI;
-
-{
- no warnings;
- no strict;
- sub _do_search {
- my ($proto, $search_type, @args) = @_;
- my $class = ref $proto || $proto;
-
- my (@cols, @vals);
- my $search_opts = (@args > 1 and ref($args[-1]) eq 'HASH') ? pop @args : {};
-
- @args = %{ $args[0] } if ref $args[0] eq "HASH";
-
- $search_opts->{offset} = int($search_opts->{page} - 1) * int($search_opts->{page_size}) if ($search_opts->{page_size});
- $search_opts->{_placeholder} ||= '?';
-
- my @frags;
- while (my ($col, $val) = splice @args, 0, 2) {
- my $column = $class->find_column($col)
- || (List::Util::first { $_->accessor eq $col } $class->columns)
- || $class->_croak("$col is not a column of $class");
-
- if (!defined($val)) {
- push @frags, "$col IS NULL";
- } elsif (ref($val) and ref($val) eq 'ARRAY') {
- push @frags, "$col IN (".join(',',map{'?'}@$val).")";
- for my $v (@$val) {
- push @vals, ''.$class->_deflated_column($column, $v);
- }
- } else {
- push @frags, "$col $search_type $$search_opts{_placeholder}";
- push @vals, $class->_deflated_column($column, $val);
- }
- }
-
- my $frag = join " AND ", @frags;
-
- $frag .= " ORDER BY $search_opts->{order_by}"
- if $search_opts->{order_by};
- $frag .= " LIMIT $search_opts->{limit}"
- if $search_opts->{limit};
- $frag .= " OFFSET $search_opts->{offset}"
- if ($search_opts->{limit} && defined($search_opts->{offset}));
-
- return $class->sth_to_objects($class->sql_Retrieve($frag), \@vals);
- }
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::Publisher;
-use base qw/OpenILS::Application::Storage/;
-our $VERSION = 1;
-
-use Digest::MD5 qw/md5_hex/;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenILS::Utils::Fieldmapper;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-
-sub register_method {
- my $class = shift;
- my %args = @_;
- my %dup_args = %args;
-
- $class = ref($class) || $class;
-
- $args{package} ||= $class;
- __PACKAGE__->SUPER::register_method( %args );
-
- if (exists($dup_args{cachable}) and $dup_args{cachable}) {
- (my $name = $dup_args{api_name}) =~ s/^open-ils\.storage/open-ils.storage.cachable/o;
- if ($name ne $dup_args{api_name}) {
- $dup_args{real_api_name} = $dup_args{api_name};
- $dup_args{method} = 'cachable_wrapper';
- $dup_args{api_name} = $name;
- $dup_args{package} = __PACKAGE__;
- __PACKAGE__->SUPER::register_method( %dup_args );
- }
- }
-
- if ($dup_args{real_api_name} =~ /^open-ils\.storage\.direct\..+\.search.+/o ||
- $dup_args{api_name} =~ /^open-ils\.storage\.direct\..+\.search.+/o) {
- $dup_args{api_name} = $dup_args{real_api_name} if ($dup_args{real_api_name});
-
- (my $name = $dup_args{api_name}) =~ s/\.direct\./.id_list./o;
-
- $dup_args{notes} = $dup_args{real_api_name};
- $dup_args{real_api_name} = $dup_args{api_name};
- $dup_args{method} = 'search_ids';
- $dup_args{api_name} = $name;
- $dup_args{package} = __PACKAGE__;
-
- __PACKAGE__->SUPER::register_method( %dup_args );
- }
-}
-
-sub cachable_wrapper {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my %cache_args = (
- limit => 100,
- offset => 0,
- timeout => 7200,
- cache_page_size => 1000,
- );
-
- my @real_args;
- my $key_string = $self->api_name;
- for (my $ind = 0; $ind < scalar(@args); $ind++) {
- if ( $args[$ind] eq 'limit' ||
- $args[$ind] eq 'offset' ||
- $args[$ind] eq 'cache_page_size' ||
- $args[$ind] eq 'timeout' ) {
-
- my $key_ind = $ind;
- $ind++;
- my $value_ind = $ind;
- $cache_args{$args[$key_ind]} = $args[$value_ind];
- $log->debug("Cache limiter value for $args[$key_ind] is $args[$value_ind]", INTERNAL);
- next;
- }
- $key_string .= $args[$ind];
- $log->debug("Partial cache key value is $args[$ind]", INTERNAL);
- push @real_args, $args[$ind];
- }
-
- my $cache_page = int($cache_args{offset} / $cache_args{cache_page_size});
- my $cache_key;
- { use bytes;
- $cache_key = md5_hex($key_string.$cache_page);
- }
-
- $log->debug("Key string for cache lookup is $key_string -> $cache_key", DEBUG);
- $log->debug("Cache page is $cache_page", DEBUG);
-
- my $cached_res = OpenSRF::Utils::Cache->new->get_cache( $cache_key );
- if (defined $cached_res) {
- $log->debug("Found ".scalar(@$cached_res)." records in the cache", INFO);
- $log->debug("Values from cache: ".join(', ', @$cached_res), INTERNAL);
- my $start = int($cache_args{offset} - ($cache_page * $cache_args{cache_page_size}));
- my $end = int($start + $cache_args{limit} - 1);
- $log->debug("Responding with values from ".$start.' to '.$end,DEBUG);
- $client->respond( $_ ) for ( grep { defined } @$cached_res[ $start .. $end ]);
- return undef;
- }
-
- my $method = $self->method_lookup($self->{real_api_name});
- my @res = $method->run(@real_args);
-
-
- $client->respond( $_ ) for ( grep { defined } @res[$cache_args{offset} .. int($cache_args{offset} + $cache_args{limit} - 1)] );
-
- $log->debug("Saving values from ".int($cache_page * $cache_args{cache_page_size})." to ".
- int(($cache_page + 1) * $cache_args{cache_page_size}). "to the cache", INTERNAL);
- try {
- OpenSRF::Utils::Cache->new->put_cache(
- $cache_key =>
- [@res[int($cache_page * $cache_args{cache_page_size}) .. int(($cache_page + 1) * $cache_args{cache_page_size}) ]] =>
- OpenSRF::Utils->interval_to_seconds( $cache_args{timeout} )
- );
- } catch Error with {
- my $e = shift;
- $log->error("Cache seems to be down, $e");
- };
-
- return undef;
-}
-
-sub random_object {
- my $self = shift;
- my $client = shift;
-
- my $cdbi = $self->{cdbi};
- my $table = $cdbi->table;
- my $sql = <<" SQL";
- SELECT id
- FROM $table
- WHERE id IN (( SELECT (RANDOM() * (SELECT MAX(id) FROM $table))::INT LIMIT 1 ));
- SQL
-
- my $trys = 100;
- while ($trys--) {
-
- my $id = $cdbi->db_Main->selectcol_arrayref($sql);
- next unless (@$id);
-
- return ($cdbi->fast_fieldmapper(@$id))[0];
- }
- return undef;
-}
-
-sub retrieve_node {
- my $self = shift;
- my $client = shift;
- my @ids = @_;
-
- my $cdbi = $self->{cdbi};
-
- for my $id ( @ids ) {
- next unless ($id);
-
- my ($rec) = $cdbi->fast_fieldmapper($id);
- if ($self->api_name !~ /batch/o) {
- return $rec if ($rec);
- }
- $client->respond($rec);
- }
- return undef;
-}
-
-sub search_ids {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my @res = $self->method_lookup($self->{real_api_name})->run(@args);
-
- if (ref($res[0]) eq 'ARRAY') {
- return [ map { $_->id } @{ $res[0] } ];
- }
-
- $client->respond($_) for ( map { $_->id } @res );
- return undef;
-}
-
-sub search_where {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- if (ref($args[0]) eq 'HASH') {
- if ($args[1]) {
- $args[1]{limit_dialect} = $self->{cdbi}->db_Main;
- } else {
- $args[1] = {limit_dialect => $self->{cdbi}->db_Main };
- }
- } else {
- $args[0] = { @args };
- $args[1] = {limit_dialect => $self->{cdbi} };
- }
-
- my $cdbi = $self->{cdbi};
-
- for my $obj ($cdbi->search_where(@args)) {
- next unless ref($obj);
- $client->respond( $obj->to_fieldmapper );
- }
- return undef;
-}
-
-sub search {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- my $cdbi = $self->{cdbi};
-
- (my $search_type = $self->api_name) =~ s/.*\.(search[^.]*).*/$1/o;
-
- for my $obj ($cdbi->$search_type(@args)) {
- next unless ref($obj);
- $client->respond( $obj->to_fieldmapper );
- }
- return undef;
-}
-
-sub search_one_field {
- my $self = shift;
- my $client = shift;
- my @args = @_;
-
- (my $field = $self->api_name) =~ s/.*\.([^\.]+)$/$1/o;
-
- return search( $self, $client, $field, @args );
-}
-
-sub old_search_one_field {
- my $self = shift;
- my $client = shift;
- my @terms = @_;
-
- (my $search_type = $self->api_name) =~ s/.*\.(search[^.]*).*/$1/o;
- (my $col = $self->api_name) =~ s/.*\.$search_type\.([^.]+).*/$1/;
- my $cdbi = $self->{cdbi};
-
- my $like = 0;
- $like = 1 if ($search_type =~ /like$/o);
- $like = 2 if ($search_type =~ /fts$/o);
- $like = 3 if ($search_type =~ /regex$/o);
-
- for my $term (@terms) {
- $log->debug("Searching $cdbi for $col using type $search_type, value '$term'",DEBUG);
- if (@terms == 1) {
- return [ $cdbi->fast_fieldmapper($term,$col,$like) ];
- }
- $client->respond( [ $cdbi->fast_fieldmapper($term,$col,$like) ] );
- }
- return undef;
-}
-
-
-sub create_node {
- my $self = shift;
- my $client = shift;
- my $node = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $cdbi = $self->{cdbi};
-
- my $success;
- try {
- my $rec = $cdbi->create($node);
- $success = $rec->id if ($rec);
- } catch Error with {
- $success = 0;
- };
-
- return $success;
-}
-
-sub update_node {
- my $self = shift;
- my $client = shift;
- my $node = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $cdbi = $self->{cdbi};
-
- return $cdbi->update($node);
-}
-
-sub mass_delete {
- my $self = shift;
- my $client = shift;
- my $search = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $where = 'WHERE ';
-
- my $cdbi = $self->{cdbi};
- my $table = $cdbi->table;
-
- my @keys = sort keys %$search;
-
- my @binds;
- my @wheres;
- for my $col ( @keys ) {
- if (ref($$search{$col}) and ref($$search{$col}) =~ /ARRAY/o) {
- push @wheres, "$col IN (" . join(',', map { '?' } @{ $$search{$col} }) . ')';
- push @binds, map { "$_" } @{ $$search{$col} };
- } else {
- push @wheres, "$col = ?";
- push @binds, $$search{$col};
- }
- }
- $where .= join ' AND ', @wheres;
-
- my $delete = "DELETE FROM $table $where";
-
- $log->debug("Performing MASS deletion : $delete",DEBUG);
-
- my $dbh = $cdbi->db_Main;
- my $success = 1;
- try {
- my $sth = $dbh->prepare($delete);
- $sth->execute( @binds );
- $sth->finish;
- $log->debug("MASS Delete succeeded",DEBUG);
- } catch Error with {
- $log->debug("MASS Delete FAILED : ".shift(),DEBUG);
- $success = 0;
- };
- return $success;
-}
-
-sub remote_update_node {
- my $self = shift;
- my $client = shift;
- my $keys = shift;
- my $vals = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $cdbi = $self->{cdbi};
-
- my $success = 1;
- try {
- $success = $cdbi->remote_update($keys,$vals);
- } catch Error with {
- $success = 0;
- };
- return $success;
-}
-
-sub merge_node {
- my $self = shift;
- my $client = shift;
- my $keys = shift;
- my $vals = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $cdbi = $self->{cdbi};
-
- my $success = 1;
- try {
- $success = $cdbi->merge($keys,$vals)->id;
- } catch Error with {
- $success = 0;
- };
- return $success;
-}
-
-sub delete_node {
- my $self = shift;
- my $client = shift;
- my $node = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $cdbi = $self->{cdbi};
-
- my $success = 1;
- try {
- $success = $cdbi->delete($node);
- } catch Error with {
- $success = 0;
- };
- return $success;
-}
-
-sub batch_call {
- my $self = shift;
- my $client = shift;
- my @nodes = @_;
-
- my $unwrap = $self->{unwrap};
-
- my $cdbi = $self->{cdbi};
- my $api_name = $self->api_name;
- (my $single_call_api_name = $api_name) =~ s/batch\.//o;
-
- $log->debug("Default $api_name looking up $single_call_api_name...",INTERNAL);
- my $method = $self->method_lookup($single_call_api_name);
-
- my @success;
- while ( my $node = shift(@nodes) ) {
- my ($res) = $method->run( ($unwrap ? (@$node) : ($node)) );
- push(@success, 1) if ($res >= 0);
- }
-
- my $insert_total = 0;
- $insert_total += $_ for (@success);
-
- return $insert_total;
-}
-
-
-# --------------------- End of generic methods -----------------------
-
-
-for my $pkg ( qw/actor action asset biblio config metabib authority money permission container/ ) {
- "OpenILS::Application::Storage::Publisher::$pkg"->use;
- if ($@) {
- $log->debug("ARG! Couldn't load $pkg class Publisher: $@", ERROR);
- throw OpenSRF::EX::ERROR ("ARG! Couldn't load $pkg class Publisher: $@");
- }
-}
-
-for my $fmclass ( (Fieldmapper->classes) ) {
-
- $log->debug("Generating methods for Fieldmapper class $fmclass", DEBUG);
-
- next if ($fmclass->is_virtual);
-
- (my $cdbi = $fmclass) =~ s/^Fieldmapper:://o;
- (my $class = $cdbi) =~ s/::.*//o;
- (my $api_class = $cdbi) =~ s/::/./go;
- my $registration_class = __PACKAGE__ . "::$class";
- my $api_prefix = 'open-ils.storage.direct.'.$api_class;
-
- # Create the search methods
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search',
- method => 'search',
- api_level => 1,
- argc => 2,
- stream => 1,
- cdbi => $cdbi,
- cachable => 1,
- );
- }
-
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_where' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_where',
- method => 'search_where',
- api_level => 1,
- stream => 1,
- argc => 1,
- cdbi => $cdbi,
- cachable => 1,
- );
- }
-
-=comment
-
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_like' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_like',
- method => 'search',
- api_level => 1,
- stream => 1,
- cdbi => $cdbi,
- cachable => 1,
- argc => 2,
- );
- }
-
- if (\&Class::DBI::search_fts and $cdbi->columns('FTS')) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_fts' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_fts',
- method => 'search',
- api_level => 1,
- stream => 1,
- cdbi => $cdbi,
- cachable => 1,
- argc => 2,
- );
- }
- }
-
- if (\&Class::DBI::search_regex) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_regex' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_regex',
- method => 'search',
- api_level => 1,
- stream => 1,
- cdbi => $cdbi,
- cachable => 1,
- argc => 2,
- );
- }
- }
-
- if (\&Class::DBI::search_ilike) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_ilike' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_ilike',
- method => 'search',
- api_level => 1,
- stream => 1,
- cdbi => $cdbi,
- cachable => 1,
- argc => 2,
- );
- }
- }
-
-=cut
-
- # Create the random method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.random' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.random',
- method => 'random_object',
- api_level => 1,
- cdbi => $cdbi,
- argc => 0,
- );
- }
-
- # Create the retrieve method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.retrieve' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.retrieve',
- method => 'retrieve_node',
- api_level => 1,
- cdbi => $cdbi,
- cachable => 1,
- argc => 1,
- );
- }
-
- # Create the batch retrieve method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.retrieve' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.batch.retrieve',
- method => 'retrieve_node',
- api_level => 1,
- stream => 1,
- cdbi => $cdbi,
- cachable => 1,
- argc => 1,
- );
- }
-
- for my $field ($fmclass->real_fields) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search.'.$field ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search.'.$field,
- method => 'search_one_field',
- api_level => 1,
- cdbi => $cdbi,
- cachable => 1,
- stream => 1,
- argc => 1,
- );
- }
-
-=comment
-
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_like.'.$field ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_like.'.$field,
- method => 'search_one_field',
- api_level => 1,
- cdbi => $cdbi,
- cachable => 1,
- stream => 1,
- argc => 1,
- );
- }
- if (\&Class::DBI::search_fts and grep { $field eq $_ } $cdbi->columns('FTS')) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_fts.'.$field ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_fts.'.$field,
- method => 'search_one_field',
- api_level => 1,
- cdbi => $cdbi,
- cachable => 1,
- stream => 1,
- argc => 1,
- );
- }
- }
- if (\&Class::DBI::search_regex) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_regex.'.$field ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_regex.'.$field,
- method => 'search_one_field',
- api_level => 1,
- cdbi => $cdbi,
- cachable => 1,
- stream => 1,
- argc => 1,
- );
- }
- }
- if (\&Class::DBI::search_ilike) {
- unless ( __PACKAGE__->is_registered( $api_prefix.'.search_ilike.'.$field ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.search_ilike.'.$field,
- method => 'search_one_field',
- api_level => 1,
- cdbi => $cdbi,
- cachable => 1,
- stream => 1,
- argc => 1,
- );
- }
- }
-
-=cut
-
- }
-
-
- unless ($fmclass->is_readonly) {
- # Create the create method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.create' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.create',
- method => 'create_node',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the batch create method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.create' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.batch.create',
- method => 'batch_call',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the update method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.update' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.update',
- method => 'update_node',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the batch update method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.update' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.batch.update',
- method => 'batch_call',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the delete method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.delete' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.delete',
- method => 'delete_node',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the batch delete method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.delete' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.batch.delete',
- method => 'batch_call',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the merge method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.merge' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.merge',
- method => 'merge_node',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the batch merge method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.merge' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.batch.merge',
- method => 'batch_call',
- unwrap => 1,
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the remote_update method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.remote_update' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.remote_update',
- method => 'remote_update_node',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the batch remote_update method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.remote_update' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.batch.remote_update',
- method => 'batch_call',
- api_level => 1,
- unwrap => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
-
- # Create the search-based mass delete method
- unless ( __PACKAGE__->is_registered( $api_prefix.'.mass_delete' ) ) {
- __PACKAGE__->register_method(
- api_name => $api_prefix.'.mass_delete',
- method => 'mass_delete',
- api_level => 1,
- cdbi => $cdbi,
- argc => 1,
- );
- }
- }
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::action;
-use parent qw/OpenILS::Application::Storage::Publisher/;
-use strict;
-use warnings;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::JSON;
-use OpenSRF::AppSession;
-use OpenSRF::EX qw/:try/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::PermitHold;
-use DateTime;
-use DateTime::Format::ISO8601;
-use OpenILS::Utils::Penalty;
-
-sub isTrue {
- my $v = shift;
- return 1 if ($v == 1);
- return 1 if ($v =~ /^t/io);
- return 1 if ($v =~ /^y/io);
- return 0;
-}
-
-my $parser = DateTime::Format::ISO8601->new;
-my $log = 'OpenSRF::Utils::Logger';
-
-sub open_noncat_circs {
- my $self = shift;
- my $client = shift;
- my $user = shift;
-
- my $a = action::non_cataloged_circulation->table;
- my $c = config::non_cataloged_type->table;
-
- my $sql = <<" SQL";
- SELECT a.id
- FROM $a a
- JOIN $c c ON (a.item_type = c.id)
- WHERE a.circ_time + c.circ_duration > current_timestamp
- AND a.patron = ?
- SQL
-
- return action::non_cataloged_circulation->db_Main->selectcol_arrayref($sql, {}, $user);
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.open_non_cataloged_circulation.user',
- method => 'open_noncat_circs',
- api_level => 1,
- argc => 1,
-);
-
-
-sub ou_hold_requests {
- my $self = shift;
- my $client = shift;
- my $ou = shift;
-
- my $h_table = action::hold_request->table;
- my $c_table = asset::copy->table;
- my $o_table = actor::org_unit->table;
-
- my $SQL = <<" SQL";
- SELECT h.id
- FROM $h_table h
- JOIN $c_table cp ON (cp.id = h.current_copy)
- JOIN $o_table ou ON (ou.id = cp.circ_lib)
- WHERE ou.id = ?
- AND h.capture_time IS NULL
- AND h.cancel_time IS NULL
- AND (h.expire_time IS NULL OR h.expire_time > NOW())
- ORDER BY h.request_time
- SQL
-
- my $sth = action::hold_request->db_Main->prepare_cached($SQL);
- $sth->execute($ou);
-
- $client->respond($_) for (
- map {
- $self
- ->method_lookup('open-ils.storage.direct.action.hold_request.retrieve')
- ->run($_)
- } map {
- $_->[0]
- } @{ $sth->fetchall_arrayref }
- );
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.targeted_hold_request.org_unit',
- api_level => 1,
- argc => 1,
- stream => 1,
- method => 'ou_hold_requests',
-);
-
-
-sub overdue_circs {
- my $grace = shift;
- my $upper_interval = shift || '1 millennium';
- my $idlist = shift;
-
- my $c_t = action::circulation->table;
-
- if ($grace && $grace =~ /^\d+$/o) {
- $grace = " - ($grace * (fine_interval))";
- } else {
- $grace = '';
- }
-
- my $sql = <<" SQL";
- SELECT *
- FROM $c_t
- WHERE stop_fines IS NULL
- AND due_date < ( CURRENT_TIMESTAMP $grace)
- AND fine_interval < ?::INTERVAL
- SQL
-
- my $sth = action::circulation->db_Main->prepare_cached($sql);
- $sth->execute($upper_interval);
-
- my @circs = map { $idlist ? $_->{id} : action::circulation->construct($_) } $sth->fetchall_hash;
-
- $c_t = booking::reservation->table;
- $sql = <<" SQL";
- SELECT *
- FROM $c_t
- WHERE return_time IS NULL
- AND end_time < ( CURRENT_TIMESTAMP $grace)
- AND fine_interval IS NOT NULL
- AND cancel_time IS NULL
- SQL
-
- $sth = action::circulation->db_Main->prepare_cached($sql);
- $sth->execute();
-
- push @circs, map { $idlist ? $_->{id} : booking::reservation->construct($_) } $sth->fetchall_hash;
-
- return @circs;
-}
-
-sub complete_reshelving {
- my $self = shift;
- my $client = shift;
- my $window = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- throw OpenSRF::EX::InvalidArg ("I need an interval of more than 0 seconds!")
- unless (interval_to_seconds( $window ));
-
- my $setting = actor::org_unit_setting->table;
- my $circ = action::circulation->table;
- my $cp = asset::copy->table;
- my $atc = action::transit_copy->table;
-
- my $sql = <<" SQL";
- UPDATE $cp
- SET status = 0
- WHERE id IN (
- SELECT id
- FROM (SELECT cp.id, MAX(circ.checkin_time), MAX(trans.dest_recv_time)
- FROM $cp cp
- JOIN $circ circ ON (circ.target_copy = cp.id)
- LEFT JOIN $atc trans ON (trans.target_copy = cp.id)
- LEFT JOIN $setting setting
- ON (cp.circ_lib = setting.org_unit AND setting.name = 'circ.reshelving_complete.interval')
- WHERE circ.checkin_time IS NOT NULL
- AND cp.status = 7
- GROUP BY 1
- HAVING (
- ( ( MAX(circ.checkin_time) > MAX(trans.dest_recv_time) or MAX(trans.dest_recv_time) IS NULL )
- AND MAX(circ.checkin_time) < NOW() - CAST( COALESCE( BTRIM( FIRST(setting.value),'"' ), ? ) AS INTERVAL) )
- OR
- ( MAX(trans.dest_recv_time) > MAX(circ.checkin_time)
- AND MAX(trans.dest_recv_time) < NOW() - CAST( COALESCE( BTRIM( FIRST(setting.value),'"' ), ? ) AS INTERVAL) )
- )
- ) AS foo
- UNION ALL
- SELECT cp.id
- FROM $cp cp
- LEFT JOIN $setting setting
- ON (cp.circ_lib = setting.org_unit AND setting.name = 'circ.reshelving_complete.interval')
- LEFT JOIN $circ circ ON (circ.target_copy = cp.id)
- WHERE cp.status = 7
- AND circ.id IS NULL
- AND cp.create_date < NOW() - CAST( COALESCE( BTRIM( setting.value,'"' ), ? ) AS INTERVAL)
- )
- SQL
- my $sth = action::circulation->db_Main->prepare_cached($sql);
- $sth->execute($window, $window, $window);
-
- return $sth->rows;
-
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.circulation.reshelving.complete',
- api_level => 1,
- argc => 1,
- method => 'complete_reshelving',
-);
-
-sub mark_longoverdue {
- my $self = shift;
- my $client = shift;
- my $window = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- throw OpenSRF::EX::InvalidArg ("I need an interval of more than 0 seconds!")
- unless (interval_to_seconds( $window ));
-
- my $setting = actor::org_unit_setting->table;
- my $circ = action::circulation->table;
-
- my $sql = <<" SQL";
- UPDATE $circ
- SET stop_fines = 'LONGOVERDUE',
- stop_fines_time = now()
- WHERE id IN (
- SELECT circ.id
- FROM $circ circ
- LEFT JOIN $setting setting
- ON (circ.circ_lib = setting.org_unit AND setting.name = 'circ.long_overdue.interval')
- WHERE circ.checkin_time IS NULL AND (stop_fines IS NULL OR stop_fines NOT IN ('LOST','LONGOVERDUE'))
- AND AGE(circ.due_date) > CAST( COALESCE( BTRIM( setting.value,'"' ), ? ) AS INTERVAL)
- )
- SQL
-
- my $sth = action::circulation->db_Main->prepare_cached($sql);
- $sth->execute($window);
-
- return $sth->rows;
-
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.circulation.long_overdue',
- api_level => 1,
- argc => 1,
- method => 'mark_longoverdue',
-);
-
-sub auto_thaw_frozen_holds {
- my $self = shift;
- my $client = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $holds = action::hold_request->table;
-
- my $sql = "UPDATE $holds SET frozen = FALSE WHERE frozen IS TRUE AND thaw_date < NOW();";
-
- my $sth = action::hold_request->db_Main->prepare_cached($sql);
- $sth->execute();
-
- return $sth->rows;
-
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.hold_request.thaw_expired_frozen',
- api_level => 1,
- stream => 0,
- argc => 0,
- method => 'auto_thaw_frozen_holds',
-);
-
-sub grab_overdue {
- my $self = shift;
- my $client = shift;
- my $grace = shift || '';
-
- my $idlist = $self->api_name =~/id_list/o ? 1 : 0;
-
- $client->respond( $idlist ? $_ : $_->to_fieldmapper ) for ( overdue_circs($grace, '', $idlist) );
-
- return undef;
-
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.circulation.overdue',
- api_level => 1,
- stream => 1,
- method => 'grab_overdue',
- signature => q/
- Return list of overdue circulations and reservations to be used for fine generation.
- Despite the name, this is not a generic method for retrieving all overdue loans,
- as it excludes loans that have already hit the maximum fine limit.
-/,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.circulation.overdue.id_list',
- api_level => 1,
- stream => 1,
- method => 'grab_overdue',
-);
-
-sub nearest_hold {
- my $self = shift;
- my $client = shift;
- my $here = shift;
- my $cp = shift;
- my $limit = int(shift()) || 10;
- my $age = shift() || '0 seconds';
- my $fifo = shift();
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $holdsort = isTrue($fifo) ?
- "pgt.hold_priority, CASE WHEN h.cut_in_line IS TRUE THEN 0 ELSE 1 END, h.request_time, h.selection_depth DESC, p.prox " :
- "p.prox, pgt.hold_priority, CASE WHEN h.cut_in_line IS TRUE THEN 0 ELSE 1 END, h.selection_depth DESC, h.request_time ";
-
- my $ids = action::hold_request->db_Main->selectcol_arrayref(<<" SQL", {}, $here, $cp, $age);
- SELECT h.id
- FROM action.hold_request h
- JOIN actor.org_unit_proximity p ON (p.from_org = ? AND p.to_org = h.pickup_lib)
- JOIN action.hold_copy_map hm ON (hm.hold = h.id)
- JOIN actor.usr au ON (au.id = h.usr)
- JOIN permission.grp_tree pgt ON (au.profile = pgt.id)
- WHERE hm.target_copy = ?
- AND (AGE(NOW(),h.request_time) >= CAST(? AS INTERVAL) OR p.prox = 0)
- AND h.capture_time IS NULL
- AND h.cancel_time IS NULL
- AND (h.expire_time IS NULL OR h.expire_time > NOW())
- AND h.frozen IS FALSE
- ORDER BY $holdsort
- LIMIT $limit
- SQL
-
- $client->respond( $_ ) for ( @$ids );
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.hold_request.nearest_hold',
- api_level => 1,
- stream => 1,
- method => 'nearest_hold',
-);
-
-sub targetable_holds {
- my $self = shift;
- my $client = shift;
- my $check_expire = shift;
-
- $check_expire ||= '12h';
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- # json_query can *almost* represent this query, but can't
- # handle the CASE statement or the interval arithmetic
- my $query = <<" SQL";
- SELECT ahr.id, mmsm.metarecord
- FROM action.hold_request ahr
- JOIN reporter.hold_request_record USING (id)
- JOIN metabib.metarecord_source_map mmsm ON (bib_record = source)
- WHERE capture_time IS NULL
- AND (prev_check_time IS NULL or prev_check_time < (NOW() - ?::interval))
- AND fulfillment_time IS NULL
- AND cancel_time IS NULL
- AND NOT frozen
- ORDER BY CASE WHEN ahr.hold_type = 'F' THEN 0 ELSE 1 END, selection_depth DESC, request_time;
- SQL
- my $sth = action::hold_request->db_Main->prepare_cached($query);
- $sth->execute($check_expire);
-
- $client->respond( $_ ) for ( $sth->fetchall_arrayref );
- return undef;
-}
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.hold_request.targetable_holds.id_list',
- api_level => 1,
- stream => 1,
- method => 'targetable_holds',
- signature => q/
- Returns ordered list of hold request and metarecord IDs
- for all hold requests that are available for initial targeting
- or retargeting.
- @param check interval
- @return list of pairs of hold request and metarecord IDs
-/,
-);
-
-sub next_resp_group_id {
- my $self = shift;
- my $client = shift;
-
- # XXX This is not replication safe!!!
-
- my ($id) = action::survey->db_Main->selectrow_array(<<" SQL");
- SELECT NEXTVAL('action.survey_response_group_id_seq'::TEXT)
- SQL
- return $id;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.survey_response.next_group_id',
- api_level => 1,
- method => 'next_resp_group_id',
-);
-
-sub patron_circ_summary {
- my $self = shift;
- my $client = shift;
- my $id = ''.shift();
-
- return undef unless ($id);
- my $c_table = action::circulation->table;
- my $b_table = money::billing->table;
-
- $log->debug("Retrieving patron summary for id $id", DEBUG);
-
- my $select = <<" SQL";
- SELECT COUNT(DISTINCT c.id), SUM( COALESCE(b.amount,0) )
- FROM $c_table c
- LEFT OUTER JOIN $b_table b ON (c.id = b.xact AND b.voided = FALSE)
- WHERE c.usr = ?
- AND c.xact_finish IS NULL
- AND (
- c.stop_fines NOT IN ('CLAIMSRETURNED','LOST')
- OR c.stop_fines IS NULL
- )
- SQL
-
- return action::survey->db_Main->selectrow_arrayref($select, {}, $id);
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.circulation.patron_summary',
- api_level => 1,
- method => 'patron_circ_summary',
-);
-
-#XXX Fix stored proc calls
-sub find_local_surveys {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = action::survey->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
- SQL
-
- my $sth = action::survey->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.survey.all',
- api_level => 1,
- stream => 1,
- method => 'find_local_surveys',
-);
-
-#XXX Fix stored proc calls
-sub find_opac_surveys {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = action::survey->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
- AND s.opac IS TRUE;
- SQL
-
- my $sth = action::survey->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.survey.opac',
- api_level => 1,
- stream => 1,
- method => 'find_opac_surveys',
-);
-
-sub hold_pull_list {
- my $self = shift;
- my $client = shift;
- my $ou = shift;
- my $limit = shift || 10;
- my $offset = shift || 0;
-
- return undef unless ($ou);
- my $h_table = action::hold_request->table;
- my $a_table = asset::copy->table;
- my $ord_table = asset::copy_location_order->table;
-
- my $idlist = 1 if ($self->api_name =~/id_list/o);
- my $count = 1 if ($self->api_name =~/count$/o);
-
- my $status_filter = '';
- $status_filter = 'AND a.status IN (0,7)' if ($self->api_name =~/status_filtered/o);
-
- my $select = <<" SQL";
- SELECT h.*
- FROM $h_table h
- JOIN $a_table a ON (h.current_copy = a.id)
- LEFT JOIN $ord_table ord ON (a.location = ord.location AND a.circ_lib = ord.org)
- WHERE a.circ_lib = ?
- AND h.capture_time IS NULL
- AND h.cancel_time IS NULL
- AND (h.expire_time IS NULL OR h.expire_time > NOW())
- $status_filter
- ORDER BY CASE WHEN ord.position IS NOT NULL THEN ord.position ELSE 999 END, h.request_time
- LIMIT $limit
- OFFSET $offset
- SQL
-
- if ($count) {
- $select = <<" SQL";
- SELECT count(*)
- FROM $h_table h
- JOIN $a_table a ON (h.current_copy = a.id)
- WHERE a.circ_lib = ?
- AND h.capture_time IS NULL
- AND h.cancel_time IS NULL
- AND (h.expire_time IS NULL OR h.expire_time > NOW())
- $status_filter
- SQL
- }
-
- my $sth = action::survey->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- if ($count) {
- $client->respond( $sth->fetchall_arrayref()->[0][0] );
- } elsif ($idlist) {
- $client->respond( $_->{id} ) for ( $sth->fetchall_hash );
- } else {
- $client->respond( $_->to_fieldmapper ) for ( map { action::hold_request->construct($_) } $sth->fetchall_hash );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.action.hold_request.pull_list.current_copy_circ_lib.count',
- api_level => 1,
- stream => 1,
- signature => [
- "Returns a count of holds for a specific library's pull list.",
- [ [org_unit => "The library's org id", "number"] ],
- ['A count of holds for the stated library to pull ', 'number']
- ],
- method => 'hold_pull_list',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.action.hold_request.pull_list.current_copy_circ_lib.status_filtered.count',
- api_level => 1,
- stream => 1,
- signature => [
- "Returns a status filtered count of holds for a specific library's pull list.",
- [ [org_unit => "The library's org id", "number"] ],
- ['A status filtered count of holds for the stated library to pull ', 'number']
- ],
- method => 'hold_pull_list',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib',
- api_level => 1,
- stream => 1,
- signature => [
- "Returns the hold ids for a specific library's pull list.",
- [ [org_unit => "The library's org id", "number"],
- [limit => 'An optional page size, defaults to 10', 'number'],
- [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
- ],
- ['A list of holds for the stated library to pull for', 'array']
- ],
- method => 'hold_pull_list',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.action.hold_request.pull_list.search.current_copy_circ_lib',
- api_level => 1,
- stream => 1,
- signature => [
- "Returns the holds for a specific library's pull list.",
- [ [org_unit => "The library's org id", "number"],
- [limit => 'An optional page size, defaults to 10', 'number'],
- [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
- ],
- ['A list of holds for the stated library to pull for', 'array']
- ],
- method => 'hold_pull_list',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib.status_filtered',
- api_level => 1,
- stream => 1,
- signature => [
- "Returns the hold ids for a specific library's pull list that are definitely in that library, based on status.",
- [ [org_unit => "The library's org id", "number"],
- [limit => 'An optional page size, defaults to 10', 'number'],
- [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
- ],
- ['A list of holds for the stated library to pull for', 'array']
- ],
- method => 'hold_pull_list',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.action.hold_request.pull_list.search.current_copy_circ_lib.status_filtered',
- api_level => 1,
- stream => 1,
- signature => [
- "Returns the holds for a specific library's pull list that are definitely in that library, based on status.",
- [ [org_unit => "The library's org id", "number"],
- [limit => 'An optional page size, defaults to 10', 'number'],
- [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
- ],
- ['A list of holds for the stated library to pull for', 'array']
- ],
- method => 'hold_pull_list',
-);
-
-sub find_optional_surveys {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = action::survey->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
- AND s.required IS FALSE;
- SQL
-
- my $sth = action::survey->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.survey.optional',
- api_level => 1,
- stream => 1,
- method => 'find_optional_surveys',
-);
-
-sub find_required_surveys {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = action::survey->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
- AND s.required IS TRUE;
- SQL
-
- my $sth = action::survey->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.survey.required',
- api_level => 1,
- stream => 1,
- method => 'find_required_surveys',
-);
-
-sub find_usr_summary_surveys {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = action::survey->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
- AND s.usr_summary IS TRUE;
- SQL
-
- my $sth = action::survey->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.survey.usr_summary',
- api_level => 1,
- stream => 1,
- method => 'find_usr_summary_surveys',
-);
-
-sub seconds_to_interval_hash {
- my $interval = shift;
- my $limit = shift || 's';
- $limit =~ s/^(.)/$1/o;
-
- my %output;
-
- my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s);
- my ($year, $month, $week, $day, $hour, $minute, $second) =
- ('years','months','weeks','days', 'hours', 'minutes', 'seconds');
-
- if ($y = int($interval / (60 * 60 * 24 * 365))) {
- $output{$year} = $y;
- $ym = $interval % (60 * 60 * 24 * 365);
- } else {
- $ym = $interval;
- }
- return %output if ($limit eq 'y');
-
- if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
- $output{$month} = $M;
- $Mm = $ym % ((60 * 60 * 24 * 365)/12);
- } else {
- $Mm = $ym;
- }
- return %output if ($limit eq 'M');
-
- if ($w = int($Mm / 604800)) {
- $output{$week} = $w;
- $wm = $Mm % 604800;
- } else {
- $wm = $Mm;
- }
- return %output if ($limit eq 'w');
-
- if ($d = int($wm / 86400)) {
- $output{$day} = $d;
- $dm = $wm % 86400;
- } else {
- $dm = $wm;
- }
- return %output if ($limit eq 'd');
-
- if ($h = int($dm / 3600)) {
- $output{$hour} = $h;
- $hm = $dm % 3600;
- } else {
- $hm = $dm;
- }
- return %output if ($limit eq 'h');
-
- if ($m = int($hm / 60)) {
- $output{$minute} = $m;
- $mm = $hm % 60;
- } else {
- $mm = $hm;
- }
- return %output if ($limit eq 'm');
-
- if ($s = int($mm)) {
- $output{$second} = $s;
- } else {
- $output{$second} = 0 unless (keys %output);
- }
- return %output;
-}
-
-
-sub generate_fines {
- my $self = shift;
- my $client = shift;
- my $grace = shift;
- my $circ = shift;
- my $overbill = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my @circs;
- if ($circ) {
- push @circs,
- action::circulation->search_where( { id => $circ, stop_fines => undef } ),
- booking::reservation->search_where( { id => $circ, return_time => undef, cancel_time => undef } );
- } else {
- push @circs, overdue_circs($grace);
- }
-
- my %hoo = map { ( $_->id => $_ ) } actor::org_unit::hours_of_operation->retrieve_all;
-
- my $penalty = OpenSRF::AppSession->create('open-ils.penalty');
- for my $c (@circs) {
-
- my $ctype = ref($c);
- $ctype =~ s/^.+::(\w+)$/$1/;
-
- my $due_date_method = 'due_date';
- my $target_copy_method = 'target_copy';
- my $circ_lib_method = 'circ_lib';
- my $recurring_fine_method = 'recurring_fine';
- my $is_reservation = 0;
- if ($ctype eq 'reservation') {
- $is_reservation = 1;
- $due_date_method = 'end_time';
- $target_copy_method = 'current_resource';
- $circ_lib_method = 'pickup_lib';
- $recurring_fine_method = 'fine_amount';
- next unless ($c->fine_interval);
- }
-
- try {
- if ($self->method_lookup('open-ils.storage.transaction.current')->run) {
- $log->debug("Cleaning up after previous transaction\n");
- $self->method_lookup('open-ils.storage.transaction.rollback')->run;
- }
- $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
- $log->info(
- sprintf("Processing %s %d...",
- ($is_reservation ? "reservation" : "circ"), $c->id
- )
- );
-
-
- my $due_dt = $parser->parse_datetime( cleanse_ISO8601( $c->$due_date_method ) );
-
- my $due = $due_dt->epoch;
- my $now = time;
-
- my $fine_interval = $c->fine_interval;
- $fine_interval =~ s/(\d{2}):(\d{2}):(\d{2})/$1 h $2 m $3 s/o;
- $fine_interval = interval_to_seconds( $fine_interval );
-
- if ( $is_reservation and $fine_interval >= interval_to_seconds('1d') ) {
- my $tz_offset_s = 0;
- if ($due_dt->strftime('%z') =~ /(-|\+)(\d{2}):?(\d{2})/) {
- $tz_offset_s = $1 . interval_to_seconds( "${2}h ${3}m");
- }
-
- $due -= ($due % $fine_interval) + $tz_offset_s;
- $now -= ($now % $fine_interval) + $tz_offset_s;
- }
-
- $client->respond(
- "ARG! Overdue $ctype ".$c->id.
- " for item ".$c->$target_copy_method.
- " (user ".$c->usr.").\n".
- "\tItem was due on or before: ".localtime($due)."\n");
-
- my @fines = money::billing->search_where(
- { xact => $c->id,
- btype => 1,
- billing_ts => { '>' => $c->$due_date_method } },
- { order_by => 'billing_ts DESC'}
- );
-
- my $f_idx = 0;
- my $fine = $fines[$f_idx] if (@fines);
- if ($overbill) {
- $fine = $fines[++$f_idx] while ($fine and $fine->voided);
- }
-
- my $current_fine_total = 0;
- $current_fine_total += int($_->amount * 100) for (grep { $_ and !$_->voided } @fines);
-
- my $last_fine;
- if ($fine) {
- $client->respond( "Last billing time: ".$fine->billing_ts." (clensed format: ".cleanse_ISO8601( $fine->billing_ts ).")");
- $last_fine = $parser->parse_datetime( cleanse_ISO8601( $fine->billing_ts ) )->epoch;
- } else {
- $log->info( "Potential first billing for circ ".$c->id );
- $last_fine = $due;
-
- if (0) {
- if (my $h = $hoo{$c->$circ_lib_method}) {
-
- $log->info( "Circ lib has an hours-of-operation entry" );
- # find the day after the due date...
- $due_dt = $due_dt->add( days => 1 );
-
- # get the day of the week for that day...
- my $dow = $due_dt->day_of_week_0;
- my $dow_open = "dow_${dow}_open";
- my $dow_close = "dow_${dow}_close";
-
- my $count = 0;
- while ( $h->$dow_open eq '00:00:00' and $h->$dow_close eq '00:00:00' ) {
- # if the circ lib is closed, add a day to the grace period...
-
- $grace++;
- $log->info( "Grace period for circ ".$c->id." extended to $grace intervals" );
- $log->info( "Day of week $dow open $dow_open, close $dow_close" );
-
- $due_dt = $due_dt->add( days => 1 );
- $dow = $due_dt->day_of_week_0;
- $dow_open = "dow_${dow}_open";
- $dow_close = "dow_${dow}_close";
-
- $count++;
-
- # and check for up to a week
- last if ($count > 6);
- }
- }
- }
- }
-
- next if ($last_fine > $now);
- my $pending_fine_count = int( ($now - $last_fine) / $fine_interval );
-
- # Generate fines for the interval we are currently inside, when the fine interval is some multiple of 1d
- $pending_fine_count++ if ($fine_interval && ($fine_interval % 86400 == 0));
-
- if ( $last_fine == $due # we have no fines yet
- && $grace # and we have a grace period
- && $pending_fine_count <= $grace # and we seem to be inside that period
- && $now < $due + $fine_interval * $grace # and some date math bares that out, then
- ) {
- $client->respond( "Still inside grace period of: ". seconds_to_interval( $fine_interval * $grace)."\n" );
- $log->info( "Circ ".$c->id." is still inside grace period of: $grace [". seconds_to_interval( $fine_interval * $grace).']' );
- next;
- }
-
- $client->respond( "\t$pending_fine_count pending fine(s)\n" );
- next unless ($pending_fine_count);
-
- my $recurring_fine = int($c->$recurring_fine_method * 100);
- my $max_fine = int($c->max_fine * 100);
-
- my ($latest_billing_ts, $latest_amount) = ('',0);
- for (my $bill = 1; $bill <= $pending_fine_count; $bill++) {
-
- if ($current_fine_total >= $max_fine) {
- $c->update({stop_fines => 'MAXFINES', stop_fines_time => 'now'}) if ($ctype eq 'circulation');
- $client->respond(
- "\tMaximum fine level of ".$c->max_fine.
- " reached for this $ctype.\n".
- "\tNo more fines will be generated.\n" );
- last;
- }
-
- # XXX Use org time zone (or default to 'local') once we have the ou setting built for that
- my $billing_ts = DateTime->from_epoch( epoch => $last_fine, time_zone => 'local' );
- my $current_bill_count = $bill;
- while ( $current_bill_count ) {
- $billing_ts->add( seconds_to_interval_hash( $fine_interval ) );
- $current_bill_count--;
- }
-
- my $dow = $billing_ts->day_of_week_0();
- my $dow_open = "dow_${dow}_open";
- my $dow_close = "dow_${dow}_close";
-
- if (my $h = $hoo{$c->$circ_lib_method}) {
- next if ( $h->$dow_open eq '00:00:00' and $h->$dow_close eq '00:00:00');
- }
-
- my $timestamptz = $billing_ts->strftime('%FT%T%z');
- my @cl = actor::org_unit::closed_date->search_where(
- { close_start => { '<=' => $timestamptz },
- close_end => { '>=' => $timestamptz },
- org_unit => $c->$circ_lib_method }
- );
- next if (@cl);
-
- $current_fine_total += $recurring_fine;
- $latest_amount += $recurring_fine;
- $latest_billing_ts = $timestamptz;
-
- money::billing->create(
- { xact => ''.$c->id,
- note => "System Generated Overdue Fine",
- billing_type => "Overdue materials",
- btype => 1,
- amount => sprintf('%0.2f', $recurring_fine/100),
- billing_ts => $timestamptz,
- }
- );
-
- }
-
- $client->respond( "\t\tAdding fines totaling $latest_amount for overdue up to $latest_billing_ts\n" )
- if ($latest_billing_ts and $latest_amount);
-
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
-
- if(1) {
-
- # Caluclate penalties inline
- OpenILS::Utils::Penalty->calculate_penalties(
- undef, $c->usr->to_fieldmapper->id.'', $c->$circ_lib_method->to_fieldmapper->id.'');
-
- } else {
-
- # Calculate penalties with an aysnc call to the penalty server. This approach
- # may lead to duplicate penalties since multiple penalty processes for a
- # given user may be running at the same time. Leave this here for reference
- # in case we later find that asyc calls are needed in some environments.
- $penalty->request(
- 'open-ils.penalty.patron_penalty.calculate',
- { patronid => ''.$c->usr,
- context_org => ''.$c->$circ_lib_method,
- update => 1,
- background => 1,
- }
- )->gather(1);
- }
-
- } catch Error with {
- my $e = shift;
- $client->respond( "Error processing overdue $ctype [".$c->id."]:\n\n$e\n" );
- $log->error("Error processing overdue $ctype [".$c->id."]:\n$e\n");
- $self->method_lookup('open-ils.storage.transaction.rollback')->run;
- throw $e if ($e =~ /IS NOT CONNECTED TO THE NETWORK/o);
- };
- }
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.circulation.overdue.generate_fines',
- api_level => 1,
- stream => 1,
- method => 'generate_fines',
-);
-
-
-
-sub new_hold_copy_targeter {
- my $self = shift;
- my $client = shift;
- my $check_expire = shift;
- my $one_hold = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- $self->{target_weight} = {};
- $self->{max_loops} = {};
-
- my $holds;
-
- try {
- if ($one_hold) {
- $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
- $holds = [ action::hold_request->search_where( { id => $one_hold, fulfillment_time => undef, cancel_time => undef } ) ];
- } elsif ( $check_expire ) {
-
- # what's the retarget time threashold?
- my $time = time;
- $check_expire ||= '12h';
- $check_expire = interval_to_seconds( $check_expire );
-
- my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time() - $check_expire);
- $year += 1900;
- $mon += 1;
- my $expire_threshold = sprintf(
- '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d-00',
- $year, $mon, $mday, $hour, $min, $sec
- );
-
- # find all the holds holds needing retargeting
- $holds = [ action::hold_request->search_where(
- { capture_time => undef,
- fulfillment_time => undef,
- cancel_time => undef,
- frozen => 'f',
- prev_check_time => { '<=' => $expire_threshold },
- },
- { order_by => 'CASE WHEN hold_type = \'F\' THEN 0 ELSE 1 END, selection_depth DESC, request_time,prev_check_time' } ) ];
-
- # find all the holds holds needing first time targeting
- push @$holds, action::hold_request->search(
- capture_time => undef,
- fulfillment_time => undef,
- prev_check_time => undef,
- frozen => 'f',
- cancel_time => undef,
- { order_by => 'CASE WHEN hold_type = \'F\' THEN 0 ELSE 1 END, selection_depth DESC, request_time' } );
- } else {
-
- # find all the holds holds needing first time targeting ONLY
- $holds = [ action::hold_request->search(
- capture_time => undef,
- fulfillment_time => undef,
- prev_check_time => undef,
- cancel_time => undef,
- frozen => 'f',
- { order_by => 'CASE WHEN hold_type = \'F\' THEN 0 ELSE 1 END, selection_depth DESC, request_time' } ) ];
- }
- } catch Error with {
- my $e = shift;
- die "Could not retrieve uncaptured hold requests:\n\n$e\n";
- };
-
- my @closed = actor::org_unit::closed_date->search_where(
- { close_start => { '<=', 'now' },
- close_end => { '>=', 'now' } }
- );
-
- if ($check_expire) {
-
- # $check_expire, if it exists, was already converted to seconds
- my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time() + $check_expire);
- $year += 1900;
- $mon += 1;
-
- my $next_check_time = sprintf(
- '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d-00',
- $year, $mon, $mday, $hour, $min, $sec
- );
-
-
- my @closed_at_next = actor::org_unit::closed_date->search_where(
- { close_start => { '<=', $next_check_time },
- close_end => { '>=', $next_check_time } }
- );
-
- my @new_closed;
- for my $c_at_n (@closed_at_next) {
- if (grep { ''.$_->org_unit eq ''.$c_at_n->org_unit } @closed) {
- push @new_closed, $c_at_n;
- }
- }
- @closed = @new_closed;
- }
-
- my @successes;
- my $actor = OpenSRF::AppSession->create('open-ils.actor');
-
- for my $hold (@$holds) {
- try {
- #start a transaction if needed
- if ($self->method_lookup('open-ils.storage.transaction.current')->run) {
- $log->debug("Cleaning up after previous transaction\n");
- $self->method_lookup('open-ils.storage.transaction.rollback')->run;
- }
- $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
- $log->info("Processing hold ".$hold->id."...\n");
-
- #first, re-fetch the hold, to make sure it's not captured already
- $hold->remove_from_object_index();
- $hold = action::hold_request->retrieve( $hold->id );
-
- die "OK\n" if (!$hold or $hold->capture_time or $hold->cancel_time);
-
- # remove old auto-targeting maps
- my @oldmaps = action::hold_copy_map->search( hold => $hold->id );
- $_->delete for (@oldmaps);
-
- if ($hold->expire_time) {
- my $ex_time = $parser->parse_datetime( cleanse_ISO8601( $hold->expire_time ) );
- if ( DateTime->compare($ex_time, DateTime->now) < 0 ) {
-
- # cancel cause = un-targeted expiration
- $hold->update( { cancel_time => 'now', cancel_cause => 1 } );
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
-
- # tell A/T the hold was cancelled
- my $fm_hold = $hold->to_fieldmapper;
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate',
- 'hold_request.cancel.expire_no_target', $fm_hold, $fm_hold->pickup_lib);
-
- die "OK\n";
- }
- }
-
- my $all_copies = [];
-
- # find filters for MR holds
- my ($types, $formats, $lang);
- if (defined($hold->holdable_formats)) {
- ($types, $formats, $lang) = split '-', $hold->holdable_formats;
- }
-
- # find all the potential copies
- if ($hold->hold_type eq 'M') {
- for my $r ( map
- {$_->record}
- metabib::record_descriptor
- ->search(
- record => [
- map {
- isTrue($_->deleted) ? () : ($_->id)
- } metabib::metarecord->retrieve($hold->target)->source_records
- ],
- ( $types ? (item_type => [split '', $types]) : () ),
- ( $formats ? (item_form => [split '', $formats]) : () ),
- ( $lang ? (item_lang => $lang) : () ),
- )
- ) {
- my ($rtree) = $self
- ->method_lookup( 'open-ils.storage.biblio.record_entry.ranged_tree')
- ->run( $r->id, $hold->selection_ou, $hold->selection_depth );
-
- for my $cn ( @{ $rtree->call_numbers } ) {
- push @$all_copies,
- asset::copy->search_where(
- { id => [map {$_->id} @{ $cn->copies }],
- deleted => 'f' }
- ) if ($cn && @{ $cn->copies });
- }
- }
- } elsif ($hold->hold_type eq 'T') {
- my ($rtree) = $self
- ->method_lookup( 'open-ils.storage.biblio.record_entry.ranged_tree')
- ->run( $hold->target, $hold->selection_ou, $hold->selection_depth );
-
- unless ($rtree) {
- push @successes, { hold => $hold->id, eligible_copies => 0, error => 'NO_RECORD' };
- die "OK\n";
- }
-
- for my $cn ( @{ $rtree->call_numbers } ) {
- push @$all_copies,
- asset::copy->search_where(
- { id => [map {$_->id} @{ $cn->copies }],
- deleted => 'f' }
- ) if ($cn && @{ $cn->copies });
- }
- } elsif ($hold->hold_type eq 'V') {
- my ($vtree) = $self
- ->method_lookup( 'open-ils.storage.asset.call_number.ranged_tree')
- ->run( $hold->target, $hold->selection_ou, $hold->selection_depth );
-
- push @$all_copies,
- asset::copy->search_where(
- { id => [map {$_->id} @{ $vtree->copies }],
- deleted => 'f' }
- ) if ($vtree && @{ $vtree->copies });
-
- } elsif ($hold->hold_type eq 'I') {
- my ($itree) = $self
- ->method_lookup( 'open-ils.storage.serial.issuance.ranged_tree')
- ->run( $hold->target, $hold->selection_ou, $hold->selection_depth );
-
- push @$all_copies,
- asset::copy->search_where(
- { id => [map {$_->unit->id} @{ $itree->items }],
- deleted => 'f' }
- ) if ($itree && @{ $itree->items });
-
- } elsif ($hold->hold_type eq 'C' || $hold->hold_type eq 'R' || $hold->hold_type eq 'F') {
- my $_cp = asset::copy->retrieve($hold->target);
- push @$all_copies, $_cp if $_cp;
- }
-
- # trim unholdables
- @$all_copies = grep { isTrue($_->status->holdable) &&
- isTrue($_->location->holdable) &&
- isTrue($_->holdable) &&
- !isTrue($_->deleted) &&
- isTrue($hold->mint_condition) ? isTrue($_->mint_condition) : 1
- } @$all_copies;
-
- # let 'em know we're still working
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- # if we have no copies ...
- if (!ref $all_copies || !@$all_copies) {
- $log->info("\tNo copies available for targeting at all!\n");
- push @successes, { hold => $hold->id, eligible_copies => 0, error => 'NO_COPIES' };
-
- $hold->update( { prev_check_time => 'today', current_copy => undef } );
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
- die "OK\n";
- }
-
- my $copy_count = @$all_copies;
-
- # map the potentials, so that we can pick up checkins
- # XXX Loop-based targeting may require that /only/ copies from this loop should be added to
- # XXX the potentials list. If this is the cased, hold_copy_map creation will move down further.
- $log->debug( "\tMapping ".scalar(@$all_copies)." potential copies for hold ".$hold->id);
- action::hold_copy_map->create( { hold => $hold->id, target_copy => $_->id } ) for (@$all_copies);
-
- #$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- my @good_copies;
- for my $c (@$all_copies) {
- # current target
- next if ($c->id eq $hold->current_copy);
-
- # circ lib is closed
- next if ( grep { ''.$_->org_unit eq ''.$c->circ_lib } @closed );
-
- # target of another hold
- next if (action::hold_request
- ->search_where(
- { current_copy => $c->id,
- fulfillment_time => undef,
- cancel_time => undef,
- }
- )
- );
-
- # we passed all three, keep it
- push @good_copies, $c if ($c);
- #$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
- }
-
- $log->debug("\t".scalar(@good_copies)." (non-current) copies available for targeting...");
-
- my $old_best = $hold->current_copy;
- $hold->update({ current_copy => undef }) if ($old_best);
-
- if (!scalar(@good_copies)) {
- $log->info("\tNo (non-current) copies eligible to fill the hold.");
- if ( $old_best && grep { ''.$old_best->id eq ''.$_->id } @$all_copies ) {
- # the old copy is still available
- $log->debug("\tPushing current_copy back onto the targeting list");
- push @good_copies, $old_best;
- } else {
- # oops, old copy is not available
- $log->debug("\tcurrent_copy is no longer available for targeting... NEXT HOLD, PLEASE!");
- $hold->update( { prev_check_time => 'today' } );
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
- push @successes, { hold => $hold->id, eligible_copies => 0, error => 'NO_TARGETS' };
- die "OK\n";
- }
- }
-
- my $pu_lib = ''.$hold->pickup_lib;
-
- my $prox_list = [];
- $$prox_list[0] =
- [
- grep {
- ''.$_->circ_lib eq $pu_lib &&
- ( $_->status == 0 || $_->status == 7 )
- } @good_copies
- ];
-
- $all_copies = [grep { $_->status == 0 || $_->status == 7 } grep {''.$_->circ_lib ne $pu_lib } @good_copies];
- # $all_copies is now a list of copies not at the pickup library
-
- my $best = choose_nearest_copy($hold, $prox_list);
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- if (!$best) {
- $log->debug("\tNothing at the pickup lib, looking elsewhere among ".scalar(@$all_copies)." copies");
-
- $self->{max_loops}{$pu_lib} = $actor->request(
- 'open-ils.actor.ou_setting.ancestor_default' => $pu_lib => 'circ.holds.max_org_unit_target_loops'
- )->gather(1);
-
- if (defined($self->{max_loops}{$pu_lib})) {
- $self->{max_loops}{$pu_lib} = $self->{max_loops}{$pu_lib}{value};
-
- my %circ_lib_map = map { (''.$_->circ_lib => 1) } @$all_copies;
- my $circ_lib_list = [keys %circ_lib_map];
-
- my $cstore = OpenSRF::AppSession->create('open-ils.cstore');
-
- # Grab the "biggest" loop for this hold so far
- my $current_loop = $cstore->request(
- 'open-ils.cstore.json_query',
- { distinct => 1,
- select => { aufhmxl => ['max'] },
- from => 'aufhmxl',
- where => { hold => $hold->id}
- }
- )->gather(1);
-
- $current_loop = $current_loop->{max} if ($current_loop);
- $current_loop ||= 1;
-
- my $exclude_list = $cstore->request(
- 'open-ils.cstore.json_query.atomic',
- { distinct => 1,
- select => { aufhol => ['circ_lib'] },
- from => 'aufhol',
- where => { hold => $hold->id}
- }
- )->gather(1);
-
- my @keepers;
- if ($exclude_list && @$exclude_list) {
- $exclude_list = [map {$_->{circ_lib}} @$exclude_list];
- # check to see if we've used up every library in the potentials list
- for my $l ( @$circ_lib_list ) {
- my $keep = 1;
- for my $ex ( @$exclude_list ) {
- if ($ex eq $l) {
- $keep = 0;
- last;
- }
- }
- push(@keepers, $l) if ($keep);
- }
- } else {
- @keepers = @$circ_lib_list;
- }
-
- $current_loop++ if (!@keepers);
-
- if ($self->{max_loops}{$pu_lib} && $self->{max_loops}{$pu_lib} >= $current_loop) {
- # We haven't exceeded max_loops yet
- my @keeper_copies;
- for my $cp ( @$all_copies ) {
- push(@keeper_copies, $cp) if ( grep { $_ eq ''.$cp->circ_lib } @keepers );
- }
- $all_copies = [@keeper_copies];
- } else {
- # We have, and should remove potentials and cancel the hold
- my @oldmaps = action::hold_copy_map->search( hold => $hold->id );
- $_->delete for (@oldmaps);
-
- # cancel cause = un-targeted expiration
- $hold->update( { cancel_time => 'now', cancel_cause => 1 } );
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
-
- # tell A/T the hold was cancelled
- my $fm_hold = $hold->to_fieldmapper;
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate',
- 'hold_request.cancel.expire_no_target', $fm_hold, $fm_hold->pickup_lib);
-
- die "OK\n";
- }
- }
-
- $prox_list = create_prox_list( $self, $pu_lib, $all_copies );
-
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- $best = choose_nearest_copy($hold, $prox_list);
- }
-
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
- if ($old_best) {
- # hold wasn't fulfilled, record the fact
-
- $log->info("\tHold was not (but should have been) fulfilled by ".$old_best->id);
- action::unfulfilled_hold_list->create(
- { hold => ''.$hold->id,
- current_copy => ''.$old_best->id,
- circ_lib => ''.$old_best->circ_lib,
- });
- }
-
- if ($best) {
- $hold->update( { current_copy => ''.$best->id, prev_check_time => 'now' } );
- $log->debug("\tUpdating hold [".$hold->id."] with new 'current_copy' [".$best->id."] for hold fulfillment.");
- } elsif (
- $old_best &&
- !action::hold_request
- ->search_where(
- { current_copy => $old_best->id,
- fulfillment_time => undef,
- cancel_time => undef,
- }
- )
- ) {
- $hold->update( { prev_check_time => 'now', current_copy => ''.$old_best->id } );
- $log->debug( "\tRetargeting the previously targeted copy [".$old_best->id."]" );
- } else {
- $hold->update( { prev_check_time => 'now' } );
- $log->info( "\tThere were no targetable copies for the hold" );
- process_recall($actor, $log, $hold, \@good_copies);
- }
-
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
- $log->info("\tProcessing of hold ".$hold->id." complete.");
-
- push @successes,
- { hold => $hold->id,
- old_target => ($old_best ? $old_best->id : undef),
- eligible_copies => $copy_count,
- target => ($best ? $best->id : undef) };
-
- } otherwise {
- my $e = shift;
- if ($e !~ /^OK/o) {
- $log->error("Processing of hold failed: $e");
- $self->method_lookup('open-ils.storage.transaction.rollback')->run;
- throw $e if ($e =~ /IS NOT CONNECTED TO THE NETWORK/o);
- }
- };
- }
-
- return \@successes;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.action.hold_request.copy_targeter',
- api_level => 1,
- method => 'new_hold_copy_targeter',
-);
-
-sub process_recall {
- my ($actor, $log, $hold, $good_copies) = @_;
-
- # Bail early if we don't have required settings to avoid spurious requests
- my ($recall_threshold, $return_interval, $fine_rules);
-
- my $rv = $actor->request(
- 'open-ils.actor.ou_setting.ancestor_default', ''.$hold->pickup_lib, 'circ.holds.recall_threshold'
- )->gather(1);
-
- if (!$rv) {
- $log->info("Recall threshold was not set; bailing out on hold ".$hold->id." processing.");
- return;
- }
- $recall_threshold = $rv->{value};
-
- $rv = $actor->request(
- 'open-ils.actor.ou_setting.ancestor_default', ''.$hold->pickup_lib, 'circ.holds.recall_return_interval'
- )->gather(1);
-
- if (!$rv) {
- $log->info("Recall return interval was not set; bailing out on hold ".$hold->id." processing.");
- return;
- }
- $return_interval = $rv->{value};
-
- $rv = $actor->request(
- 'open-ils.actor.ou_setting.ancestor_default', ''.$hold->pickup_lib, 'circ.holds.recall_fine_rules'
- )->gather(1);
-
- if ($rv) {
- $fine_rules = $rv->{value};
- }
-
- $log->info("Recall threshold: $recall_threshold; return interval: $return_interval");
-
- # We want checked out copies (status = 1) at the hold pickup lib
- my $all_copies = [grep { $_->status == 1 } grep {''.$_->circ_lib eq ''.$hold->pickup_lib } @$good_copies];
-
- my @copy_ids = map { $_->id } @$all_copies;
-
- $log->info("Found " . scalar(@$all_copies) . " eligible checked-out copies for recall");
-
- my $return_date = DateTime->now(time_zone => 'local')->add(seconds => interval_to_seconds($return_interval))->iso8601();
-
- # Iterate over the checked-out copies to find a copy with a
- # loan period longer than the recall threshold:
- my $circs = [ action::circulation->search_where(
- { target_copy => \@copy_ids, checkin_time => undef, duration => { '>' => $recall_threshold } },
- { order_by => 'due_date ASC' }
- )];
-
- # If we have a candidate copy, then:
- if (scalar(@$circs)) {
- my $circ = $circs->[0];
- $log->info("Recalling circ ID : " . $circ->id);
-
- # Give the user a new due date of either a full recall threshold,
- # or the return interval, whichever is further in the future
- my $threshold_date = DateTime::Format::ISO8601->parse_datetime(cleanse_ISO8601($circ->xact_start))->add(seconds => interval_to_seconds($recall_threshold))->iso8601();
- if (DateTime->compare(DateTime::Format::ISO8601->parse_datetime($threshold_date), DateTime::Format::ISO8601->parse_datetime($return_date)) == 1) {
- $return_date = $threshold_date;
- }
-
- my $update_fields = {
- due_date => $return_date,
- renewal_remaining => 0,
- };
-
- # If the OU hasn't defined new fine rules for recalls, keep them
- # as they were
- if ($fine_rules) {
- $log->info("Apply recall fine rules: $fine_rules");
- my $rules = OpenSRF::Utils::JSON->JSON2perl($fine_rules);
- $update_fields->{recurring_fine} = $rules->[0];
- $update_fields->{fine_interval} = $rules->[1];
- $update_fields->{max_fine} = $rules->[2];
- }
-
- # Adjust circ for current user
- $circ->update($update_fields);
-
- # Create trigger event for notifying current user
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'circ.recall.target', $circ->to_fieldmapper(), $circ->circ_lib->id);
- }
-
- $log->info("Processing of hold ".$hold->id." for recall is now complete.");
-}
-
-sub reservation_targeter {
- my $self = shift;
- my $client = shift;
- my $one_reservation = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $reservations;
-
- try {
- if ($one_reservation) {
- $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
- $reservations = [ booking::reservation->search_where( { id => $one_reservation, capture_time => undef, cancel_time => undef } ) ];
- } else {
-
- # find all the reservations needing targeting
- $reservations = [
- booking::reservation->search_where(
- { current_resource => undef,
- cancel_time => undef,
- start_time => { '>' => 'now' }
- },
- { order_by => 'start_time' }
- )
- ];
- }
- } catch Error with {
- my $e = shift;
- die "Could not retrieve reservation requests:\n\n$e\n";
- };
-
- my @successes = ();
- for my $bresv (@$reservations) {
- try {
- #start a transaction if needed
- if ($self->method_lookup('open-ils.storage.transaction.current')->run) {
- $log->debug("Cleaning up after previous transaction\n");
- $self->method_lookup('open-ils.storage.transaction.rollback')->run;
- }
- $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
- $log->info("Processing reservation ".$bresv->id."...\n");
-
- #first, re-fetch the hold, to make sure it's not captured already
- $bresv->remove_from_object_index();
- $bresv = booking::reservation->retrieve( $bresv->id );
-
- die "OK\n" if (!$bresv or $bresv->capture_time or $bresv->cancel_time);
-
- my $end_time = $parser->parse_datetime( cleanse_ISO8601( $bresv->end_time ) );
- if (DateTime->compare($end_time, DateTime->now) < 0) {
-
- # cancel cause = un-targeted expiration
- $bresv->update( { cancel_time => 'now' } );
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
-
- # tell A/T the reservation was cancelled
- my $fm_bresv = $bresv->to_fieldmapper;
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate',
- 'booking.reservation.cancel.expire_no_target', $fm_bresv, $fm_bresv->pickup_lib);
-
- die "OK\n";
- }
-
- my $possible_resources;
-
- # find all the potential resources
- if (!$bresv->target_resource) {
- my $filter = { type => $bresv->target_resource_type };
- my $attr_maps = [ booking::reservation_attr_value_map->search( reservation => $bresv->id) ];
-
- $filter->{attribute_values} = [ map { $_->attr_value } @$attr_maps ] if (@$attr_maps);
-
- $filter->{available} = [$bresv->start_time, $bresv->end_time];
- my $ses = OpenSRF::AppSession->create('open-ils.booking');
- $possible_resources = $ses->request('open-ils.booking.resources.filtered_id_list', undef, $filter)->gather(1);
- } else {
- $possible_resources = $bresv->target_resource;
- }
-
- my $all_resources = [ booking::resource->search( id => $possible_resources ) ];
- @$all_resources = grep { isTrue($_->type->transferable) || $_->owner.'' eq $bresv->pickup_lib.'' } @$all_resources;
-
-
- my @good_resources = ();
- my %conflicts = ();
- for my $res (@$all_resources) {
- unless (isTrue($res->type->catalog_item)) {
- push @good_resources, $res;
- next;
- }
-
- my $copy = [ asset::copy->search( deleted => 'f', barcode => $res->barcode )]->[0];
-
- unless ($copy) {
- push @good_resources, $res;
- next;
- }
-
- if ($copy->status->id == 0 || $copy->status->id == 7) {
- push @good_resources, $res;
- next;
- }
-
- if ($copy->status->id == 1) {
- my $circs = [ action::circulation->search_where(
- {target_copy => $copy->id, checkin_time => undef },
- { order_by => 'id DESC' }
- ) ];
-
- if (@$circs) {
- my $due_date = $circs->[0]->due_date;
- $due_date = $parser->parse_datetime( cleanse_ISO8601( $due_date ) );
- my $start_time = $parser->parse_datetime( cleanse_ISO8601( $bresv->start_time ) );
- if (DateTime->compare($start_time, $due_date) < 0) {
- $conflicts{$res->id} = $circs->[0]->to_fieldmapper;
- next;
- }
-
- push @good_resources, $res;
- }
-
- next;
- }
-
- push @good_resources, $res if (isTrue($copy->status->holdable));
- }
-
- # let 'em know we're still working
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- # if we have no copies ...
- if (!@good_resources) {
- $log->info("\tNo resources available for targeting at all!\n");
- push @successes, { reservation => $bresv->id, eligible_copies => 0, error => 'NO_COPIES', conflicts => \%conflicts };
-
-
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
- die "OK\n";
- }
-
- $log->debug("\t".scalar(@good_resources)." resources available for targeting...");
-
- my $prox_list = [];
- $$prox_list[0] =
- [
- grep {
- $_->owner == $bresv->pickup_lib
- } @good_resources
- ];
-
- $all_resources = [grep {$_->owner != $bresv->pickup_lib } @good_resources];
- # $all_copies is now a list of copies not at the pickup library
-
- my $best = shift @good_resources;
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- if (!$best) {
- $log->debug("\tNothing at the pickup lib, looking elsewhere among ".scalar(@$all_resources)." resources");
-
- $prox_list =
- map { $_->[1] }
- sort { $a->[0] <=> $b->[0] }
- map {
- [ actor::org_unit_proximity->search_where(
- { from_org => $bresv->pickup_lib.'', to_org => $_->owner.'' }
- )->[0]->prox,
- $_
- ]
- } @$all_resources;
-
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- $best = shift @$prox_list
- }
-
- if ($best) {
- $bresv->update( { current_resource => ''.$best->id } );
- $log->debug("\tUpdating reservation [".$bresv->id."] with new 'current_resource' [".$best->id."] for reservation fulfillment.");
- }
-
- $self->method_lookup('open-ils.storage.transaction.commit')->run;
- $log->info("\tProcessing of bresv ".$bresv->id." complete.");
-
- push @successes,
- { reservation => $bresv->id,
- current_resource => ($best ? $best->id : undef) };
-
- } otherwise {
- my $e = shift;
- if ($e !~ /^OK/o) {
- $log->error("Processing of bresv failed: $e");
- $self->method_lookup('open-ils.storage.transaction.rollback')->run;
- throw $e if ($e =~ /IS NOT CONNECTED TO THE NETWORK/o);
- }
- };
- }
-
- return \@successes;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.booking.reservation.resource_targeter',
- api_level => 1,
- method => 'reservation_targeter',
-);
-
-my $locations;
-my $statuses;
-my %cache = (titles => {}, cns => {});
-
-sub copy_hold_capture {
- my $self = shift;
- my $hold = shift;
- my $cps = shift;
-
- if (!defined($cps)) {
- try {
- $cps = [ asset::copy->search( id => $hold->target ) ];
- } catch Error with {
- my $e = shift;
- die "Could not retrieve initial volume list:\n\n$e\n";
- };
- }
-
- my @copies = grep { $_->holdable } @$cps;
-
- for (my $i = 0; $i < @$cps; $i++) {
- next unless $$cps[$i];
-
- my $cn = $cache{cns}{$copies[$i]->call_number};
- my $rec = $cache{titles}{$cn->record};
- $copies[$i] = undef if ($copies[$i] && !grep{ $copies[$i]->status eq $_->id}@$statuses);
- $copies[$i] = undef if ($copies[$i] && !grep{ $copies[$i]->location eq $_->id}@$locations);
- $copies[$i] = undef if (
- !$copies[$i] ||
- !$self->{user_filter}->request(
- 'open-ils.circ.permit_hold',
- $hold->to_fieldmapper, do {
- my $cp_fm = $copies[$i]->to_fieldmapper;
- $cp_fm->circ_lib( $copies[$i]->circ_lib->to_fieldmapper );
- $cp_fm->location( $copies[$i]->location->to_fieldmapper );
- $cp_fm->status( $copies[$i]->status->to_fieldmapper );
- $cp_fm;
- },
- { title => $rec->to_fieldmapper,
- usr => actor::user->retrieve($hold->usr)->to_fieldmapper,
- requestor => actor::user->retrieve($hold->requestor)->to_fieldmapper,
- })->gather(1)
- );
- $self->{client}->status( new OpenSRF::DomainObject::oilsContinueStatus );
- }
-
- @copies = grep { $_ } @copies;
-
- my $count = @copies;
-
- return unless ($count);
-
- action::hold_copy_map->search( hold => $hold->id )->delete_all;
-
- my @maps;
- $self->{client}->respond( "\tMapping ".scalar(@copies)." eligable copies for hold ".$hold->id."\n");
- for my $c (@copies) {
- push @maps, action::hold_copy_map->create( { hold => $hold->id, target_copy => $c->id } );
- }
- $self->{client}->respond( "\tA total of ".scalar(@maps)." mapping were created for hold ".$hold->id."\n");
-
- return \@copies;
-}
-
-
-sub choose_nearest_copy {
- my $hold = shift;
- my $prox_list = shift;
-
- for my $p ( 0 .. int( scalar(@$prox_list) - 1) ) {
- next unless (ref $$prox_list[$p]);
-
- my @capturable = @{ $$prox_list[$p] };
- next unless (@capturable);
-
- my $rand = int(rand(scalar(@capturable)));
- my %seen = ();
- while (my ($c) = splice(@capturable, $rand, 1)) {
- return $c if !exists($seen{$c->id}) && ( OpenILS::Utils::PermitHold::permit_copy_hold(
- { title => $c->call_number->record->to_fieldmapper,
- title_descriptor => $c->call_number->record->record_descriptor->next->to_fieldmapper,
- patron => $hold->usr->to_fieldmapper,
- copy => $c->to_fieldmapper,
- requestor => $hold->requestor->to_fieldmapper,
- request_lib => $hold->request_lib->to_fieldmapper,
- pickup_lib => $hold->pickup_lib->id,
- retarget => 1
- }
- ));
- $seen{$c->id}++;
-
- last unless(@capturable);
- $rand = int(rand(scalar(@capturable)));
- }
- }
-}
-
-sub create_prox_list {
- my $self = shift;
- my $lib = shift;
- my $copies = shift;
-
- my $actor = OpenSRF::AppSession->create('open-ils.actor');
-
- my @prox_list;
- for my $cp (@$copies) {
- my ($prox) = $self->method_lookup('open-ils.storage.asset.copy.proximity')->run( $cp, $lib );
- next unless (defined($prox));
-
- my $copy_circ_lib = ''.$cp->circ_lib;
- # Fetch the weighting value for hold targeting, defaulting to 1
- $self->{target_weight}{$copy_circ_lib} ||= $actor->request(
- 'open-ils.actor.ou_setting.ancestor_default' => $copy_circ_lib.'' => 'circ.holds.org_unit_target_weight'
- )->gather(1);
- $self->{target_weight}{$copy_circ_lib} = $self->{target_weight}{$copy_circ_lib}{value} if (ref $self->{target_weight}{$copy_circ_lib});
- $self->{target_weight}{$copy_circ_lib} ||= 1;
-
- $prox_list[$prox] = [] unless defined($prox_list[$prox]);
- for my $w ( 1 .. $self->{target_weight}{$copy_circ_lib} ) {
- push @{$prox_list[$prox]}, $cp;
- }
- }
- return \@prox_list;
-}
-
-sub volume_hold_capture {
- my $self = shift;
- my $hold = shift;
- my $vols = shift;
-
- if (!defined($vols)) {
- try {
- $vols = [ asset::call_number->search( id => $hold->target ) ];
- $cache{cns}{$_->id} = $_ for (@$vols);
- } catch Error with {
- my $e = shift;
- die "Could not retrieve initial volume list:\n\n$e\n";
- };
- }
-
- my @v_ids = map { $_->id } @$vols;
-
- my $cp_list;
- try {
- $cp_list = [ asset::copy->search( call_number => \@v_ids ) ];
-
- } catch Error with {
- my $e = shift;
- warn "Could not retrieve copy list:\n\n$e\n";
- };
-
- $self->copy_hold_capture($hold,$cp_list) if (ref $cp_list and @$cp_list);
-}
-
-sub title_hold_capture {
- my $self = shift;
- my $hold = shift;
- my $titles = shift;
-
- if (!defined($titles)) {
- try {
- $titles = [ biblio::record_entry->search( id => $hold->target ) ];
- $cache{titles}{$_->id} = $_ for (@$titles);
- } catch Error with {
- my $e = shift;
- die "Could not retrieve initial title list:\n\n$e\n";
- };
- }
-
- my @t_ids = map { $_->id } @$titles;
- my $cn_list;
- try {
- ($cn_list) = $self->method_lookup('open-ils.storage.direct.asset.call_number.search.record.atomic')->run( \@t_ids );
-
- } catch Error with {
- my $e = shift;
- warn "Could not retrieve volume list:\n\n$e\n";
- };
-
- $cache{cns}{$_->id} = $_ for (@$cn_list);
-
- $self->volume_hold_capture($hold,$cn_list) if (ref $cn_list and @$cn_list);
-}
-
-sub metarecord_hold_capture {
- my $self = shift;
- my $hold = shift;
-
- my $titles;
- try {
- $titles = [ metabib::metarecord_source_map->search( metarecord => $hold->target) ];
-
- } catch Error with {
- my $e = shift;
- die "Could not retrieve initial title list:\n\n$e\n";
- };
-
- try {
- my @recs = map {$_->record} metabib::record_descriptor->search( record => $titles, item_type => [split '', $hold->holdable_formats] );
-
- $titles = [ biblio::record_entry->search( id => \@recs ) ];
-
- } catch Error with {
- my $e = shift;
- die "Could not retrieve format-pruned title list:\n\n$e\n";
- };
-
-
- $cache{titles}{$_->id} = $_ for (@$titles);
- $self->title_hold_capture($hold,$titles) if (ref $titles and @$titles);
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::actor;
-use base qw/OpenILS::Application::Storage/;
-use OpenILS::Application::Storage::CDBI::actor;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::Utils qw/:datetime/;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::SettingsClient;
-
-use DateTime;
-use DateTime::Format::ISO8601;
-use DateTime::Set;
-use DateTime::SpanSet;
-
-
-my $_dt_parser = DateTime::Format::ISO8601->new;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub new_usergroup_id {
- return actor::user->db_Main->selectrow_array("select nextval('actor.usr_usrgroup_seq'::regclass)");
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.group_id.new',
- api_level => 1,
- method => 'new_usergroup_id',
-);
-
-sub juv_to_adult {
- my $self = shift;
- my $client = shift;
- my $adult_age = shift;
-
- my $sql = <<" SQL";
- UPDATE actor.usr
- SET juvenile = FALSE
- WHERE AGE(dob) > ?::INTERVAL;
- SQL
-
- my $sth = actor::user->db_Main->prepare_cached($sql);
- $sth->execute($adult_age);
-
- return $sth->rows;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.juvenile_to_adult',
- api_level => 1,
- method => 'juv_to_adult',
-);
-
-sub usr_total_owed {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
-
- my $sql = <<" SQL";
- SELECT x.usr,
- SUM(COALESCE((SELECT SUM(b.amount) FROM money.billing b WHERE b.voided IS FALSE AND b.xact = x.id),0.0)) -
- SUM(COALESCE((SELECT SUM(p.amount) FROM money.payment p WHERE p.voided IS FALSE AND p.xact = x.id),0.0))
- FROM money.billable_xact x
- WHERE x.usr = ? AND x.xact_finish IS NULL
- GROUP BY 1
- SQL
-
- my (undef,$val) = actor::user->db_Main->selectrow_array($sql, {}, $usr);
-
- return $val;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.total_owed',
- api_level => 1,
- method => 'usr_total_owed',
-);
-
-sub usr_breakdown_out {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
-
- $self->method_lookup('open-ils.storage.transaction.begin')->run($client);
-
- my $out_sql = <<" SQL";
- SELECT id
- FROM action.circulation
- WHERE usr = ?
- AND checkin_time IS NULL
- AND ( (fine_interval >= '1 day' AND due_date >= 'today')
- OR (fine_interval < '1 day' AND due_date > 'now' ))
- AND (stop_fines IS NULL
- OR stop_fines NOT IN ('LOST','CLAIMSRETURNED','LONGOVERDUE'))
- SQL
-
- my $out = actor::user->db_Main->selectcol_arrayref($out_sql, {}, $usr);
-
- my $od_sql = <<" SQL";
- SELECT id
- FROM action.circulation
- WHERE usr = ?
- AND checkin_time IS NULL
- AND ( (fine_interval >= '1 day' AND due_date < 'today')
- OR (fine_interval < '1 day' AND due_date < 'now' ))
- AND (stop_fines IS NULL
- OR stop_fines NOT IN ('LOST','CLAIMSRETURNED','LONGOVERDUE'))
- SQL
-
- my $od = actor::user->db_Main->selectcol_arrayref($od_sql, {}, $usr);
-
- my $lost_sql = <<" SQL";
- SELECT id
- FROM action.circulation
- WHERE usr = ? AND checkin_time IS NULL AND xact_finish IS NULL AND stop_fines = 'LOST'
- SQL
-
- my $lost = actor::user->db_Main->selectcol_arrayref($lost_sql, {}, $usr);
-
- my $cl_sql = <<" SQL";
- SELECT id
- FROM action.circulation
- WHERE usr = ? AND checkin_time IS NULL AND stop_fines = 'CLAIMSRETURNED'
- SQL
-
- my $cl = actor::user->db_Main->selectcol_arrayref($cl_sql, {}, $usr);
-
- my $lo_sql = <<" SQL";
- SELECT id
- FROM action.circulation
- WHERE usr = ? AND checkin_time IS NULL AND stop_fines = 'LONGOVERDUE'
- SQL
-
- my $lo = actor::user->db_Main->selectcol_arrayref($lo_sql, {}, $usr);
-
- $self->method_lookup('open-ils.storage.transaction.rollback')->run($client);
-
- if ($self->api_name =~/count$/o) {
- return { total => scalar(@$out) + scalar(@$od) + scalar(@$lost) + scalar(@$cl) + scalar(@$lo),
- out => scalar(@$out),
- overdue => scalar(@$od),
- lost => scalar(@$lost),
- claims_returned => scalar(@$cl),
- long_overdue => scalar(@$lo),
- };
- }
-
- return { out => $out,
- overdue => $od,
- lost => $lost,
- claims_returned => $cl,
- long_overdue => $lo,
- };
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.checked_out',
- api_level => 1,
- method => 'usr_breakdown_out',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.checked_out.count',
- api_level => 1,
- method => 'usr_breakdown_out',
-);
-
-sub usr_total_out {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
-
- my $sql = <<" SQL";
- SELECT count(*)
- FROM action.circulation
- WHERE usr = ? AND checkin_time IS NULL
- SQL
-
- my ($val) = actor::user->db_Main->selectrow_array($sql, {}, $usr);
-
- return $val;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.total_out',
- api_level => 1,
- method => 'usr_total_out',
-);
-
-sub calc_proximity {
- my $self = shift;
- my $client = shift;
-
- local $OpenILS::Application::Storage::WRITE = 1;
-
- my $delete_sql = <<" SQL";
- DELETE FROM actor.org_unit_proximity;
- SQL
-
- my $insert_sql = <<" SQL";
- INSERT INTO actor.org_unit_proximity (from_org, to_org, prox)
- SELECT l.id,
- r.id,
- actor.org_unit_proximity(l.id,r.id)
- FROM actor.org_unit l,
- actor.org_unit r;
- SQL
-
- actor::org_unit_proximity->db_Main->do($delete_sql);
- actor::org_unit_proximity->db_Main->do($insert_sql);
-
- return 1;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.org_unit.refresh_proximity',
- api_level => 1,
- method => 'calc_proximity',
-);
-
-sub make_hoo_spanset {
- my $hoo = shift;
- return undef unless $hoo;
-
- my $today = shift || DateTime->now;
-
- my $tz = OpenSRF::AppSession->create('open-ils.actor')->request(
- 'open-ils.actor.ou_setting.ancestor_default' => $hoo->id.'' => 'org_unit.timezone'
- )->gather(1) || DateTime::TimeZone->new( name => 'local' )->name;
-
- my $current_dow = $today->day_of_week_0;
-
- my $spanset = DateTime::SpanSet->empty_set;
- for my $d ( 0 .. 6 ) {
-
- my $omethod = 'dow_'.$d.'_open';
- my $cmethod = 'dow_'.$d.'_close';
-
- my $open = interval_to_seconds($hoo->$omethod());
- my $close = interval_to_seconds($hoo->$cmethod());
-
- next if ($open == $close && $open == 0);
-
- my $dow_offset = ($d - $current_dow) * $one_day;
- $close += $one_day if ($close <= $open);
-
- $spanset = $spanset->union(
- DateTime::Span->new(
- start => $today->clone->add( seconds => $dow_offset + $open ),
- end => $today->clone->add( seconds => $dow_offset + $close )
- )
- );
- }
-
- return $spanset->complement;
-}
-
-sub make_closure_spanset {
- my $closures = shift;
- return undef unless $closures;
-
- my $spanset = DateTime::SpanSet->empty_set;
- for my $k ( keys %$closures ) {
- my $c = $$closures{$k};
-
- $spanset = $spanset->union(
- DateTime::Span->new(
- start => $_dt_parser->parse_datetime(cleanse_ISO8601($c->{close_start})),
- end => $_dt_parser->parse_datetime(cleanse_ISO8601($c->{close_end}))
- )
- );
- }
-
- return $spanset;
-}
-
-sub new_org_closed_overlap {
- my $self = shift;
- my $client = shift;
- my $ou = shift;
- my $date = shift;
- my $direction = shift || 0;
- my $no_hoo = shift || 0;
-
- return undef unless ($date && $ou);
-
- # we're given a date and a direction, find any closures that contain the date
- my $t = actor::org_unit::closed_date->table;
- my $sql = <<" SQL";
- SELECT *
- FROM $t
- WHERE close_end > ?
- AND org_unit = ?
- ORDER BY close_start ASC, close_end DESC
- LIMIT 1
- SQL
-
- $date = cleanse_ISO8601($date);
-
- my $target_date = $_dt_parser->parse_datetime( $date );
- my ($begin, $end) = ($target_date, $target_date);
-
- # create a spanset from the closures that contain the $date
- my $closure_spanset = make_closure_spanset(
- actor::org_unit::closed_date->db_Main->selectall_hashref( $sql, 'id', {}, $date, $ou )
- );
-
- if ($closure_spanset && $closure_spanset->intersects( $target_date )) {
- my $closure_intersection = $closure_spanset->intersection( $target_date );
- $begin = $closure_intersection->min;
- $end = $closure_intersection->max;
-
- if ( $direction <= 0 ) {
- $begin->subtract( minutes => 1 );
-
- while ( my $_b = new_org_closed_overlap($self, $client, $ou, $begin->strftime('%FT%T%z'), -1, 1 ) ) {
- $begin = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
- }
- }
-
- if ( $direction >= 0 ) {
- $end->add( minutes => 1 );
-
- while ( my $_a = new_org_closed_overlap($self, $client, $ou, $end->strftime('%FT%T%z'), 1, 1 ) ) {
- $end = $_dt_parser->parse_datetime( cleanse_ISO8601($_a->{end}) );
- }
- }
- }
-
- if ( !$no_hoo ) {
-
- my $begin_hoo = make_hoo_spanset(actor::org_unit::hours_of_operation->retrieve($ou), $begin);
- my $end_hoo = make_hoo_spanset(actor::org_unit::hours_of_operation->retrieve($ou), $end );
-
-
- if ( $begin_hoo && $direction <= 0 && $begin_hoo->intersects($begin) ) {
- my $hoo_intersection = $begin_hoo->intersection( $begin );
- $begin = $hoo_intersection->min;
- $begin->subtract( minutes => 1 );
-
- while ( my $_b = new_org_closed_overlap($self, $client, $ou, $begin->strftime('%FT%T%z'), -1 ) ) {
- $begin = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
- }
- }
-
- if ( $end_hoo && $direction >= 0 && $end_hoo->intersects($end) ) {
- my $hoo_intersection = $end_hoo->intersection( $end );
- $end = $hoo_intersection->max;
- $end->add( minutes => 1 );
-
-
- while ( my $_b = new_org_closed_overlap($self, $client, $ou, $end->strftime('%FT%T%z'), -1 ) ) {
- $end = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{end}) );
- }
- }
- }
-
- my $start = $begin->strftime('%FT%T%z');
- my $stop = $end->strftime('%FT%T%z');
-
- return undef if ($start eq $stop);
- return { start => $start, end => $stop };
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.org_unit.closed_date.overlap',
- api_level => 0,
- method => 'new_org_closed_overlap',
-);
-
-sub org_closed_overlap {
- my $self = shift;
- my $client = shift;
- my $ou = shift;
- my $date = shift;
- my $direction = shift || 0;
- my $no_hoo = shift || 0;
-
- return undef unless ($date && $ou);
-
- my $t = actor::org_unit::closed_date->table;
- my $sql = <<" SQL";
- SELECT *
- FROM $t
- WHERE ? between close_start and close_end
- AND org_unit = ?
- ORDER BY close_start ASC, close_end DESC
- LIMIT 1
- SQL
-
- $date = cleanse_ISO8601($date);
- my ($begin, $end) = ($date,$date);
-
- my $hoo = actor::org_unit::hours_of_operation->retrieve($ou);
-
- if (my $closure = actor::org_unit::closed_date->db_Main->selectrow_hashref( $sql, {}, $date, $ou )) {
- $begin = cleanse_ISO8601($closure->{close_start});
- $end = cleanse_ISO8601($closure->{close_end});
-
- if ( $direction <= 0 ) {
- $before = $_dt_parser->parse_datetime( $begin );
- $before->subtract( minutes => 1 );
-
- while ( my $_b = org_closed_overlap($self, $client, $ou, $before->strftime('%FT%T%z'), -1, 1 ) ) {
- $before = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
- }
- $begin = cleanse_ISO8601($before->strftime('%FT%T%z'));
- }
-
- if ( $direction >= 0 ) {
- $after = $_dt_parser->parse_datetime( $end );
- $after->add( minutes => 1 );
-
- while ( my $_a = org_closed_overlap($self, $client, $ou, $after->strftime('%FT%T%z'), 1, 1 ) ) {
- $after = $_dt_parser->parse_datetime( cleanse_ISO8601($_a->{end}) );
- }
- $end = cleanse_ISO8601($after->strftime('%FT%T%z'));
- }
- }
-
- if ( !$no_hoo ) {
- if ( $hoo ) {
-
- if ( $direction <= 0 ) {
- my $begin_dow = $_dt_parser->parse_datetime( $begin )->day_of_week_0;
- my $begin_open_meth = "dow_".$begin_dow."_open";
- my $begin_close_meth = "dow_".$begin_dow."_close";
-
- my $count = 1;
- while ($hoo->$begin_open_meth eq '00:00:00' and $hoo->$begin_close_meth eq '00:00:00') {
- $begin = cleanse_ISO8601($_dt_parser->parse_datetime( $begin )->subtract( days => 1)->strftime('%FT%T%z'));
- $begin_dow++;
- $begin_dow %= 7;
- $count++;
- last if ($count > 6);
- $begin_open_meth = "dow_".$begin_dow."_open";
- $begin_close_meth = "dow_".$begin_dow."_close";
- }
-
- if (my $closure = actor::org_unit::closed_date->db_Main->selectrow_hashref( $sql, {}, $begin, $ou )) {
- $before = $_dt_parser->parse_datetime( $begin );
- $before->subtract( minutes => 1 );
- while ( my $_b = org_closed_overlap($self, $client, $ou, $before->strftime('%FT%T%z'), -1 ) ) {
- $before = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
- }
- }
- }
-
- if ( $direction >= 0 ) {
- my $end_dow = $_dt_parser->parse_datetime( $end )->day_of_week_0;
- my $end_open_meth = "dow_".$end_dow."_open";
- my $end_close_meth = "dow_".$end_dow."_close";
-
- $count = 1;
- while ($hoo->$end_open_meth eq '00:00:00' and $hoo->$end_close_meth eq '00:00:00') {
- $end = cleanse_ISO8601($_dt_parser->parse_datetime( $end )->add( days => 1)->strftime('%FT%T%z'));
- $end_dow++;
- $end_dow %= 7;
- $count++;
- last if ($count > 6);
- $end_open_meth = "dow_".$end_dow."_open";
- $end_close_meth = "dow_".$end_dow."_close";
- }
-
- if (my $closure = actor::org_unit::closed_date->db_Main->selectrow_hashref( $sql, {}, $end, $ou )) {
- $after = $_dt_parser->parse_datetime( $end );
- $after->add( minutes => 1 );
-
- while ( my $_a = org_closed_overlap($self, $client, $ou, $after->strftime('%FT%T%z'), 1 ) ) {
- $after = $_dt_parser->parse_datetime( cleanse_ISO8601($_a->{end}) );
- }
- $end = cleanse_ISO8601($after->strftime('%FT%T%z'));
- }
- }
-
- }
- }
-
- if ($begin eq $date && $end eq $date) {
- return undef;
- }
-
- return { start => $begin, end => $end };
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.org_unit.closed_date.overlap',
- api_level => 1,
- method => 'org_closed_overlap',
-);
-
-sub user_by_barcode {
- my $self = shift;
- my $client = shift;
- my @barcodes = shift;
-
- return undef unless @barcodes;
-
- for my $card ( actor::card->search( { barcode => @barcodes } ) ) {
- next unless $card;
- if (@barcodes == 1) {
- return $card->usr->to_fieldmapper;
- }
- $client->respond( $card->usr->to_fieldmapper);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.actor.user.search.barcode',
- api_level => 1,
- method => 'user_by_barcode',
- stream => 1,
- cachable => 1,
-);
-
-sub lost_barcodes {
- my $self = shift;
- my $client = shift;
-
- my $c = actor::card->table;
- my $p = actor::user->table;
-
- my $sql = "SELECT c.barcode FROM $c c JOIN $p p ON (c.usr = p.id) WHERE p.card <> c.id";
-
- my $list = actor::user->db_Main->selectcol_arrayref($sql);
- for my $bc ( @$list ) {
- $client->respond($bc);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.lost_barcodes',
- api_level => 1,
- stream => 1,
- method => 'lost_barcodes',
- signature => <<' NOTE',
- Returns an array of barcodes that belong to lost cards.
- @return array of barcodes
- NOTE
-);
-
-sub expired_barcodes {
- my $self = shift;
- my $client = shift;
-
- my $c = actor::card->table;
- my $p = actor::user->table;
-
- my $sql = "SELECT c.barcode FROM $c c JOIN $p p ON (c.usr = p.id) WHERE p.expire_date < CURRENT_DATE";
-
- my $list = actor::user->db_Main->selectcol_arrayref($sql);
- for my $bc ( @$list ) {
- $client->respond($bc);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.expired_barcodes',
- api_level => 1,
- stream => 1,
- method => 'expired_barcodes',
- signature => <<' NOTE',
- Returns an array of barcodes that are currently expired.
- @return array of barcodes
- NOTE
-);
-
-sub barred_barcodes {
- my $self = shift;
- my $client = shift;
-
- my $c = actor::card->table;
- my $p = actor::user->table;
-
- my $sql = "SELECT c.barcode FROM $c c JOIN $p p ON (c.usr = p.id) WHERE p.barred IS TRUE";
-
- my $list = actor::user->db_Main->selectcol_arrayref($sql);
- for my $bc ( @$list ) {
- $client->respond($bc);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.barred_barcodes',
- api_level => 1,
- stream => 1,
- method => 'barred_barcodes',
- signature => <<' NOTE',
- Returns an array of barcodes that are currently barred.
- @return array of barcodes
- NOTE
-);
-
-sub penalized_barcodes {
- my $self = shift;
- my $client = shift;
-
- my $c = actor::card->table;
- my $p = actor::user_standing_penalty->table;
-
- my $sql = <<" SQL";
- SELECT DISTINCT c.barcode
- FROM $c c
- JOIN $p p USING (usr)
- JOIN config.standing_penalty csp ON (csp.id = p.standing_penalty)
- WHERE csp.block_list IS NOT NULL
- AND p.set_date < CURRENT_DATE
- AND (p.stop_date IS NULL OR p.stop_date > CURRENT_DATE);
- SQL
-
- my $list = actor::user->db_Main->selectcol_arrayref($sql);
- for my $bc ( @$list ) {
- $client->respond($bc);
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.penalized_barcodes',
- api_level => 1,
- stream => 1,
- method => 'penalized_barcodes',
- signature => <<' NOTE',
- Returns an array of barcodes that have blocking penalties.
- @return array of barcodes
- NOTE
-);
-
-
-sub patron_search {
- my $self = shift;
- my $client = shift;
- my $search = shift;
- my $limit = shift || 1000;
- my $sort = shift;
- my $inactive = shift;
- my $ws_ou = shift;
- my $ws_ou_depth = shift || 0;
-
- my $penalty_sort = 0;
-
- my $strict_opt_in = OpenSRF::Utils::SettingsClient->new->config_value( share => user => 'opt_in' );
-
- $sort = ['family_name','first_given_name'] unless ($$sort[0]);
- push @$sort,'id';
-
- if ($$sort[0] eq 'penalties') {
- shift @$sort;
- $penalty_sort = 1;
- }
-
- # group 0 = user
- # group 1 = address
- # group 2 = phone, ident
- # group 3 = barcode
-
- my $usr = join ' AND ', map { "LOWER(CAST($_ AS text)) ~ ?" } grep { ''.$$search{$_}{group} eq '0' } keys %$search;
- my @usrv = map { "^$$search{$_}{value}" } grep { ''.$$search{$_}{group} eq '0' } keys %$search;
-
- my $addr = join ' AND ', map { "LOWER(CAST($_ AS text)) ~ ?" } grep { ''.$$search{$_}{group} eq '1' } keys %$search;
- my @addrv = map { "^$$search{$_}{value}" } grep { ''.$$search{$_}{group} eq '1' } keys %$search;
-
- my $pv = $$search{phone}{value};
- my $iv = $$search{ident}{value};
- my $nv = $$search{name}{value};
- my $cv = $$search{card}{value};
-
- my $card = '';
- if ($cv) {
- $card = 'JOIN (SELECT DISTINCT usr FROM actor.card WHERE LOWER(barcode) LIKE ?||\'%\') AS card ON (card.usr = users.id)';
- unshift(@usrv, $cv);
- }
-
- my $phone = '';
- my @ps;
- my @phonev;
- if ($pv) {
- for my $p ( qw/day_phone evening_phone other_phone/ ) {
- push @ps, "LOWER($p) ~ ?";
- push @phonev, "^$pv";
- }
- $phone = '(' . join(' OR ', @ps) . ')';
- }
-
- my $ident = '';
- my @is;
- my @identv;
- if ($iv) {
- for my $i ( qw/ident_value ident_value2/ ) {
- push @is, "LOWER($i) ~ ?";
- push @identv, "^$iv";
- }
- $ident = '(' . join(' OR ', @is) . ')';
- }
-
- my $name = '';
- my @ns;
- my @namev;
- if (0 && $nv) {
- for my $n ( qw/first_given_name second_given_name family_name/ ) {
- push @ns, "LOWER($n) ~ ?";
- push @namev, "^$nv";
- }
- $name = '(' . join(' OR ', @ns) . ')';
- }
-
- my $usr_where = join ' AND ', grep { $_ } ($usr,$phone,$ident,$name);
- my $addr_where = $addr;
-
-
- my $u_table = actor::user->table;
- my $a_table = actor::user_address->table;
- my $opt_in_table = actor::usr_org_unit_opt_in->table;
- my $ou_table = actor::org_unit->table;
-
- my $u_select = "SELECT id as id FROM $u_table u WHERE $usr_where";
- my $a_select = "SELECT u.id as id FROM $a_table a JOIN $u_table u ON (u.mailing_address = a.id OR u.billing_address = a.id) WHERE $addr_where";
-
- my $clone_select = '';
-
- #$clone_select = "JOIN (SELECT cu.id as id FROM $a_table ca ".
- # "JOIN $u_table cu ON (cu.mailing_address = ca.id OR cu.billing_address = ca.id) ".
- # "WHERE $addr_where) AS clone ON (clone.id = users.id)" if ($addr_where);
-
- my $select = '';
- if ($usr_where) {
- if ($addr_where) {
- $select = "$u_select INTERSECT $a_select";
- } else {
- $select = $u_select;
- }
- } elsif ($addr_where) {
- $select = "$a_select";
- }
-
- return undef if (!$select && !$card);
-
- my $order_by = join ', ', map { 'LOWER(CAST(users.'. (split / /,$_)[0] . ' AS text)) ' . (split / /,$_)[1] } @$sort;
- my $distinct_list = join ', ', map { 'LOWER(CAST(users.'. (split / /,$_)[0] . ' AS text))' } @$sort;
- my $group_list = $distinct_list;
-
- if ($inactive) {
- $inactive = '';
- } else {
- $inactive = 'AND users.active = TRUE';
- }
-
- if (!$ws_ou) { # XXX This should be required!!
- $ws_ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
- }
-
- my $opt_in_join = '';
- my $opt_in_where = '';
- if (lc($strict_opt_in) eq 'true') {
- $opt_in_join = "LEFT JOIN $opt_in_table oi ON (oi.org_unit = $ws_ou AND users.id = oi.usr)";
- $opt_in_where = "AND (oi.id IS NOT NULL OR users.home_ou = $ws_ou)";
- }
-
- my $penalty_join = '';
- if ($penalty_sort) {
- $distinct_list = 'COUNT(penalties.id), ' . $distinct_list;
- $order_by = 'COUNT(penalties.id) DESC, ' . $order_by;
- unshift @$sort, 'COUNT(penalties.id)';
- $penalty_join = <<" SQL";
- LEFT JOIN actor.usr_standing_penalty penalties
- ON (users.id = penalties.usr AND (penalties.stop_date IS NULL OR penalties.stop_date > NOW()))
- SQL
- }
-
- my $descendants = "actor.org_unit_descendants($ws_ou, $ws_ou_depth)";
-
- $select = "JOIN ($select) AS search ON (search.id = users.id)" if ($select);
- $select = <<" SQL";
- SELECT $distinct_list
- FROM $u_table AS users $card
- JOIN $descendants d ON (d.id = users.home_ou)
- $select
- $opt_in_join
- $clone_select
- $penalty_join
- WHERE users.deleted = FALSE
- $inactive
- $opt_in_where
- GROUP BY $group_list
- ORDER BY $order_by
- LIMIT $limit
- SQL
-
- return actor::user->db_Main->selectcol_arrayref($select, {Columns=>[scalar(@$sort)]}, map {lc($_)} (@usrv,@phonev,@identv,@namev,@addrv));
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.user.crazy_search',
- api_level => 1,
- method => 'patron_search',
-);
-
-sub org_unit_list {
- my $self = shift;
- my $client = shift;
-
- my $select =<<" SQL";
- SELECT *
- FROM actor.org_unit
- ORDER BY CASE WHEN parent_ou IS NULL THEN 0 ELSE 1 END, name;
- SQL
-
- my $sth = actor::org_unit->db_Main->prepare_cached($select);
- $sth->execute;
-
- $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.actor.org_unit.retrieve.all',
- api_level => 1,
- stream => 1,
- method => 'org_unit_list',
-);
-
-sub org_unit_type_list {
- my $self = shift;
- my $client = shift;
-
- my $select =<<" SQL";
- SELECT *
- FROM actor.org_unit_type
- ORDER BY depth, name;
- SQL
-
- my $sth = actor::org_unit_type->db_Main->prepare_cached($select);
- $sth->execute;
-
- $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit_type->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.actor.org_unit_type.retrieve.all',
- api_level => 1,
- stream => 1,
- method => 'org_unit_type_list',
-);
-
-sub org_unit_full_path {
- my $self = shift;
- my $client = shift;
- my @binds = @_;
-
- return undef unless (@binds);
-
- my $func = 'actor.org_unit_full_path(?)';
- $func = 'actor.org_unit_full_path(?,?)' if (@binds > 1);
-
- my $sth = actor::org_unit->db_Main->prepare_cached("SELECT * FROM $func");
- $sth->execute(@binds);
-
- $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.org_unit.full_path',
- api_level => 1,
- stream => 1,
- method => 'org_unit_full_path',
-);
-
-sub org_unit_ancestors {
- my $self = shift;
- my $client = shift;
- my $id = shift;
-
- return undef unless ($id);
-
- my $func = 'actor.org_unit_ancestors(?)';
-
- my $sth = actor::org_unit->db_Main->prepare_cached(<<" SQL");
- SELECT f.*
- FROM $func f
- JOIN actor.org_unit_type t ON (f.ou_type = t.id)
- ORDER BY t.depth, f.name;
- SQL
- $sth->execute(''.$id);
-
- $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.org_unit.ancestors',
- api_level => 1,
- stream => 1,
- method => 'org_unit_ancestors',
-);
-
-sub org_unit_descendants {
- my $self = shift;
- my $client = shift;
- my $id = shift;
- my $depth = shift;
-
- return undef unless ($id);
-
- my $func = 'actor.org_unit_descendants(?)';
- if (defined $depth) {
- $func = 'actor.org_unit_descendants(?,?)';
- }
-
- my $sth = actor::org_unit->db_Main->prepare_cached("SELECT * FROM $func");
- $sth->execute(''.$id, ''.$depth) if (defined $depth);
- $sth->execute(''.$id) unless (defined $depth);
-
- $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.actor.org_unit.descendants',
- api_level => 1,
- stream => 1,
- method => 'org_unit_descendants',
-);
-
-sub fleshed_actor_stat_cat {
- my $self = shift;
- my $client = shift;
- my @list = @_;
-
- @list = ($list[0]) unless ($self->api_name =~ /batch/o);
-
- for my $sc (@list) {
- my $cat = actor::stat_cat->retrieve($sc);
- next unless ($cat);
-
- my $sc_fm = $cat->to_fieldmapper;
- $sc_fm->entries( [ map { $_->to_fieldmapper } $cat->entries ] );
-
- $client->respond( $sc_fm );
-
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.actor.stat_cat.retrieve',
- api_level => 1,
- argc => 1,
- method => 'fleshed_actor_stat_cat',
-);
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.actor.stat_cat.retrieve.batch',
- api_level => 1,
- argc => 1,
- stream => 1,
- method => 'fleshed_actor_stat_cat',
-);
-
-#XXX Fix stored proc calls
-sub ranged_actor_stat_cat_all {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = actor::stat_cat->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- ORDER BY name
- SQL
-
- $fleshed = 0;
- $fleshed = 1 if ($self->api_name =~ /fleshed/o);
-
- my $sth = actor::stat_cat->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- for my $sc ( map { actor::stat_cat->construct($_) } $sth->fetchall_hash ) {
- my $sc_fm = $sc->to_fieldmapper;
- $sc_fm->entries(
- [ $self->method_lookup( 'open-ils.storage.ranged.actor.stat_cat_entry.search.stat_cat' )->run($ou,$sc->id) ]
- ) if ($fleshed);
- $client->respond( $sc_fm );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ranged.fleshed.actor.stat_cat.all',
- api_level => 1,
- argc => 1,
- stream => 1,
- method => 'ranged_actor_stat_cat_all',
-);
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ranged.actor.stat_cat.all',
- api_level => 1,
- argc => 1,
- stream => 1,
- method => 'ranged_actor_stat_cat_all',
-);
-
-#XXX Fix stored proc calls
-sub ranged_actor_stat_cat_entry {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
- my $sc = ''.shift();
-
- return undef unless ($ou);
- my $s_table = actor::stat_cat_entry->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE stat_cat = ?
- ORDER BY name
- SQL
-
- my $sth = actor::stat_cat->db_Main->prepare_cached($select);
- $sth->execute($ou,$sc);
-
- for my $sce ( map { actor::stat_cat_entry->construct($_) } $sth->fetchall_hash ) {
- $client->respond( $sce->to_fieldmapper );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ranged.actor.stat_cat_entry.search.stat_cat',
- api_level => 1,
- stream => 1,
- method => 'ranged_actor_stat_cat_entry',
-);
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::asset;
-use base qw/OpenILS::Application::Storage/;
-#use OpenILS::Application::Storage::CDBI::asset;
-#use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils::JSON;
-
-#
-
-my $log = 'OpenSRF::Utils::Logger';
-
-use MARC::Record;
-use MARC::File::XML;
-
-sub circ_count {
- my $self = shift;
- my $client = shift;
- my $copy = shift;
- my $granularity = shift;
-
- my $c_table = action::circulation->table;
-
- if (lc($granularity) eq 'year') {
- $granularity = ", to_char(xact_start, 'YYYY') as when";
- } elsif (lc($granularity) eq 'month') {
- $granularity = ", to_char(xact_start, 'YYYY-MM') as when";
- } elsif (lc($granularity) eq 'day') {
- $granularity = ", to_char(xact_start, 'YYYY-MM-DD') as when";
- } else {
- $granularity = ", 'total' as when";
- }
-
- my $SQL = <<" SQL";
- SELECT COUNT(*) as count $granularity
- FROM $c_table
- WHERE target_copy = ?
- SQL
-
-
- if ($granularity !~ /total/o) {
- $SQL .= ' GROUP BY 2 ORDER BY 2';
- }
-
- $log->debug("Circ count SQL [$SQL]", DEBUG);
-
- return action::circulation->db_Main->selectall_hashref($SQL, 'when', {}, $copy);
-}
-__PACKAGE__->register_method(
- method => 'circ_count',
- api_name => 'open-ils.storage.asset.copy.circ_count',
- argc => 1,
-);
-
-
-#our $_default_subfield_map = {
-# call_number => $cn,
-# barcode => $bc,
-# owning_lib => $ol,
-# circulating_lib => $cl,
-# copy_location => $sl,
-# copy_number => $num,
-# price => $pr,
-# status => $loc,
-# create_date => $date,
-#
-# legacy_item_type => $it,
-# legacy_item_cat_1 => $ic1,
-# legacy_item_cat_2 => $ic2,
-#};
-
-my %org_cache;
-
-sub import_xml_holdings {
- my $self = shift;
- my $client = shift;
- my $editor = shift;
- my $record = shift;
- my $xml = shift;
- my $tag = shift;
- my $map = shift;
- my $date_format = shift || 'mm/dd/yyyy';
-
- ($record) = biblio::record_entry->search_where($record);
-
- return 0 unless ($record);
-
- my $r = MARC::Record->new_from_xml($xml);
-
- my $count = 0;
- for my $f ( $r->fields( $tag ) ) {
- next unless ($f->subfield( $map->{owning_lib} ));
-
- my ($ol,$cl);
-
- try {
- $ol =
- $org_cache{ $f->subfield( $map->{owning_lib} ) }
- || actor::org_unit->search( shortname => $f->subfield( $map->{owning_lib} ) )->next->id;
-
- $org_cache{ $f->subfield( $map->{owning_lib} ) } = $ol;
- } otherwise {
- $log->debug('Could not find library with shortname ['.$f->subfield( $map->{owning_lib} ).'] : '. shift(), ERROR);
- $log->info('Failed holdings tag: ['.OpenSRF::Utils::JSON->perl2JSON( $f ).']');
- };
-
- try {
- $cl =
- $org_cache{ $f->subfield( $map->{circulating_lib} ) }
- || actor::org_unit->search( shortname => $f->subfield( $map->{circulating_lib} ) )->next->id;
-
- $org_cache{ $f->subfield( $map->{circulating_lib} ) } = $cl;
- } otherwise {
- $log->debug('Could not find library with shortname ['.$f->subfield( $map->{circulating_lib} ).'] : '. shift(), ERROR);
- $log->info('Failed holdings tag: ['.OpenSRF::Utils::JSON->perl2JSON( $f ).']');
- };
-
- next unless ($ol && $cl);
-
- my $cn;
- try {
- $cn = asset::call_number->find_or_create(
- { label => $f->subfield( $map->{call_number} ),
- owning_lib => $ol,
- record => $record->id,
- creator => $editor,
- editor => $editor,
- }
- );
- } otherwise {
- $log->debug('Could not find or create callnumber ['.$f->subfield( $map->{call_number} )."] on record $record : ". shift(), ERROR);
- $log->info('Failed holdings tag: ['.OpenSRF::Utils::JSON->perl2JSON( $f ).']');
- };
-
- next unless ($cn);
-
- my $create_date = $f->subfield( $map->{create_date} );
-
- my ($m,$d,$y);
- if ($date_format eq 'mm/dd/yyyy') {
- ($m,$d,$y) = split '/', $create_date;
-
- } elsif ($date_format eq 'dd/mm/yyyy') {
- ($d,$m,$y) = split '/', $create_date;
-
- } elsif ($date_format eq 'mm-dd-yyyy') {
- ($m,$d,$y) = split '-', $create_date;
-
- } elsif ($date_format eq 'dd-mm-yyyy') {
- ($d,$m,$y) = split '-', $create_date;
-
- } elsif ($date_format eq 'yyyy-mm-dd') {
- ($y,$m,$d) = split '-', $create_date;
-
- } elsif ($date_format eq 'yyyy/mm/dd') {
- ($y,$m,$d) = split '/', $create_date;
- }
-
- if ($y == 0) {
- (undef,undef,undef,$d,$m,$y) = localtime;
- $m++;
- $y+=1900;
- }
-
- my $price = $f->subfield( $map->{price} );
- $price =~ s/[^0-9\.]+//gso;
- $price ||= '0.00';
-
- try {
- $cn->add_to_copies(
- { circ_lib => $cl,
- copy_number => $f->subfield( $map->{copy_number} ),
- price => $price,
- barcode => $f->subfield( $map->{barcode} ),
- loan_duration => 2,
- fine_level => 2,
- creator => $editor,
- editor => $editor,
- create_date => sprintf('%04d-%02d-%02d',$y,$m,$d),
- }
- );
- $count++;
- } otherwise {
- $log->debug('Could not create copy ['.$f->subfield( $map->{barcode} ).'] : '. shift(), ERROR);
- };
- }
-
- return $count;
-}
-__PACKAGE__->register_method(
- method => 'import_xml_holdings',
- api_name => 'open-ils.storage.asset.holdings.import.xml',
- argc => 5,
- stream => 0,
-);
-
-# XXX
-# see /home/miker/cn_browse-test.sql for page up and down sql ...
-# XXX
-
-sub cn_browse_pagedown {
- my $self = shift;
- my $client = shift;
-
- my %args = @_;
-
- my $cn = uc($args{label});
- my $org = $args{org_unit};
- my $depth = $args{depth};
- my $boundry_id = $args{boundry_id};
- my $size = $args{page_size} || 20;
- $size = int($size);
-
- my $table = asset::call_number->table;
-
- my $descendants = "actor.org_unit_descendants($org)";
- if (defined $depth) {
- $descendants = "actor.org_unit_descendants($org,$depth)";
- }
-
- my $orgs = join(',', @{ asset::call_number->db_Main->selectcol_arrayref("SELECT DISTINCT id FROM $descendants;") });
-
- my $sql = <<" SQL";
- select
- cn.label,
- cn.owning_lib,
- cn.record,
- cn.id
- from
- $table cn
- where
- not deleted
- and (oils_text_as_bytea(label) > ? or ( cn.id > ? and oils_text_as_bytea(label) = ? ))
- and owning_lib in ($orgs)
- order by oils_text_as_bytea(label), 4, 2
- limit $size;
- SQL
-
- my $sth = asset::call_number->db_Main->prepare($sql);
- $sth->execute($cn, $boundry_id, $cn);
- while ( my @row = $sth->fetchrow_array ) {
- $client->respond([@row]);
- }
- $sth->finish;
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'cn_browse_pagedown',
- api_name => 'open-ils.storage.asset.call_number.browse.page_down',
- argc => 4,
- stream => 1,
-);
-
-sub cn_browse_pageup {
- my $self = shift;
- my $client = shift;
-
- my %args = @_;
-
- my $cn = uc($args{label});
- my $org = $args{org_unit};
- my $depth = $args{depth};
- my $boundry_id = $args{boundry_id};
- my $size = $args{page_size} || 20;
- $size = int($size);
-
- my $table = asset::call_number->table;
-
- my $descendants = "actor.org_unit_descendants($org)";
- if (defined $depth) {
- $descendants = "actor.org_unit_descendants($org,$depth)";
- }
-
- my $orgs = join(',', @{ asset::call_number->db_Main->selectcol_arrayref("SELECT DISTINCT id FROM $descendants;") });
-
- my $sql = <<" SQL";
- select * from (
- select
- cn.label,
- cn.owning_lib,
- cn.record,
- cn.id
- from
- $table cn
- where
- not deleted
- and (oils_text_as_bytea(label) < ? or ( cn.id < ? and oils_text_as_bytea(label) = ? ))
- and owning_lib in ($orgs)
- order by oils_text_as_bytea(label) desc, 4 desc, 2 desc
- limit $size
- ) as bar
- order by 1,4,2;
- SQL
-
- my $sth = asset::call_number->db_Main->prepare($sql);
- $sth->execute($cn, $boundry_id, $cn);
- while ( my @row = $sth->fetchrow_array ) {
- $client->respond([@row]);
- }
- $sth->finish;
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'cn_browse_pageup',
- api_name => 'open-ils.storage.asset.call_number.browse.page_up',
- argc => 4,
- stream => 1,
-);
-
-sub cn_browse_target {
- my $self = shift;
- my $client = shift;
-
- my %args = @_;
-
- my $cn = uc($args{label});
- my $org = $args{org_unit};
- my $depth = $args{depth};
- my $size = $args{page_size} || 20;
- my $topsize = $size / 2;
- $topsize = int($topsize);
- $bottomsize = $size - $topsize;
-
- my $table = asset::call_number->table;
-
- my $descendants = "actor.org_unit_descendants($org)";
- if (defined $depth) {
- $descendants = "actor.org_unit_descendants($org,$depth)";
- }
-
- my $orgs = join(',', @{ asset::call_number->db_Main->selectcol_arrayref("SELECT DISTINCT id FROM $descendants;") });
-
- my $top_sql = <<" SQL";
- select * from (
- select
- cn.label,
- cn.owning_lib,
- cn.record,
- cn.id
- from
- $table cn
- where
- not deleted
- and oils_text_as_bytea(label) < ?
- and owning_lib in ($orgs)
- order by oils_text_as_bytea(label) desc, 4 desc, 2 desc
- limit $topsize
- ) as bar
- order by 1,4,2;
- SQL
-
- my $bottom_sql = <<" SQL";
- select
- cn.label,
- cn.owning_lib,
- cn.record,
- cn.id
- from
- $table cn
- where
- not deleted
- and oils_text_as_bytea(label) >= ?
- and owning_lib in ($orgs)
- order by oils_text_as_bytea(label),4,2
- limit $bottomsize;
- SQL
-
- my $sth = asset::call_number->db_Main->prepare($top_sql);
- $sth->execute($cn);
- while ( my @row = $sth->fetchrow_array ) {
- $client->respond([@row]);
- }
- $sth->finish;
-
- $sth = asset::call_number->db_Main->prepare($bottom_sql);
- $sth->execute($cn);
- while ( my @row = $sth->fetchrow_array ) {
- $client->respond([@row]);
- }
- $sth->finish;
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'cn_browse_target',
- api_name => 'open-ils.storage.asset.call_number.browse.target',
- argc => 4,
- stream => 1,
-);
-
-
-sub copy_proximity {
- my $self = shift;
- my $client = shift;
-
- my $cp = shift;
- my $org = shift;
-
- return unless ($cp && $org);
-
- $cp = asset::copy->retrieve($cp) unless (ref($cp));
-
- return unless $cp;
- my $ol = $cp->circ_lib;
-
- return (actor::org_unit_proximity->search( from_org => "$ol", to_org => "$org"))[0]->prox;
-}
-__PACKAGE__->register_method(
- method => 'copy_proximity',
- api_name => 'open-ils.storage.asset.copy.proximity',
- argc => 2,
- stream => 1,
-);
-
-sub asset_copy_location_all {
- my $self = shift;
- my $client = shift;
-
- for my $rec ( asset::copy_location->retrieve_all ) {
- $client->respond( $rec->to_fieldmapper );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'asset_copy_location_all',
- api_name => 'open-ils.storage.direct.asset.copy_location.retrieve.all',
- argc => 0,
- stream => 1,
-);
-
-# XXX arg, with the descendancy SPs...
-sub ranged_asset_copy_location {
- my $self = shift;
- my $client = shift;
- my @binds = @_;
-
- my $ctable = asset::copy_location->table;
-
- my $descendants = defined($binds[1]) ?
- "actor.org_unit_full_path(?, ?)" :
- "actor.org_unit_full_path(?)" ;
-
-
- my $sql = <<" SQL";
- SELECT DISTINCT c.*
- FROM $ctable c
- JOIN $descendants d
- ON (d.id = c.owning_lib)
- ORDER BY name
- SQL
-
- my $sth = asset::copy_location->db_Main->prepare($sql);
- $sth->execute(@binds);
-
- while ( my $rec = $sth->fetchrow_hashref ) {
-
- my $cnct = new Fieldmapper::asset::copy_location;
- map {$cnct->$_($$rec{$_})} keys %$rec;
- $client->respond( $cnct );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'ranged_asset_copy_location',
- api_name => 'open-ils.storage.ranged.asset.copy_location.retrieve',
- argc => 1,
- stream => 1,
-);
-
-
-sub fleshed_copy {
- my $self = shift;
- my $client = shift;
- my @ids = @_;
-
- return undef unless (@ids);
-
- @ids = ($ids[0]) unless ($self->api_name =~ /batch/o);
-
- for my $id ( @ids ) {
- next unless $id;
- my $cp = asset::copy->retrieve($id);
- next unless $cp;
-
- my $cp_fm = $cp->to_fieldmapper;
- $cp_fm->circ_lib( $cp->circ_lib->to_fieldmapper );
- $cp_fm->location( $cp->location->to_fieldmapper );
- $cp_fm->status( $cp->status->to_fieldmapper );
- $cp_fm->stat_cat_entries( [ map { $_->to_fieldmapper } $cp->stat_cat_entries ] );
-
- $client->respond( $cp_fm );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.asset.copy.batch.retrieve',
- method => 'fleshed_copy',
- argc => 1,
- stream => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.asset.copy.retrieve',
- method => 'fleshed_copy',
- argc => 1,
-);
-
-sub fleshed_copy_by_barcode {
- my $self = shift;
- my $client = shift;
- my $bc = ''.shift;
-
- my ($cp) = asset::copy->search( { barcode => $bc } );
-
- return undef unless ($cp);
-
- my $cp_fm = $cp->to_fieldmapper;
- $cp_fm->circ_lib( $cp->circ_lib->to_fieldmapper );
- $cp_fm->location( $cp->location->to_fieldmapper );
- $cp_fm->status( $cp->status->to_fieldmapper );
-
- return $cp_fm;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.asset.copy.search.barcode',
- method => 'fleshed_copy_by_barcode',
- argc => 1,
- stream => 1,
-);
-
-
-#XXX Fix stored proc calls
-sub fleshed_asset_stat_cat {
- my $self = shift;
- my $client = shift;
- my @list = @_;
-
- @list = ($list[0]) unless ($self->api_name =~ /batch/o);
- for my $sc (@list) {
- my $cat = asset::stat_cat->retrieve($sc);
-
- next unless ($cat);
-
- my $sc_fm = $cat->to_fieldmapper;
- $sc_fm->entries( [ map { $_->to_fieldmapper } $cat->entries ] );
- $client->respond( $sc_fm );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.asset.stat_cat.retrieve',
- api_level => 1,
- method => 'fleshed_asset_stat_cat',
-);
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.asset.stat_cat.retrieve.batch',
- api_level => 1,
- stream => 1,
- method => 'fleshed_asset_stat_cat',
-);
-
-
-#XXX Fix stored proc calls
-sub ranged_asset_stat_cat {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
-
- return undef unless ($ou);
- my $s_table = asset::stat_cat->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- ORDER BY name
- SQL
-
- $fleshed = 0;
- $fleshed = 1 if ($self->api_name =~ /fleshed/o);
-
- my $sth = asset::stat_cat->db_Main->prepare_cached($select);
- $sth->execute($ou);
-
- for my $sc ( map { asset::stat_cat->construct($_) } $sth->fetchall_hash ) {
- my $sc_fm = $sc->to_fieldmapper;
- $sc_fm->entries(
- [ $self->method_lookup( 'open-ils.storage.ranged.asset.stat_cat_entry.search.stat_cat' )->run($ou,$sc->id) ]
- ) if ($fleshed);
- $client->respond( $sc_fm );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ranged.fleshed.asset.stat_cat.all',
- api_level => 1,
- stream => 1,
- method => 'ranged_asset_stat_cat',
-);
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ranged.asset.stat_cat.all',
- api_level => 1,
- stream => 1,
- method => 'ranged_asset_stat_cat',
-);
-
-
-#XXX Fix stored proc calls
-sub multiranged_asset_stat_cat {
- my $self = shift;
- my $client = shift;
- my $ous = shift;
-
- return undef unless (defined($ous) and @$ous);
- my $s_table = asset::stat_cat->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- WHERE s.owner IN ( XXX )
- ORDER BY name
- SQL
-
- my $collector = ' INTERSECT ';
- my $entry_method = 'open-ils.storage.multiranged.intersect.asset.stat_cat_entry.search.stat_cat';
- if ($self->api_name =~ /union/o) {
- $collector = ' UNION ';
- $entry_method = 'open-ils.storage.multiranged.union.asset.stat_cat_entry.search.stat_cat';
- }
-
- my $binds = join($collector, map { 'SELECT id FROM actor.org_unit_full_path(?)' } grep {defined} @$ous);
- $select =~ s/XXX/$binds/so;
-
- $fleshed = 0;
- $fleshed = 1 if ($self->api_name =~ /fleshed/o);
-
- my $sth = asset::stat_cat->db_Main->prepare_cached($select);
- $sth->execute(map { "$_" } grep {defined} @$ous);
-
- for my $sc ( map { asset::stat_cat->construct($_) } $sth->fetchall_hash ) {
- my $sc_fm = $sc->to_fieldmapper;
- $sc_fm->entries(
- [ $self->method_lookup( $entry_method )->run($ous, $sc->id) ]
- ) if ($fleshed);
- $client->respond( $sc_fm );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.multiranged.intersect.fleshed.asset.stat_cat.all',
- api_level => 1,
- stream => 1,
- method => 'multiranged_asset_stat_cat',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.multiranged.union.fleshed.asset.stat_cat.all',
- api_level => 1,
- stream => 1,
- method => 'multiranged_asset_stat_cat',
-);
-
-#XXX Fix stored proc calls
-sub ranged_asset_stat_cat_entry {
- my $self = shift;
- my $client = shift;
- my $ou = ''.shift();
- my $sc = ''.shift();
-
- return undef unless ($ou);
- my $s_table = asset::stat_cat_entry->table;
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
- WHERE stat_cat = ?
- ORDER BY name
- SQL
-
- my $sth = asset::stat_cat->db_Main->prepare_cached($select);
- $sth->execute($ou,$sc);
-
- for my $sce ( map { asset::stat_cat_entry->construct($_) } $sth->fetchall_hash ) {
- $client->respond( $sce->to_fieldmapper );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ranged.asset.stat_cat_entry.search.stat_cat',
- api_level => 1,
- stream => 1,
- method => 'ranged_asset_stat_cat_entry',
-);
-
-#XXX Fix stored proc calls
-sub multiranged_asset_stat_cat_entry {
- my $self = shift;
- my $client = shift;
- my $ous = shift;
- my $sc = ''.shift();
-
- return undef unless (defined($ous) and @$ous);
- my $s_table = asset::stat_cat_entry->table;
-
- my $collector = ' INTERSECT ';
- $collector = ' UNION ' if ($self->api_name =~ /union/o);
-
- my $select = <<" SQL";
- SELECT s.*
- FROM $s_table s
- WHERE s.owner IN ( XXX ) and s.stat_cat = ?
- ORDER BY value
- SQL
-
- my $binds = join($collector, map { 'SELECT id FROM actor.org_unit_full_path(?)' } grep {defined} @$ous);
- $select =~ s/XXX/$binds/so;
-
- my $sth = asset::stat_cat->db_Main->prepare_cached($select);
- $sth->execute(map {"$_"} @$ous,$sc);
-
- for my $sce ( map { asset::stat_cat_entry->construct($_) } $sth->fetchall_hash ) {
- $client->respond( $sce->to_fieldmapper );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.multiranged.intersect.asset.stat_cat_entry.search.stat_cat',
- api_level => 1,
- stream => 1,
- method => 'multiranged_asset_stat_cat_entry',
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.multiranged.union.asset.stat_cat_entry.search.stat_cat',
- api_level => 1,
- stream => 1,
- method => 'multiranged_asset_stat_cat_entry',
-);
-
-
-sub cn_ranged_tree {
- my $self = shift;
- my $client = shift;
- my $cn = shift;
- my $ou = shift;
- my $depth = shift || 0;
-
- my $ou_list =
- actor::org_unit
- ->db_Main
- ->selectcol_arrayref(
- 'SELECT id FROM actor.org_unit_descendants(?,?)',
- {},
- $ou,
- $depth
- );
-
- return undef unless ($ou_list and @$ou_list);
-
- $cn = asset::call_number->retrieve( $cn );
- return undef unless ($cn);
- return undef if ($cn->deleted);
-
- my $call_number = $cn->to_fieldmapper;
- $call_number->copies([]);
-
- $call_number->record( $cn->record->to_fieldmapper );
- $call_number->record->fixed_fields( $cn->record->record_descriptor->next->to_fieldmapper );
-
- for my $cp ( $cn->copies(circ_lib => $ou_list) ) {
- next if ($cp->deleted);
- my $copy = $cp->to_fieldmapper;
- $copy->status( $cp->status->to_fieldmapper );
- $copy->location( $cp->location->to_fieldmapper );
-
- push @{ $call_number->copies }, $copy;
- }
-
- return $call_number;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.asset.call_number.ranged_tree',
- method => 'cn_ranged_tree',
- argc => 1,
- api_level => 1,
-);
-
-
-# XXX Since this is all we need in open-ils.storage for serial stuff ATM, just
-# XXX putting it here instead of creating a whole new file.
-sub issuance_ranged_tree {
- my $self = shift;
- my $client = shift;
- my $iss = shift;
- my $ou = shift;
- my $depth = shift || 0;
-
- my $ou_list =
- actor::org_unit
- ->db_Main
- ->selectcol_arrayref(
- 'SELECT id FROM actor.org_unit_descendants(?,?)',
- {},
- $ou,
- $depth
- );
-
- return undef unless ($ou_list and @$ou_list);
-
- $iss = serial::issuance->retrieve( $iss );
- return undef unless ($iss);
-
- my $issuance = $iss->to_fieldmapper;
- $issuance->items([]);
-
- # Now, gather issuances on the same bib, with the same label and date_published ...
- my @subs = map { $_->id } serial::subscription->search( record_entry => $iss->subscription->record_entry->id );
-
- my @similar_iss = serial::issuance->search_where(
- subscription => \@subs,
- label => $iss->label,
- date_published => $iss->date_published
- );
-
- # ... and add all /their/ items to the target issuance
- for my $i ( @similar_iss ) {
- for my $it ( $i->items() ) {
- next unless $it->unit and not $it->unit->deleted;
- next unless (grep { $it->unit->circ_lib eq $_ } @$ou_list);
-
- my $unit = $it->unit->to_fieldmapper;
- $unit->status( $it->unit->status->to_fieldmapper );
- $unit->location( $it->unit->location->to_fieldmapper );
-
- my $item = $it->to_fieldmapper;
- $item->unit( $unit );
-
- push @{ $issuance->items }, $item;
- }
- }
-
- return $issuance;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.serial.issuance.ranged_tree',
- method => 'issuance_ranged_tree',
- argc => 1,
- api_level => 1,
-);
-
-sub merge_record_assets {
- my $self = shift;
- my $client = shift;
- my $target = shift;
- my @sources = @_;
-
- my $count = 0;
- for my $source ( @sources ) {
- $count += asset::call_number
- ->db_Main
- ->selectcol_arrayref(
- "SELECT asset.merge_record_assets(?,?);",
- {},
- $target,
- $source
- )->[0];
- }
-
- return $count;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.asset.merge_record_assets',
- method => 'merge_record_assets',
- argc => 2,
- api_level => 1,
-);
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::authority;
-use base qw/OpenILS::Application::Storage::Publisher/;
-use vars qw/$VERSION/;
-use OpenSRF::EX qw/:try/;
-use OpenILS::Application::Storage::FTS;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::Normalize qw( naco_normalize );
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::Utils::Cache;
-use Data::Dumper;
-use Digest::MD5 qw/md5_hex/;
-use XML::LibXML;
-use Time::HiRes qw/time sleep/;
-use Unicode::Normalize;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-$VERSION = 1;
-
-my $parser = XML::LibXML->new;
-
-sub validate_tag {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my @tags = @{$args{tags}};
- my @searches = @{$args{searches}};
-
- my $search_table = authority::full_rec->table;
-
- my @values;
- my @selects;
- for my $t ( @tags ) {
- for my $search ( @searches ) {
- my $sf = $$search{subfield};
- my $term = naco_normalize($$search{term}, $sf);
-
- $tag = [$tag] if (!ref($tag));
-
- push @values, $t, $sf, $term;
-
- push @selects,
- "SELECT record FROM $search_table ".
- "WHERE tag = ? AND subfield = ? AND value = ?";
- }
-
- my $sql;
- if ($self->api_name =~ /id_list/) {
- $sql = 'SELECT DISTINCT record FROM (';
- } else {
- $sql = 'SELECT COUNT(DISTINCT record) FROM (';
- }
- $sql .= 'SELECT record FROM (('.join(') INTERSECT (', @selects).')) AS x ';
- $sql .= "JOIN $search_table recheck USING (record) WHERE recheck.tag = ? ";
- $sql .= "GROUP BY 1 HAVING (COUNT(recheck.id) - ?) = 0) AS foo;";
-
- if ($self->api_name =~ /id_list/) {
- my $id_list = authority::full_rec->db_Main->selectcol_arrayref( $sql, {}, @values, $t, scalar(@searches) );
- return $id_list;
- } else {
- my $count = authority::full_rec->db_Main->selectcol_arrayref( $sql, {}, @values, $t, scalar(@searches) )->[0];
- return $count if ($count > 0);
- }
- }
-
- return 0;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.authority.validate.tag",
- method => 'validate_tag',
- api_level => 1,
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.authority.validate.tag.id_list",
- method => 'validate_tag',
- api_level => 1,
-);
-
-
-sub find_authority_marc {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $term = NFD(lc($args{term}));
- my $tag = $args{tag};
- my $subfield = $args{subfield};
- my $limit = $args{limit} || 100;
- my $offset = $args{offset} || 0;
-
- if ($limit) {
- $limit = "LIMIT $limit";
- } else {
- $limit = '';
- }
-
- if ($offset) {
- $offset = "OFFSET $offset";
- } else {
- $offset = '';
- }
-
- my $tag_where = "AND f.tag LIKE '$tag'";
- if (ref $tag) {
- $tag_where = "AND f.tag IN ('".join("','",@$tag)."')";
- }
-
- my $sf_where = "AND f.subfield = '$subfield'";
- if (ref $subfield) {
- $sf_where = "AND f.subfield IN ('".join("','",@$subfield)."')";
- }
-
- my $search_table = authority::full_rec->table;
- my $marc_table = authority::record_entry->table;
-
- my ($index_col) = authority::full_rec->columns('FTS');
- $index_col ||= 'value';
-
- my $fts = OpenILS::Application::Storage::FTS->compile(default => $term, 'f.value', "f.$index_col");
-
- $term =~ s/\W+$//gso;
- $term =~ s/'/''/gso;
- $term =~ s/\pM//gso;
-
- my $fts_where = $fts->sql_where_clause;
- my $fts_words = join '%', $fts->words;
-
- return undef unless ($fts_words);
-
- my $fts_words_where = "f.value LIKE '$fts_words\%'";
- my $fts_start_where = "f.value LIKE '$term\%'";
- my $fts_eq_where = "f.value = '$term'";
-
- my $fts_rank = join '+', $fts->fts_rank;
-
- my $select = <<" SQL";
- SELECT a.marc, sum($fts_rank), count(f.record), first(f.value)
- FROM $search_table f,
- $marc_table a
- WHERE $fts_start_where
- $tag_where
- $sf_where
- AND a.id = f.record
- GROUP BY 1
- ORDER BY 2 desc, 3 desc, 4
- $limit
- $offset
-
- SQL
-
- $log->debug("Authority Search SQL :: [$select]",DEBUG);
-
- my $recs = authority::full_rec->db_Main->selectcol_arrayref( $select );
-
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- $client->respond($_) for (@$recs);
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.authority.search.marc",
- method => 'find_authority_marc',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-sub _empty_check {
- my $term = shift;
- my $class = shift || 'metabib::full_rec';
-
- my $table = $class->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
- my $fts = OpenILS::Application::Storage::FTS->compile(default => $term, 'm.value', "m.$index_col");
- my $fts_where = $fts->sql_where_clause;
-
- my $sql = <<" SQL";
- SELECT TRUE
- FROM $table m
- WHERE $fts_where
- LIMIT 1
- SQL
-
- return $class->db_Main->selectcol_arrayref($sql)->[0];
-}
-
-my $prevtime;
-
-sub find_see_from_controlled {
- my $self = shift;
- my $client = shift;
- my $term = shift;
- my $limit = shift;
- my $offset = shift;
-
- $prevtime = time;
-
- (my $class = $self->api_name) =~ s/^.+authority.([^\.]+)\.see.+$/$1/o;
- my $sf = 'a';
- $sf = 't' if ($class eq 'title');
-
- my @marc = $self->method_lookup('open-ils.storage.authority.search.marc')
- ->run( term => $term, tag => [400,410,411,430,450,455], subfield => $sf, limit => $limit, offset => $offset );
-
-
- for my $m ( @marc ) {
- my $doc = $parser->parse_string($m);
- my @nodes = $doc->documentElement->findnodes('//*[substring(@tag,1,1)="1"]/*[@code="a" or @code="d" or @code="x"]');
- my $list = [ map { $_->textContent } @nodes ];
- $client->respond( $list ) if (_empty_check(join(' ',@$list), "metabib::${class}_field_entry"));
- }
- return undef;
-}
-for my $class ( qw/title author subject keyword series identifier/ ) {
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.authority.$class.see_from.controlled",
- method => 'find_see_from_controlled',
- api_level => 1,
- stream => 1,
- cachable => 1,
- );
-}
-
-sub find_see_also_from_controlled {
- my $self = shift;
- my $client = shift;
- my $term = shift;
- my $limit = shift;
- my $offset = shift;
-
- (my $class = $self->api_name) =~ s/^.+authority.([^\.]+)\.see.+$/$1/o;
- my $sf = 'a';
- $sf = 't' if ($class eq 'title');
-
- my @marc = $self->method_lookup('open-ils.storage.authority.search.marc')
- ->run( term => $term, tag => [500,510,511,530,550,555], subfield => $sf, limit => $limit, offset => $offset );
- for my $m ( @marc ) {
- my $doc = $parser->parse_string($m);
- my @nodes = $doc->documentElement->findnodes('//*[substring(@tag,1,1)="1"]/*[@code="a" or @code="d" or @code="x"]');
- my $list = [ map { $_->textContent } @nodes ];
- $client->respond( $list ) if (_empty_check(join(' ',@$list), "metabib::${class}_field_entry"));
- }
- return undef;
-}
-for my $class ( qw/title author subject keyword series identifier/ ) {
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.authority.$class.see_also_from.controlled",
- method => 'find_see_also_from_controlled',
- api_level => 1,
- stream => 1,
- cachable => 1,
- );
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::biblio;
-use base qw/OpenILS::Application::Storage/;
-use vars qw/$VERSION/;
-use OpenSRF::EX qw/:try/;
-#use OpenILS::Application::Storage::CDBI::biblio;
-#use OpenILS::Application::Storage::CDBI::asset;
-use OpenILS::Utils::Fieldmapper;
-
-$VERSION = 1;
-
-sub record_copy_count {
- my $self = shift;
- my $client = shift;
-
- my %args = @_;
-
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
- my $st_table = config::copy_status->table;
- my $src_table = config::bib_source->table;
- my $br_table = biblio::record_entry->table;
- my $loc_table = asset::copy_location->table;
- my $out_table = actor::org_unit_type->table;
-
- my $descendants = "actor.org_unit_descendants(u.id)";
- my $ancestors = "actor.org_unit_ancestors(?) u JOIN $out_table t ON (u.ou_type = t.id)";
-
- if ($args{org_unit} < 0) {
- $args{org_unit} *= -1;
- $ancestors = "(select org_unit as id from actor.org_lasso_map where lasso = ?) u CROSS JOIN (SELECT -1 AS depth) t";
- }
-
- my $visible = 'AND a.opac_visible = TRUE AND st.opac_visible = TRUE AND loc.opac_visible = TRUE AND cp.opac_visible = TRUE';
- if ($self->api_name =~ /staff/o) {
- $visible = ''
- }
-
- my $sql = <<" SQL";
- SELECT t.depth,
- u.id AS org_unit,
- sum(
- (SELECT count(cp.id)
- FROM $cn_table cn
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $descendants a ON (cp.circ_lib = a.id)
- JOIN $st_table st ON (cp.status = st.id)
- JOIN $loc_table loc ON (cp.location = loc.id)
- WHERE cn.record = ?
- $visible
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE)
- ) AS count,
- sum(
- (SELECT count(cp.id)
- FROM $cn_table cn
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $descendants a ON (cp.circ_lib = a.id)
- JOIN $st_table st ON (cp.status = st.id)
- JOIN $loc_table loc ON (cp.location = loc.id)
- WHERE cn.record = ?
- $visible
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE
- AND cp.status IN (0,7,12))
- ) AS available,
- sum(
- (SELECT count(cp.id)
- FROM $cn_table cn
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $st_table st ON (cp.status = st.id)
- JOIN $loc_table loc ON (cp.location = loc.id)
- WHERE cn.record = ?
- AND st.opac_visible = TRUE
- AND loc.opac_visible = TRUE
- AND cp.opac_visible = TRUE
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE)
- ) AS unshadow,
- sum(
- (SELECT sum(1)
- FROM $br_table br
- JOIN $src_table src ON (src.id = br.source)
- WHERE br.id = ?
- AND src.transcendant IS TRUE
- )
- ) AS transcendant
- FROM $ancestors
- GROUP BY 1,2
- SQL
-
- my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
- $sth->execute(''.$args{record}, ''.$args{record}, ''.$args{record}, ''.$args{record}, ''.$args{org_unit});
- while ( my $row = $sth->fetchrow_hashref ) {
- $client->respond( $row );
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.copy_count',
- method => 'record_copy_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.copy_count.staff',
- method => 'record_copy_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-sub record_ranged_tree {
- my $self = shift;
- my $client = shift;
- my $r = shift;
- my $ou = shift;
- my $depth = shift;
- my $limit = shift || 0;
- my $offset = shift || 0;
-
- my $ou_sql = defined($depth) ?
- "SELECT id FROM actor.org_unit_descendants(?,?)":
- "SELECT id FROM actor.org_unit_descendants(?)";
-
- my $ou_list =
- actor::org_unit
- ->db_Main
- ->selectcol_arrayref(
- $ou_sql,
- {},
- $ou,
- (defined($depth) ? ($depth) : ()),
- );
-
- return undef unless ($ou_list and @$ou_list);
-
- $r = biblio::record_entry->retrieve( $r );
- return undef unless ($r);
-
- my $rec = $r->to_fieldmapper;
- $rec->call_numbers([]);
-
- $rec->fixed_fields( $r->record_descriptor->next->to_fieldmapper );
-
- my $offset_count = 0;
- my $limit_count = 0;
- for my $cn ( $r->call_numbers ) {
- next if ($cn->deleted);
- my $call_number = $cn->to_fieldmapper;
- $call_number->copies([]);
-
-
- for my $cp ( $cn->copies(circ_lib => $ou_list) ) {
- next if ($cp->deleted);
- if ($offset > 0 && $offset_count < $offset) {
- $offset_count++;
- next;
- }
-
- last if ($limit > 0 && $limit_count >= $limit);
-
- my $copy = $cp->to_fieldmapper;
- $copy->status( $cp->status->to_fieldmapper );
- $copy->location( $cp->location->to_fieldmapper );
- push @{ $call_number->copies }, $copy;
-
- $limit_count++;
- }
-
- last if ($limit > 0 && $limit_count >= $limit);
-
- push @{ $rec->call_numbers }, $call_number if (@{ $call_number->copies });
- }
-
- return $rec;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.ranged_tree',
- method => 'record_ranged_tree',
- argc => 1,
- api_level => 1,
-);
-
-sub record_by_barcode {
- my $self = shift;
- my $client = shift;
-
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
-
- my $id = ''.shift;
- my ($r) = biblio::record_entry->db_Main->selectrow_array( <<" SQL", {}, $id );
- SELECT cn.record
- FROM $cn_table cn
- JOIN $cp_table cp ON (cp.call_number = cn.id)
- WHERE cp.barcode = ?
- SQL
-
- my $rec = biblio::record_entry->retrieve( $r );
-
- return $rec->to_fieldmapper if ($rec);
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.retrieve_by_barcode',
- method => 'record_by_barcode',
- api_level => 1,
- cachable => 1,
-);
-
-sub record_by_copy {
- my $self = shift;
- my $client = shift;
-
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
-
- my $id = ''.shift;
- my ($r) = biblio::record_entry->db_Main->selectrow_array( <<" SQL", {}, $id );
- SELECT cn.record
- FROM $cn_table cn
- JOIN $cp_table cp ON (cp.call_number = cn.id)
- WHERE cp.id = ?
- SQL
-
- my $rec = biblio::record_entry->retrieve( $r );
- return undef unless ($rec);
-
- my $r_fm = $rec->to_fieldmapper;
- my $ff = $rec->record_descriptor->next;
- $r_fm->fixed_fields( $ff->to_fieldmapper ) if ($ff);
-
- return $r_fm;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.fleshed.biblio.record_entry.retrieve_by_copy',
- method => 'record_by_copy',
- api_level => 1,
- cachable => 1,
-);
-
-
-=comment Old version
-
-my $org_unit_lookup;
-sub record_copy_count {
- my $self = shift;
- my $client = shift;
- my $oid = shift;
- my @recs = @_;
-
- if ($self->api_name !~ /batch/o) {
- @recs = ($recs[0]);
- }
-
- throw OpenSRF::EX::InvalidArg ( "No org_unit id passed!" )
- unless ($oid);
-
- throw OpenSRF::EX::InvalidArg ( "No record id passed!" )
- unless (@recs);
-
- $org_unit_lookup ||= $self->method_lookup('open-ils.storage.direct.actor.org_unit.retrieve');
- my ($org_unit) = $org_unit_lookup->run($oid);
-
- # XXX Use descendancy tree here!!!
- my $short_name_hack = $org_unit->shortname;
- $short_name_hack = '' if (!$org_unit->parent_ou);
- $short_name_hack .= '%';
- # XXX Use descendancy tree here!!!
-
- my $rec_list = join(',',@recs);
-
- my $cp_table = asset::copy->table;
- my $cn_table = asset::call_number->table;
-
- my $select =<<" SQL";
- SELECT count(cp.*) as copies
- FROM $cn_table cn
- JOIN $cp_table cp ON (cp.call_number = cn.id)
- WHERE cn.owning_lib LIKE ? AND
- cn.record IN ($rec_list)
- SQL
-
- my $sth = asset::copy->db_Main->prepare_cached($select);
- $sth->execute($short_name_hack);
-
- my $results = $sth->fetchall_hashref('record');
-
- $client->respond($$results{$_}{copies} || 0) for (@recs);
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'record_copy_count',
- api_name => 'open-ils.storage.direct.biblio.record_copy_count',
- api_level => 1,
- argc => 1,
-);
-__PACKAGE__->register_method(
- method => 'record_copy_count',
- api_name => 'open-ils.storage.direct.biblio.record_copy_count.batch',
- api_level => 1,
- argc => 1,
- stream => 1,
-);
-
-=cut
-
-sub global_record_copy_count {
- my $self = shift;
- my $client = shift;
-
- my $rec = shift;
-
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
- my $cl_table = asset::copy_location->table;
- my $cs_table = config::copy_status->table;
-
- my $copies_visible = 'AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
- $copies_visible = '' if ($self->api_name =~ /staff/o);
-
- my $sql = <<" SQL";
-
- SELECT owning_lib, sum(avail), sum(tot)
- FROM (
- SELECT cn.owning_lib, count(cp.id) as avail, 0 as tot
- FROM $cn_table cn
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $cs_table cs ON (cs.id = cp.status)
- JOIN $cl_table cl ON (cl.id = cp.location)
- WHERE cn.record = ?
- AND cp.status IN (0,7,12)
- $copies_visible
- GROUP BY 1
- UNION
- SELECT cn.owning_lib, 0 as avail, count(cp.id) as tot
- FROM $cn_table cn
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $cs_table cs ON (cs.id = cp.status)
- JOIN $cl_table cl ON (cl.id = cp.location)
- WHERE cn.record = ?
- $copies_visible
- GROUP BY 1
- ) x
- GROUP BY 1
- SQL
-
- my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
- $sth->execute("$rec", "$rec");
-
- $client->respond( $_ ) for (@{$sth->fetchall_arrayref});
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.global_copy_count',
- method => 'global_record_copy_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.global_copy_count.staff',
- method => 'global_record_copy_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-sub record_copy_status_count {
- my $self = shift;
- my $client = shift;
-
- my $rec = shift;
- my $ou = shift || 1;
- my $depth = shift || 0;
-
-
- my $descendants = "actor.org_unit_descendants(?,?)";
-
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
- my $cl_table = asset::copy_location->table;
- my $cs_table = config::copy_status->table;
-
- my $sql = <<" SQL";
-
- SELECT cp.circ_lib, cn.label, cp.status, count(cp.id)
- FROM $cp_table cp,
- $cn_table cn,
- $cl_table cl,
- $cs_table cs,
- $descendants d
- WHERE cn.record = ?
- AND cp.call_number = cn.id
- AND cp.location = cl.id
- AND cp.circ_lib = d.id
- AND cp.status = cs.id
- AND cl.opac_visible IS TRUE
- AND cp.opac_visible IS TRUE
- AND cp.deleted IS FALSE
- AND cs.opac_visible IS TRUE
- GROUP BY 1,2,3;
- SQL
-
- my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
- $sth->execute($ou, $depth, "$rec" );
-
- my %data = ();
- for my $row (@{$sth->fetchall_arrayref}) {
- $data{$$row[0]}{$$row[1]}{$$row[2]} += $$row[3];
- }
-
- for my $ou (keys %data) {
- for my $cn (keys %{$data{$ou}}) {
- $client->respond( [$ou, $cn, $data{$ou}{$cn}] );
- }
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.status_copy_count',
- method => 'record_copy_status_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-
-sub record_copy_status_location_count {
- my $self = shift;
- my $client = shift;
-
- my $rec = shift;
- my $ou = shift || 1;
- my $depth = shift || 0;
-
-
- my $descendants = "actor.org_unit_descendants(?,?)";
-
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
- my $cl_table = asset::copy_location->table;
- my $cs_table = config::copy_status->table;
-
- # FIXME using oils_i18n_xlate here is exposing a hitherto unexposed
- # implementation detail of json_query; doing it this way because
- # json_query currently doesn't grok joining a function to tables
- my $sql = <<" SQL";
-
- SELECT cp.circ_lib,
- cn.label,
- oils_i18n_xlate('asset.copy_location', 'acpl', 'name', 'id', cl.id::TEXT, ?),
- cp.status,
- count(cp.id)
- FROM $cp_table cp,
- $cn_table cn,
- $cl_table cl,
- $cs_table cs,
- $descendants d
- WHERE cn.record = ?
- AND cp.call_number = cn.id
- AND cp.location = cl.id
- AND cp.circ_lib = d.id
- AND cp.status = cs.id
- AND cl.opac_visible IS TRUE
- AND cp.opac_visible IS TRUE
- AND cp.deleted IS FALSE
- AND cs.opac_visible IS TRUE
- GROUP BY 1,2,3,4;
- SQL
-
- my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
- my $ses_locale = $client->session ? $client->session->session_locale : 'en-US';
- $sth->execute($ses_locale, $ou, $depth, "$rec" );
-
- my %data = ();
- for my $row (@{$sth->fetchall_arrayref}) {
- $data{$$row[0]}{$$row[1]}{$$row[2]}{$$row[3]} += $$row[4];
- }
-
- for my $ou (keys %data) {
- for my $cn (keys %{$data{$ou}}) {
- for my $cl (keys %{$data{$ou}{$cn}}) {
- $client->respond( [$ou, $cn, $cl, $data{$ou}{$cn}{$cl}] );
- }
- }
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.record_entry.status_copy_location_count',
- method => 'record_copy_status_location_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::config;
-use base qw/OpenILS::Application::Storage/;
-use OpenILS::Application::Storage::CDBI::config;
-
-
-sub retrieve_all {
- my $self = shift;
- my $client = shift;
-
- $self->api_name =~ /direct\.config\.(.+)\.retrieve/o;
-
- my $class = 'config::'.$1;
- for my $rec ( $class->retrieve_all ) {
- $client->respond( $rec->to_fieldmapper );
- }
-
- return undef;
-}
-
-for my $class (
- qw/metabib_field standing identification_type copy_status
- non_cataloged_type audience_map item_form_map item_type_map
- language_map lit_form_map bib_source net_access_level/ ) {
-
- __PACKAGE__->register_method(
- method => 'retrieve_all',
- api_name => "open-ils.storage.direct.config.$class.retrieve.all",
- argc => 0,
- stream => 1,
- );
-}
-
-
-# XXX arg, with the descendancy SPs...
-sub ranged_config_non_cat {
- my $self = shift;
- my $client = shift;
- my @binds = @_;
-
- my $ctable = config::non_cataloged_type->table;
-
- my $descendants = defined($binds[1]) ?
- "actor.org_unit_full_path(?, ?)" :
- "actor.org_unit_full_path(?)" ;
-
-
- my $sql = <<" SQL";
- SELECT DISTINCT c.*
- FROM $ctable c
- JOIN $descendants d
- ON (d.id = c.owning_lib)
- SQL
-
- my $sth = config::non_cataloged_type->db_Main->prepare($sql);
- $sth->execute(@binds);
-
- while ( my $rec = $sth->fetchrow_hashref ) {
-
- my $cnct = new Fieldmapper::config::non_cataloged_type;
- $cnct->name($rec->{name});
- $cnct->owning_lib($rec->{owning_lib});
- $cnct->id($rec->{id});
- $cnct->circ_duration($rec->{circ_duration});
- $cnct->in_house($rec->{in_house});
-
- $client->respond( $cnct );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'ranged_config_non_cat',
- api_name => 'open-ils.storage.ranged.config.non_cataloged_type.retrieve',
- argc => 1,
- stream => 1,
- notes => <<" NOTES",
- Returns
- NOTES
-);
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::container;
-use base qw/OpenILS::Application::Storage/;
-#use OpenILS::Application::Storage::CDBI::config;
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::metabib;
-use base qw/OpenILS::Application::Storage::Publisher/;
-use vars qw/$VERSION/;
-use OpenSRF::EX qw/:try/;
-use OpenILS::Application::Storage::FTS;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/:level/;
-use OpenSRF::Utils::Cache;
-use OpenSRF::Utils::JSON;
-use Data::Dumper;
-use Digest::MD5 qw/md5_hex/;
-
-
-my $log = 'OpenSRF::Utils::Logger';
-
-$VERSION = 1;
-
-sub ordered_records_from_metarecord {
- my $self = shift;
- my $client = shift;
- my $mr = shift;
- my $formats = shift;
- my $org = shift || 1;
- my $depth = shift;
-
- my (@types,@forms,@blvl);
-
- if ($formats) {
- my ($t, $f, $b) = split '-', $formats;
- @types = split '', $t;
- @forms = split '', $f;
- @blvl = split '', $b;
- }
-
- my $descendants =
- defined($depth) ?
- "actor.org_unit_descendants($org, $depth)" :
- "actor.org_unit_descendants($org)" ;
-
-
- my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
- $copies_visible = '' if ($self->api_name =~ /staff/o);
-
- my $sm_table = metabib::metarecord_source_map->table;
- my $rd_table = metabib::record_descriptor->table;
- my $fr_table = metabib::full_rec->table;
- my $cn_table = asset::call_number->table;
- my $cl_table = asset::copy_location->table;
- my $cp_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $src_table = config::bib_source->table;
- my $out_table = actor::org_unit_type->table;
- my $br_table = biblio::record_entry->table;
-
- my $sql = <<" SQL";
- SELECT record,
- item_type,
- item_form,
- quality,
- FIRST(COALESCE(LTRIM(SUBSTR( value, COALESCE(SUBSTRING(ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'zzzzzzzz')) AS title
- FROM (
- SELECT rd.record,
- rd.item_type,
- rd.item_form,
- br.quality,
- fr.tag,
- fr.subfield,
- fr.value,
- fr.ind2
- SQL
-
- if ($copies_visible) {
- $sql .= <<" SQL";
- FROM $sm_table sm,
- $br_table br,
- $fr_table fr,
- $rd_table rd
- WHERE rd.record = sm.source
- AND fr.record = sm.source
- AND br.id = sm.source
- AND sm.metarecord = ?
- AND (EXISTS ((SELECT 1
- FROM $cp_table cp
- JOIN $cn_table cn ON (cp.call_number = cn.id)
- JOIN $cs_table cs ON (cp.status = cs.id)
- JOIN $cl_table cl ON (cp.location = cl.id)
- JOIN $descendants d ON (cp.circ_lib = d.id)
- WHERE cn.record = sm.source
- $copies_visible
- LIMIT 1))
- OR EXISTS ((
- SELECT 1
- FROM $src_table src
- WHERE src.id = br.source
- AND src.transcendant IS TRUE))
- )
-
- SQL
- } else {
- $sql .= <<" SQL";
- FROM $sm_table sm
- JOIN $br_table br ON (sm.source = br.id)
- JOIN $fr_table fr ON (fr.record = br.id)
- JOIN $rd_table rd ON (rd.record = br.id)
- WHERE sm.metarecord = ?
- AND (( EXISTS (
- SELECT 1
- FROM $cp_table cp,
- $cn_table cn,
- $descendants d
- WHERE cn.record = br.id
- AND cn.deleted = FALSE
- AND cp.deleted = FALSE
- AND cp.circ_lib = d.id
- AND cn.id = cp.call_number
- LIMIT 1
- ) OR NOT EXISTS (
- SELECT 1
- FROM $cp_table cp,
- $cn_table cn
- WHERE cn.record = br.id
- AND cn.deleted = FALSE
- AND cp.deleted = FALSE
- AND cn.id = cp.call_number
- LIMIT 1
- ))
- OR EXISTS ((
- SELECT 1
- FROM $src_table src
- WHERE src.id = br.source
- AND src.transcendant IS TRUE))
- )
- SQL
- }
-
- if (@types) {
- $sql .= ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $sql .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- }
-
- if (@blvl) {
- $sql .= ' AND rd.bib_level IN ('.join(',',map{'?'}@blvl).')';
- }
-
-
-
- $sql .= <<" SQL";
- OFFSET 0
- ) AS x
- WHERE tag = '245'
- AND subfield = 'a'
- GROUP BY record, item_type, item_form, quality
- ORDER BY
- CASE
- WHEN item_type IS NULL -- default
- THEN 0
- WHEN item_type = '' -- default
- THEN 0
- WHEN item_type IN ('a','t') -- books
- THEN 1
- WHEN item_type = 'g' -- movies
- THEN 2
- WHEN item_type IN ('i','j') -- sound recordings
- THEN 3
- WHEN item_type = 'm' -- software
- THEN 4
- WHEN item_type = 'k' -- images
- THEN 5
- WHEN item_type IN ('e','f') -- maps
- THEN 6
- WHEN item_type IN ('o','p') -- mixed
- THEN 7
- WHEN item_type IN ('c','d') -- music
- THEN 8
- WHEN item_type = 'r' -- 3d
- THEN 9
- END,
- title ASC,
- quality DESC
- SQL
-
- my $ids = metabib::metarecord_source_map->db_Main->selectcol_arrayref($sql, {}, "$mr", @types, @forms, @blvl);
- return $ids if ($self->api_name =~ /atomic$/o);
-
- $client->respond( $_ ) for ( @$ids );
- return undef;
-
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ordered.metabib.metarecord.records',
- method => 'ordered_records_from_metarecord',
- api_level => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ordered.metabib.metarecord.records.staff',
- method => 'ordered_records_from_metarecord',
- api_level => 1,
- cachable => 1,
-);
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ordered.metabib.metarecord.records.atomic',
- method => 'ordered_records_from_metarecord',
- api_level => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.ordered.metabib.metarecord.records.staff.atomic',
- method => 'ordered_records_from_metarecord',
- api_level => 1,
- cachable => 1,
-);
-
-sub isxn_search {
- my $self = shift;
- my $client = shift;
- my $isxn = lc(shift());
-
- $isxn =~ s/^\s*//o;
- $isxn =~ s/\s*$//o;
- $isxn =~ s/-//o if ($self->api_name =~ /isbn/o);
-
- my $tag = ($self->api_name =~ /isbn/o) ? "'020' OR f.tag = '024'" : "'022'";
-
- my $fr_table = metabib::full_rec->table;
- my $bib_table = biblio::record_entry->table;
-
- my $sql = <<" SQL";
- SELECT DISTINCT f.record
- FROM $fr_table f
- JOIN $bib_table b ON (b.id = f.record)
- WHERE (f.tag = $tag)
- AND f.value LIKE ?
- AND b.deleted IS FALSE
- SQL
-
- my $list = metabib::full_rec->db_Main->selectcol_arrayref($sql, {}, "$isxn%");
- $client->respond($_) for (@$list);
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.id_list.biblio.record_entry.search.isbn',
- method => 'isxn_search',
- api_level => 1,
- stream => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.id_list.biblio.record_entry.search.issn',
- method => 'isxn_search',
- api_level => 1,
- stream => 1,
-);
-
-sub metarecord_copy_count {
- my $self = shift;
- my $client = shift;
-
- my %args = @_;
-
- my $sm_table = metabib::metarecord_source_map->table;
- my $rd_table = metabib::record_descriptor->table;
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
- my $br_table = biblio::record_entry->table;
- my $src_table = config::bib_source->table;
- my $cl_table = asset::copy_location->table;
- my $cs_table = config::copy_status->table;
- my $out_table = actor::org_unit_type->table;
-
- my $descendants = "actor.org_unit_descendants(u.id)";
- my $ancestors = "actor.org_unit_ancestors(?) u JOIN $out_table t ON (u.ou_type = t.id)";
-
- if ($args{org_unit} < 0) {
- $args{org_unit} *= -1;
- $ancestors = "(select org_unit as id from actor.org_lasso_map where lasso = ?) u CROSS JOIN (SELECT -1 AS depth) t";
- }
-
- my $copies_visible = 'AND a.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
- $copies_visible = '' if ($self->api_name =~ /staff/o);
-
- my (@types,@forms,@blvl);
- my ($t_filter, $f_filter, $b_filter) = ('','','');
-
- if ($args{format}) {
- my ($t, $f, $b) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- @blvl = split '', $b;
-
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- }
-
- if (@blvl) {
- $b_filter .= ' AND rd.bib_level IN ('.join(',',map{'?'}@blvl).')';
- }
- }
-
- my $sql = <<" SQL";
- SELECT t.depth,
- u.id AS org_unit,
- sum(
- (SELECT count(cp.id)
- FROM $sm_table r
- JOIN $cn_table cn ON (cn.record = r.source)
- JOIN $rd_table rd ON (cn.record = rd.record)
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $cs_table cs ON (cp.status = cs.id)
- JOIN $cl_table cl ON (cp.location = cl.id)
- JOIN $descendants a ON (cp.circ_lib = a.id)
- WHERE r.metarecord = ?
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE
- $copies_visible
- $t_filter
- $f_filter
- $b_filter
- )
- ) AS count,
- sum(
- (SELECT count(cp.id)
- FROM $sm_table r
- JOIN $cn_table cn ON (cn.record = r.source)
- JOIN $rd_table rd ON (cn.record = rd.record)
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $cs_table cs ON (cp.status = cs.id)
- JOIN $cl_table cl ON (cp.location = cl.id)
- JOIN $descendants a ON (cp.circ_lib = a.id)
- WHERE r.metarecord = ?
- AND cp.status IN (0,7,12)
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE
- $copies_visible
- $t_filter
- $f_filter
- $b_filter
- )
- ) AS available,
- sum(
- (SELECT count(cp.id)
- FROM $sm_table r
- JOIN $cn_table cn ON (cn.record = r.source)
- JOIN $rd_table rd ON (cn.record = rd.record)
- JOIN $cp_table cp ON (cn.id = cp.call_number)
- JOIN $cs_table cs ON (cp.status = cs.id)
- JOIN $cl_table cl ON (cp.location = cl.id)
- WHERE r.metarecord = ?
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE
- AND cp.opac_visible IS TRUE
- AND cs.opac_visible IS TRUE
- AND cl.opac_visible IS TRUE
- $t_filter
- $f_filter
- $b_filter
- )
- ) AS unshadow,
- sum(
- (SELECT sum(1)
- FROM $sm_table r
- JOIN $br_table br ON (br.id = r.source)
- JOIN $src_table src ON (src.id = br.source)
- WHERE r.metarecord = ?
- AND src.transcendant IS TRUE
- )
- ) AS transcendant
-
- FROM $ancestors
- GROUP BY 1,2
- SQL
-
- my $sth = metabib::metarecord_source_map->db_Main->prepare_cached($sql);
- $sth->execute( ''.$args{metarecord},
- @types,
- @forms,
- @blvl,
- ''.$args{metarecord},
- @types,
- @forms,
- @blvl,
- ''.$args{metarecord},
- @types,
- @forms,
- @blvl,
- ''.$args{metarecord},
- ''.$args{org_unit},
- );
-
- while ( my $row = $sth->fetchrow_hashref ) {
- $client->respond( $row );
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.metabib.metarecord.copy_count',
- method => 'metarecord_copy_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.metabib.metarecord.copy_count.staff',
- method => 'metarecord_copy_count',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-sub biblio_multi_search_full_rec {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $class_join = $args{class_join} || 'AND';
- my $limit = $args{limit} || 100;
- my $offset = $args{offset} || 0;
- my $sort = $args{'sort'};
- my $sort_dir = $args{sort_dir} || 'DESC';
-
- my @binds;
- my @selects;
-
- for my $arg (@{ $args{searches} }) {
- my $term = $$arg{term};
- my $limiters = $$arg{restrict};
-
- my ($index_col) = metabib::full_rec->columns('FTS');
- $index_col ||= 'value';
- my $search_table = metabib::full_rec->table;
-
- my $fts = OpenILS::Application::Storage::FTS->compile('default' => $term, 'value',"$index_col");
-
- my $fts_where = $fts->sql_where_clause();
- my @fts_ranks = $fts->fts_rank;
-
- my $rank = join(' + ', @fts_ranks);
-
- my @wheres;
- for my $limit (@$limiters) {
- if ($$limit{tag} =~ /^\d+$/ and $$limit{tag} < 10) {
- # MARC control field; mfr.subfield is NULL
- push @wheres, "( tag = ? AND $fts_where )";
- push @binds, $$limit{tag};
- $log->debug("Limiting query using { tag => $$limit{tag} }", DEBUG);
- } else {
- push @wheres, "( tag = ? AND subfield LIKE ? AND $fts_where )";
- push @binds, $$limit{tag}, $$limit{subfield};
- $log->debug("Limiting query using { tag => $$limit{tag}, subfield => $$limit{subfield} }", DEBUG);
- }
- }
- my $where = join(' OR ', @wheres);
-
- push @selects, "SELECT id, record, $rank as sum FROM $search_table WHERE $where";
-
- }
-
- my $descendants = defined($args{depth}) ?
- "actor.org_unit_descendants($args{org_unit}, $args{depth})" :
- "actor.org_unit_descendants($args{org_unit})" ;
-
-
- my $metabib_record_descriptor = metabib::record_descriptor->table;
- my $metabib_full_rec = metabib::full_rec->table;
- my $asset_call_number_table = asset::call_number->table;
- my $asset_copy_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $cl_table = asset::copy_location->table;
- my $br_table = biblio::record_entry->table;
-
- my $cj = 'HAVING COUNT(x.id) = ' . scalar(@selects) if ($class_join eq 'AND');
- my $search_table =
- '(SELECT x.record, sum(x.sum) FROM (('.
- join(') UNION ALL (', @selects).
- ")) x GROUP BY 1 $cj ORDER BY 2 DESC )";
-
- my $has_vols = 'AND cn.owning_lib = d.id';
- my $has_copies = 'AND cp.call_number = cn.id';
- my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
-
- if ($self->api_name =~ /staff/o) {
- $copies_visible = '';
- $has_copies = '' if ($ou_type == 0);
- $has_vols = '' if ($ou_type == 0);
- }
-
- my ($t_filter, $f_filter) = ('','');
- my ($a_filter, $l_filter, $lf_filter) = ('','','');
-
- if (my $a = $args{audience}) {
- $a = [$a] if (!ref($a));
- my @aud = @$a;
-
- $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
- push @binds, @aud;
- }
-
- if (my $l = $args{language}) {
- $l = [$l] if (!ref($l));
- my @lang = @$l;
-
- $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
- push @binds, @lang;
- }
-
- if (my $f = $args{lit_form}) {
- $f = [$f] if (!ref($f));
- my @lit_form = @$f;
-
- $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- push @binds, @lit_form;
- }
-
- if (my $f = $args{item_form}) {
- $f = [$f] if (!ref($f));
- my @forms = @$f;
-
- $f_filter = ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- push @binds, @forms;
- }
-
- if (my $t = $args{item_type}) {
- $t = [$t] if (!ref($t));
- my @types = @$t;
-
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- push @binds, @types;
- }
-
-
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- my @types = split '', $t;
- my @forms = split '', $f;
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- }
- push @binds, @types, @forms;
- }
-
- my $relevance = 'sum(f.sum)';
- $relevance = 1 if (!$copies_visible);
-
- my $rank = $relevance;
- if (lc($sort) eq 'pubdate') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d+'),'9999')::INT
- FROM $metabib_full_rec frp
- WHERE frp.record = f.record
- AND frp.tag = '260'
- AND frp.subfield = 'c'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'create_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = f.record)) )
- RANK
- } elsif (lc($sort) eq 'edit_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = f.record)) )
- RANK
- } elsif (lc($sort) eq 'title') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'zzzzzzzz')
- FROM $metabib_full_rec frt
- WHERE frt.record = f.record
- AND frt.tag = '245'
- AND frt.subfield = 'a'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'author') {
- $rank = <<" RANK";
- ( FIRST((
- SELECT COALESCE(LTRIM(fra.value),'zzzzzzzz')
- FROM $metabib_full_rec fra
- WHERE fra.record = f.record
- AND fra.tag LIKE '1%'
- AND fra.subfield = 'a'
- ORDER BY fra.tag::text::int
- LIMIT 1
- )) )
- RANK
- } else {
- $sort = undef;
- }
-
-
- if ($copies_visible) {
- $select = <<" SQL";
- SELECT f.record, $relevance, count(DISTINCT cp.id), $rank
- FROM $search_table f,
- $asset_call_number_table cn,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $br_table br,
- $metabib_record_descriptor rd,
- $descendants d
- WHERE br.id = f.record
- AND cn.record = f.record
- AND rd.record = f.record
- AND cp.status = cs.id
- AND cp.location = cl.id
- AND br.deleted IS FALSE
- AND cn.deleted IS FALSE
- AND cp.deleted IS FALSE
- $has_vols
- $has_copies
- $copies_visible
- $t_filter
- $f_filter
- $a_filter
- $l_filter
- $lf_filter
- GROUP BY f.record HAVING count(DISTINCT cp.id) > 0
- ORDER BY 4 $sort_dir,3 DESC
- SQL
- } else {
- $select = <<" SQL";
- SELECT f.record, 1, 1, $rank
- FROM $search_table f,
- $br_table br,
- $metabib_record_descriptor rd
- WHERE br.id = f.record
- AND rd.record = f.record
- AND br.deleted IS FALSE
- $t_filter
- $f_filter
- $a_filter
- $l_filter
- $lf_filter
- GROUP BY 1,2,3
- ORDER BY 4 $sort_dir
- SQL
- }
-
-
- $log->debug("Search SQL :: [$select]",DEBUG);
-
- my $recs = metabib::full_rec->db_Main->selectall_arrayref("$select;", {}, @binds);
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- my $max = 0;
- $max = 1 if (!@$recs);
- for (@$recs) {
- $max = $$_[1] if ($$_[1] > $max);
- }
-
- my $count = @$recs;
- for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
- next unless ($$rec[0]);
- my ($rid,$rank,$junk,$skip) = @$rec;
- $client->respond( [$rid, sprintf('%0.3f',$rank/$max), $count] );
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.full_rec.multi_search',
- method => 'biblio_multi_search_full_rec',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.biblio.full_rec.multi_search.staff',
- method => 'biblio_multi_search_full_rec',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-sub search_full_rec {
- my $self = shift;
- my $client = shift;
-
- my %args = @_;
-
- my $term = $args{term};
- my $limiters = $args{restrict};
-
- my ($index_col) = metabib::full_rec->columns('FTS');
- $index_col ||= 'value';
- my $search_table = metabib::full_rec->table;
-
- my $fts = OpenILS::Application::Storage::FTS->compile('default' => $term, 'value',"$index_col");
-
- my $fts_where = $fts->sql_where_clause();
- my @fts_ranks = $fts->fts_rank;
-
- my $rank = join(' + ', @fts_ranks);
-
- my @binds;
- my @wheres;
- for my $limit (@$limiters) {
- if ($$limit{tag} =~ /^\d+$/ and $$limit{tag} < 10) {
- # MARC control field; mfr.subfield is NULL
- push @wheres, "( tag = ? AND $fts_where )";
- push @binds, $$limit{tag};
- $log->debug("Limiting query using { tag => $$limit{tag} }", DEBUG);
- } else {
- push @wheres, "( tag = ? AND subfield LIKE ? AND $fts_where )";
- push @binds, $$limit{tag}, $$limit{subfield};
- $log->debug("Limiting query using { tag => $$limit{tag}, subfield => $$limit{subfield} }", DEBUG);
- }
- }
- my $where = join(' OR ', @wheres);
-
- my $select = "SELECT record, sum($rank) FROM $search_table WHERE $where GROUP BY 1 ORDER BY 2 DESC;";
-
- $log->debug("Search SQL :: [$select]",DEBUG);
-
- my $recs = metabib::full_rec->db_Main->selectall_arrayref($select, {}, @binds);
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- $client->respond($_) for (@$recs);
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.metabib.full_rec.search_fts.value',
- method => 'search_full_rec',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.storage.direct.metabib.full_rec.search_fts.index_vector',
- method => 'search_full_rec',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-
-# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
-sub search_class_fts {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $term = $args{term};
- my $ou = $args{org_unit};
- my $ou_type = $args{depth};
- my $limit = $args{limit};
- my $offset = $args{offset};
-
- my $limit_clause = '';
- my $offset_clause = '';
-
- $limit_clause = "LIMIT $limit" if (defined $limit and int($limit) > 0);
- $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
-
- my (@types,@forms);
- my ($t_filter, $f_filter) = ('','');
-
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- }
- }
-
-
-
- my $descendants = defined($ou_type) ?
- "actor.org_unit_descendants($ou, $ou_type)" :
- "actor.org_unit_descendants($ou)";
-
- my $class = $self->{cdbi};
- my $search_table = $class->table;
-
- my $metabib_record_descriptor = metabib::record_descriptor->table;
- my $metabib_metarecord = metabib::metarecord->table;
- my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
- my $asset_call_number_table = asset::call_number->table;
- my $asset_copy_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $cl_table = asset::copy_location->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
- (my $search_class = $self->api_name) =~ s/.*metabib.(\w+).search_fts.*/$1/o;
- my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $term, 'f.value', "f.$index_col");
-
- my $fts_where = $fts->sql_where_clause;
- my @fts_ranks = $fts->fts_rank;
-
- my $rank = join(' + ', @fts_ranks);
-
- my $has_vols = 'AND cn.owning_lib = d.id';
- my $has_copies = 'AND cp.call_number = cn.id';
- my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
-
- my $visible_count = ', count(DISTINCT cp.id)';
- my $visible_count_test = 'HAVING count(DISTINCT cp.id) > 0';
-
- if ($self->api_name =~ /staff/o) {
- $copies_visible = '';
- $visible_count_test = '';
- $has_copies = '' if ($ou_type == 0);
- $has_vols = '' if ($ou_type == 0);
- }
-
- my $rank_calc = <<" RANK";
- , (SUM( $rank
- * CASE WHEN f.value ILIKE ? THEN 1.2 ELSE 1 END -- phrase order
- * CASE WHEN f.value ILIKE ? THEN 1.5 ELSE 1 END -- first word match
- * CASE WHEN f.value ~* ? THEN 2 ELSE 1 END -- only word match
- )/COUNT(m.source)), MIN(COALESCE(CHAR_LENGTH(f.value),1))
- RANK
-
- $rank_calc = ',1 , 1' if ($self->api_name =~ /unordered/o);
-
- if ($copies_visible) {
- $select = <<" SQL";
- SELECT m.metarecord $rank_calc $visible_count, CASE WHEN COUNT(DISTINCT m.source) = 1 THEN MAX(m.source) ELSE MAX(0) END
- FROM $search_table f,
- $metabib_metarecord_source_map_table m,
- $asset_call_number_table cn,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $metabib_record_descriptor rd,
- $descendants d
- WHERE $fts_where
- AND m.source = f.source
- AND cn.record = m.source
- AND rd.record = m.source
- AND cp.status = cs.id
- AND cp.location = cl.id
- $has_vols
- $has_copies
- $copies_visible
- $t_filter
- $f_filter
- GROUP BY 1 $visible_count_test
- ORDER BY 2 DESC,3
- $limit_clause $offset_clause
- SQL
- } else {
- $select = <<" SQL";
- SELECT m.metarecord $rank_calc, 0, CASE WHEN COUNT(DISTINCT m.source) = 1 THEN MAX(m.source) ELSE MAX(0) END
- FROM $search_table f,
- $metabib_metarecord_source_map_table m,
- $metabib_record_descriptor rd
- WHERE $fts_where
- AND m.source = f.source
- AND rd.record = m.source
- $t_filter
- $f_filter
- GROUP BY 1, 4
- ORDER BY 2 DESC,3
- $limit_clause $offset_clause
- SQL
- }
-
- $log->debug("Field Search SQL :: [$select]",DEBUG);
-
- my $SQLstring = join('%',$fts->words);
- my $REstring = join('\\s+',$fts->words);
- my $first_word = ($fts->words)[0].'%';
- my $recs = ($self->api_name =~ /unordered/o) ?
- $class->db_Main->selectall_arrayref($select, {}, @types, @forms) :
- $class->db_Main->selectall_arrayref($select, {},
- '%'.lc($SQLstring).'%', # phrase order match
- lc($first_word), # first word match
- '^\\s*'.lc($REstring).'\\s*/?\s*$', # full exact match
- @types, @forms
- );
-
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- $client->respond($_) for (map { [@$_[0,1,3,4]] } @$recs);
- return undef;
-}
-
-for my $class ( qw/title author subject keyword series identifier/ ) {
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.search_fts.metarecord",
- method => 'search_class_fts',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.search_fts.metarecord.unordered",
- method => 'search_class_fts',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.search_fts.metarecord.staff",
- method => 'search_class_fts',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.search_fts.metarecord.staff.unordered",
- method => 'search_class_fts',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
-}
-
-# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
-sub search_class_fts_count {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $term = $args{term};
- my $ou = $args{org_unit};
- my $ou_type = $args{depth};
- my $limit = $args{limit} || 100;
- my $offset = $args{offset} || 0;
-
- my $descendants = defined($ou_type) ?
- "actor.org_unit_descendants($ou, $ou_type)" :
- "actor.org_unit_descendants($ou)";
-
- my (@types,@forms);
- my ($t_filter, $f_filter) = ('','');
-
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- }
- }
-
-
- (my $search_class = $self->api_name) =~ s/.*metabib.(\w+).search_fts.*/$1/o;
-
- my $class = $self->{cdbi};
- my $search_table = $class->table;
-
- my $metabib_record_descriptor = metabib::record_descriptor->table;
- my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
- my $asset_call_number_table = asset::call_number->table;
- my $asset_copy_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $cl_table = asset::copy_location->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
- my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $term, 'value',"$index_col");
-
- my $fts_where = $fts->sql_where_clause;
-
- my $has_vols = 'AND cn.owning_lib = d.id';
- my $has_copies = 'AND cp.call_number = cn.id';
- my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
- if ($self->api_name =~ /staff/o) {
- $copies_visible = '';
- $has_vols = '' if ($ou_type == 0);
- $has_copies = '' if ($ou_type == 0);
- }
-
- # XXX test an "EXISTS version of descendant checking...
- my $select;
- if ($copies_visible) {
- $select = <<" SQL";
- SELECT count(distinct m.metarecord)
- FROM $search_table f,
- $metabib_metarecord_source_map_table m,
- $metabib_metarecord_source_map_table mr,
- $asset_call_number_table cn,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $metabib_record_descriptor rd,
- $descendants d
- WHERE $fts_where
- AND mr.source = f.source
- AND mr.metarecord = m.metarecord
- AND cn.record = m.source
- AND rd.record = m.source
- AND cp.status = cs.id
- AND cp.location = cl.id
- $has_vols
- $has_copies
- $copies_visible
- $t_filter
- $f_filter
- SQL
- } else {
- $select = <<" SQL";
- SELECT count(distinct m.metarecord)
- FROM $search_table f,
- $metabib_metarecord_source_map_table m,
- $metabib_metarecord_source_map_table mr,
- $metabib_record_descriptor rd
- WHERE $fts_where
- AND mr.source = f.source
- AND mr.metarecord = m.metarecord
- AND rd.record = m.source
- $t_filter
- $f_filter
- SQL
- }
-
- $log->debug("Field Search Count SQL :: [$select]",DEBUG);
-
- my $recs = $class->db_Main->selectrow_arrayref($select, {}, @types, @forms)->[0];
-
- $log->debug("Count Search yielded $recs results.",DEBUG);
-
- return $recs;
-
-}
-for my $class ( qw/title author subject keyword series identifier/ ) {
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.search_fts.metarecord_count",
- method => 'search_class_fts_count',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.search_fts.metarecord_count.staff",
- method => 'search_class_fts_count',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
-}
-
-
-# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
-sub postfilter_search_class_fts {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $term = $args{term};
- my $sort = $args{'sort'};
- my $sort_dir = $args{sort_dir} || 'DESC';
- my $ou = $args{org_unit};
- my $ou_type = $args{depth};
- my $limit = $args{limit} || 10;
- my $visibility_limit = $args{visibility_limit} || 5000;
- my $offset = $args{offset} || 0;
-
- my $outer_limit = 1000;
-
- my $limit_clause = '';
- my $offset_clause = '';
-
- $limit_clause = "LIMIT $outer_limit";
- $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
-
- my (@types,@forms,@lang,@aud,@lit_form);
- my ($t_filter, $f_filter) = ('','');
- my ($a_filter, $l_filter, $lf_filter) = ('','','');
- my ($ot_filter, $of_filter) = ('','');
- my ($oa_filter, $ol_filter, $olf_filter) = ('','','');
-
- if (my $a = $args{audience}) {
- $a = [$a] if (!ref($a));
- @aud = @$a;
-
- $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
- $oa_filter = ' AND ord.audience IN ('.join(',',map{'?'}@aud).')';
- }
-
- if (my $l = $args{language}) {
- $l = [$l] if (!ref($l));
- @lang = @$l;
-
- $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
- $ol_filter = ' AND ord.item_lang IN ('.join(',',map{'?'}@lang).')';
- }
-
- if (my $f = $args{lit_form}) {
- $f = [$f] if (!ref($f));
- @lit_form = @$f;
-
- $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- $olf_filter = ' AND ord.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- }
-
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- $of_filter .= ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
- }
- }
-
-
- my $descendants = defined($ou_type) ?
- "actor.org_unit_descendants($ou, $ou_type)" :
- "actor.org_unit_descendants($ou)";
-
- my $class = $self->{cdbi};
- my $search_table = $class->table;
-
- my $metabib_full_rec = metabib::full_rec->table;
- my $metabib_record_descriptor = metabib::record_descriptor->table;
- my $metabib_metarecord = metabib::metarecord->table;
- my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
- my $asset_call_number_table = asset::call_number->table;
- my $asset_copy_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $cl_table = asset::copy_location->table;
- my $br_table = biblio::record_entry->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
- (my $search_class = $self->api_name) =~ s/.*metabib.(\w+).post_filter.*/$1/o;
-
- my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $term, 'f.value', "f.$index_col");
-
- my $SQLstring = join('%',map { lc($_) } $fts->words);
- my $REstring = '^' . join('\s+',map { lc($_) } $fts->words) . '\W*$';
- my $first_word = lc(($fts->words)[0]).'%';
-
- my $fts_where = $fts->sql_where_clause;
- my @fts_ranks = $fts->fts_rank;
-
- my %bonus = ();
- $bonus{'metabib::identifier_field_entry'} =
- $bonus{'metabib::keyword_field_entry'} = [
- { 'CASE WHEN f.value ILIKE ? THEN 1.2 ELSE 1 END' => $SQLstring }
- ];
-
- $bonus{'metabib::title_field_entry'} =
- $bonus{'metabib::series_field_entry'} = [
- { 'CASE WHEN f.value ILIKE ? THEN 1.5 ELSE 1 END' => $first_word },
- { 'CASE WHEN f.value ~* ? THEN 2 ELSE 1 END' => $REstring },
- @{ $bonus{'metabib::keyword_field_entry'} }
- ];
-
- my $bonus_list = join ' * ', map { keys %$_ } @{ $bonus{$class} };
- $bonus_list ||= '1';
-
- my @bonus_values = map { values %$_ } @{ $bonus{$class} };
-
- my $relevance = join(' + ', @fts_ranks);
- $relevance = <<" RANK";
- (SUM( ( $relevance ) * ( $bonus_list ) )/COUNT(m.source))
- RANK
-
- my $string_default_sort = 'zzzz';
- $string_default_sort = 'AAAA' if ($sort_dir eq 'DESC');
-
- my $number_default_sort = '9999';
- $number_default_sort = '0000' if ($sort_dir eq 'DESC');
-
- my $rank = $relevance;
- if (lc($sort) eq 'pubdate') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d+'),'$number_default_sort')::INT
- FROM $metabib_full_rec frp
- WHERE frp.record = mr.master_record
- AND frp.tag = '260'
- AND frp.subfield = 'c'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'create_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
- RANK
- } elsif (lc($sort) eq 'edit_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
- RANK
- } elsif (lc($sort) eq 'title') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
- FROM $metabib_full_rec frt
- WHERE frt.record = mr.master_record
- AND frt.tag = '245'
- AND frt.subfield = 'a'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'author') {
- $rank = <<" RANK";
- ( FIRST((
- SELECT COALESCE(LTRIM(fra.value),'$string_default_sort')
- FROM $metabib_full_rec fra
- WHERE fra.record = mr.master_record
- AND fra.tag LIKE '1%'
- AND fra.subfield = 'a'
- ORDER BY fra.tag::text::int
- LIMIT 1
- )) )
- RANK
- } else {
- $sort = undef;
- }
-
- my $select = <<" SQL";
- SELECT m.metarecord,
- $relevance,
- CASE WHEN COUNT(DISTINCT smrs.source) = 1 THEN MIN(m.source) ELSE 0 END,
- $rank
- FROM $search_table f,
- $metabib_metarecord_source_map_table m,
- $metabib_metarecord_source_map_table smrs,
- $metabib_metarecord mr,
- $metabib_record_descriptor rd
- WHERE $fts_where
- AND smrs.metarecord = mr.id
- AND m.source = f.source
- AND m.metarecord = mr.id
- AND rd.record = smrs.source
- $t_filter
- $f_filter
- $a_filter
- $l_filter
- $lf_filter
- GROUP BY m.metarecord
- ORDER BY 4 $sort_dir, MIN(COALESCE(CHAR_LENGTH(f.value),1))
- LIMIT $visibility_limit
- SQL
-
- if (0) {
- $select = <<" SQL";
-
- SELECT DISTINCT s.*
- FROM $asset_call_number_table cn,
- $metabib_metarecord_source_map_table mrs,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $br_table br,
- $descendants d,
- $metabib_record_descriptor ord,
- ($select) s
- WHERE mrs.metarecord = s.metarecord
- AND br.id = mrs.source
- AND cn.record = mrs.source
- AND cp.status = cs.id
- AND cp.location = cl.id
- AND cn.owning_lib = d.id
- AND cp.call_number = cn.id
- AND cp.opac_visible IS TRUE
- AND cs.opac_visible IS TRUE
- AND cl.opac_visible IS TRUE
- AND d.opac_visible IS TRUE
- AND br.active IS TRUE
- AND br.deleted IS FALSE
- AND ord.record = mrs.source
- $ot_filter
- $of_filter
- $oa_filter
- $ol_filter
- $olf_filter
- ORDER BY 4 $sort_dir
- SQL
- } elsif ($self->api_name !~ /staff/o) {
- $select = <<" SQL";
-
- SELECT DISTINCT s.*
- FROM ($select) s
- WHERE EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $metabib_metarecord_source_map_table mrs,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $br_table br,
- $descendants d,
- $metabib_record_descriptor ord
-
- WHERE mrs.metarecord = s.metarecord
- AND br.id = mrs.source
- AND cn.record = mrs.source
- AND cp.status = cs.id
- AND cp.location = cl.id
- AND cp.circ_lib = d.id
- AND cp.call_number = cn.id
- AND cp.opac_visible IS TRUE
- AND cs.opac_visible IS TRUE
- AND cl.opac_visible IS TRUE
- AND d.opac_visible IS TRUE
- AND br.active IS TRUE
- AND br.deleted IS FALSE
- AND ord.record = mrs.source
- $ot_filter
- $of_filter
- $oa_filter
- $ol_filter
- $olf_filter
- LIMIT 1
- )
- ORDER BY 4 $sort_dir
- SQL
- } else {
- $select = <<" SQL";
-
- SELECT DISTINCT s.*
- FROM ($select) s
- WHERE EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $asset_copy_table cp,
- $metabib_metarecord_source_map_table mrs,
- $br_table br,
- $descendants d,
- $metabib_record_descriptor ord
-
- WHERE mrs.metarecord = s.metarecord
- AND br.id = mrs.source
- AND cn.record = mrs.source
- AND cn.id = cp.call_number
- AND br.deleted IS FALSE
- AND cn.deleted IS FALSE
- AND ord.record = mrs.source
- AND ( cn.owning_lib = d.id
- OR ( cp.circ_lib = d.id
- AND cp.deleted IS FALSE
- )
- )
- $ot_filter
- $of_filter
- $oa_filter
- $ol_filter
- $olf_filter
- LIMIT 1
- )
- OR NOT EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $metabib_metarecord_source_map_table mrs,
- $metabib_record_descriptor ord
- WHERE mrs.metarecord = s.metarecord
- AND cn.record = mrs.source
- AND ord.record = mrs.source
- $ot_filter
- $of_filter
- $oa_filter
- $ol_filter
- $olf_filter
- LIMIT 1
- )
- ORDER BY 4 $sort_dir
- SQL
- }
-
-
- $log->debug("Field Search SQL :: [$select]",DEBUG);
-
- my $recs = $class->db_Main->selectall_arrayref(
- $select, {},
- (@bonus_values > 0 ? @bonus_values : () ),
- ( (!$sort && @bonus_values > 0) ? @bonus_values : () ),
- @types, @forms, @aud, @lang, @lit_form,
- @types, @forms, @aud, @lang, @lit_form,
- ($self->api_name =~ /staff/o ? (@types, @forms, @aud, @lang, @lit_form) : () ) );
-
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- my $max = 0;
- $max = 1 if (!@$recs);
- for (@$recs) {
- $max = $$_[1] if ($$_[1] > $max);
- }
-
- my $count = scalar(@$recs);
- for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
- my ($mrid,$rank,$skip) = @$rec;
- $client->respond( [$mrid, sprintf('%0.3f',$rank/$max), $skip, $count] );
- }
- return undef;
-}
-
-for my $class ( qw/title author subject keyword series identifier/ ) {
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.post_filter.search_fts.metarecord",
- method => 'postfilter_search_class_fts',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
- __PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.$class.post_filter.search_fts.metarecord.staff",
- method => 'postfilter_search_class_fts',
- api_level => 1,
- stream => 1,
- cdbi => "metabib::${class}_field_entry",
- cachable => 1,
- );
-}
-
-
-
-my $_cdbi = { title => "metabib::title_field_entry",
- author => "metabib::author_field_entry",
- subject => "metabib::subject_field_entry",
- keyword => "metabib::keyword_field_entry",
- series => "metabib::series_field_entry",
- identifier => "metabib::identifier_field_entry",
-};
-
-# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
-sub postfilter_search_multi_class_fts {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $sort = $args{'sort'};
- my $sort_dir = $args{sort_dir} || 'DESC';
- my $ou = $args{org_unit};
- my $ou_type = $args{depth};
- my $limit = $args{limit} || 10;
- my $offset = $args{offset} || 0;
- my $visibility_limit = $args{visibility_limit} || 5000;
-
- if (!$ou) {
- $ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
- }
-
- if (!defined($args{org_unit})) {
- die "No target organizational unit passed to ".$self->api_name;
- }
-
- if (! scalar( keys %{$args{searches}} )) {
- die "No search arguments were passed to ".$self->api_name;
- }
-
- my $outer_limit = 1000;
-
- my $limit_clause = '';
- my $offset_clause = '';
-
- $limit_clause = "LIMIT $outer_limit";
- $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
-
- my ($avail_filter,@types,@forms,@lang,@aud,@lit_form,@vformats) = ('');
- my ($t_filter, $f_filter, $v_filter) = ('','','');
- my ($a_filter, $l_filter, $lf_filter) = ('','','');
- my ($ot_filter, $of_filter, $ov_filter) = ('','','');
- my ($oa_filter, $ol_filter, $olf_filter) = ('','','');
-
- if ($args{available}) {
- $avail_filter = ' AND cp.status IN (0,7,12)';
- }
-
- if (my $a = $args{audience}) {
- $a = [$a] if (!ref($a));
- @aud = @$a;
-
- $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
- $oa_filter = ' AND ord.audience IN ('.join(',',map{'?'}@aud).')';
- }
-
- if (my $l = $args{language}) {
- $l = [$l] if (!ref($l));
- @lang = @$l;
-
- $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
- $ol_filter = ' AND ord.item_lang IN ('.join(',',map{'?'}@lang).')';
- }
-
- if (my $f = $args{lit_form}) {
- $f = [$f] if (!ref($f));
- @lit_form = @$f;
-
- $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- $olf_filter = ' AND ord.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- }
-
- if (my $f = $args{item_form}) {
- $f = [$f] if (!ref($f));
- @forms = @$f;
-
- $f_filter = ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- $of_filter = ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
- }
-
- if (my $t = $args{item_type}) {
- $t = [$t] if (!ref($t));
- @types = @$t;
-
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (my $v = $args{vr_format}) {
- $v = [$v] if (!ref($v));
- @vformats = @$v;
-
- $v_filter = ' AND rd.vr_format IN ('.join(',',map{'?'}@vformats).')';
- $ov_filter = ' AND ord.vr_format IN ('.join(',',map{'?'}@vformats).')';
- }
-
-
- # XXX legacy format and item type support
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- $of_filter .= ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
- }
- }
-
-
-
- my $descendants = defined($ou_type) ?
- "actor.org_unit_descendants($ou, $ou_type)" :
- "actor.org_unit_descendants($ou)";
-
- my $search_table_list = '';
- my $fts_list = '';
- my $join_table_list = '';
- my @rank_list;
-
- my $field_table = config::metabib_field->table;
-
- my @bonus_lists;
- my @bonus_values;
- my $prev_search_group;
- my $curr_search_group;
- my $search_class;
- my $search_field;
- my $metabib_field;
- for my $search_group (sort keys %{$args{searches}}) {
- (my $search_group_name = $search_group) =~ s/\|/_/gso;
- ($search_class,$search_field) = split /\|/, $search_group;
- $log->debug("Searching class [$search_class] and field [$search_field]",DEBUG);
-
- if ($search_field) {
- unless ( $metabib_field = config::metabib_field->search( field_class => $search_class, name => $search_field )->next ) {
- $log->warn("Requested class [$search_class] or field [$search_field] does not exist!");
- return undef;
- }
- }
-
- $prev_search_group = $curr_search_group if ($curr_search_group);
-
- $curr_search_group = $search_group_name;
-
- my $class = $_cdbi->{$search_class};
- my $search_table = $class->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
-
- my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $args{searches}{$search_group}{term}, $search_group_name.'.value', "$search_group_name.$index_col");
-
- my $fts_where = $fts->sql_where_clause;
- my @fts_ranks = $fts->fts_rank;
-
- my $SQLstring = join('%',map { lc($_) } $fts->words);
- my $REstring = '^' . join('\s+',map { lc($_) } $fts->words) . '\W*$';
- my $first_word = lc(($fts->words)[0]).'%';
-
- $_.=" * (SELECT weight FROM $field_table WHERE $search_group_name.field = id)" for (@fts_ranks);
- my $rank = join(' + ', @fts_ranks);
-
- my %bonus = ();
- $bonus{'keyword'} = [ { "CASE WHEN $search_group_name.value LIKE ? THEN 10 ELSE 1 END" => $SQLstring } ];
- $bonus{'author'} = [ { "CASE WHEN $search_group_name.value ILIKE ? THEN 10 ELSE 1 END" => $first_word } ];
-
- $bonus{'series'} = [
- { "CASE WHEN $search_group_name.value LIKE ? THEN 1.5 ELSE 1 END" => $first_word },
- { "CASE WHEN $search_group_name.value ~ ? THEN 20 ELSE 1 END" => $REstring },
- ];
-
- $bonus{'title'} = [ @{ $bonus{'series'} }, @{ $bonus{'keyword'} } ];
-
- my $bonus_list = join ' * ', map { keys %$_ } @{ $bonus{$search_class} };
- $bonus_list ||= '1';
-
- push @bonus_lists, $bonus_list;
- push @bonus_values, map { values %$_ } @{ $bonus{$search_class} };
-
-
- #---------------------
-
- $search_table_list .= "$search_table $search_group_name, ";
- push @rank_list,$rank;
- $fts_list .= " AND $fts_where AND m.source = $search_group_name.source";
-
- if ($metabib_field) {
- $join_table_list .= " AND $search_group_name.field = " . $metabib_field->id;
- $metabib_field = undef;
- }
-
- if ($prev_search_group) {
- $join_table_list .= " AND $prev_search_group.source = $curr_search_group.source";
- }
- }
-
- my $metabib_record_descriptor = metabib::record_descriptor->table;
- my $metabib_full_rec = metabib::full_rec->table;
- my $metabib_metarecord = metabib::metarecord->table;
- my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
- my $asset_call_number_table = asset::call_number->table;
- my $asset_copy_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $cl_table = asset::copy_location->table;
- my $br_table = biblio::record_entry->table;
- my $source_table = config::bib_source->table;
-
- my $bonuses = join (' * ', @bonus_lists);
- my $relevance = join (' + ', @rank_list);
- $relevance = "SUM( ($relevance) * ($bonuses) )/COUNT(DISTINCT smrs.source)";
-
- my $string_default_sort = 'zzzz';
- $string_default_sort = 'AAAA' if ($sort_dir eq 'DESC');
-
- my $number_default_sort = '9999';
- $number_default_sort = '0000' if ($sort_dir eq 'DESC');
-
-
-
- my $secondary_sort = <<" SORT";
- ( FIRST ((
- SELECT COALESCE(LTRIM(SUBSTR( sfrt.value, COALESCE(SUBSTRING(sfrt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
- FROM $metabib_full_rec sfrt,
- $metabib_metarecord mr
- WHERE sfrt.record = mr.master_record
- AND sfrt.tag = '245'
- AND sfrt.subfield = 'a'
- LIMIT 1
- )) )
- SORT
-
- my $rank = $relevance;
- if (lc($sort) eq 'pubdate') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d+'),'$number_default_sort')::INT
- FROM $metabib_full_rec frp
- WHERE frp.record = mr.master_record
- AND frp.tag = '260'
- AND frp.subfield = 'c'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'create_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
- RANK
- } elsif (lc($sort) eq 'edit_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
- RANK
- } elsif (lc($sort) eq 'title') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
- FROM $metabib_full_rec frt
- WHERE frt.record = mr.master_record
- AND frt.tag = '245'
- AND frt.subfield = 'a'
- LIMIT 1
- )) )
- RANK
- $secondary_sort = <<" SORT";
- ( FIRST ((
- SELECT COALESCE(SUBSTRING(sfrp.value FROM E'\\\\d+'),'$number_default_sort')::INT
- FROM $metabib_full_rec sfrp
- WHERE sfrp.record = mr.master_record
- AND sfrp.tag = '260'
- AND sfrp.subfield = 'c'
- LIMIT 1
- )) )
- SORT
- } elsif (lc($sort) eq 'author') {
- $rank = <<" RANK";
- ( FIRST((
- SELECT COALESCE(LTRIM(fra.value),'$string_default_sort')
- FROM $metabib_full_rec fra
- WHERE fra.record = mr.master_record
- AND fra.tag LIKE '1%'
- AND fra.subfield = 'a'
- ORDER BY fra.tag::text::int
- LIMIT 1
- )) )
- RANK
- } else {
- push @bonus_values, @bonus_values;
- $sort = undef;
- }
-
-
- my $select = <<" SQL";
- SELECT m.metarecord,
- $relevance,
- CASE WHEN COUNT(DISTINCT smrs.source) = 1 THEN FIRST(m.source) ELSE 0 END,
- $rank,
- $secondary_sort
- FROM $search_table_list
- $metabib_metarecord mr,
- $metabib_metarecord_source_map_table m,
- $metabib_metarecord_source_map_table smrs
- WHERE m.metarecord = smrs.metarecord
- AND mr.id = m.metarecord
- $fts_list
- $join_table_list
- GROUP BY m.metarecord
- -- ORDER BY 4 $sort_dir
- LIMIT $visibility_limit
- SQL
-
- if ($self->api_name !~ /staff/o) {
- $select = <<" SQL";
-
- SELECT s.*
- FROM ($select) s
- WHERE EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $metabib_metarecord_source_map_table mrs,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $br_table br,
- $descendants d,
- $metabib_record_descriptor ord
- WHERE mrs.metarecord = s.metarecord
- AND br.id = mrs.source
- AND cn.record = mrs.source
- AND cp.status = cs.id
- AND cp.location = cl.id
- AND cp.circ_lib = d.id
- AND cp.call_number = cn.id
- AND cp.opac_visible IS TRUE
- AND cs.opac_visible IS TRUE
- AND cl.opac_visible IS TRUE
- AND d.opac_visible IS TRUE
- AND br.active IS TRUE
- AND br.deleted IS FALSE
- AND cp.deleted IS FALSE
- AND cn.deleted IS FALSE
- AND ord.record = mrs.source
- $ot_filter
- $of_filter
- $ov_filter
- $oa_filter
- $ol_filter
- $olf_filter
- $avail_filter
- LIMIT 1
- )
- OR EXISTS (
- SELECT 1
- FROM $br_table br,
- $metabib_metarecord_source_map_table mrs,
- $metabib_record_descriptor ord,
- $source_table src
- WHERE mrs.metarecord = s.metarecord
- AND ord.record = mrs.source
- AND br.id = mrs.source
- AND br.source = src.id
- AND src.transcendant IS TRUE
- $ot_filter
- $of_filter
- $ov_filter
- $oa_filter
- $ol_filter
- $olf_filter
- )
- ORDER BY 4 $sort_dir, 5
- SQL
- } else {
- $select = <<" SQL";
-
- SELECT DISTINCT s.*
- FROM ($select) s,
- $metabib_metarecord_source_map_table omrs,
- $metabib_record_descriptor ord
- WHERE omrs.metarecord = s.metarecord
- AND ord.record = omrs.source
- AND ( EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $asset_copy_table cp,
- $descendants d,
- $br_table br
- WHERE br.id = omrs.source
- AND cn.record = omrs.source
- AND br.deleted IS FALSE
- AND cn.deleted IS FALSE
- AND cp.call_number = cn.id
- AND ( cn.owning_lib = d.id
- OR ( cp.circ_lib = d.id
- AND cp.deleted IS FALSE
- )
- )
- $avail_filter
- LIMIT 1
- )
- OR NOT EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn
- WHERE cn.record = omrs.source
- AND cn.deleted IS FALSE
- LIMIT 1
- )
- OR EXISTS (
- SELECT 1
- FROM $br_table br,
- $metabib_metarecord_source_map_table mrs,
- $metabib_record_descriptor ord,
- $source_table src
- WHERE mrs.metarecord = s.metarecord
- AND br.id = mrs.source
- AND br.source = src.id
- AND src.transcendant IS TRUE
- $ot_filter
- $of_filter
- $ov_filter
- $oa_filter
- $ol_filter
- $olf_filter
- )
- )
- $ot_filter
- $of_filter
- $ov_filter
- $oa_filter
- $ol_filter
- $olf_filter
-
- ORDER BY 4 $sort_dir, 5
- SQL
- }
-
-
- $log->debug("Field Search SQL :: [$select]",DEBUG);
-
- my $recs = $_cdbi->{title}->db_Main->selectall_arrayref(
- $select, {},
- @bonus_values,
- @types, @forms, @vformats, @aud, @lang, @lit_form,
- @types, @forms, @vformats, @aud, @lang, @lit_form,
- # ($self->api_name =~ /staff/o ? (@types, @forms, @aud, @lang, @lit_form) : () )
- );
-
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- my $max = 0;
- $max = 1 if (!@$recs);
- for (@$recs) {
- $max = $$_[1] if ($$_[1] > $max);
- }
-
- my $count = scalar(@$recs);
- for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
- next unless ($$rec[0]);
- my ($mrid,$rank,$skip) = @$rec;
- $client->respond( [$mrid, sprintf('%0.3f',$rank/$max), $skip, $count] );
- }
- return undef;
-}
-
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.post_filter.multiclass.search_fts.metarecord",
- method => 'postfilter_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.post_filter.multiclass.search_fts.metarecord.staff",
- method => 'postfilter_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.multiclass.search_fts",
- method => 'postfilter_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.multiclass.search_fts.staff",
- method => 'postfilter_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
-sub biblio_search_multi_class_fts {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- my $sort = $args{'sort'};
- my $sort_dir = $args{sort_dir} || 'DESC';
- my $ou = $args{org_unit};
- my $ou_type = $args{depth};
- my $limit = $args{limit} || 10;
- my $offset = $args{offset} || 0;
- my $pref_lang = $args{prefered_language} || 'eng';
- my $visibility_limit = $args{visibility_limit} || 5000;
-
- if (!$ou) {
- $ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
- }
-
- if (! scalar( keys %{$args{searches}} )) {
- die "No search arguments were passed to ".$self->api_name;
- }
-
- my $outer_limit = 1000;
-
- my $limit_clause = '';
- my $offset_clause = '';
-
- $limit_clause = "LIMIT $outer_limit";
- $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
-
- my ($avail_filter,@types,@forms,@lang,@aud,@lit_form,@vformats) = ('');
- my ($t_filter, $f_filter, $v_filter) = ('','','');
- my ($a_filter, $l_filter, $lf_filter) = ('','','');
- my ($ot_filter, $of_filter, $ov_filter) = ('','','');
- my ($oa_filter, $ol_filter, $olf_filter) = ('','','');
-
- if ($args{available}) {
- $avail_filter = ' AND cp.status IN (0,7,12)';
- }
-
- if (my $a = $args{audience}) {
- $a = [$a] if (!ref($a));
- @aud = @$a;
-
- $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
- $oa_filter = ' AND ord.audience IN ('.join(',',map{'?'}@aud).')';
- }
-
- if (my $l = $args{language}) {
- $l = [$l] if (!ref($l));
- @lang = @$l;
-
- $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
- $ol_filter = ' AND ord.item_lang IN ('.join(',',map{'?'}@lang).')';
- }
-
- if (my $f = $args{lit_form}) {
- $f = [$f] if (!ref($f));
- @lit_form = @$f;
-
- $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- $olf_filter = ' AND ord.lit_form IN ('.join(',',map{'?'}@lit_form).')';
- }
-
- if (my $f = $args{item_form}) {
- $f = [$f] if (!ref($f));
- @forms = @$f;
-
- $f_filter = ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- $of_filter = ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
- }
-
- if (my $t = $args{item_type}) {
- $t = [$t] if (!ref($t));
- @types = @$t;
-
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (my $v = $args{vr_format}) {
- $v = [$v] if (!ref($v));
- @vformats = @$v;
-
- $v_filter = ' AND rd.vr_format IN ('.join(',',map{'?'}@vformats).')';
- $ov_filter = ' AND ord.vr_format IN ('.join(',',map{'?'}@vformats).')';
- }
-
- # XXX legacy format and item type support
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- if (@types) {
- $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
- $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
- }
-
- if (@forms) {
- $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
- $of_filter .= ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
- }
- }
-
-
- my $descendants = defined($ou_type) ?
- "actor.org_unit_descendants($ou, $ou_type)" :
- "actor.org_unit_descendants($ou)";
-
- my $search_table_list = '';
- my $fts_list = '';
- my $join_table_list = '';
- my @rank_list;
-
- my $field_table = config::metabib_field->table;
-
- my @bonus_lists;
- my @bonus_values;
- my $prev_search_group;
- my $curr_search_group;
- my $search_class;
- my $search_field;
- my $metabib_field;
- for my $search_group (sort keys %{$args{searches}}) {
- (my $search_group_name = $search_group) =~ s/\|/_/gso;
- ($search_class,$search_field) = split /\|/, $search_group;
- $log->debug("Searching class [$search_class] and field [$search_field]",DEBUG);
-
- if ($search_field) {
- unless ( $metabib_field = config::metabib_field->search( field_class => $search_class, name => $search_field )->next ) {
- $log->warn("Requested class [$search_class] or field [$search_field] does not exist!");
- return undef;
- }
- }
-
- $prev_search_group = $curr_search_group if ($curr_search_group);
-
- $curr_search_group = $search_group_name;
-
- my $class = $_cdbi->{$search_class};
- my $search_table = $class->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
-
- my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $args{searches}{$search_group}{term}, $search_group_name.'.value', "$search_group_name.$index_col");
-
- my $fts_where = $fts->sql_where_clause;
- my @fts_ranks = $fts->fts_rank;
-
- my $SQLstring = join('%',map { lc($_) } $fts->words) .'%';
- my $REstring = '^' . join('\s+',map { lc($_) } $fts->words) . '\W*$';
- my $first_word = lc(($fts->words)[0]).'%';
-
- $_.=" * (SELECT weight FROM $field_table WHERE $search_group_name.field = id)" for (@fts_ranks);
- my $rank = join(' + ', @fts_ranks);
-
- my %bonus = ();
- $bonus{'subject'} = [];
- $bonus{'author'} = [ { "CASE WHEN $search_group_name.value ILIKE ? THEN 1.5 ELSE 1 END" => $first_word } ];
-
- $bonus{'keyword'} = [ { "CASE WHEN $search_group_name.value ILIKE ? THEN 10 ELSE 1 END" => $SQLstring } ];
-
- $bonus{'series'} = [
- { "CASE WHEN $search_group_name.value ILIKE ? THEN 1.5 ELSE 1 END" => $first_word },
- { "CASE WHEN $search_group_name.value ~ ? THEN 20 ELSE 1 END" => $REstring },
- ];
-
- $bonus{'title'} = [ @{ $bonus{'series'} }, @{ $bonus{'keyword'} } ];
-
- if ($pref_lang) {
- push @{ $bonus{'title'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
- push @{ $bonus{'author'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
- push @{ $bonus{'subject'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
- push @{ $bonus{'keyword'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
- push @{ $bonus{'series'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
- }
-
- my $bonus_list = join ' * ', map { keys %$_ } @{ $bonus{$search_class} };
- $bonus_list ||= '1';
-
- push @bonus_lists, $bonus_list;
- push @bonus_values, map { values %$_ } @{ $bonus{$search_class} };
-
- #---------------------
-
- $search_table_list .= "$search_table $search_group_name, ";
- push @rank_list,$rank;
- $fts_list .= " AND $fts_where AND b.id = $search_group_name.source";
-
- if ($metabib_field) {
- $fts_list .= " AND $curr_search_group.field = " . $metabib_field->id;
- $metabib_field = undef;
- }
-
- if ($prev_search_group) {
- $join_table_list .= " AND $prev_search_group.source = $curr_search_group.source";
- }
- }
-
- my $metabib_record_descriptor = metabib::record_descriptor->table;
- my $metabib_full_rec = metabib::full_rec->table;
- my $metabib_metarecord = metabib::metarecord->table;
- my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
- my $asset_call_number_table = asset::call_number->table;
- my $asset_copy_table = asset::copy->table;
- my $cs_table = config::copy_status->table;
- my $cl_table = asset::copy_location->table;
- my $br_table = biblio::record_entry->table;
- my $source_table = config::bib_source->table;
-
-
- my $bonuses = join (' * ', @bonus_lists);
- my $relevance = join (' + ', @rank_list);
- $relevance = "AVG( ($relevance) * ($bonuses) )";
-
- my $string_default_sort = 'zzzz';
- $string_default_sort = 'AAAA' if ($sort_dir eq 'DESC');
-
- my $number_default_sort = '9999';
- $number_default_sort = '0000' if ($sort_dir eq 'DESC');
-
- my $rank = $relevance;
- if (lc($sort) eq 'pubdate') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d{4}'),'$number_default_sort')::INT
- FROM $metabib_full_rec frp
- WHERE frp.record = b.id
- AND frp.tag = '260'
- AND frp.subfield = 'c'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'create_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = b.id)) )
- RANK
- } elsif (lc($sort) eq 'edit_date') {
- $rank = <<" RANK";
- ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = b.id)) )
- RANK
- } elsif (lc($sort) eq 'title') {
- $rank = <<" RANK";
- ( FIRST ((
- SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
- FROM $metabib_full_rec frt
- WHERE frt.record = b.id
- AND frt.tag = '245'
- AND frt.subfield = 'a'
- LIMIT 1
- )) )
- RANK
- } elsif (lc($sort) eq 'author') {
- $rank = <<" RANK";
- ( FIRST((
- SELECT COALESCE(LTRIM(fra.value),'$string_default_sort')
- FROM $metabib_full_rec fra
- WHERE fra.record = b.id
- AND fra.tag LIKE '1%'
- AND fra.subfield = 'a'
- ORDER BY fra.tag::text::int
- LIMIT 1
- )) )
- RANK
- } else {
- push @bonus_values, @bonus_values;
- $sort = undef;
- }
-
-
- my $select = <<" SQL";
- SELECT b.id,
- $relevance AS rel,
- $rank AS rank,
- b.source
- FROM $search_table_list
- $metabib_record_descriptor rd,
- $source_table src,
- $br_table b
- WHERE rd.record = b.id
- AND b.active IS TRUE
- AND b.deleted IS FALSE
- $fts_list
- $join_table_list
- $t_filter
- $f_filter
- $v_filter
- $a_filter
- $l_filter
- $lf_filter
- GROUP BY b.id, b.source
- ORDER BY 3 $sort_dir
- LIMIT $visibility_limit
- SQL
-
- if ($self->api_name !~ /staff/o) {
- $select = <<" SQL";
-
- SELECT s.*
- FROM ($select) s
- LEFT OUTER JOIN $source_table src ON (s.source = src.id)
- WHERE EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $asset_copy_table cp,
- $cs_table cs,
- $cl_table cl,
- $descendants d
- WHERE cn.record = s.id
- AND cp.status = cs.id
- AND cp.location = cl.id
- AND cp.call_number = cn.id
- AND cp.opac_visible IS TRUE
- AND cs.opac_visible IS TRUE
- AND cl.opac_visible IS TRUE
- AND d.opac_visible IS TRUE
- AND cp.deleted IS FALSE
- AND cn.deleted IS FALSE
- AND cp.circ_lib = d.id
- $avail_filter
- LIMIT 1
- )
- OR src.transcendant IS TRUE
- ORDER BY 3 $sort_dir
- SQL
- } else {
- $select = <<" SQL";
-
- SELECT s.*
- FROM ($select) s
- LEFT OUTER JOIN $source_table src ON (s.source = src.id)
- WHERE EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn,
- $asset_copy_table cp,
- $descendants d
- WHERE cn.record = s.id
- AND cp.call_number = cn.id
- AND cn.deleted IS FALSE
- AND cp.circ_lib = d.id
- AND cp.deleted IS FALSE
- $avail_filter
- LIMIT 1
- )
- OR NOT EXISTS (
- SELECT 1
- FROM $asset_call_number_table cn
- WHERE cn.record = s.id
- LIMIT 1
- )
- OR src.transcendant IS TRUE
- ORDER BY 3 $sort_dir
- SQL
- }
-
-
- $log->debug("Field Search SQL :: [$select]",DEBUG);
-
- my $recs = $_cdbi->{title}->db_Main->selectall_arrayref(
- $select, {},
- @bonus_values, @types, @forms, @vformats, @aud, @lang, @lit_form
- );
-
- $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
-
- my $count = scalar(@$recs);
- for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
- next unless ($$rec[0]);
- my ($mrid,$rank) = @$rec;
- $client->respond( [$mrid, sprintf('%0.3f',$rank), $count] );
- }
- return undef;
-}
-
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.search_fts.record",
- method => 'biblio_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.search_fts.record.staff",
- method => 'biblio_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.search_fts",
- method => 'biblio_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.search_fts.staff",
- method => 'biblio_search_multi_class_fts',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-
-my %locale_map;
-my $default_preferred_language;
-my $default_preferred_language_weight;
-
-# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
-sub staged_fts {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- if (!$locale_map{COMPLETE}) {
-
- my @locales = config::i18n_locale->search_where({ code => { '<>' => '' } });
- for my $locale ( @locales ) {
- $locale_map{lc($locale->code)} = $locale->marc_code;
- }
- $locale_map{COMPLETE} = 1;
-
- }
-
- if (!$default_preferred_language) {
-
- $default_preferred_language = OpenSRF::Utils::SettingsClient
- ->new
- ->config_value(
- apps => 'open-ils.storage' => app_settings => 'default_preferred_language'
- );
-
- }
-
- if (!$default_preferred_language_weight) {
-
- $default_preferred_language_weight = OpenSRF::Utils::SettingsClient
- ->new
- ->config_value(
- apps => 'open-ils.storage' => app_settings => 'default_preferred_language_weight'
- );
-
- }
-
- # inclusion, exclusion, delete_adjusted_inclusion, delete_adjusted_exclusion
- my $estimation_strategy = $args{estimation_strategy} || 'inclusion';
-
- my $ou = $args{org_unit};
- my $limit = $args{limit} || 10;
- my $offset = $args{offset} || 0;
-
- if (!$ou) {
- $ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
- }
-
- if (! scalar( keys %{$args{searches}} )) {
- die "No search arguments were passed to ".$self->api_name;
- }
-
- my (@between,@statuses,@locations,@types,@forms,@lang,@aud,@lit_form,@vformats,@bib_level);
-
- if (!defined($args{preferred_language})) {
- my $ses_locale = $client->session ? $client->session->session_locale : $default_preferred_language;
- $args{preferred_language} =
- $locale_map{ lc($ses_locale) } || 'eng';
- }
-
- if (!defined($args{preferred_language_weight})) {
- $args{preferred_language_weight} = $default_preferred_language_weight || 2;
- }
-
- if ($args{available}) {
- @statuses = (0,7,12);
- }
-
- if (my $s = $args{locations}) {
- $s = [$s] if (!ref($s));
- @locations = @$s;
- }
-
- if (my $b = $args{between}) {
- if (ref($b) && @$b == 2) {
- @between = @$b;
- }
- }
-
- if (my $s = $args{statuses}) {
- $s = [$s] if (!ref($s));
- @statuses = @$s;
- }
-
- if (my $a = $args{audience}) {
- $a = [$a] if (!ref($a));
- @aud = @$a;
- }
-
- if (my $l = $args{language}) {
- $l = [$l] if (!ref($l));
- @lang = @$l;
- }
-
- if (my $f = $args{lit_form}) {
- $f = [$f] if (!ref($f));
- @lit_form = @$f;
- }
-
- if (my $f = $args{item_form}) {
- $f = [$f] if (!ref($f));
- @forms = @$f;
- }
-
- if (my $t = $args{item_type}) {
- $t = [$t] if (!ref($t));
- @types = @$t;
- }
-
- if (my $b = $args{bib_level}) {
- $b = [$b] if (!ref($b));
- @bib_level = @$b;
- }
-
- if (my $v = $args{vr_format}) {
- $v = [$v] if (!ref($v));
- @vformats = @$v;
- }
-
- # XXX legacy format and item type support
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- @types = split '', $t;
- @forms = split '', $f;
- }
-
- my %stored_proc_search_args;
- for my $search_group (sort keys %{$args{searches}}) {
- (my $search_group_name = $search_group) =~ s/\|/_/gso;
- my ($search_class,$search_field) = split /\|/, $search_group;
- $log->debug("Searching class [$search_class] and field [$search_field]",DEBUG);
-
- if ($search_field) {
- unless ( config::metabib_field->search( field_class => $search_class, name => $search_field )->next ) {
- $log->warn("Requested class [$search_class] or field [$search_field] does not exist!");
- return undef;
- }
- }
-
- my $class = $_cdbi->{$search_class};
- my $search_table = $class->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
-
- my $fts = OpenILS::Application::Storage::FTS->compile(
- $search_class => $args{searches}{$search_group}{term},
- $search_group_name.'.value',
- "$search_group_name.$index_col"
- );
- $fts->sql_where_clause; # this builds the ranks for us
-
- my @fts_ranks = $fts->fts_rank;
- my @fts_queries = $fts->fts_query;
- my @phrases = map { lc($_) } $fts->phrases;
- my @words = map { lc($_) } $fts->words;
-
- $stored_proc_search_args{$search_group} = {
- fts_rank => \@fts_ranks,
- fts_query => \@fts_queries,
- phrase => \@phrases,
- word => \@words,
- };
-
- }
-
- my $param_search_ou = $ou;
- my $param_depth = $args{depth}; $param_depth = 'NULL' unless (defined($param_depth) and length($param_depth) > 0 );
- my $param_searches = OpenSRF::Utils::JSON->perl2JSON( \%stored_proc_search_args ); $param_searches =~ s/\$//go; $param_searches = '$$'.$param_searches.'$$';
- my $param_statuses = '$${' . join(',', map { s/\$//go; "\"$_\"" } @statuses ) . '}$$';
- my $param_locations = '$${' . join(',', map { s/\$//go; "\"$_\"" } @locations) . '}$$';
- my $param_audience = '$${' . join(',', map { s/\$//go; "\"$_\"" } @aud ) . '}$$';
- my $param_language = '$${' . join(',', map { s/\$//go; "\"$_\"" } @lang ) . '}$$';
- my $param_lit_form = '$${' . join(',', map { s/\$//go; "\"$_\"" } @lit_form ) . '}$$';
- my $param_types = '$${' . join(',', map { s/\$//go; "\"$_\"" } @types ) . '}$$';
- my $param_forms = '$${' . join(',', map { s/\$//go; "\"$_\"" } @forms ) . '}$$';
- my $param_vformats = '$${' . join(',', map { s/\$//go; "\"$_\"" } @vformats ) . '}$$';
- my $param_bib_level = '$${' . join(',', map { s/\$//go; "\"$_\"" } @bib_level) . '}$$';
- my $param_before = $args{before}; $param_before = 'NULL' unless (defined($param_before) and length($param_before) > 0 );
- my $param_after = $args{after} ; $param_after = 'NULL' unless (defined($param_after ) and length($param_after ) > 0 );
- my $param_during = $args{during}; $param_during = 'NULL' unless (defined($param_during) and length($param_during) > 0 );
- my $param_between = '$${"' . join('","', map { int($_) } @between) . '"}$$';
- my $param_pref_lang = $args{preferred_language}; $param_pref_lang =~ s/\$//go; $param_pref_lang = '$$'.$param_pref_lang.'$$';
- my $param_pref_lang_multiplier = $args{preferred_language_weight}; $param_pref_lang_multiplier ||= 'NULL';
- my $param_sort = $args{'sort'}; $param_sort =~ s/\$//go; $param_sort = '$$'.$param_sort.'$$';
- my $param_sort_desc = defined($args{sort_dir}) && $args{sort_dir} =~ /^d/io ? "'t'" : "'f'";
- my $metarecord = $self->api_name =~ /metabib/o ? "'t'" : "'f'";
- my $staff = $self->api_name =~ /staff/o ? "'t'" : "'f'";
- my $param_rel_limit = $args{core_limit}; $param_rel_limit ||= 'NULL';
- my $param_chk_limit = $args{check_limit}; $param_chk_limit ||= 'NULL';
- my $param_skip_chk = $args{skip_check}; $param_skip_chk ||= 'NULL';
-
- my $sth = metabib::metarecord_source_map->db_Main->prepare(<<" SQL");
- SELECT *
- FROM search.staged_fts(
- $param_search_ou\:\:INT,
- $param_depth\:\:INT,
- $param_searches\:\:TEXT,
- $param_statuses\:\:INT[],
- $param_locations\:\:INT[],
- $param_audience\:\:TEXT[],
- $param_language\:\:TEXT[],
- $param_lit_form\:\:TEXT[],
- $param_types\:\:TEXT[],
- $param_forms\:\:TEXT[],
- $param_vformats\:\:TEXT[],
- $param_bib_level\:\:TEXT[],
- $param_before\:\:TEXT,
- $param_after\:\:TEXT,
- $param_during\:\:TEXT,
- $param_between\:\:TEXT[],
- $param_pref_lang\:\:TEXT,
- $param_pref_lang_multiplier\:\:REAL,
- $param_sort\:\:TEXT,
- $param_sort_desc\:\:BOOL,
- $metarecord\:\:BOOL,
- $staff\:\:BOOL,
- $param_rel_limit\:\:INT,
- $param_chk_limit\:\:INT,
- $param_skip_chk\:\:INT
- );
- SQL
-
- $sth->execute;
-
- my $recs = $sth->fetchall_arrayref({});
- my $summary_row = pop @$recs;
-
- my $total = $$summary_row{total};
- my $checked = $$summary_row{checked};
- my $visible = $$summary_row{visible};
- my $deleted = $$summary_row{deleted};
- my $excluded = $$summary_row{excluded};
-
- my $estimate = $visible;
- if ( $total > $checked && $checked ) {
-
- $$summary_row{hit_estimate} = FTS_paging_estimate($self, $client, $checked, $visible, $excluded, $deleted, $total);
- $estimate = $$summary_row{estimated_hit_count} = $$summary_row{hit_estimate}{$estimation_strategy};
-
- }
-
- delete $$summary_row{id};
- delete $$summary_row{rel};
- delete $$summary_row{record};
-
- $client->respond( $summary_row );
-
- $log->debug("Search yielded ".scalar(@$recs)." checked, visible results with an approximate visible total of $estimate.",DEBUG);
-
- for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
- delete $$rec{checked};
- delete $$rec{visible};
- delete $$rec{excluded};
- delete $$rec{deleted};
- delete $$rec{total};
- $$rec{rel} = sprintf('%0.3f',$$rec{rel});
-
- $client->respond( $rec );
- }
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.staged.search_fts",
- method => 'staged_fts',
- api_level => 0,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.staged.search_fts.staff",
- method => 'staged_fts',
- api_level => 0,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.multiclass.staged.search_fts",
- method => 'staged_fts',
- api_level => 0,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.multiclass.staged.search_fts.staff",
- method => 'staged_fts',
- api_level => 0,
- stream => 1,
- cachable => 1,
-);
-
-sub FTS_paging_estimate {
- my $self = shift;
- my $client = shift;
-
- my $checked = shift;
- my $visible = shift;
- my $excluded = shift;
- my $deleted = shift;
- my $total = shift;
-
- my $deleted_ratio = $deleted / $checked;
- my $delete_adjusted_total = $total - ( $total * $deleted_ratio );
-
- my $exclusion_ratio = $excluded / $checked;
- my $delete_adjusted_exclusion_ratio = $excluded / ($checked - $deleted);
-
- my $inclusion_ratio = $visible / $checked;
- my $delete_adjusted_inclusion_ratio = $visible / ($checked - $deleted);
-
- return {
- exclusion => int($delete_adjusted_total - ( $delete_adjusted_total * $exclusion_ratio )),
- inclusion => int($delete_adjusted_total * $inclusion_ratio),
- delete_adjusted_exclusion => int($delete_adjusted_total - ( $delete_adjusted_total * $delete_adjusted_exclusion_ratio )),
- delete_adjusted_inclusion => int($delete_adjusted_total * $delete_adjusted_inclusion_ratio)
- };
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.fts_paging_estimate",
- method => 'FTS_paging_estimate',
- argc => 5,
- strict => 1,
- api_level => 1,
- signature => {
- 'return'=> q#
- Hash of estimation values based on four variant estimation strategies:
- exclusion -- Estimate based on the ratio of excluded records on the current superpage;
- inclusion -- Estimate based on the ratio of visible records on the current superpage;
- delete_adjusted_exclusion -- Same as exclusion strategy, but the ratio is adjusted by deleted count;
- delete_adjusted_inclusion -- Same as inclusion strategy, but the ratio is adjusted by deleted count;
- #,
- desc => q#
- Helper method used to determin the approximate number of
- hits for a search that spans multiple superpages. For
- sparse superpages, the inclusion estimate will likely be the
- best estimate. The exclusion strategy is the original, but
- inclusion is the default.
- #,
- params => [
- { name => 'checked',
- desc => 'Number of records check -- nominally the size of a superpage, or a remaining amount from the last superpage.',
- type => 'number'
- },
- { name => 'visible',
- desc => 'Number of records visible to the search location on the current superpage.',
- type => 'number'
- },
- { name => 'excluded',
- desc => 'Number of records excluded from the search location on the current superpage.',
- type => 'number'
- },
- { name => 'deleted',
- desc => 'Number of deleted records on the current superpage.',
- type => 'number'
- },
- { name => 'total',
- desc => 'Total number of records up to check_limit (superpage_size * max_superpages).',
- type => 'number'
- }
- ]
- }
-);
-
-
-sub xref_count {
- my $self = shift;
- my $client = shift;
- my $args = shift;
-
- my $term = $$args{term};
- my $limit = $$args{max} || 1;
- my $min = $$args{min} || 1;
- my @classes = @{$$args{class}};
-
- $limit = $min if ($min > $limit);
-
- if (!@classes) {
- @classes = ( qw/ title author subject series keyword / );
- }
-
- my %matches;
- my $bre_table = biblio::record_entry->table;
- my $cn_table = asset::call_number->table;
- my $cp_table = asset::copy->table;
-
- for my $search_class ( @classes ) {
-
- my $class = $_cdbi->{$search_class};
- my $search_table = $class->table;
-
- my ($index_col) = $class->columns('FTS');
- $index_col ||= 'value';
-
-
- my $where = OpenILS::Application::Storage::FTS
- ->compile($search_class => $term, $search_class.'.value', "$search_class.$index_col")
- ->sql_where_clause;
-
- my $SQL = <<" SQL";
- SELECT COUNT(DISTINCT X.source)
- FROM (SELECT $search_class.source
- FROM $search_table $search_class
- JOIN $bre_table b ON (b.id = $search_class.source)
- WHERE $where
- AND NOT b.deleted
- AND b.active
- LIMIT $limit) X
- HAVING COUNT(DISTINCT X.source) >= $min;
- SQL
-
- my $res = $class->db_Main->selectrow_arrayref( $SQL );
- $matches{$search_class} = $res ? $res->[0] : 0;
- }
-
- return \%matches;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.search.xref",
- method => 'xref_count',
- api_level => 1,
-);
-
-sub query_parser_fts {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
-
- # grab the query parser and initialize it
- my $parser = $OpenILS::Application::Storage::QParser;
- $parser->use;
-
- if (!$parser->initialization_complete) {
- my $cstore = OpenSRF::AppSession->create( 'open-ils.cstore' );
- $parser->initialize(
- config_metabib_field_index_norm_map =>
- $cstore->request(
- 'open-ils.cstore.direct.config.metabib_field_index_norm_map.search.atomic',
- { id => { "!=" => undef } },
- { flesh => 1, flesh_fields => { cmfinm => [qw/norm/] }, order_by => [{ class => "cmfinm", field => "pos" }] }
- )->gather(1),
- search_relevance_adjustment =>
- $cstore->request(
- 'open-ils.cstore.direct.search.relevance_adjustment.search.atomic',
- { id => { "!=" => undef } }
- )->gather(1),
- config_metabib_field =>
- $cstore->request(
- 'open-ils.cstore.direct.config.metabib_field.search.atomic',
- { id => { "!=" => undef } }
- )->gather(1),
- config_metabib_search_alias =>
- $cstore->request(
- 'open-ils.cstore.direct.config.metabib_search_alias.search.atomic',
- { alias => { "!=" => undef } }
- )->gather(1),
- );
-
- $cstore->disconnect;
- die("Cannot initialize $parser!") unless ($parser->initialization_complete);
- }
-
-
- # populate the locale/language map
- if (!$locale_map{COMPLETE}) {
-
- my @locales = config::i18n_locale->search_where({ code => { '<>' => '' } });
- for my $locale ( @locales ) {
- $locale_map{lc($locale->code)} = $locale->marc_code;
- }
- $locale_map{COMPLETE} = 1;
-
- }
-
- # I hope we have a query!
- if (! $args{query} ) {
- die "No query was passed to ".$self->api_name;
- }
-
-
- my $simple_plan = $args{_simple_plan};
- # remove bad chunks of the %args hash
- for my $bad ( grep { /^_/ } keys(%args)) {
- delete($args{$bad});
- }
-
-
- # parse the query and supply any query-level %arg-based defaults
- # we expect, and make use of, query, superpage, superpage_size, debug and core_limit args
- my $query = $parser->new( %args )->parse;
-
-
- # set the locale-based default prefered location
- if (!$query->parse_tree->find_filter('preferred_language')) {
- $parser->default_preferred_language( $args{preferred_language} );
- if (!$parser->default_preferred_language) {
- my $ses_locale = $client->session ? $client->session->session_locale : '';
- $parser->default_preferred_language( $locale_map{ lc($ses_locale) } );
- }
- $parser->default_preferred_language(
- OpenSRF::Utils::SettingsClient->new->config_value(
- apps => 'open-ils.storage' => app_settings => 'default_preferred_language'
- )
- ) if (!$parser->default_preferred_language);
- }
-
-
- # set the global default language multiplier
- if (!$query->parse_tree->find_filter('preferred_language_weight') and !$query->parse_tree->find_filter('preferred_language_multiplier')) {
- $parser->default_preferred_language_multiplier($args{preferred_language_weight});
- $parser->default_preferred_language_multiplier($args{preferred_language_multiplier});
- $parser->default_preferred_language_multiplier(
- OpenSRF::Utils::SettingsClient->new->config_value(
- apps => 'open-ils.storage' => app_settings => 'default_preferred_language_weight'
- )
- ) if (!$parser->default_preferred_language_multiplier);
- }
-
- # gather the site, if one is specified, defaulting to the in-query version
- my $ou = $args{org_unit};
- if (my ($filter) = $query->parse_tree->find_filter('site')) {
- $ou = $filter->args->[0] if (@{$filter->args});
- }
- $ou = actor::org_unit->search( { shortname => $ou } )->next->id if ($ou and $ou !~ /^\d+$/);
-
-
- # gather lasso, as with $ou
- my $lasso = $args{lasso};
- if (my ($filter) = $query->parse_tree->find_filter('lasso')) {
- $lasso = $filter->args->[0] if (@{$filter->args});
- }
- $lasso = actor::org_lasso->search( { name => $lasso } )->next->id if ($lasso and $lasso !~ /^\d+$/);
- $lasso = -$lasso if ($lasso);
-
-
-# # XXX once we have org_unit containers, we can make user-defined lassos .. WHEEE
-# # gather user lasso, as with $ou and lasso
-# my $mylasso = $args{my_lasso};
-# if (my ($filter) = $query->parse_tree->find_filter('my_lasso')) {
-# $mylasso = $filter->args->[0] if (@{$filter->args});
-# }
-# $mylasso = actor::org_unit->search( { name => $mylasso } )->next->id if ($mylasso and $mylasso !~ /^\d+$/);
-
-
- # if we have a lasso, go with that, otherwise ... ou
- $ou = $lasso if ($lasso);
-
-
- # get the default $ou if we have nothing
- $ou = actor::org_unit->search( { parent_ou => undef } )->next->id if (!$ou and !$lasso and !$mylasso);
-
-
- # XXX when user lassos are here, check to make sure we don't have one -- it'll be passed in the depth, with an ou of 0
- # gather the depth, if one is specified, defaulting to the in-query version
- my $depth = $args{depth};
- if (my ($filter) = $query->parse_tree->find_filter('depth')) {
- $depth = $filter->args->[0] if (@{$filter->args});
- }
- $depth = actor::org_unit->search_where( [{ name => $depth },{ opac_label => $depth }], {limit => 1} )->next->id if ($depth and $depth !~ /^\d+$/);
-
-
- # gather the limit or default to 10
- my $limit = $args{check_limit} || 'NULL';
- if (my ($filter) = $query->parse_tree->find_filter('limit')) {
- $limit = $filter->args->[0] if (@{$filter->args});
- }
- if (my ($filter) = $query->parse_tree->find_filter('check_limit')) {
- $limit = $filter->args->[0] if (@{$filter->args});
- }
-
-
- # gather the offset or default to 0
- my $offset = $args{skip_check} || $args{offset} || 0;
- if (my ($filter) = $query->parse_tree->find_filter('offset')) {
- $offset = $filter->args->[0] if (@{$filter->args});
- }
- if (my ($filter) = $query->parse_tree->find_filter('skip_check')) {
- $offset = $filter->args->[0] if (@{$filter->args});
- }
-
-
- # gather the estimation strategy or default to inclusion
- my $estimation_strategy = $args{estimation_strategy} || 'inclusion';
- if (my ($filter) = $query->parse_tree->find_filter('estimation_strategy')) {
- $estimation_strategy = $filter->args->[0] if (@{$filter->args});
- }
-
-
- # gather the estimation strategy or default to inclusion
- my $core_limit = $args{core_limit};
- if (my ($filter) = $query->parse_tree->find_filter('core_limit')) {
- $core_limit = $filter->args->[0] if (@{$filter->args});
- }
-
-
- # gather statuses, and then forget those if we have an #available modifier
- my @statuses;
- if (my ($filter) = $query->parse_tree->find_filter('statuses')) {
- @statuses = @{$filter->args} if (@{$filter->args});
- }
- @statuses = (0,7,12) if ($query->parse_tree->find_modifier('available'));
-
-
- # gather locations
- my @location;
- if (my ($filter) = $query->parse_tree->find_filter('locations')) {
- @location = @{$filter->args} if (@{$filter->args});
- }
-
-
- my $param_check = $limit || $query->superpage_size || 'NULL';
- my $param_offset = $offset || 'NULL';
- my $param_limit = $core_limit || 'NULL';
-
- my $sp = $query->superpage || 1;
- if ($sp > 1) {
- $param_offset = ($sp - 1) * $sp_size;
- }
-
- my $param_search_ou = $ou;
- my $param_depth = $depth; $param_depth = 'NULL' unless (defined($depth) and length($depth) > 0 );
- my $param_core_query = "\$core_query_$$\$" . $query->parse_tree->toSQL . "\$core_query_$$\$";
- my $param_statuses = '$${' . join(',', map { s/\$//go; "\"$_\""} @statuses) . '}$$';
- my $param_locations = '$${' . join(',', map { s/\$//go; "\"$_\""} @location) . '}$$';
- my $staff = ($self->api_name =~ /staff/ or $query->parse_tree->find_modifier('staff')) ? "'t'" : "'f'";
- my $metarecord = ($self->api_name =~ /metabib/ or $query->parse_tree->find_modifier('metabib') or $query->parse_tree->find_modifier('metarecord')) ? "'t'" : "'f'";
-
- my $sth = metabib::metarecord_source_map->db_Main->prepare(<<" SQL");
- SELECT * /* bib search */
- FROM search.query_parser_fts(
- $param_search_ou\:\:INT,
- $param_depth\:\:INT,
- $param_core_query\:\:TEXT,
- $param_statuses\:\:INT[],
- $param_locations\:\:INT[],
- $param_offset\:\:INT,
- $param_check\:\:INT,
- $param_limit\:\:INT,
- $metarecord\:\:BOOL,
- $staff\:\:BOOL
- );
- SQL
-
- $sth->execute;
-
- my $recs = $sth->fetchall_arrayref({});
- my $summary_row = pop @$recs;
-
- my $total = $$summary_row{total};
- my $checked = $$summary_row{checked};
- my $visible = $$summary_row{visible};
- my $deleted = $$summary_row{deleted};
- my $excluded = $$summary_row{excluded};
-
- my $estimate = $visible;
- if ( $total > $checked && $checked ) {
-
- $$summary_row{hit_estimate} = FTS_paging_estimate($self, $client, $checked, $visible, $excluded, $deleted, $total);
- $estimate = $$summary_row{estimated_hit_count} = $$summary_row{hit_estimate}{$estimation_strategy};
-
- }
-
- delete $$summary_row{id};
- delete $$summary_row{rel};
- delete $$summary_row{record};
-
- if (defined($simple_plan)) {
- $$summary_row{complex_query} = $simple_plan ? 0 : 1;
- } else {
- $$summary_row{complex_query} = $query->simple_plan ? 0 : 1;
- }
-
- $client->respond( $summary_row );
-
- $log->debug("Search yielded ".scalar(@$recs)." checked, visible results with an approximate visible total of $estimate.",DEBUG);
-
- for my $rec (@$recs) {
- delete $$rec{checked};
- delete $$rec{visible};
- delete $$rec{excluded};
- delete $$rec{deleted};
- delete $$rec{total};
- $$rec{rel} = sprintf('%0.3f',$$rec{rel});
-
- $client->respond( $rec );
- }
- return undef;
-}
-
-sub query_parser_fts_wrapper {
- my $self = shift;
- my $client = shift;
- my %args = @_;
-
- $log->debug("Entering compatability wrapper function for old-style staged search", DEBUG);
- # grab the query parser and initialize it
- my $parser = $OpenILS::Application::Storage::QParser;
- $parser->use;
-
- if (!$parser->initialization_complete) {
- my $cstore = OpenSRF::AppSession->create( 'open-ils.cstore' );
- $parser->initialize(
- config_metabib_field_index_norm_map =>
- $cstore->request(
- 'open-ils.cstore.direct.config.metabib_field_index_norm_map.search.atomic',
- { id => { "!=" => undef } },
- { flesh => 1, flesh_fields => { cmfinm => [qw/norm/] }, order_by => [{ class => "cmfinm", field => "pos" }] }
- )->gather(1),
- search_relevance_adjustment =>
- $cstore->request(
- 'open-ils.cstore.direct.search.relevance_adjustment.search.atomic',
- { id => { "!=" => undef } }
- )->gather(1),
- config_metabib_field =>
- $cstore->request(
- 'open-ils.cstore.direct.config.metabib_field.search.atomic',
- { id => { "!=" => undef } }
- )->gather(1),
- config_metabib_search_alias =>
- $cstore->request(
- 'open-ils.cstore.direct.config.metabib_search_alias.search.atomic',
- { alias => { "!=" => undef } }
- )->gather(1),
- );
-
- $cstore->disconnect;
- die("Cannot initialize $parser!") unless ($parser->initialization_complete);
- }
-
- if (! scalar( keys %{$args{searches}} )) {
- die "No search arguments were passed to ".$self->api_name;
- }
-
- $log->debug("Constructing QueryParser query from staged search hash ...", DEBUG);
- my $base_query = '';
- for my $sclass ( keys %{$args{searches}} ) {
- $log->debug(" --> staged search key: $sclass --> term: $args{searches}{$sclass}{term}", DEBUG);
- $base_query .= " $sclass: $args{searches}{$sclass}{term}";
- }
-
- my $query = $base_query;
- $log->debug("Full base query: $base_query", DEBUG);
-
- $query = "$args{facets} $query" if ($args{facets});
-
- if (!$locale_map{COMPLETE}) {
-
- my @locales = config::i18n_locale->search_where({ code => { '<>' => '' } });
- for my $locale ( @locales ) {
- $locale_map{lc($locale->code)} = $locale->marc_code;
- }
- $locale_map{COMPLETE} = 1;
-
- }
-
- my $base_plan = $parser->new( query => $base_query )->parse;
-
- $query = "preferred_language($args{preferred_language}) $query"
- if ($args{preferred_language} and !$base_plan->parse_tree->find_filter('preferred_language'));
- $query = "preferred_language_weight($args{preferred_language_weight}) $query"
- if ($args{preferred_language_weight} and !$base_plan->parse_tree->find_filter('preferred_language_weight') and !$base_plan->parse_tree->find_filter('preferred_language_multiplier'));
-
- $query = "estimation_strategy($args{estimation_strategy}) $query" if ($args{estimation_strategy});
- $query = "site($args{org_unit}) $query" if ($args{org_unit});
- $query = "depth($args{depth}) $query" if (defined($args{depth}));
- $query = "sort($args{sort}) $query" if ($args{sort});
- $query = "limit($args{limit}) $query" if ($args{limit});
- $query = "core_limit($args{core_limit}) $query" if ($args{core_limit});
- $query = "skip_check($args{skip_check}) $query" if ($args{skip_check});
- $query = "superpage($args{superpage}) $query" if ($args{superpage});
- $query = "offset($args{offset}) $query" if ($args{offset});
- $query = "#metarecord $query" if ($self->api_name =~ /metabib/);
- $query = "#available $query" if ($args{available});
- $query = "#descending $query" if ($args{sort_dir} && $args{sort_dir} =~ /^d/i);
- $query = "#staff $query" if ($self->api_name =~ /staff/);
- $query = "before($args{before}) $query" if (defined($args{before}) and $args{before} =~ /^\d+$/);
- $query = "after($args{after}) $query" if (defined($args{after}) and $args{after} =~ /^\d+$/);
- $query = "during($args{during}) $query" if (defined($args{during}) and $args{during} =~ /^\d+$/);
- $query = "between($args{between}[0],$args{between}[1]) $query"
- if ( ref($args{between}) and @{$args{between}} == 2 and $args{between}[0] =~ /^\d+$/ and $args{between}[1] =~ /^\d+$/ );
-
-
- my (@between,@statuses,@locations,@types,@forms,@lang,@aud,@lit_form,@vformats,@bib_level);
-
- # XXX legacy format and item type support
- if ($args{format}) {
- my ($t, $f) = split '-', $args{format};
- $args{item_type} = [ split '', $t ];
- $args{item_form} = [ split '', $f ];
- }
-
- for my $filter ( qw/locations statuses between audience language lit_form item_form item_type bib_level vr_format/ ) {
- if (my $s = $args{$filter}) {
- $s = [$s] if (!ref($s));
-
- my @filter_list = @$s;
-
- next if ($filter eq 'between' and scalar(@filter_list) != 2);
- next if (@filter_list == 0);
-
- my $filter_string = join ',', @filter_list;
- $query = "$filter($filter_string) $query";
- }
- }
-
- $log->debug("Full QueryParser query: $query", DEBUG);
-
- return query_parser_fts($self, $client, query => $query, _simple_plan => $base_plan->simple_plan );
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.staged.search_fts",
- method => 'query_parser_fts_wrapper',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.biblio.multiclass.staged.search_fts.staff",
- method => 'query_parser_fts_wrapper',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.multiclass.staged.search_fts",
- method => 'query_parser_fts_wrapper',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.storage.metabib.multiclass.staged.search_fts.staff",
- method => 'query_parser_fts_wrapper',
- api_level => 1,
- stream => 1,
- cachable => 1,
-);
-
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::money;
-use base qw/OpenILS::Application::Storage/;
-use OpenSRF::Utils::Logger qw/:level/;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub _make_mbts {
- my @xacts = @_;
-
- my @mbts;
- for my $x (@xacts) {
- my $s = new Fieldmapper::money::billable_transaction_summary;
- $s->id( $x->id );
- $s->usr( $x->usr );
- $s->xact_start( $x->xact_start );
- $s->xact_finish( $x->xact_finish );
-
- my $to = 0;
- my $lb = undef;
- for my $b ($x->billings) {
- next if ($b->voided);
- #$log->debug( "billing is ".$b->amount, DEBUG );
- $to += ($b->amount * 100);
- $lb ||= $b->billing_ts;
- if ($b->billing_ts ge $lb) {
- $lb = $b->billing_ts;
- $s->last_billing_note($b->note);
- $s->last_billing_ts($b->billing_ts);
- $s->last_billing_type($b->billing_type);
- }
- }
-
- $s->total_owed( sprintf('%0.2f', ($to) / 100 ) );
-
- my $tp = 0;
- my $lp = undef;
- for my $p ($x->payments) {
- #$log->debug( "payment is ".$p->amount." voided = ".$p->voided, DEBUG );
- next if ($p->voided eq 't');
- $tp += ($p->amount * 100);
- $lp ||= $p->payment_ts;
- if ($p->payment_ts ge $lp) {
- $lp = $p->payment_ts;
- $s->last_payment_note($p->note);
- $s->last_payment_ts($p->payment_ts);
- $s->last_payment_type($p->payment_type);
- }
- }
- $s->total_paid( sprintf('%0.2f', ($tp) / 100 ) );
-
- $s->balance_owed( sprintf('%0.2f', (($to) - ($tp)) / 100) );
- #$log->debug( "balance of ".$x->id." == ".$s->balance_owed, DEBUG );
-
- if (action::circulation->retrieve($x->id)) {
- $s->xact_type( 'circulation' );
- } elsif (money::grocery->retrieve($x->id)) {
- $s->xact_type( 'grocery' );
- } elsif (booking::reservation->retrieve($x->id)) {
- $s->xact_type( 'reservation' );
- }
-
- push @mbts, $s;
- }
-
- return @mbts;
-}
-
-sub search_mbts {
- my $self = shift;
- my $client = shift;
- my $search = shift;
-
- my @xacts = money::billable_transaction->search_where( $search );
- $client->respond( $_ ) for (_make_mbts(@xacts));
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'search_mbts',
- api_name => 'open-ils.storage.money.billable_transaction.summary.search',
- stream => 1,
- argc => 1,
-);
-
-sub search_ous {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
-
- my @xacts = $self->method_lookup( 'open-ils.storage.money.billable_transaction.summary.search' )->run( { usr => $usr, xact_finish => undef } );
-
- my ($total,$owed,$paid) = (0.0,0.0,0.0);
- for my $x (@xacts) {
- $total += $x->total_owed;
- $owed += $x->balance_owed;
- $paid += $x->total_paid;
- }
-
- my $ous = Fieldmapper::money::open_user_summary->new;
- $ous->usr( $usr );
- $ous->total_paid( sprintf('%0.2f', $paid) );
- $ous->total_owed( sprintf('%0.2f', $total) );
- $ous->balance_owed( sprintf('%0.2f', $owed) );
-
- return $ous;
-}
-__PACKAGE__->register_method(
- method => 'search_ous',
- api_name => 'open-ils.storage.money.open_user_summary.search',
- argc => 1,
-);
-
-
-sub new_collections {
- my $self = shift;
- my $client = shift;
- my $age = shift;
- my $amount = shift;
- my @loc = @_;
-
- my $mct = money::collections_tracker->table;
- my $mb = money::billing->table;
- my $circ = action::circulation->table;
- my $mg = money::grocery->table;
- my $res = booking::reservation->table;
- my $descendants = "actor.org_unit_descendants((select id from actor.org_unit where shortname = ?))";
-
- my $SQL = <<" SQL";
-
-select
- usr,
- MAX(last_billing) as last_pertinent_billing,
- SUM(total_billing) - SUM(COALESCE(p.amount,0)) as threshold_amount
- from (select
- x.id,
- x.usr,
- MAX(b.billing_ts) as last_billing,
- SUM(b.amount) AS total_billing
- from action.circulation x
- left join money.collections_tracker c ON (c.usr = x.usr AND c.location = ?)
- join money.billing b on (b.xact = x.id)
- where x.xact_finish is null
- and c.id is null
- and x.circ_lib in (XX)
- and b.billing_ts < current_timestamp - ? * '1 day'::interval
- and not b.voided
- group by 1,2
-
- union all
-
- select
- x.id,
- x.usr,
- MAX(b.billing_ts) as last_billing,
- SUM(b.amount) AS total_billing
- from money.grocery x
- left join money.collections_tracker c ON (c.usr = x.usr AND c.location = ?)
- join money.billing b on (b.xact = x.id)
- where x.xact_finish is null
- and c.id is null
- and x.billing_location in (XX)
- and b.billing_ts < current_timestamp - ? * '1 day'::interval
- and not b.voided
- group by 1,2
-
- union all
-
- select
- x.id,
- x.usr,
- MAX(b.billing_ts) as last_billing,
- SUM(b.amount) AS total_billing
- from booking.reservation x
- left join money.collections_tracker c ON (c.usr = x.usr AND c.location = ?)
- join money.billing b on (b.xact = x.id)
- where x.xact_finish is null
- and c.id is null
- and x.pickup_lib in (XX)
- and b.billing_ts < current_timestamp - ? * '1 day'::interval
- and not b.voided
- group by 1,2
- ) full_list
- left join money.payment p on (full_list.id = p.xact)
- group by 1
- having SUM(total_billing) - SUM(COALESCE(p.amount,0)) > ?
-;
- SQL
-
- my @l_ids;
- for my $l (@loc) {
- my ($org) = actor::org_unit->search( shortname => uc($l) );
- next unless $org;
-
- my $o_list = actor::org_unit->db_Main->selectcol_arrayref( "SELECT id FROM actor.org_unit_descendants(?);", {}, $org->id );
- next unless (@$o_list);
-
- my $o_txt = join ',' => @$o_list;
-
- (my $real_sql = $SQL) =~ s/XX/$o_txt/gsm;
-
- my $sth = money::collections_tracker->db_Main->prepare($real_sql);
- $sth->execute( $org->id, $age, $org->id, $age, $org->id, $age, $amount );
-
- while (my $row = $sth->fetchrow_hashref) {
- #$row->{usr} = actor::user->retrieve($row->{usr})->to_fieldmapper;
- $client->respond( $row );
- }
- }
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'new_collections',
- api_name => 'open-ils.storage.money.collections.users_of_interest',
- stream => 1,
- argc => 3,
-);
-
-sub users_owing_money {
- my $self = shift;
- my $client = shift;
- my $start = shift;
- my $end = shift;
- my $amount = shift;
- my @loc = @_;
-
- my $mct = money::collections_tracker->table;
- my $mb = money::billing->table;
- my $circ = action::circulation->table;
- my $mg = money::grocery->table;
- my $descendants = "actor.org_unit_descendants((select id from actor.org_unit where shortname = ?))";
-
- my $SQL = <<" SQL";
-
-select
- usr,
- SUM(total_billing) - SUM(COALESCE(p.amount,0)) as threshold_amount
- from (select
- x.id,
- x.usr,
- SUM(b.amount) AS total_billing
- from action.circulation x
- join money.billing b on (b.xact = x.id)
- where x.xact_finish is null
- and x.circ_lib in (XX)
- and b.billing_ts between ? and ?
- and not b.voided
- group by 1,2
-
- union all
-
- select
- x.id,
- x.usr,
- SUM(b.amount) AS total_billing
- from money.grocery x
- join money.billing b on (b.xact = x.id)
- where x.xact_finish is null
- and x.billing_location in (XX)
- and b.billing_ts between ? and ?
- and not b.voided
- group by 1,2
-
- union all
-
- select
- x.id,
- x.usr,
- SUM(b.amount) AS total_billing
- from booking.reservation x
- join money.billing b on (b.xact = x.id)
- where x.xact_finish is null
- and x.pickup_lib in (XX)
- and b.billing_ts between ? and ?
- and not b.voided
- group by 1,2
- ) full_list
- left join money.payment p on (full_list.id = p.xact)
- group by 1
- having SUM(total_billing) - SUM(COALESCE(p.amount,0)) > ?
-;
- SQL
-
- my @l_ids;
- for my $l (@loc) {
- my ($org) = actor::org_unit->search( shortname => uc($l) );
- next unless $org;
-
- my $o_list = actor::org_unit->db_Main->selectcol_arrayref( "SELECT id FROM actor.org_unit_descendants(?);", {}, $org->id );
- next unless (@$o_list);
-
- my $o_txt = join ',' => @$o_list;
-
- (my $real_sql = $SQL) =~ s/XX/$o_txt/gsm;
-
- my $sth = money::collections_tracker->db_Main->prepare($real_sql);
- $sth->execute( $start, $end, $start, $end, $amount );
-
- while (my $row = $sth->fetchrow_hashref) {
- #$row->{usr} = actor::user->retrieve($row->{usr})->to_fieldmapper;
- $client->respond( $row );
- }
- }
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'users_owing_money',
- api_name => 'open-ils.storage.money.collections.users_owing_money',
- stream => 1,
- argc => 4,
-);
-
-sub active_in_collections {
- my $self = shift;
- my $client = shift;
- my $startdate = shift;
- my $enddate = shift;
- my @loc = @_;
-
- my $mct = money::collections_tracker->table;
- my $mb = money::billing->table;
- my $circ = action::circulation->table;
- my $mg = money::grocery->table;
-
- my $SQL = <<" SQL";
-SELECT usr,
- MAX(last_pertinent_billing) AS last_pertinent_billing,
- MAX(last_pertinent_payment) AS last_pertinent_payment
- FROM (
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM booking.reservation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.billing bl ON (lt.id = bl.xact)
- WHERE cl.location = ?
- AND lt.pickup_lib IN (XX)
- AND bl.void_time BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- MAX(bl.billing_ts) AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM booking.reservation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.billing bl ON (lt.id = bl.xact)
- WHERE cl.location = ?
- AND lt.pickup_lib IN (XX)
- AND bl.billing_ts BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- MAX(pm.payment_ts) AS last_pertinent_payment
- FROM booking.reservation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.payment pm ON (lt.id = pm.xact)
- WHERE cl.location = ?
- AND lt.pickup_lib IN (XX)
- AND pm.payment_ts BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM money.grocery lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.billing bl ON (lt.id = bl.xact)
- WHERE cl.location = ?
- AND lt.billing_location IN (XX)
- AND bl.void_time BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- MAX(bl.billing_ts) AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM money.grocery lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.billing bl ON (lt.id = bl.xact)
- WHERE cl.location = ?
- AND lt.billing_location IN (XX)
- AND bl.billing_ts BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- MAX(pm.payment_ts) AS last_pertinent_payment
- FROM money.grocery lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.payment pm ON (lt.id = pm.xact)
- WHERE cl.location = ?
- AND lt.billing_location IN (XX)
- AND pm.payment_ts BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM action.circulation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- WHERE cl.location = ?
- AND lt.circ_lib IN (XX)
- AND lt.checkin_time BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- MAX(pm.payment_ts) AS last_pertinent_payment
- FROM action.circulation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.payment pm ON (lt.id = pm.xact)
- WHERE cl.location = ?
- AND lt.circ_lib IN (XX)
- AND pm.payment_ts BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- NULL::TIMESTAMPTZ AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM action.circulation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.billing bl ON (lt.id = bl.xact)
- WHERE cl.location = ?
- AND lt.circ_lib IN (XX)
- AND bl.void_time BETWEEN ? AND ?
- GROUP BY 1
-
- UNION ALL
- SELECT lt.usr,
- MAX(bl.billing_ts) AS last_pertinent_billing,
- NULL::TIMESTAMPTZ AS last_pertinent_payment
- FROM action.circulation lt
- JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
- JOIN money.billing bl ON (lt.id = bl.xact)
- WHERE cl.location = ?
- AND lt.circ_lib IN (XX)
- AND bl.billing_ts BETWEEN ? AND ?
- GROUP BY 1
- ) foo
- GROUP BY 1
-;
- SQL
-
- my @l_ids;
- for my $l (@loc) {
- my ($org) = actor::org_unit->search( shortname => uc($l) );
- next unless $org;
-
- my $o_list = actor::org_unit->db_Main->selectcol_arrayref( "SELECT id FROM actor.org_unit_descendants(?);", {}, $org->id );
- next unless (@$o_list);
-
- my $o_txt = join ',' => @$o_list;
-
- (my $real_sql = $SQL) =~ s/XX/$o_txt/gsm;
-
- my $sth = money::collections_tracker->db_Main->prepare($real_sql);
- $sth->execute(
- # reservation queries
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate,
-
- # grocery queries
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate,
-
- # circ queries
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate,
- $org->id, $startdate, $enddate
- );
-
- while (my $row = $sth->fetchrow_hashref) {
- $row->{usr} = actor::user->retrieve($row->{usr})->to_fieldmapper;
- $client->respond( $row );
- }
- }
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'active_in_collections',
- api_name => 'open-ils.storage.money.collections.users_with_activity',
- stream => 1,
- argc => 3,
-);
-
-sub ou_desk_payments {
- my $self = shift;
- my $client = shift;
- my $lib = shift;
- my $startdate = shift;
- my $enddate = shift;
-
- return undef unless ($startdate =~ /^\d{4}-\d{2}-\d{2}$/o);
- return undef unless ($enddate =~ /^\d{4}-\d{2}-\d{2}$/o);
- return undef unless ($lib =~ /^\d+$/o);
-
- my $sql = <<" SQL";
-
- SELECT ws.id as workstation,
- SUM( CASE WHEN p.payment_type = 'cash_payment' THEN p.amount ELSE 0.0 END ) as cash_payment,
- SUM( CASE WHEN p.payment_type = 'check_payment' THEN p.amount ELSE 0.0 END ) as check_payment,
- SUM( CASE WHEN p.payment_type = 'credit_card_payment' THEN p.amount ELSE 0.0 END ) as credit_card_payment
- FROM money.desk_payment_view p
- JOIN actor.workstation ws ON (ws.id = p.cash_drawer)
- WHERE p.payment_ts >= '$startdate'
- AND p.payment_ts < '$enddate'::TIMESTAMPTZ + INTERVAL '1 day'
- AND p.voided IS FALSE
- AND ws.owning_lib = $lib
- GROUP BY 1
- ORDER BY 1;
-
- SQL
-
- my $rows = money::payment->db_Main->selectall_arrayref( $sql );
-
- for my $r (@$rows) {
- my $x = new Fieldmapper::money::workstation_payment_summary;
- $x->workstation( actor::workstation->retrieve($$r[0])->to_fieldmapper );
- $x->cash_payment($$r[1]);
- $x->check_payment($$r[2]);
- $x->credit_card_payment($$r[3]);
-
- $client->respond($x);
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'ou_desk_payments',
- api_name => 'open-ils.storage.money.org_unit.desk_payments',
- stream => 1,
- argc => 3,
-);
-
-sub ou_user_payments {
- my $self = shift;
- my $client = shift;
- my $lib = shift;
- my $startdate = shift;
- my $enddate = shift;
-
- return undef unless ($startdate =~ /^\d{4}-\d{2}-\d{2}$/o);
- return undef unless ($enddate =~ /^\d{4}-\d{2}-\d{2}$/o);
- return undef unless ($lib =~ /^\d+$/o);
-
- my $sql = <<" SQL";
-
- SELECT au.id as usr,
- SUM( CASE WHEN p.payment_type = 'forgive_payment' THEN p.amount ELSE 0.0 END ) as forgive_payment,
- SUM( CASE WHEN p.payment_type = 'work_payment' THEN p.amount ELSE 0.0 END ) as work_payment,
- SUM( CASE WHEN p.payment_type = 'credit_payment' THEN p.amount ELSE 0.0 END ) as credit_payment,
- SUM( CASE WHEN p.payment_type = 'goods_payment' THEN p.amount ELSE 0.0 END ) as goods_payment
- FROM money.bnm_payment_view p
- JOIN actor.usr au ON (au.id = p.accepting_usr)
- WHERE p.payment_ts >= '$startdate'
- AND p.payment_ts < '$enddate'::TIMESTAMPTZ + INTERVAL '1 day'
- AND p.voided IS FALSE
- AND au.home_ou = $lib
- AND p.payment_type IN ('credit_payment','forgive_payment','work_payment','goods_payment')
- GROUP BY 1
- ORDER BY 1;
-
- SQL
-
- my $rows = money::payment->db_Main->selectall_arrayref( $sql );
-
- for my $r (@$rows) {
- my $x = new Fieldmapper::money::user_payment_summary;
- $x->usr( actor::user->retrieve($$r[0])->to_fieldmapper );
- $x->forgive_payment($$r[1]);
- $x->work_payment($$r[2]);
- $x->credit_payment($$r[3]);
- $x->goods_payment($$r[4]);
-
- $client->respond($x);
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'ou_user_payments',
- api_name => 'open-ils.storage.money.org_unit.user_payments',
- stream => 1,
- argc => 3,
-);
-
-sub mark_unrecovered {
- my $self = shift;
- my $xact = shift;
-
- my $x = money::billable_xact->retrieve($xact);
- $x->unrecovered( 't' );
- return $x->update;
-}
-__PACKAGE__->register_method(
- method => 'mark_unrecovered',
- api_name => 'open-ils.storage.money.billable_xact.mark_unrecovered',
- argc => 1,
-);
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Storage::Publisher::permission;
-use base qw/OpenILS::Application::Storage/;
-#use OpenILS::Application::Storage::CDBI::config;
-
-
-sub retrieve_all {
- my $self = shift;
- my $client = shift;
-
- for my $rec ( permission::grp_tree->retrieve_all ) {
- $client->respond( $rec->to_fieldmapper );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'retrieve_all',
- api_name => 'open-ils.storage.direct.permission.grp_tree.retrieve.all',
- argc => 0,
- stream => 1,
-);
-
-sub retrieve_perms {
- my $self = shift;
- my $client = shift;
-
- for my $rec ( sort { $a->code cmp $b->code } permission::perm_list->retrieve_all ) {
- $client->respond( $rec->to_fieldmapper );
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'retrieve_perms',
- api_name => 'open-ils.storage.direct.permission.perm_list.retrieve.all',
- argc => 0,
- stream => 1,
-);
-
-sub usr_has_perm {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
- my $perm = shift;
- my $target = shift;
-
- return permission::usr_grp_map->db_Main->selectrow_arrayref(<<" SQL",{}, "$usr", "$perm", "$target")->[0];
- SELECT permission.usr_has_perm(?,?,?)
- SQL
-}
-__PACKAGE__->register_method(
- method => 'usr_has_perm',
- api_name => 'open-ils.storage.permission.user_has_perm',
- argc => 3,
-);
-
-sub usr_has_home_perm {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
- my $perm = shift;
- my $target = shift;
-
- return permission::usr_grp_map->db_Main->selectrow_arrayref(<<" SQL",{}, "$usr", "$perm", "$target")->[0];
- SELECT permission.usr_has_home_perm(?,?,?)
- SQL
-}
-__PACKAGE__->register_method(
- method => 'usr_has_home_perm',
- api_name => 'open-ils.storage.permission.user_has_home_perm',
- argc => 3,
-);
-
-sub usr_has_work_perm {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
- my $perm = shift;
- my $target = shift;
-
- return permission::usr_grp_map->db_Main->selectrow_arrayref(<<" SQL",{}, "$usr", "$perm", "$target")->[0];
- SELECT permission.usr_has_work_perm(?,?,?)
- SQL
-}
-__PACKAGE__->register_method(
- method => 'usr_has_work_perm',
- api_name => 'open-ils.storage.permission.user_has_work_perm',
- argc => 3,
-);
-
-sub usr_perms {
- my $self = shift;
- my $client = shift;
- my $usr = shift;
-
- my $sth = permission::usr_perm_map->db_Main->prepare('SELECT DISTINCT * FROM permission.usr_perms(?)');
- $sth->execute("$usr");
-
- $client->respond( $_->to_fieldmapper ) for ( map { permission::usr_perm_map->construct($_) } $sth->fetchall_hash );
-
- return undef;
-}
-__PACKAGE__->register_method(
- method => 'usr_perms',
- api_name => 'open-ils.storage.permission.user_perms',
- argc => 1,
- stream => 1,
-);
-
-1;
+++ /dev/null
-package QueryParser;
-our %parser_config = (
- QueryParser => {
- filters => [],
- modifiers => [],
- operators => {
- 'and' => '&&',
- 'or' => '||',
- group_start => '(',
- group_end => ')',
- required => '+',
- modifier => '#'
- }
- }
-);
-
-sub facet_class_count {
- my $self = shift;
- return @{$self->facet_classes};
-}
-
-sub search_class_count {
- my $self = shift;
- return @{$self->search_classes};
-}
-
-sub filter_count {
- my $self = shift;
- return @{$self->filters};
-}
-
-sub modifier_count {
- my $self = shift;
- return @{$self->modifiers};
-}
-
-sub custom_data {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{custom_data} ||= {};
- return $parser_config{$class}{custom_data};
-}
-
-sub operators {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{operators} ||= {};
- return $parser_config{$class}{operators};
-}
-
-sub filters {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{filters} ||= [];
- return $parser_config{$class}{filters};
-}
-
-sub modifiers {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{modifiers} ||= [];
- return $parser_config{$class}{modifiers};
-}
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my %opts = @_;
-
- my $self = bless {} => $class;
-
- for my $o (keys %{QueryParser->operators}) {
- $class->operator($o => QueryParser->operator($o)) unless ($class->operator($o));
- }
-
- for my $opt ( keys %opts) {
- $self->$opt( $opts{$opt} ) if ($self->can($opt));
- }
-
- return $self;
-}
-
-sub new_plan {
- my $self = shift;
- my $pkg = ref($self) || $self;
- return do{$pkg.'::query_plan'}->new( QueryParser => $self, @_ );
-}
-
-sub add_search_filter {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $filter = shift;
-
- return $filter if (grep { $_ eq $filter } @{$pkg->filters});
- push @{$pkg->filters}, $filter;
- return $filter;
-}
-
-sub add_search_modifier {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $modifier = shift;
-
- return $modifier if (grep { $_ eq $modifier } @{$pkg->modifiers});
- push @{$pkg->modifiers}, $modifier;
- return $modifier;
-}
-
-sub add_facet_class {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
-
- return $class if (grep { $_ eq $class } @{$pkg->facet_classes});
-
- push @{$pkg->facet_classes}, $class;
- $pkg->facet_fields->{$class} = [];
-
- return $class;
-}
-
-sub add_search_class {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
-
- return $class if (grep { $_ eq $class } @{$pkg->search_classes});
-
- push @{$pkg->search_classes}, $class;
- $pkg->search_fields->{$class} = [];
- $pkg->default_search_class( $pkg->search_classes->[0] ) if (@{$pkg->search_classes} == 1);
-
- return $class;
-}
-
-sub operator {
- my $class = shift;
- $class = ref($class) || $class;
- my $opname = shift;
- my $op = shift;
-
- return undef unless ($opname);
-
- $parser_config{$class}{operators} ||= {};
- $parser_config{$class}{operators}{$opname} = $op if ($op);
-
- return $parser_config{$class}{operators}{$opname};
-}
-
-sub facet_classes {
- my $class = shift;
- $class = ref($class) || $class;
- my $classes = shift;
-
- $parser_config{$class}{facet_classes} ||= [];
- $parser_config{$class}{facet_classes} = $classes if (ref($classes) && @$classes);
- return $parser_config{$class}{facet_classes};
-}
-
-sub search_classes {
- my $class = shift;
- $class = ref($class) || $class;
- my $classes = shift;
-
- $parser_config{$class}{classes} ||= [];
- $parser_config{$class}{classes} = $classes if (ref($classes) && @$classes);
- return $parser_config{$class}{classes};
-}
-
-sub add_query_normalizer {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
- my $func = shift;
- my $params = shift || [];
-
- return $func if (grep { $_ eq $func } @{$pkg->query_normalizers->{$class}->{$field}});
-
- push(@{$pkg->query_normalizers->{$class}->{$field}}, { function => $func, params => $params });
-
- return $func;
-}
-
-sub query_normalizers {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
-
- my $class = shift;
- my $field = shift;
-
- $parser_config{$pkg}{normalizers} ||= {};
- if ($class) {
- if ($field) {
- $parser_config{$pkg}{normalizers}{$class}{$field} ||= [];
- return $parser_config{$pkg}{normalizers}{$class}{$field};
- } else {
- return $parser_config{$pkg}{normalizers}{$class};
- }
- }
-
- return $parser_config{$pkg}{normalizers};
-}
-
-sub default_search_class {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- $QueryParser::parser_config{$pkg}{default_class} = $pkg->add_search_class( $class ) if $class;
-
- return $QueryParser::parser_config{$pkg}{default_class};
-}
-
-sub remove_facet_class {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
-
- return $class if (!grep { $_ eq $class } @{$pkg->facet_classes});
-
- $pkg->facet_classes( [ grep { $_ ne $class } @{$pkg->facet_classes} ] );
- delete $QueryParser::parser_config{$pkg}{facet_fields}{$class};
-
- return $class;
-}
-
-sub remove_search_class {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
-
- return $class if (!grep { $_ eq $class } @{$pkg->search_classes});
-
- $pkg->search_classes( [ grep { $_ ne $class } @{$pkg->search_classes} ] );
- delete $QueryParser::parser_config{$pkg}{fields}{$class};
-
- return $class;
-}
-
-sub add_facet_field {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
-
- $pkg->add_facet_class( $class );
-
- return { $class => $field } if (grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
-
- push @{$pkg->facet_fields->{$class}}, $field;
-
- return { $class => $field };
-}
-
-sub facet_fields {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{facet_fields} ||= {};
- return $parser_config{$class}{facet_fields};
-}
-
-sub add_search_field {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
-
- $pkg->add_search_class( $class );
-
- return { $class => $field } if (grep { $_ eq $field } @{$pkg->search_fields->{$class}});
-
- push @{$pkg->search_fields->{$class}}, $field;
-
- return { $class => $field };
-}
-
-sub search_fields {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{fields} ||= {};
- return $parser_config{$class}{fields};
-}
-
-sub add_search_class_alias {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $alias = shift;
-
- $pkg->add_search_class( $class );
-
- return { $class => $alias } if (grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
-
- push @{$pkg->search_class_aliases->{$class}}, $alias;
-
- return { $class => $alias };
-}
-
-sub search_class_aliases {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{class_map} ||= {};
- return $parser_config{$class}{class_map};
-}
-
-sub add_search_field_alias {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
- my $alias = shift;
-
- return { $class => { $field => $alias } } if (grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
-
- push @{$pkg->search_field_aliases->{$class}{$field}}, $alias;
-
- return { $class => { $field => $alias } };
-}
-
-sub search_field_aliases {
- my $class = shift;
- $class = ref($class) || $class;
-
- $parser_config{$class}{field_alias_map} ||= {};
- return $parser_config{$class}{field_alias_map};
-}
-
-sub remove_facet_field {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
-
- return { $class => $field } if (!$pkg->facet_fields->{$class} || !grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
-
- $pkg->facet_fields->{$class} = [ grep { $_ ne $field } @{$pkg->facet_fields->{$class}} ];
-
- return { $class => $field };
-}
-
-sub remove_search_field {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
-
- return { $class => $field } if (!$pkg->search_fields->{$class} || !grep { $_ eq $field } @{$pkg->search_fields->{$class}});
-
- $pkg->search_fields->{$class} = [ grep { $_ ne $field } @{$pkg->search_fields->{$class}} ];
-
- return { $class => $field };
-}
-
-sub remove_search_field_alias {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $field = shift;
- my $alias = shift;
-
- return { $class => { $field => $alias } } if (!$pkg->search_field_aliases->{$class}{$field} || !grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
-
- $pkg->search_field_aliases->{$class}{$field} = [ grep { $_ ne $alias } @{$pkg->search_field_aliases->{$class}{$field}} ];
-
- return { $class => { $field => $alias } };
-}
-
-sub remove_search_class_alias {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $class = shift;
- my $alias = shift;
-
- return { $class => $alias } if (!$pkg->search_class_aliases->{$class} || !grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
-
- $pkg->search_class_aliases->{$class} = [ grep { $_ ne $alias } @{$pkg->search_class_aliases->{$class}} ];
-
- return { $class => $alias };
-}
-
-sub debug {
- my $self = shift;
- my $q = shift;
- $self->{_debug} = $q if (defined $q);
- return $self->{_debug};
-}
-
-sub query {
- my $self = shift;
- my $q = shift;
- $self->{_query} = $q if (defined $q);
- return $self->{_query};
-}
-
-sub parse_tree {
- my $self = shift;
- my $q = shift;
- $self->{_parse_tree} = $q if (defined $q);
- return $self->{_parse_tree};
-}
-
-sub parse {
- my $self = shift;
- my $pkg = ref($self) || $self;
- warn " ** parse package is $pkg\n" if $self->debug;
- $self->parse_tree(
- $self->decompose(
- $self->query( shift() )
- )
- );
-
- return $self;
-}
-
-sub decompose {
- my $self = shift;
- my $pkg = ref($self) || $self;
-
- warn " ** decompose package is $pkg\n" if $self->debug;
-
- $_ = shift;
- my $current_class = shift || $self->default_search_class;
-
- my $recursing = shift || 0;
-
- # Build the search class+field uber-regexp
- my $search_class_re = '^\s*(';
- my $first_class = 1;
-
- my %seen_classes;
- for my $class ( keys %{$pkg->search_fields} ) {
-
- for my $field ( @{$pkg->search_fields->{$class}} ) {
-
- for my $alias ( @{$pkg->search_field_aliases->{$class}{$field}} ) {
- $alias = qr/$alias/;
- s/(^|\s+)$alias[:=]/$1$class\|$field:/g;
- }
- }
-
- $search_class_re .= '|' unless ($first_class);
- $first_class = 0;
- $search_class_re .= $class . '(?:\|\w+)*';
- $seen_classes{$class} = 1;
- }
-
- for my $class ( keys %{$pkg->search_class_aliases} ) {
-
- for my $alias ( @{$pkg->search_class_aliases->{$class}} ) {
- $alias = qr/$alias/;
- s/(^|[^|])\b$alias\|/$1$class\|/g;
- s/(^|[^|])\b$alias[:=]/$1$class:/g;
- }
-
- $search_class_re .= '|' unless ($first_class);
- $first_class = 0;
-
- $search_class_re .= $class . '(?:\|\w+)*' if (!$seen_classes{$class});
- $seen_classes{$class} = 1;
- }
- $search_class_re .= '):';
-
- warn " ** Search class RE: $search_class_re\n" if $self->debug;
-
- my $required_re = $pkg->operator('required');
- $required_re = qr/^\s*\Q$required_re\E/;
- my $and_re = $pkg->operator('and');
- $and_re = qr/^\s*\Q$and_re\E/;
-
- my $or_re = $pkg->operator('or');
- $or_re = qr/^\s*\Q$or_re\E/;
-
- my $group_start_re = $pkg->operator('group_start');
- $group_start_re = qr/^\s*\Q$group_start_re\E/;
-
- my $group_end = $pkg->operator('group_end');
- my $group_end_re = qr/^\s*\Q$group_end\E/;
-
- my $modifier_tag_re = $pkg->operator('modifier');
- $modifier_tag_re = qr/^\s*\Q$modifier_tag_re\E/;
-
-
- # Build the filter and modifier uber-regexps
- my $facet_re = '^\s*((?:' . join( '|', @{$pkg->facet_classes}) . ')(?:\|\w+)*)\[(.+?)\]';
- warn " Facet RE: $facet_re\n" if $self->debug;
-
- my $filter_re = '^\s*(' . join( '|', @{$pkg->filters}) . ')\(([^()]+)\)';
- my $filter_as_class_re = '^\s*(' . join( '|', @{$pkg->filters}) . '):\s*(\S+)';
-
- my $modifier_re = '^\s*'.$modifier_tag_re.'(' . join( '|', @{$pkg->modifiers}) . ')\b';
- my $modifier_as_class_re = '^\s*(' . join( '|', @{$pkg->modifiers}) . '):\s*(\S+)';
-
- my $struct = $self->new_plan( level => $recursing );
- my $remainder = '';
-
- my $last_type = '';
- while (!$remainder) {
- if (/^\s*$/) { # end of an explicit group
- last;
- } elsif (/$group_end_re/) { # end of an explicit group
- warn "Encountered explicit group end\n" if $self->debug;
-
- $_ = $';
- $remainder = $';
-
- $last_type = '';
- } elsif ($self->filter_count && /$filter_re/) { # found a filter
- warn "Encountered search filter: $1 set to $2\n" if $self->debug;
-
- $_ = $';
- $struct->new_filter( $1 => [ split '[, ]+', $2 ] );
-
- $last_type = '';
- } elsif ($self->filter_count && /$filter_as_class_re/) { # found a filter
- warn "Encountered search filter: $1 set to $2\n" if $self->debug;
-
- $_ = $';
- $struct->new_filter( $1 => [ split '[, ]+', $2 ] );
-
- $last_type = '';
- } elsif ($self->modifier_count && /$modifier_re/) { # found a modifier
- warn "Encountered search modifier: $1\n" if $self->debug;
-
- $_ = $';
- if (!$struct->top_plan) {
- warn " Search modifiers only allowed at the top level of the query\n" if $self->debug;
- } else {
- $struct->new_modifier($1);
- }
-
- $last_type = '';
- } elsif ($self->modifier_count && /$modifier_as_class_re/) { # found a modifier
- warn "Encountered search modifier: $1\n" if $self->debug;
-
- my $mod = $1;
-
- $_ = $';
- if (!$struct->top_plan) {
- warn " Search modifiers only allowed at the top level of the query\n" if $self->debug;
- } elsif ($2 =~ /^[ty1]/i) {
- $struct->new_modifier($mod);
- }
-
- $last_type = '';
- } elsif (/$group_start_re/) { # start of an explicit group
- warn "Encountered explicit group start\n" if $self->debug;
-
- my ($substruct, $subremainder) = $self->decompose( $', $current_class, $recursing + 1 );
- $struct->add_node( $substruct );
- $_ = $subremainder;
-
- $last_type = '';
- } elsif (/$and_re/) { # ANDed expression
- $_ = $';
- next if ($last_type eq 'AND');
- next if ($last_type eq 'OR');
- warn "Encountered AND\n" if $self->debug;
-
- $struct->joiner( '&' );
-
- $last_type = 'AND';
- } elsif (/$or_re/) { # ORed expression
- $_ = $';
- next if ($last_type eq 'AND');
- next if ($last_type eq 'OR');
- warn "Encountered OR\n" if $self->debug;
-
- $struct->joiner( '|' );
-
- $last_type = 'OR';
- } elsif ($self->facet_class_count && /$facet_re/) { # changing current class
- warn "Encountered facet: $1 => $2\n" if $self->debug;
-
- my $facet = $1;
- my $facet_value = [ split '\s*#\s*', $2 ];
- $struct->new_facet( $facet => $facet_value );
- $_ = $';
-
- $last_type = '';
- } elsif ($self->search_class_count && /$search_class_re/) { # changing current class
-
- if ($last_type eq 'CLASS') {
- $struct->remove_last_node( $current_class );
- warn "Encountered class change with no searches!\n" if $self->debug;
- }
-
- warn "Encountered class change: $1\n" if $self->debug;
-
- $current_class = $1;
- $struct->classed_node( $current_class );
- $_ = $';
-
- $last_type = 'CLASS';
- } elsif (/^\s*"([^"]+)"/) { # phrase, always anded
- warn "Encountered phrase: $1\n" if $self->debug;
-
- $struct->joiner( '&' );
- my $phrase = $1;
-
- my $class_node = $struct->classed_node($current_class);
- $class_node->add_phrase( $phrase );
- $_ = $phrase . $';
-
- $last_type = '';
- } elsif (/$required_re([^\s)]+)/) { # phrase, always anded
- warn "Encountered required atom (mini phrase): $1\n" if $self->debug;
-
- my $phrase = $1;
-
- my $class_node = $struct->classed_node($current_class);
- $class_node->add_phrase( $phrase );
- $_ = $phrase . $';
- $struct->joiner( '&' );
-
- $last_type = '';
- } elsif (/^\s*([^$group_end\s]+)/o) { # atom
- warn "Encountered atom: $1\n" if $self->debug;
- warn "Remainder: $'\n" if $self->debug;
-
- my $atom = $1;
- my $after = $';
-
- $_ = $after;
- $last_type = '';
-
- my $negator = ($atom =~ s/^-//o) ? '!' : '';
- my $truncate = ($atom =~ s/\*$//o) ? '*' : '';
-
- if (!grep { $atom eq $_ } ('&','|')) { # throw away & and |, not allowed in tsquery, and not really useful anyway
- my $class_node = $struct->classed_node($current_class);
- $class_node->add_fts_atom( $atom, suffix => $truncate, prefix => $negator, node => $class_node );
- $struct->joiner( '&' );
- }
- }
-
- last unless ($_);
-
- }
-
- return $struct if !wantarray;
- return ($struct, $remainder);
-}
-
-sub find_class_index {
- my $class = shift;
- my $query = shift;
-
- my ($class_part, @field_parts) = split '\|', $class;
- $class_part ||= $class;
-
- for my $idx ( 0 .. scalar(@$query) - 1 ) {
- next unless ref($$query[$idx]);
- return $idx if ( $$query[$idx]{requested_class} && $class eq $$query[$idx]{requested_class} );
- }
-
- push(@$query, { classname => $class_part, (@field_parts ? (fields => \@field_parts) : ()), requested_class => $class, ftsquery => [], phrases => [] });
- return -1;
-}
-
-sub core_limit {
- my $self = shift;
- my $l = shift;
- $self->{core_limit} = $l if ($l);
- return $self->{core_limit};
-}
-
-sub superpage {
- my $self = shift;
- my $l = shift;
- $self->{superpage} = $l if ($l);
- return $self->{superpage};
-}
-
-sub superpage_size {
- my $self = shift;
- my $l = shift;
- $self->{superpage_size} = $l if ($l);
- return $self->{superpage_size};
-}
-
-
-#-------------------------------
-package QueryParser::query_plan;
-
-sub QueryParser {
- my $self = shift;
- return undef unless ref($self);
- return $self->{QueryParser};
-}
-
-sub new {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my %args = (query => [], joiner => '&', @_);
-
- return bless \%args => $pkg;
-}
-
-sub new_node {
- my $self = shift;
- my $pkg = ref($self) || $self;
- my $node = do{$pkg.'::node'}->new( plan => $self, @_ );
- $self->add_node( $node );
- return $node;
-}
-
-sub new_facet {
- my $self = shift;
- my $pkg = ref($self) || $self;
- my $name = shift;
- my $args = shift;
-
- my $node = do{$pkg.'::facet'}->new( plan => $self, name => $name, 'values' => $args );
- $self->add_node( $node );
-
- return $node;
-}
-
-sub new_filter {
- my $self = shift;
- my $pkg = ref($self) || $self;
- my $name = shift;
- my $args = shift;
-
- my $node = do{$pkg.'::filter'}->new( plan => $self, name => $name, args => $args );
- $self->add_filter( $node );
-
- return $node;
-}
-
-sub find_filter {
- my $self = shift;
- my $needle = shift;;
- return undef unless ($needle);
- return grep { $_->name eq $needle } @{ $self->filters };
-}
-
-sub find_modifier {
- my $self = shift;
- my $needle = shift;;
- return undef unless ($needle);
- return grep { $_->name eq $needle } @{ $self->modifiers };
-}
-
-sub new_modifier {
- my $self = shift;
- my $pkg = ref($self) || $self;
- my $name = shift;
-
- my $node = do{$pkg.'::modifier'}->new( $name );
- $self->add_modifier( $node );
-
- return $node;
-}
-
-sub classed_node {
- my $self = shift;
- my $requested_class = shift;
-
- my $node;
- for my $n (@{$self->{query}}) {
- next unless (ref($n) && $n->isa( 'QueryParser::query_plan::node' ));
- if ($n->requested_class eq $requested_class) {
- $node = $n;
- last;
- }
- }
-
- if (!$node) {
- $node = $self->new_node;
- $node->requested_class( $requested_class );
- }
-
- return $node;
-}
-
-sub remove_last_node {
- my $self = shift;
- my $requested_class = shift;
-
- my $old = pop(@{$self->query_nodes});
- pop(@{$self->query_nodes}) if (@{$self->query_nodes});
-
- return $old;
-}
-
-sub query_nodes {
- my $self = shift;
- return $self->{query};
-}
-
-sub add_node {
- my $self = shift;
- my $node = shift;
-
- $self->{query} ||= [];
- push(@{$self->{query}}, $self->joiner) if (@{$self->{query}});
- push(@{$self->{query}}, $node);
-
- return $self;
-}
-
-sub top_plan {
- my $self = shift;
-
- return $self->{level} ? 0 : 1;
-}
-
-sub plan_level {
- my $self = shift;
- return $self->{level};
-}
-
-sub joiner {
- my $self = shift;
- my $joiner = shift;
-
- $self->{joiner} = $joiner if ($joiner);
- return $self->{joiner};
-}
-
-sub modifiers {
- my $self = shift;
- $self->{modifiers} ||= [];
- return $self->{modifiers};
-}
-
-sub add_modifier {
- my $self = shift;
- my $modifier = shift;
-
- $self->{modifiers} ||= [];
- return $self if (grep {$$_ eq $$modifier} @{$self->{modifiers}});
-
- push(@{$self->{modifiers}}, $modifier);
-
- return $self;
-}
-
-sub facets {
- my $self = shift;
- $self->{facets} ||= [];
- return $self->{facets};
-}
-
-sub add_facet {
- my $self = shift;
- my $facet = shift;
-
- $self->{facets} ||= [];
- return $self if (grep {$_->name eq $facet->name} @{$self->{facets}});
-
- push(@{$self->{facets}}, $facet);
-
- return $self;
-}
-
-sub filters {
- my $self = shift;
- $self->{filters} ||= [];
- return $self->{filters};
-}
-
-sub add_filter {
- my $self = shift;
- my $filter = shift;
-
- $self->{filters} ||= [];
- return $self if (grep {$_->name eq $filter->name} @{$self->{filters}});
-
- push(@{$self->{filters}}, $filter);
-
- return $self;
-}
-
-
-#-------------------------------
-package QueryParser::query_plan::node;
-
-sub new {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my %args = @_;
-
- return bless \%args => $pkg;
-}
-
-sub new_atom {
- my $self = shift;
- my $pkg = ref($self) || $self;
- return do{$pkg.'::atom'}->new( @_ );
-}
-
-sub requested_class { # also split into classname and fields
- my $self = shift;
- my $class = shift;
-
- if ($class) {
- my ($class_part, @field_parts) = split '\|', $class;
- $class_part ||= $class;
-
- $self->{requested_class} = $class;
- $self->{classname} = $class_part;
- $self->{fields} = \@field_parts;
- }
-
- return $self->{requested_class};
-}
-
-sub plan {
- my $self = shift;
- my $plan = shift;
-
- $self->{plan} = $plan if ($plan);
- return $self->{plan};
-}
-
-sub classname {
- my $self = shift;
- my $class = shift;
-
- $self->{classname} = $class if ($class);
- return $self->{classname};
-}
-
-sub fields {
- my $self = shift;
- my @fields = @_;
-
- $self->{fields} ||= [];
- $self->{fields} = \@fields if (@fields);
- return $self->{fields};
-}
-
-sub phrases {
- my $self = shift;
- my @phrases = @_;
-
- $self->{phrases} ||= [];
- $self->{phrases} = \@phrases if (@phrases);
- return $self->{phrases};
-}
-
-sub add_phrase {
- my $self = shift;
- my $phrase = shift;
-
- push(@{$self->phrases}, $phrase);
-
- return $self;
-}
-
-sub query_atoms {
- my $self = shift;
- my @query_atoms = @_;
-
- $self->{query_atoms} ||= [];
- $self->{query_atoms} = \@query_atoms if (@query_atoms);
- return $self->{query_atoms};
-}
-
-sub add_fts_atom {
- my $self = shift;
- my $atom = shift;
-
- if (!ref($atom)) {
- my $content = $atom;
- my @parts = @_;
-
- $atom = $self->new_atom( content => $content, @parts );
- }
-
- push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
- push(@{$self->query_atoms}, $atom);
-
- return $self;
-}
-
-#-------------------------------
-package QueryParser::query_plan::node::atom;
-
-sub new {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my %args = @_;
-
- return bless \%args => $pkg;
-}
-
-sub node {
- my $self = shift;
- return undef unless (ref $self);
- return $self->{node};
-}
-
-sub content {
- my $self = shift;
- return undef unless (ref $self);
- return $self->{content};
-}
-
-sub prefix {
- my $self = shift;
- return undef unless (ref $self);
- return $self->{prefix};
-}
-
-sub suffix {
- my $self = shift;
- return undef unless (ref $self);
- return $self->{suffix};
-}
-
-#-------------------------------
-package QueryParser::query_plan::filter;
-
-sub new {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my %args = @_;
-
- return bless \%args => $pkg;
-}
-
-sub plan {
- my $self = shift;
- return $self->{plan};
-}
-
-sub name {
- my $self = shift;
- return $self->{name};
-}
-
-sub args {
- my $self = shift;
- return $self->{args};
-}
-
-#-------------------------------
-package QueryParser::query_plan::facet;
-
-sub new {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my %args = @_;
-
- return bless \%args => $pkg;
-}
-
-sub plan {
- my $self = shift;
- return $self->{plan};
-}
-
-sub name {
- my $self = shift;
- return $self->{name};
-}
-
-sub values {
- my $self = shift;
- return $self->{'values'};
-}
-
-#-------------------------------
-package QueryParser::query_plan::modifier;
-
-sub new {
- my $pkg = shift;
- $pkg = ref($pkg) || $pkg;
- my $modifier = shift;
-
- return bless \$modifier => $pkg;
-}
-
-sub name {
- my $self = shift;
- return $$self;
-}
-
-1;
-
+++ /dev/null
-# We'll be working with XML, so...
-use XML::LibXML;
-use XML::LibXSLT;
-use Unicode::Normalize;
-
-# ... and this has some handy common methods
-use OpenILS::Application::AppUtils;
-
-my $parser = new XML::LibXML;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-package OpenILS::Application::SuperCat;
-
-use strict;
-use warnings;
-use OpenILS::Utils::Normalize qw( naco_normalize );
-
-# All OpenSRF applications must be based on OpenSRF::Application or
-# a subclass thereof. Makes sense, eh?
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-# This is the client class, used for connecting to open-ils.storage
-use OpenSRF::AppSession;
-
-# This is an extension of Error.pm that supplies some error types to throw
-use OpenSRF::EX qw(:try);
-
-# This is a helper class for querying the OpenSRF Settings application ...
-use OpenSRF::Utils::SettingsClient;
-
-# ... and here we have the built in logging helper ...
-use OpenSRF::Utils::Logger qw($logger);
-
-# ... and this is our OpenILS object (en|de)coder and psuedo-ORM package.
-use OpenILS::Utils::Fieldmapper;
-
-our (
- $_parser,
- $_xslt,
- %record_xslt,
- %metarecord_xslt,
- %holdings_data_cache,
-);
-
-sub child_init {
- # we need an XML parser
- $_parser = new XML::LibXML;
-
- # and an xslt parser
- $_xslt = new XML::LibXSLT;
-
- # parse the MODS xslt ...
- my $mods33_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2MODS33.xsl"
- );
- # and stash a transformer
- $record_xslt{mods33}{xslt} = $_xslt->parse_stylesheet( $mods33_xslt );
- $record_xslt{mods33}{namespace_uri} = 'http://www.loc.gov/mods/v3';
- $record_xslt{mods33}{docs} = 'http://www.loc.gov/mods/';
- $record_xslt{mods33}{schema_location} = 'http://www.loc.gov/standards/mods/v3/mods-3-3.xsd';
-
- # parse the MODS xslt ...
- my $mods32_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2MODS32.xsl"
- );
- # and stash a transformer
- $record_xslt{mods32}{xslt} = $_xslt->parse_stylesheet( $mods32_xslt );
- $record_xslt{mods32}{namespace_uri} = 'http://www.loc.gov/mods/v3';
- $record_xslt{mods32}{docs} = 'http://www.loc.gov/mods/';
- $record_xslt{mods32}{schema_location} = 'http://www.loc.gov/standards/mods/v3/mods-3-2.xsd';
-
- # parse the MODS xslt ...
- my $mods3_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2MODS3.xsl"
- );
- # and stash a transformer
- $record_xslt{mods3}{xslt} = $_xslt->parse_stylesheet( $mods3_xslt );
- $record_xslt{mods3}{namespace_uri} = 'http://www.loc.gov/mods/v3';
- $record_xslt{mods3}{docs} = 'http://www.loc.gov/mods/';
- $record_xslt{mods3}{schema_location} = 'http://www.loc.gov/standards/mods/v3/mods-3-1.xsd';
-
- # parse the MODS xslt ...
- my $mods_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2MODS.xsl"
- );
- # and stash a transformer
- $record_xslt{mods}{xslt} = $_xslt->parse_stylesheet( $mods_xslt );
- $record_xslt{mods}{namespace_uri} = 'http://www.loc.gov/mods/';
- $record_xslt{mods}{docs} = 'http://www.loc.gov/mods/';
- $record_xslt{mods}{schema_location} = 'http://www.loc.gov/standards/mods/mods.xsd';
-
- # parse the ATOM entry xslt ...
- my $atom_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2ATOM.xsl"
- );
- # and stash a transformer
- $record_xslt{atom}{xslt} = $_xslt->parse_stylesheet( $atom_xslt );
- $record_xslt{atom}{namespace_uri} = 'http://www.w3.org/2005/Atom';
- $record_xslt{atom}{docs} = 'http://www.ietf.org/rfc/rfc4287.txt';
-
- # parse the RDFDC xslt ...
- my $rdf_dc_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2RDFDC.xsl"
- );
- # and stash a transformer
- $record_xslt{rdf_dc}{xslt} = $_xslt->parse_stylesheet( $rdf_dc_xslt );
- $record_xslt{rdf_dc}{namespace_uri} = 'http://purl.org/dc/elements/1.1/';
- $record_xslt{rdf_dc}{schema_location} = 'http://purl.org/dc/elements/1.1/';
-
- # parse the SRWDC xslt ...
- my $srw_dc_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2SRWDC.xsl"
- );
- # and stash a transformer
- $record_xslt{srw_dc}{xslt} = $_xslt->parse_stylesheet( $srw_dc_xslt );
- $record_xslt{srw_dc}{namespace_uri} = 'info:srw/schema/1/dc-schema';
- $record_xslt{srw_dc}{schema_location} = 'http://www.loc.gov/z3950/agency/zing/srw/dc-schema.xsd';
-
- # parse the OAIDC xslt ...
- my $oai_dc_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2OAIDC.xsl"
- );
- # and stash a transformer
- $record_xslt{oai_dc}{xslt} = $_xslt->parse_stylesheet( $oai_dc_xslt );
- $record_xslt{oai_dc}{namespace_uri} = 'http://www.openarchives.org/OAI/2.0/oai_dc/';
- $record_xslt{oai_dc}{schema_location} = 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd';
-
- # parse the RSS xslt ...
- my $rss_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2RSS2.xsl"
- );
- # and stash a transformer
- $record_xslt{rss2}{xslt} = $_xslt->parse_stylesheet( $rss_xslt );
-
- # parse the FGDC xslt ...
- my $fgdc_xslt = $_parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/MARC21slim2FGDC.xsl"
- );
- # and stash a transformer
- $record_xslt{fgdc}{xslt} = $_xslt->parse_stylesheet( $fgdc_xslt );
- $record_xslt{fgdc}{docs} = 'http://www.fgdc.gov/metadata/csdgm/index_html';
- $record_xslt{fgdc}{schema_location} = 'http://www.fgdc.gov/metadata/fgdc-std-001-1998.xsd';
-
- register_record_transforms();
-
- return 1;
-}
-
-sub register_record_transforms {
- for my $type ( keys %record_xslt ) {
- __PACKAGE__->register_method(
- method => 'retrieve_record_transform',
- api_name => "open-ils.supercat.record.$type.retrieve",
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns the \U$type\E representation ".
- "of the requested bibliographic record",
- params =>
- [
- { name => 'bibId',
- desc => 'An OpenILS biblio::record_entry id',
- type => 'number' },
- ],
- 'return' =>
- { desc => "The bib record in \U$type\E",
- type => 'string' }
- }
- );
-
- __PACKAGE__->register_method(
- method => 'retrieve_isbn_transform',
- api_name => "open-ils.supercat.isbn.$type.retrieve",
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns the \U$type\E representation ".
- "of the requested bibliographic record",
- params =>
- [
- { name => 'isbn',
- desc => 'An ISBN',
- type => 'string' },
- ],
- 'return' =>
- { desc => "The bib record in \U$type\E",
- type => 'string' }
- }
- );
- }
-}
-
-sub tree_walker {
- my $tree = shift;
- my $field = shift;
- my $filter = shift;
-
- return unless ($tree && ref($tree->$field));
-
- my @things = $filter->($tree);
- for my $v ( @{$tree->$field} ){
- push @things, $filter->($v);
- push @things, tree_walker($v, $field, $filter);
- }
- return @things
-}
-
-sub cn_browse {
- my $self = shift;
- my $client = shift;
-
- my $label = shift;
- my $ou = shift;
- my $page_size = shift || 9;
- my $page = shift || 0;
- my $statuses = shift || [];
- my $copy_locations = shift || [];
-
- my ($before_limit,$after_limit) = (0,0);
- my ($before_offset,$after_offset) = (0,0);
-
- if (!$page) {
- $before_limit = $after_limit = int($page_size / 2);
- $after_limit += 1 if ($page_size % 2);
- } else {
- $before_offset = $after_offset = int($page_size / 2);
- $before_offset += 1 if ($page_size % 2);
- $before_limit = $after_limit = $page_size;
- }
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $o_search = { shortname => $ou };
- if (!$ou || $ou eq '-') {
- $o_search = { parent_ou => undef };
- }
-
- my $orgs = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- $o_search,
- { flesh => 100,
- flesh_fields => { aou => [qw/children/] }
- }
- )->gather(1);
-
- my @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
-
- $logger->debug("Searching for CNs at orgs [".join(',',@ou_ids)."], based on $ou");
-
- my @list = ();
-
- my @cp_filter = ();
- if (@$statuses || @$copy_locations) {
- @cp_filter = (
- '-exists' => {
- from => 'acp',
- where => {
- call_number => { '=' => { '+acn' => 'id' } },
- deleted => 'f',
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- }
- }
- );
- }
-
- if ($page <= 0) {
- my $before = $_storage->request(
- "open-ils.cstore.direct.asset.call_number.search.atomic",
- { label => { "<" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
- owning_lib => \@ou_ids,
- deleted => 'f',
- @cp_filter
- },
- { flesh => 1,
- flesh_fields => { acn => [qw/record owning_lib/] },
- order_by => { acn => "oils_text_as_bytea(label_sortkey) desc, oils_text_as_bytea(label) desc, id desc, owning_lib desc" },
- limit => $before_limit,
- offset => abs($page) * $page_size - $before_offset,
- }
- )->gather(1);
- push @list, reverse(@$before);
- }
-
- if ($page >= 0) {
- my $after = $_storage->request(
- "open-ils.cstore.direct.asset.call_number.search.atomic",
- { label => { ">=" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
- owning_lib => \@ou_ids,
- deleted => 'f',
- @cp_filter
- },
- { flesh => 1,
- flesh_fields => { acn => [qw/record owning_lib/] },
- order_by => { acn => "oils_text_as_bytea(label_sortkey), oils_text_as_bytea(label), id, owning_lib" },
- limit => $after_limit,
- offset => abs($page) * $page_size - $after_offset,
- }
- )->gather(1);
- push @list, @$after;
- }
-
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'cn_browse',
- api_name => 'open-ils.supercat.call_number.browse',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the XML representation of the requested bibliographic record's holdings
- DESC
- params =>
- [
- { name => 'label',
- desc => 'The target call number lable',
- type => 'string' },
- { name => 'org_unit',
- desc => 'The org unit shortname (or "-" or undef for global) to browse',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'page',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- { name => 'statuses',
- desc => 'Array of statuses to filter copies by, optional and can be undef.',
- type => 'array' },
- { name => 'locations',
- desc => 'Array of copy locations to filter copies by, optional and can be undef.',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'Call numbers with owning_lib and record fleshed',
- type => 'array' }
- }
-);
-
-sub cn_startwith {
- my $self = shift;
- my $client = shift;
-
- my $label = shift;
- my $ou = shift;
- my $limit = shift || 10;
- my $page = shift || 0;
- my $statuses = shift || [];
- my $copy_locations = shift || [];
-
-
- my $offset = abs($page) * $limit;
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $o_search = { shortname => $ou };
- if (!$ou || $ou eq '-') {
- $o_search = { parent_ou => undef };
- }
-
- my $orgs = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- $o_search,
- { flesh => 100,
- flesh_fields => { aou => [qw/children/] }
- }
- )->gather(1);
-
- my @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
-
- $logger->debug("Searching for CNs at orgs [".join(',',@ou_ids)."], based on $ou");
-
- my @list = ();
-
- my @cp_filter = ();
- if (@$statuses || @$copy_locations) {
- @cp_filter = (
- '-exists' => {
- from => 'acp',
- where => {
- call_number => { '=' => { '+acn' => 'id' } },
- deleted => 'f',
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- }
- }
- );
- }
-
- if ($page < 0) {
- my $before = $_storage->request(
- "open-ils.cstore.direct.asset.call_number.search.atomic",
- { label => { "<" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
- owning_lib => \@ou_ids,
- deleted => 'f',
- @cp_filter
- },
- { flesh => 1,
- flesh_fields => { acn => [qw/record owning_lib/] },
- order_by => { acn => "oils_text_as_bytea(label_sortkey) desc, oils_text_as_bytea(label) desc, id desc, owning_lib desc" },
- limit => $limit,
- offset => $offset,
- }
- )->gather(1);
- push @list, reverse(@$before);
- }
-
- if ($page >= 0) {
- my $after = $_storage->request(
- "open-ils.cstore.direct.asset.call_number.search.atomic",
- { label => { ">=" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
- owning_lib => \@ou_ids,
- deleted => 'f',
- @cp_filter
- },
- { flesh => 1,
- flesh_fields => { acn => [qw/record owning_lib/] },
- order_by => { acn => "oils_text_as_bytea(label_sortkey), oils_text_as_bytea(label), id, owning_lib" },
- limit => $limit,
- offset => $offset,
- }
- )->gather(1);
- push @list, @$after;
- }
-
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'cn_startwith',
- api_name => 'open-ils.supercat.call_number.startwith',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the XML representation of the requested bibliographic record's holdings
- DESC
- params =>
- [
- { name => 'label',
- desc => 'The target call number lable',
- type => 'string' },
- { name => 'org_unit',
- desc => 'The org unit shortname (or "-" or undef for global) to browse',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'page',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- { name => 'statuses',
- desc => 'Array of statuses to filter copies by, optional and can be undef.',
- type => 'array' },
- { name => 'locations',
- desc => 'Array of copy locations to filter copies by, optional and can be undef.',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'Call numbers with owning_lib and record fleshed',
- type => 'array' }
- }
-);
-
-
-sub new_books_by_item {
- my $self = shift;
- my $client = shift;
-
- my $ou = shift;
- my $page_size = shift || 10;
- my $page = shift || 1;
- my $statuses = shift || [];
- my $copy_locations = shift || [];
-
- my $offset = $page_size * ($page - 1);
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my @ou_ids;
- if ($ou && $ou ne '-') {
- my $orgs = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- { shortname => $ou },
- { flesh => 100,
- flesh_fields => { aou => [qw/children/] }
- }
- )->gather(1);
- @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
- }
-
- $logger->debug("Searching for records with new copies at orgs [".join(',',@ou_ids)."], based on $ou");
- my $cns = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { acn => ['record'],
- acp => [{ aggregate => 1 => transform => max => column => create_date => alias => 'create_date'}]
- },
- from => { 'acn' => { 'acp' => { field => call_number => fkey => 'id' } } },
- where =>
- { '+acp' =>
- { deleted => 'f',
- ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- },
- '+acn' => { record => { '>' => 0 } },
- },
- order_by => { acp => { create_date => { transform => 'max', direction => 'desc' } } },
- limit => $page_size,
- offset => $offset
- }
- )->gather(1);
-
- return [ map { $_->{record} } @$cns ];
-}
-__PACKAGE__->register_method(
- method => 'new_books_by_item',
- api_name => 'open-ils.supercat.new_book_list',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the XML representation of the requested bibliographic record's holdings
- DESC
- params =>
- [
- { name => 'org_unit',
- desc => 'The org unit shortname (or "-" or undef for global) to list',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of records to retrieve, default is 10',
- type => 'number' },
- { name => 'page',
- desc => 'The page of records to retrieve, calculated based on page_size. Starts at 1.',
- type => 'number' },
- { name => 'statuses',
- desc => 'Array of statuses to filter copies by, optional and can be undef.',
- type => 'array' },
- { name => 'locations',
- desc => 'Array of copy locations to filter copies by, optional and can be undef.',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'Record IDs',
- type => 'array' }
- }
-);
-
-
-sub general_browse {
- my $self = shift;
- my $client = shift;
- return tag_sf_browse($self, $client, $self->{tag}, $self->{subfield}, @_);
-}
-__PACKAGE__->register_method(
- method => 'general_browse',
- api_name => 'open-ils.supercat.title.browse',
- tag => 'tnf', subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target title', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_browse',
- api_name => 'open-ils.supercat.author.browse',
- tag => [qw/100 110 111/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target author', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_browse',
- api_name => 'open-ils.supercat.subject.browse',
- tag => [qw/600 610 611 630 648 650 651 653 655 656 662 690 691 696 697 698 699/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target subject', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_browse',
- api_name => 'open-ils.supercat.topic.browse',
- tag => [qw/650 690/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target topical subject', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_browse',
- api_name => 'open-ils.supercat.series.browse',
- tag => [qw/440 490 800 810 811 830/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target series', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-
-
-sub tag_sf_browse {
- my $self = shift;
- my $client = shift;
-
- my $tag = shift;
- my $subfield = shift;
- my $value = shift;
- my $ou = shift;
- my $page_size = shift || 9;
- my $page = shift || 0;
- my $statuses = shift || [];
- my $copy_locations = shift || [];
-
- my ($before_limit,$after_limit) = (0,0);
- my ($before_offset,$after_offset) = (0,0);
-
- if (!$page) {
- $before_limit = $after_limit = int($page_size / 2);
- $after_limit += 1 if ($page_size % 2);
- } else {
- $before_offset = $after_offset = int($page_size / 2);
- $before_offset += 1 if ($page_size % 2);
- $before_limit = $after_limit = $page_size;
- }
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my @ou_ids;
- if ($ou && $ou ne '-') {
- my $orgs = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- { shortname => $ou },
- { flesh => 100,
- flesh_fields => { aou => [qw/children/] }
- }
- )->gather(1);
- @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
- }
-
- $logger->debug("Searching for records at orgs [".join(',',@ou_ids)."], based on $ou");
-
- my @list = ();
-
- if ($page <= 0) {
- my $before = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { mfr => [qw/record value/] },
- from => 'mfr',
- where =>
- { '+mfr' =>
- { tag => $tag,
- subfield => $subfield,
- value => { '<' => lc($value) }
- },
- '-or' => [
- { '-exists' =>
- { select=> { acp => [ 'id' ] },
- from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
- '+acp' =>
- { deleted => 'f',
- ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- }
- },
- limit => 1
- }
- },
- { '-exists' =>
- { select=> { auri => [ 'id' ] },
- from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
- '+auri' => { active => 't' }
- },
- limit => 1
- }
- }
- ]
- },
- order_by => { mfr => { value => 'desc' } },
- limit => $before_limit,
- offset => abs($page) * $page_size - $before_offset,
- }
- )->gather(1);
- push @list, map { $_->{record} } reverse(@$before);
- }
-
- if ($page >= 0) {
- my $after = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { mfr => [qw/record value/] },
- from => 'mfr',
- where =>
- { '+mfr' =>
- { tag => $tag,
- subfield => $subfield,
- value => { '>=' => lc($value) }
- },
- '-or' => [
- { '-exists' =>
- { select=> { acp => [ 'id' ] },
- from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
- '+acp' =>
- { deleted => 'f',
- ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- }
- },
- limit => 1
- }
- },
- { '-exists' =>
- { select=> { auri => [ 'id' ] },
- from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
- '+auri' => { active => 't' }
- },
- limit => 1
- },
- }
- ]
- },
- order_by => { mfr => { value => 'asc' } },
- limit => $after_limit,
- offset => abs($page) * $page_size - $after_offset,
- }
- )->gather(1);
- push @list, map { $_->{record} } @$after;
- }
-
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'tag_sf_browse',
- api_name => 'open-ils.supercat.tag.browse',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns a list of the requested org-scoped record IDs held
- DESC
- params =>
- [
- { name => 'tag',
- desc => 'The target MARC tag',
- type => 'string' },
- { name => 'subfield',
- desc => 'The target MARC subfield',
- type => 'string' },
- { name => 'value',
- desc => 'The target string',
- type => 'string' },
- { name => 'org_unit',
- desc => 'The org unit shortname (or "-" or undef for global) to browse',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'page',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- { name => 'statuses',
- desc => 'Array of statuses to filter copies by, optional and can be undef.',
- type => 'array' },
- { name => 'locations',
- desc => 'Array of copy locations to filter copies by, optional and can be undef.',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'Record IDs that have copies at the relevant org units',
- type => 'array' }
- }
-);
-
-sub general_authority_browse {
- my $self = shift;
- my $client = shift;
- return authority_tag_sf_browse($self, $client, $self->{tag}, $self->{subfield}, @_);
-}
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.title.browse',
- tag => ['130'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target title', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.author.browse',
- tag => [qw/100 110 111/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target author', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.subject.browse',
- tag => [qw/148 150 151 155/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.topic.browse',
- tag => ['150'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target topical subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.title.refs.browse',
- tag => ['130'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target title', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.author.refs.browse',
- tag => [qw/100 110 111/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target author', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.subject.refs.browse',
- tag => [qw/148 150 151 155/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_browse',
- api_name => 'open-ils.supercat.authority.topic.refs.browse',
- tag => ['150'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target topical subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-
-sub authority_tag_sf_browse {
- my $self = shift;
- my $client = shift;
-
- my $tag = shift;
- my $subfield = shift;
- my $value = shift;
- my $page_size = shift || 9;
- my $page = shift || 0;
-
- # Match authority.full_rec normalization
- $value = naco_normalize($value, $subfield);
-
- my ($before_limit,$after_limit) = (0,0);
- my ($before_offset,$after_offset) = (0,0);
-
- if (!$page) {
- $before_limit = $after_limit = int($page_size / 2);
- $after_limit += 1 if ($page_size % 2);
- } else {
- $before_offset = $after_offset = int($page_size / 2);
- $before_offset += 1 if ($page_size % 2);
- $before_limit = $after_limit = $page_size;
- }
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- # .refs variant includes 4xx and 5xx variants for see / see also
- my @ref_tags = ();
- foreach my $tagname (@$tag) {
- push(@ref_tags, $tagname);
- if ($self->api_name =~ /\.refs\./) {
- push(@ref_tags, '4' . substr($tagname, 1, 2));
- push(@ref_tags, '5' . substr($tagname, 1, 2));
- }
- }
- my @list = ();
-
- if ($page <= 0) {
- my $before = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { afr => [qw/record value/] },
- from => { 'are', 'afr' },
- where => {
- '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '<' => $value } },
- '+are' => { 'deleted' => 'f' }
- },
- order_by => { afr => { value => 'desc' } },
- limit => $before_limit,
- offset => abs($page) * $page_size - $before_offset,
- }
- )->gather(1);
- push @list, map { $_->{record} } reverse(@$before);
- }
-
- if ($page >= 0) {
- my $after = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { afr => [qw/record value/] },
- from => { 'are', 'afr' },
- where => {
- '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '>=' => $value } },
- '+are' => { 'deleted' => 'f' }
- },
- order_by => { afr => { value => 'asc' } },
- limit => $after_limit,
- offset => abs($page) * $page_size - $after_offset,
- }
- )->gather(1);
- push @list, map { $_->{record} } @$after;
- }
-
- # If we're not pulling in see/see also references, just return the raw list
- if ($self->api_name !~ /\.refs\./) {
- return \@list;
- }
-
- # Remove dupe record IDs that turn up due to 4xx and 5xx matches
- my @retlist = ();
- my %seen;
- foreach my $record (@list) {
- next if exists $seen{$record};
- push @retlist, int($record);
- $seen{$record} = 1;
- }
-
- return \@retlist;
-}
-__PACKAGE__->register_method(
- method => 'authority_tag_sf_browse',
- api_name => 'open-ils.supercat.authority.tag.browse',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns a list of the requested authority record IDs held
- DESC
- params =>
- [
- { name => 'tag',
- desc => 'The target Authority MARC tag',
- type => 'string' },
- { name => 'subfield',
- desc => 'The target Authority MARC subfield',
- type => 'string' },
- { name => 'value',
- desc => 'The target string',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'page',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'Authority Record IDs that are near the target string',
- type => 'array' }
- }
-);
-
-sub general_startwith {
- my $self = shift;
- my $client = shift;
- return tag_sf_startwith($self, $client, $self->{tag}, $self->{subfield}, @_);
-}
-__PACKAGE__->register_method(
- method => 'general_startwith',
- api_name => 'open-ils.supercat.title.startwith',
- tag => 'tnf', subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target title', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_startwith',
- api_name => 'open-ils.supercat.author.startwith',
- tag => [qw/100 110 111/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target author', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_startwith',
- api_name => 'open-ils.supercat.subject.startwith',
- tag => [qw/600 610 611 630 648 650 651 653 655 656 662 690 691 696 697 698 699/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target subject', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_startwith',
- api_name => 'open-ils.supercat.topic.startwith',
- tag => [qw/650 690/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target topical subject', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_startwith',
- api_name => 'open-ils.supercat.series.startwith',
- tag => [qw/440 490 800 810 811 830/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested org-scoped record IDs held",
- params =>
- [ { name => 'value', desc => 'The target series', type => 'string' },
- { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
- { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
- { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
- 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
- }
-);
-
-
-sub tag_sf_startwith {
- my $self = shift;
- my $client = shift;
-
- my $tag = shift;
- my $subfield = shift;
- my $value = shift;
- my $ou = shift;
- my $limit = shift || 10;
- my $page = shift || 0;
- my $statuses = shift || [];
- my $copy_locations = shift || [];
-
- my $offset = $limit * abs($page);
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my @ou_ids;
- if ($ou && $ou ne '-') {
- my $orgs = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- { shortname => $ou },
- { flesh => 100,
- flesh_fields => { aou => [qw/children/] }
- }
- )->gather(1);
- @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
- }
-
- $logger->debug("Searching for records at orgs [".join(',',@ou_ids)."], based on $ou");
-
- my @list = ();
-
- if ($page < 0) {
- my $before = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { mfr => [qw/record value/] },
- from => 'mfr',
- where =>
- { '+mfr' =>
- { tag => $tag,
- subfield => $subfield,
- value => { '<' => lc($value) }
- },
- '-or' => [
- { '-exists' =>
- { select=> { acp => [ 'id' ] },
- from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
- '+acp' =>
- { deleted => 'f',
- ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- }
- },
- limit => 1
- }
- },
- { '-exists' =>
- { select=> { auri => [ 'id' ] },
- from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
- '+auri' => { active => 't' }
- },
- limit => 1
- }
- }
- ]
- },
- order_by => { mfr => { value => 'desc' } },
- limit => $limit,
- offset => $offset
- }
- )->gather(1);
- push @list, map { $_->{record} } reverse(@$before);
- }
-
- if ($page >= 0) {
- my $after = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { mfr => [qw/record value/] },
- from => 'mfr',
- where =>
- { '+mfr' =>
- { tag => $tag,
- subfield => $subfield,
- value => { '>=' => lc($value) }
- },
- '-or' => [
- { '-exists' =>
- { select=> { acp => [ 'id' ] },
- from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
- '+acp' =>
- { deleted => 'f',
- ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
- ((@$statuses) ? ( status => $statuses) : ()),
- ((@$copy_locations) ? ( location => $copy_locations) : ())
- }
- },
- limit => 1
- }
- },
- { '-exists' =>
- { select=> { auri => [ 'id' ] },
- from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
- where =>
- { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
- '+auri' => { active => 't' }
- },
- limit => 1
- },
- }
- ]
- },
- order_by => { mfr => { value => 'asc' } },
- limit => $limit,
- offset => $offset
- }
- )->gather(1);
- push @list, map { $_->{record} } @$after;
- }
-
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'tag_sf_startwith',
- api_name => 'open-ils.supercat.tag.startwith',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns a list of the requested org-scoped record IDs held
- DESC
- params =>
- [
- { name => 'tag',
- desc => 'The target MARC tag',
- type => 'string' },
- { name => 'subfield',
- desc => 'The target MARC subfield',
- type => 'string' },
- { name => 'value',
- desc => 'The target string',
- type => 'string' },
- { name => 'org_unit',
- desc => 'The org unit shortname (or "-" or undef for global) to browse',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'page',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- { name => 'statuses',
- desc => 'Array of statuses to filter copies by, optional and can be undef.',
- type => 'array' },
- { name => 'locations',
- desc => 'Array of copy locations to filter copies by, optional and can be undef.',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'Record IDs that have copies at the relevant org units',
- type => 'array' }
- }
-);
-
-sub general_authority_startwith {
- my $self = shift;
- my $client = shift;
- return authority_tag_sf_startwith($self, $client, $self->{tag}, $self->{subfield}, @_);
-}
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.title.startwith',
- tag => ['130'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target title', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.author.startwith',
- tag => [qw/100 110 111/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target author', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.subject.startwith',
- tag => [qw/148 150 151 155/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.topic.startwith',
- tag => ['150'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held",
- params =>
- [ { name => 'value', desc => 'The target topical subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.title.refs.startwith',
- tag => ['130'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target title', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.author.refs.startwith',
- tag => [qw/100 110 111/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target author', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.subject.refs.startwith',
- tag => [qw/148 150 151 155/], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'general_authority_startwith',
- api_name => 'open-ils.supercat.authority.topic.refs.startwith',
- tag => ['150'], subfield => 'a',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
- params =>
- [ { name => 'value', desc => 'The target topical subject', type => 'string' },
- { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
- { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
- 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
- }
-);
-
-sub authority_tag_sf_startwith {
- my $self = shift;
- my $client = shift;
-
- my $tag = shift;
- my $subfield = shift;
-
- my $value = shift;
- my $limit = shift || 10;
- my $page = shift || 0;
-
- # Match authority.full_rec normalization
- $value = naco_normalize($value, $subfield);
-
- my $ref_limit = $limit;
- my $offset = $limit * abs($page);
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my @ref_tags = ();
- # .refs variant includes 4xx and 5xx variants for see / see also
- foreach my $tagname (@$tag) {
- push(@ref_tags, $tagname);
- if ($self->api_name =~ /\.refs\./) {
- push(@ref_tags, '4' . substr($tagname, 1, 2));
- push(@ref_tags, '5' . substr($tagname, 1, 2));
- }
- }
-
- my @list = ();
-
- if ($page < 0) {
- # Don't skip the first actual page of results in descending order
- $offset = $offset - $limit;
-
- my $before = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { afr => [qw/record value/] },
- from => { 'afr', 'are' },
- where => {
- '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '<' => $value } },
- '+are' => { deleted => 'f' }
- },
- order_by => { afr => { value => 'desc' } },
- limit => $ref_limit,
- offset => $offset,
- }
- )->gather(1);
- push @list, map { $_->{record} } reverse(@$before);
- }
-
- if ($page >= 0) {
- my $after = $_storage->request(
- "open-ils.cstore.json_query.atomic",
- { select => { afr => [qw/record value/] },
- from => { 'afr', 'are' },
- where => {
- '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '>=' => $value } },
- '+are' => { deleted => 'f' }
- },
- order_by => { afr => { value => 'asc' } },
- limit => $ref_limit,
- offset => $offset,
- }
- )->gather(1);
- push @list, map { $_->{record} } @$after;
- }
-
- # If we're not pulling in see/see also references, just return the raw list
- if ($self->api_name !~ /\.refs\./) {
- return \@list;
- }
-
- # Remove dupe record IDs that turn up due to 4xx and 5xx matches
- my @retlist = ();
- my %seen;
- foreach my $record (@list) {
- next if exists $seen{$record};
- push @retlist, int($record);
- $seen{$record} = 1;
- }
-
- return \@retlist;
-}
-__PACKAGE__->register_method(
- method => 'authority_tag_sf_startwith',
- api_name => 'open-ils.supercat.authority.tag.startwith',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns a list of the requested authority record IDs held
- DESC
- params =>
- [
- { name => 'tag',
- desc => 'The target Authority MARC tag',
- type => 'string' },
- { name => 'subfield',
- desc => 'The target Authority MARC subfield',
- type => 'string' },
- { name => 'value',
- desc => 'The target string',
- type => 'string' },
- { name => 'page_size',
- desc => 'Count of call numbers to retrieve, default is 9',
- type => 'number' },
- { name => 'page',
- desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'Authority Record IDs that are near the target string',
- type => 'array' }
- }
-);
-
-
-sub holding_data_formats {
- return [{
- marcxml => {
- namespace_uri => 'http://www.loc.gov/MARC21/slim',
- docs => 'http://www.loc.gov/marcxml/',
- schema_location => 'http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd',
- }
- }];
-}
-__PACKAGE__->register_method( method => 'holding_data_formats', api_name => 'open-ils.supercat.acn.formats', api_level => 1 );
-__PACKAGE__->register_method( method => 'holding_data_formats', api_name => 'open-ils.supercat.acp.formats', api_level => 1 );
-__PACKAGE__->register_method( method => 'holding_data_formats', api_name => 'open-ils.supercat.auri.formats', api_level => 1 );
-
-
-__PACKAGE__->register_method(
- method => 'retrieve_uri',
- api_name => 'open-ils.supercat.auri.marcxml.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns a fleshed call number object
- DESC
- params =>
- [
- { name => 'uri_id',
- desc => 'An OpenILS asset::uri id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'fleshed uri',
- type => 'object' }
- }
-);
-sub retrieve_uri {
- my $self = shift;
- my $client = shift;
- my $cpid = shift;
- my $args = shift || {};
-
- return OpenILS::Application::SuperCat::unAPI
- ->new(OpenSRF::AppSession
- ->create( 'open-ils.cstore' )
- ->request(
- "open-ils.cstore.direct.asset.uri.retrieve",
- $cpid,
- { flesh => 10,
- flesh_fields => {
- auri => [qw/call_number_maps/],
- auricnm => [qw/call_number/],
- acn => [qw/owning_lib record/],
- }
- })
- ->gather(1))
- ->as_xml($args);
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_copy',
- api_name => 'open-ils.supercat.acp.marcxml.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns a fleshed call number object
- DESC
- params =>
- [
- { name => 'cn_id',
- desc => 'An OpenILS asset::copy id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'fleshed copy',
- type => 'object' }
- }
-);
-sub retrieve_copy {
- my $self = shift;
- my $client = shift;
- my $cpid = shift;
- my $args = shift || {};
-
- return OpenILS::Application::SuperCat::unAPI
- ->new(OpenSRF::AppSession
- ->create( 'open-ils.cstore' )
- ->request(
- "open-ils.cstore.direct.asset.copy.retrieve",
- $cpid,
- { flesh => 2,
- flesh_fields => {
- acn => [qw/owning_lib record/],
- acp => [qw/call_number location status circ_lib stat_cat_entries notes/],
- }
- })
- ->gather(1))
- ->as_xml($args);
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_callnumber',
- api_name => 'open-ils.supercat.acn.marcxml.retrieve',
- api_level => 1,
- argc => 1,
- stream => 1,
- signature =>
- { desc => <<" DESC",
-Returns a fleshed call number object
- DESC
- params =>
- [
- { name => 'cn_id',
- desc => 'An OpenILS asset::call_number id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'call number with copies',
- type => 'object' }
- }
-);
-sub retrieve_callnumber {
- my $self = shift;
- my $client = shift;
- my $cnid = shift;
- my $args = shift || {};
-
- return OpenILS::Application::SuperCat::unAPI
- ->new(OpenSRF::AppSession
- ->create( 'open-ils.cstore' )
- ->request(
- "open-ils.cstore.direct.asset.call_number.retrieve",
- $cnid,
- { flesh => 5,
- flesh_fields => {
- acn => [qw/owning_lib record copies uri_maps/],
- auricnm => [qw/uri/],
- acp => [qw/location status circ_lib stat_cat_entries notes/],
- }
- })
- ->gather(1))
- ->as_xml($args);
-
-}
-
-__PACKAGE__->register_method(
- method => 'basic_record_holdings',
- api_name => 'open-ils.supercat.record.basic_holdings.retrieve',
- api_level => 1,
- argc => 1,
- stream => 1,
- signature =>
- { desc => <<" DESC",
-Returns a basic hash representation of the requested bibliographic record's holdings
- DESC
- params =>
- [
- { name => 'bibId',
- desc => 'An OpenILS biblio::record_entry id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'Hash of bib record holdings hierarchy (call numbers and copies)',
- type => 'string' }
- }
-);
-sub basic_record_holdings {
- my $self = shift;
- my $client = shift;
- my $bib = shift;
- my $ou = shift;
-
- # holdings hold an array of call numbers, which hold an array of copies
- # holdings => [ label: { library, [ copies: { barcode, location, status, circ_lib } ] } ]
- my %holdings;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $tree = $_storage->request(
- "open-ils.cstore.direct.biblio.record_entry.retrieve",
- $bib,
- { flesh => 5,
- flesh_fields => {
- bre => [qw/call_numbers/],
- acn => [qw/copies owning_lib/],
- acp => [qw/location status circ_lib/],
- }
- }
- )->gather(1);
-
- my $o_search = { shortname => uc($ou) };
- if (!$ou || $ou eq '-') {
- $o_search = { parent_ou => undef };
- }
-
- my $orgs = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- $o_search,
- { flesh => 100,
- flesh_fields => { aou => [qw/children/] }
- }
- )->gather(1);
-
- my @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
-
- $logger->debug("Searching for holdings at orgs [".join(',',@ou_ids)."], based on $ou");
-
- for my $cn (@{$tree->call_numbers}) {
- next unless ( $cn->deleted eq 'f' || $cn->deleted == 0 );
-
- my $found = 0;
- for my $c (@{$cn->copies}) {
- next unless grep {$c->circ_lib->id == $_} @ou_ids;
- next unless ( $c->deleted eq 'f' || $c->deleted == 0 );
- $found = 1;
- last;
- }
- next unless $found;
-
- $holdings{$cn->label}{'owning_lib'} = $cn->owning_lib->shortname;
-
- for my $cp (@{$cn->copies}) {
-
- next unless grep { $cp->circ_lib->id == $_ } @ou_ids;
- next unless ( $cp->deleted eq 'f' || $cp->deleted == 0 );
-
- push @{$holdings{$cn->label}{'copies'}}, {
- barcode => $cp->barcode,
- status => $cp->status->name,
- location => $cp->location->name,
- circlib => $cp->circ_lib->shortname
- };
-
- }
- }
-
- return \%holdings;
-}
-
-#__PACKAGE__->register_method(
-# method => 'new_record_holdings',
-# api_name => 'open-ils.supercat.record.holdings_xml.retrieve',
-# api_level => 1,
-# argc => 1,
-# stream => 1,
-# signature =>
-# { desc => <<" DESC",
-#Returns the XML representation of the requested bibliographic record's holdings
-# DESC
-# params =>
-# [
-# { name => 'bibId',
-# desc => 'An OpenILS biblio::record_entry id',
-# type => 'number' },
-# ],
-# 'return' =>
-# { desc => 'Stream of bib record holdings hierarchy in XML',
-# type => 'string' }
-# }
-#);
-#
-
-sub new_record_holdings {
- my $self = shift;
- my $client = shift;
- my $bib = shift;
- my $ou = shift;
- my $depth = shift;
- my $flesh = shift;
- my $paging = shift;
-
- $paging = [-1,0] if (!$paging or !ref($paging) or @$paging == 0);
- my $limit = $$paging[0];
- my $offset = $$paging[1] || 0;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
- my $_search = OpenSRF::AppSession->create( 'open-ils.search' );
-
- my $o_search = { shortname => uc($ou) };
- if (!$ou || $ou eq '-') {
- $o_search = { parent_ou => undef };
- }
-
- my $one_org = $_storage->request(
- "open-ils.cstore.direct.actor.org_unit.search",
- $o_search
- )->gather(1);
-
- my $count_req = $_search->request('open-ils.search.biblio.record.copy_count' => $one_org->id => $bib);
- my $staff_count_req = $_search->request('open-ils.search.biblio.record.copy_count.staff' => $one_org->id => $bib);
-
- my $orgs = $_storage->request(
- 'open-ils.cstore.json_query.atomic',
- { from => [ 'actor.org_unit_descendants', defined($depth) ? ( $one_org->id, $depth ) : ( $one_org->id ) ] }
- )->gather(1);
-
-
- my @ou_ids = map { $_->{id} } @$orgs;
-
- $logger->info("Searching for holdings at orgs [".join(',',@ou_ids)."], based on $ou");
-
- my %subselect = ( '-or' => [
- { owning_lib => \@ou_ids },
- { '-exists' =>
- { from => 'acp',
- where => {
- call_number => { '=' => {'+acn'=>'id'} },
- deleted => 'f',
- circ_lib => \@ou_ids
- }
- }
- }
- ]);
-
- if ($flesh and $flesh eq 'uris') {
- %subselect = (
- owning_lib => \@ou_ids,
- '-exists' => {
- from => { auricnm => 'auri' },
- where => {
- call_number => { '=' => {'+acn'=>'id'} },
- '+auri' => { active => 't' }
- }
- }
- );
- }
-
-
- my $cns = $_storage->request(
- "open-ils.cstore.direct.asset.call_number.search.atomic",
- { record => $bib,
- deleted => 'f',
- %subselect
- },
- { flesh => 5,
- flesh_fields => {
- acn => [qw/copies owning_lib uri_maps/],
- auricnm => [qw/uri/],
- acp => [qw/circ_lib location status stat_cat_entries notes/],
- asce => [qw/stat_cat/],
- },
- ( $limit > -1 ? ( limit => $limit ) : () ),
- ( $offset ? ( offset => $offset ) : () ),
- order_by => { acn => { label_sortkey => {} } }
- }
- )->gather(1);
-
- my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
- $year += 1900;
- $month += 1;
-
- $client->respond("<holdings xmlns='http://open-ils.org/spec/holdings/v1'><counts>\n");
-
- my $copy_counts = $count_req->gather(1);
- my $staff_copy_counts = $staff_count_req->gather(1);
-
- for my $c (@$copy_counts) {
- $$c{transcendant} ||= 0;
- my $out = "<count type='public'";
- $out .= " $_='$$c{$_}'" for (qw/count available unshadow transcendant org_unit depth/);
- $client->respond("$out/>\n")
- }
-
- for my $c (@$staff_copy_counts) {
- $$c{transcendant} ||= 0;
- my $out = "<count type='staff'";
- $out .= " $_='$$c{$_}'" for (qw/count available unshadow transcendant org_unit depth/);
- $client->respond("$out/>\n")
- }
-
- $client->respond("</counts><volumes>\n");
-
- for my $cn (@$cns) {
- next unless (@{$cn->copies} > 0 or (ref($cn->uri_maps) and @{$cn->uri_maps}));
-
- # We don't want O:A:S:unAPI::acn to return the record, we've got that already
- # In the context of BibTemplate, copies aren't necessary because we pull those
- # in a separate call
- $client->respond(
- OpenILS::Application::SuperCat::unAPI::acn
- ->new( $cn )
- ->as_xml( {no_record => 1, no_copies => ($flesh ? 0 : 1)} )
- );
- }
-
- $client->respond("</volumes><subscriptions>\n");
-
- $logger->info("Searching for serial holdings at orgs [".join(',',@ou_ids)."], based on $ou");
-
- %subselect = ( '-or' => [
- { owning_lib => \@ou_ids },
- { '-exists' =>
- { from => 'sdist',
- where => { holding_lib => \@ou_ids }
- }
- }
- ]);
-
- my $ssubs = $_storage->request(
- "open-ils.cstore.direct.serial.subscription.search.atomic",
- { record_entry => $bib,
- %subselect
- },
- { flesh => 7,
- flesh_fields => {
- ssub => [qw/distributions issuances scaps owning_lib/],
- sdist => [qw/basic_summary supplement_summary index_summary streams holding_lib/],
- sstr => [qw/items/],
- sitem => [qw/notes unit/],
- sunit => [qw/notes location status circ_lib stat_cat_entries call_number/],
- acn => [qw/owning_lib/],
- },
- ( $limit > -1 ? ( limit => $limit ) : () ),
- ( $offset ? ( offset => $offset ) : () ),
- order_by => {
- ssub => {
- start_date => {},
- owning_lib => {},
- id => {}
- },
- sdist => {
- label => {},
- owning_lib => {},
- },
- sunit => {
- date_expected => {},
- }
- }
- }
- )->gather(1);
-
-
- for my $ssub (@$ssubs) {
- next unless (@{$ssub->distributions} or @{$ssub->issuances} or @{$ssub->scaps});
-
- # We don't want O:A:S:unAPI::ssub to return the record, we've got that already
- # In the context of BibTemplate, copies aren't necessary because we pull those
- # in a separate call
- $client->respond(
- OpenILS::Application::SuperCat::unAPI::ssub
- ->new( $ssub )
- ->as_xml( {no_record => 1, no_items => ($flesh ? 0 : 1)} )
- );
- }
-
-
- return "</subscriptions></holdings>\n";
-}
-__PACKAGE__->register_method(
- method => 'new_record_holdings',
- api_name => 'open-ils.supercat.record.holdings_xml.retrieve',
- api_level => 1,
- argc => 1,
- stream => 1,
- signature =>
- { desc => <<" DESC",
-Returns the XML representation of the requested bibliographic record's holdings
- DESC
- params =>
- [
- { name => 'bibId',
- desc => 'An OpenILS biblio::record_entry ID',
- type => 'number' },
- { name => 'orgUnit',
- desc => 'An OpenILS actor::org_unit short name that limits the scope of returned holdings',
- type => 'text' },
- { name => 'depth',
- desc => 'An OpenILS actor::org_unit_type depththat limits the scope of returned holdings',
- type => 'number' },
- { name => 'hideCopies',
- desc => 'Flag that prevents the inclusion of copies in the returned holdings',
- type => 'boolean' },
- { name => 'paging',
- desc => 'Arry of limit and offset for holdings paging',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'Stream of bib record holdings hierarchy in XML',
- type => 'string' }
- }
-);
-
-sub isbn_holdings {
- my $self = shift;
- my $client = shift;
- my $isbn = shift;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $recs = $_storage->request(
- 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
- { tag => { like => '02%'}, value => {like => "$isbn\%"}}
- )->gather(1);
-
- return undef unless (@$recs);
-
- return ($self->method_lookup( 'open-ils.supercat.record.holdings_xml.retrieve')->run( $recs->[0]->record ))[0];
-}
-__PACKAGE__->register_method(
- method => 'isbn_holdings',
- api_name => 'open-ils.supercat.isbn.holdings_xml.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the XML representation of the requested bibliographic record's holdings
- DESC
- params =>
- [
- { name => 'isbn',
- desc => 'An isbn',
- type => 'string' },
- ],
- 'return' =>
- { desc => 'The bib record holdings hierarchy in XML',
- type => 'string' }
- }
-);
-
-sub escape {
- my $self = shift;
- my $text = shift;
- return '' unless $text;
- $text =~ s/&/&/gsom;
- $text =~ s/</</gsom;
- $text =~ s/>/>/gsom;
- $text =~ s/"/"/gsom;
- $text =~ s/'/'/gsom;
- return $text;
-}
-
-sub recent_changes {
- my $self = shift;
- my $client = shift;
- my $when = shift || '1-01-01';
- my $limit = shift;
-
- my $type = 'biblio';
- my $hint = 'bre';
-
- if ($self->api_name =~ /authority/o) {
- $type = 'authority';
- $hint = 'are';
- }
-
- my $axis = 'create_date';
- $axis = 'edit_date' if ($self->api_name =~ /edit/o);
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- return $_storage->request(
- "open-ils.cstore.direct.$type.record_entry.id_list.atomic",
- { $axis => { ">" => $when }, id => { '>' => 0 }, deleted => 'f', active => 't' },
- { order_by => { $hint => "$axis desc" }, limit => $limit }
- )->gather(1);
-}
-
-for my $t ( qw/biblio authority/ ) {
- for my $a ( qw/import edit/ ) {
-
- __PACKAGE__->register_method(
- method => 'recent_changes',
- api_name => "open-ils.supercat.$t.record.$a.recent",
- api_level => 1,
- argc => 0,
- signature =>
- { desc => "Returns a list of recently ${a}ed $t records",
- params =>
- [
- { name => 'when',
- desc => "Date to start looking for ${a}ed records",
- default => '1-01-01',
- type => 'string' },
-
- { name => 'limit',
- desc => "Maximum count to retrieve",
- type => 'number' },
- ],
- 'return' =>
- { desc => "An id list of $t records",
- type => 'array' }
- },
- );
- }
-}
-
-
-sub retrieve_authority_marcxml {
- my $self = shift;
- my $client = shift;
- my $rid = shift;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $record = $_storage->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rid )->gather(1);
- return $U->entityize( $record->marc ) if ($record);
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_authority_marcxml',
- api_name => 'open-ils.supercat.authority.marcxml.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the MARCXML representation of the requested authority record
- DESC
- params =>
- [
- { name => 'authorityId',
- desc => 'An OpenILS authority::record_entry id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'The authority record in MARCXML',
- type => 'string' }
- }
-);
-
-sub retrieve_record_marcxml {
- my $self = shift;
- my $client = shift;
- my $rid = shift;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $record = $_storage->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rid )->gather(1);
- return $U->entityize( $record->marc ) if ($record);
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_record_marcxml',
- api_name => 'open-ils.supercat.record.marcxml.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the MARCXML representation of the requested bibliographic record
- DESC
- params =>
- [
- { name => 'bibId',
- desc => 'An OpenILS biblio::record_entry id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'The bib record in MARCXML',
- type => 'string' }
- }
-);
-
-sub retrieve_isbn_marcxml {
- my $self = shift;
- my $client = shift;
- my $isbn = shift;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $recs = $_storage->request(
- 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
- { tag => { like => '02%'}, value => {like => "$isbn\%"}}
- )->gather(1);
-
- return undef unless (@$recs);
-
- my $record = $_storage->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $recs->[0]->record )->gather(1);
- return $U->entityize( $record->marc ) if ($record);
- return undef;
-}
-
-__PACKAGE__->register_method(
- method => 'retrieve_isbn_marcxml',
- api_name => 'open-ils.supercat.isbn.marcxml.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the MARCXML representation of the requested ISBN
- DESC
- params =>
- [
- { name => 'ISBN',
- desc => 'An ... um ... ISBN',
- type => 'string' },
- ],
- 'return' =>
- { desc => 'The bib record in MARCXML',
- type => 'string' }
- }
-);
-
-sub retrieve_record_transform {
- my $self = shift;
- my $client = shift;
- my $rid = shift;
-
- (my $transform = $self->api_name) =~ s/^.+record\.([^\.]+)\.retrieve$/$1/o;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
- #$_storage->connect;
-
- my $record = $_storage->request(
- 'open-ils.cstore.direct.biblio.record_entry.retrieve',
- $rid
- )->gather(1);
-
- return undef unless ($record);
-
- return $U->entityize($record_xslt{$transform}{xslt}->transform( $_parser->parse_string( $record->marc ) )->toString);
-}
-
-sub retrieve_isbn_transform {
- my $self = shift;
- my $client = shift;
- my $isbn = shift;
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- my $recs = $_storage->request(
- 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
- { tag => { like => '02%'}, value => {like => "$isbn\%"}}
- )->gather(1);
-
- return undef unless (@$recs);
-
- (my $transform = $self->api_name) =~ s/^.+isbn\.([^\.]+)\.retrieve$/$1/o;
-
- my $record = $_storage->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $recs->[0]->record )->gather(1);
-
- return undef unless ($record);
-
- return $U->entityize($record_xslt{$transform}{xslt}->transform( $_parser->parse_string( $record->marc ) )->toString);
-}
-
-sub retrieve_record_objects {
- my $self = shift;
- my $client = shift;
- my $ids = shift;
-
- $ids = [$ids] unless (ref $ids);
- $ids = [grep {$_} @$ids];
-
- return [] unless (@$ids);
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
- return $_storage->request('open-ils.cstore.direct.biblio.record_entry.search.atomic' => { id => [grep {$_} @$ids] })->gather(1);
-}
-__PACKAGE__->register_method(
- method => 'retrieve_record_objects',
- api_name => 'open-ils.supercat.record.object.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the Fieldmapper object representation of the requested bibliographic records
- DESC
- params =>
- [
- { name => 'bibIds',
- desc => 'OpenILS biblio::record_entry ids',
- type => 'array' },
- ],
- 'return' =>
- { desc => 'The bib records',
- type => 'array' }
- }
-);
-
-
-sub retrieve_isbn_object {
- my $self = shift;
- my $client = shift;
- my $isbn = shift;
-
- return undef unless ($isbn);
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
- my $recs = $_storage->request(
- 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
- { tag => { like => '02%'}, value => {like => "$isbn\%"}}
- )->gather(1);
-
- return undef unless (@$recs);
-
- return $_storage->request(
- 'open-ils.cstore.direct.biblio.record_entry.search.atomic',
- { id => $recs->[0]->record }
- )->gather(1);
-}
-__PACKAGE__->register_method(
- method => 'retrieve_isbn_object',
- api_name => 'open-ils.supercat.isbn.object.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the Fieldmapper object representation of the requested bibliographic record
- DESC
- params =>
- [
- { name => 'isbn',
- desc => 'an ISBN',
- type => 'string' },
- ],
- 'return' =>
- { desc => 'The bib record',
- type => 'object' }
- }
-);
-
-
-
-sub retrieve_metarecord_mods {
- my $self = shift;
- my $client = shift;
- my $rid = shift;
-
- my $_storage = OpenSRF::AppSession->connect( 'open-ils.cstore' );
-
- # Get the metarecord in question
- my $mr =
- $_storage->request(
- 'open-ils.cstore.direct.metabib.metarecord.retrieve' => $rid
- )->gather(1);
-
- # Now get the map of all bib records for the metarecord
- my $recs =
- $_storage->request(
- 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
- {metarecord => $rid}
- )->gather(1);
-
- $logger->debug("Adding ".scalar(@$recs)." bib record to the MODS of the metarecord");
-
- # and retrieve the lead (master) record as MODS
- my ($master) =
- $self ->method_lookup('open-ils.supercat.record.mods.retrieve')
- ->run($mr->master_record);
- my $master_mods = $_parser->parse_string($master)->documentElement;
- $master_mods->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $master_mods->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
-
- # ... and a MODS clone to populate, with guts removed.
- my $mods = $_parser->parse_string($master)->documentElement;
- $mods->setNamespace( "http://www.loc.gov/mods/", "mods" ); # modsCollection element
- $mods->setNamespace('http://www.loc.gov/mods/', undef, 1);
- ($mods) = $mods->findnodes('//mods:mods');
- #$mods->setNamespace( "http://www.loc.gov/mods/", "mods" ); # mods element
- $mods->removeChildNodes;
- $mods->setNamespace('http://www.loc.gov/mods/', undef, 1);
-
- # Add the metarecord ID as a (locally defined) info URI
- my $recordInfo = $mods
- ->ownerDocument
- ->createElement("recordInfo");
-
- my $recordIdentifier = $mods
- ->ownerDocument
- ->createElement("recordIdentifier");
-
- my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
- $year += 1900;
- $month += 1;
-
- my $id = $mr->id;
- $recordIdentifier->appendTextNode(
- sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d:metabib-metarecord/$id", $month, $day)
- );
-
- $recordInfo->appendChild($recordIdentifier);
- $mods->appendChild($recordInfo);
-
- # Grab the title, author and ISBN for the master record and populate the metarecord
- my ($title) = $master_mods->findnodes( './mods:titleInfo[not(@type)]' );
-
- if ($title) {
- $title->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $title->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
- $title = $mods->ownerDocument->importNode($title);
- $mods->appendChild($title);
- }
-
- my ($author) = $master_mods->findnodes( './mods:name[mods:role/mods:text[text()="creator"]]' );
- if ($author) {
- $author->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $author->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
- $author = $mods->ownerDocument->importNode($author);
- $mods->appendChild($author);
- }
-
- my ($isbn) = $master_mods->findnodes( './mods:identifier[@type="isbn"]' );
- if ($isbn) {
- $isbn->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $isbn->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
- $isbn = $mods->ownerDocument->importNode($isbn);
- $mods->appendChild($isbn);
- }
-
- # ... and loop over the constituent records
- for my $map ( @$recs ) {
-
- # get the MODS
- my ($rec) =
- $self ->method_lookup('open-ils.supercat.record.mods.retrieve')
- ->run($map->source);
-
- my $part_mods = $_parser->parse_string($rec);
- $part_mods->documentElement->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $part_mods->documentElement->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
- ($part_mods) = $part_mods->findnodes('//mods:mods');
-
- for my $node ( ($part_mods->findnodes( './mods:subject' )) ) {
- $node->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $node->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
- $node = $mods->ownerDocument->importNode($node);
- $mods->appendChild( $node );
- }
-
- my $relatedItem = $mods
- ->ownerDocument
- ->createElement("relatedItem");
-
- $relatedItem->setAttribute( type => 'constituent' );
-
- my $identifier = $mods
- ->ownerDocument
- ->createElement("identifier");
-
- $identifier->setAttribute( type => 'uri' );
-
- my $subRecordInfo = $mods
- ->ownerDocument
- ->createElement("recordInfo");
-
- my $subRecordIdentifier = $mods
- ->ownerDocument
- ->createElement("recordIdentifier");
-
- my $subid = $map->source;
- $subRecordIdentifier->appendTextNode(
- sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d:biblio-record_entry/$subid",
- $month,
- $day
- )
- );
- $subRecordInfo->appendChild($subRecordIdentifier);
-
- $relatedItem->appendChild( $subRecordInfo );
-
- my ($tor) = $part_mods->findnodes( './mods:typeOfResource' );
- $tor->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $tor->setNamespace( "http://www.loc.gov/mods/", undef, 1 ) if ($tor);
- $tor = $mods->ownerDocument->importNode($tor) if ($tor);
- $relatedItem->appendChild($tor) if ($tor);
-
- if ( my ($part_isbn) = $part_mods->findnodes( './mods:identifier[@type="isbn"]' ) ) {
- $part_isbn->setNamespace( "http://www.loc.gov/mods/", "mods" );
- $part_isbn->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
- $part_isbn = $mods->ownerDocument->importNode($part_isbn);
- $relatedItem->appendChild( $part_isbn );
-
- if (!$isbn) {
- $isbn = $mods->appendChild( $part_isbn->cloneNode(1) );
- }
- }
-
- $mods->appendChild( $relatedItem );
-
- }
-
- $_storage->disconnect;
-
- return $U->entityize($mods->toString);
-
-}
-__PACKAGE__->register_method(
- method => 'retrieve_metarecord_mods',
- api_name => 'open-ils.supercat.metarecord.mods.retrieve',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the MODS representation of the requested metarecord
- DESC
- params =>
- [
- { name => 'metarecordId',
- desc => 'An OpenILS metabib::metarecord id',
- type => 'number' },
- ],
- 'return' =>
- { desc => 'The metarecord in MODS',
- type => 'string' }
- }
-);
-
-sub list_metarecord_formats {
- my @list = (
- { mods =>
- { namespace_uri => 'http://www.loc.gov/mods/',
- docs => 'http://www.loc.gov/mods/',
- schema_location => 'http://www.loc.gov/standards/mods/mods.xsd',
- }
- }
- );
-
- for my $type ( keys %metarecord_xslt ) {
- push @list,
- { $type =>
- { namespace_uri => $metarecord_xslt{$type}{namespace_uri},
- docs => $metarecord_xslt{$type}{docs},
- schema_location => $metarecord_xslt{$type}{schema_location},
- }
- };
- }
-
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'list_metarecord_formats',
- api_name => 'open-ils.supercat.metarecord.formats',
- api_level => 1,
- argc => 0,
- signature =>
- { desc => <<" DESC",
-Returns the list of valid metarecord formats that supercat understands.
- DESC
- 'return' =>
- { desc => 'The format list',
- type => 'array' }
- }
-);
-
-
-sub list_authority_formats {
- my @list = (
- { marcxml =>
- { namespace_uri => 'http://www.loc.gov/MARC21/slim',
- docs => 'http://www.loc.gov/marcxml/',
- schema_location => 'http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd',
- }
- }
- );
-
-# for my $type ( keys %record_xslt ) {
-# push @list,
-# { $type =>
-# { namespace_uri => $record_xslt{$type}{namespace_uri},
-# docs => $record_xslt{$type}{docs},
-# schema_location => $record_xslt{$type}{schema_location},
-# }
-# };
-# }
-#
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'list_authority_formats',
- api_name => 'open-ils.supercat.authority.formats',
- api_level => 1,
- argc => 0,
- signature =>
- { desc => <<" DESC",
-Returns the list of valid authority formats that supercat understands.
- DESC
- 'return' =>
- { desc => 'The format list',
- type => 'array' }
- }
-);
-
-sub list_record_formats {
- my @list = (
- { marcxml =>
- { namespace_uri => 'http://www.loc.gov/MARC21/slim',
- docs => 'http://www.loc.gov/marcxml/',
- schema_location => 'http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd',
- }
- }
- );
-
- for my $type ( keys %record_xslt ) {
- push @list,
- { $type =>
- { namespace_uri => $record_xslt{$type}{namespace_uri},
- docs => $record_xslt{$type}{docs},
- schema_location => $record_xslt{$type}{schema_location},
- }
- };
- }
-
- return \@list;
-}
-__PACKAGE__->register_method(
- method => 'list_record_formats',
- api_name => 'open-ils.supercat.record.formats',
- api_level => 1,
- argc => 0,
- signature =>
- { desc => <<" DESC",
-Returns the list of valid record formats that supercat understands.
- DESC
- 'return' =>
- { desc => 'The format list',
- type => 'array' }
- }
-);
-__PACKAGE__->register_method(
- method => 'list_record_formats',
- api_name => 'open-ils.supercat.isbn.formats',
- api_level => 1,
- argc => 0,
- signature =>
- { desc => <<" DESC",
-Returns the list of valid record formats that supercat understands.
- DESC
- 'return' =>
- { desc => 'The format list',
- type => 'array' }
- }
-);
-
-
-sub oISBN {
- my $self = shift;
- my $client = shift;
- my $isbn = shift;
-
- $isbn =~ s/-//gso;
-
- throw OpenSRF::EX::InvalidArg ('I need an ISBN please')
- unless (length($isbn) >= 10);
-
- my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
-
- # Create a storage session, since we'll be making muliple requests.
- $_storage->connect;
-
- # Find the record that has that ISBN.
- my $bibrec = $_storage->request(
- 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
- { tag => '020', subfield => 'a', value => { like => lc($isbn).'%'} }
- )->gather(1);
-
- # Go away if we don't have one.
- return {} unless (@$bibrec);
-
- # Find the metarecord for that bib record.
- my $mr = $_storage->request(
- 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
- {source => $bibrec->[0]->record}
- )->gather(1);
-
- # Find the other records for that metarecord.
- my $records = $_storage->request(
- 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
- {metarecord => $mr->[0]->metarecord}
- )->gather(1);
-
- # Just to be safe. There's currently no unique constraint on sources...
- my %unique_recs = map { ($_->source, 1) } @$records;
- my @rec_list = sort keys %unique_recs;
-
- # And now fetch the ISBNs for thos records.
- my $recs = [];
- push @$recs,
- $_storage->request(
- 'open-ils.cstore.direct.metabib.full_rec.search',
- { tag => '020', subfield => 'a', record => $_ }
- )->gather(1) for (@rec_list);
-
- # We're done with the storage server session.
- $_storage->disconnect;
-
- # Return the oISBN data structure. This will be XMLized at a higher layer.
- return
- { metarecord => $mr->[0]->metarecord,
- record_list => { map { $_ ? ($_->record, $_->value) : () } @$recs } };
-
-}
-__PACKAGE__->register_method(
- method => 'oISBN',
- api_name => 'open-ils.supercat.oisbn',
- api_level => 1,
- argc => 1,
- signature =>
- { desc => <<" DESC",
-Returns the ISBN list for the metarecord of the requested isbn
- DESC
- params =>
- [
- { name => 'isbn',
- desc => 'An ISBN. Duh.',
- type => 'string' },
- ],
- 'return' =>
- { desc => 'record to isbn map',
- type => 'object' }
- }
-);
-
-package OpenILS::Application::SuperCat::unAPI;
-use base qw/OpenILS::Application::SuperCat/;
-
-sub as_xml {
- die "dummy superclass, use a real class";
-}
-
-sub new {
- my $class = shift;
- my $obj = shift;
- return unless ($obj);
-
- $class = ref($class) || $class;
-
- if ($class eq __PACKAGE__) {
- return unless (ref($obj));
- $class .= '::' . $obj->json_hint;
- }
-
- return bless { obj => $obj } => $class;
-}
-
-sub obj {
- my $self = shift;
- return $self->{obj};
-}
-
-package OpenILS::Application::SuperCat::unAPI::auri;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <uri xmlns="http://open-ils.org/spec/holdings/v1" ';
- $xml .= 'id="tag:open-ils.org:asset-uri/' . $self->obj->id . '" ';
- $xml .= 'use_restriction="' . $self->escape( $self->obj->use_restriction ) . '" ';
- $xml .= 'label="' . $self->escape( $self->obj->label ) . '" ';
- $xml .= 'href="' . $self->escape( $self->obj->href ) . '">';
-
- if (!$args->{no_volumes}) {
- if (ref($self->obj->call_number_maps) && @{ $self->obj->call_number_maps }) {
- $xml .= " <volumes>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_->call_number )
- ->as_xml({ %$args, no_uris=>1, no_copies=>1 })
- } @{ $self->obj->call_number_maps }
- ) . " </volumes>\n";
-
- } else {
- $xml .= " <volumes/>\n";
- }
- }
-
- $xml .= " </uri>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::acn;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <volume xmlns="http://open-ils.org/spec/holdings/v1" ';
-
- $xml .= 'id="tag:open-ils.org:asset-call_number/' . $self->obj->id . '" ';
- $xml .= 'lib="' . $self->escape( $self->obj->owning_lib->shortname ) . '" ';
- $xml .= 'opac_visible="' . $self->obj->owning_lib->opac_visible . '" ';
- $xml .= 'deleted="' . $self->obj->deleted . '" ';
- $xml .= 'label="' . $self->escape( $self->obj->label ) . '">';
- $xml .= "\n";
-
- if (!$args->{no_copies}) {
- if (ref($self->obj->copies) && @{ $self->obj->copies }) {
- $xml .= " <copies>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_volume=>1 })
- } @{ $self->obj->copies }
- ) . " </copies>\n";
-
- } else {
- $xml .= " <copies/>\n";
- }
- }
-
- if (!$args->{no_uris}) {
- if (ref($self->obj->uri_maps) && @{ $self->obj->uri_maps }) {
- $xml .= " <uris>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_->uri )
- ->as_xml({ %$args, no_volumes=>1 })
- } @{ $self->obj->uri_maps }
- ) . " </uris>\n";
-
- } else {
- $xml .= " <uris/>\n";
- }
- }
-
-
- $xml .= ' <owning_lib xmlns="http://open-ils.org/spec/actors/v1" ';
- $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->owning_lib->id . '" ';
- $xml .= 'shortname="'.$self->escape( $self->obj->owning_lib->shortname ) .'" ';
- $xml .= 'name="'.$self->escape( $self->obj->owning_lib->name ) .'"/>';
- $xml .= "\n";
-
- unless ($args->{no_record}) {
- my $rec_tag = "tag:open-ils.org:biblio-record_entry/".$self->obj->record->id.'/'.$self->escape( $self->obj->owning_lib->shortname ) ;
-
- my $r_doc = $parser->parse_string($self->obj->record->marc);
- $r_doc->documentElement->setAttribute( id => $rec_tag );
- $xml .= $U->entityize($r_doc->documentElement->toString);
- }
-
- $xml .= " </volume>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::ssub;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <subscription xmlns="http://open-ils.org/spec/holdings/v1" ';
-
- $xml .= 'id="tag:open-ils.org:serial-subscription/' . $self->obj->id . '" ';
- $xml .= 'start="' . $self->escape( $self->obj->start_date ) . '" ';
- $xml .= 'end="' . $self->escape( $self->obj->end_date ) . '" ';
- $xml .= 'expected_date_offset="' . $self->escape( $self->obj->expected_date_offset ) . '">';
- $xml .= "\n";
-
- if (!$args->{no_distributions}) {
- if (ref($self->obj->distributions) && @{ $self->obj->distributions }) {
- $xml .= " <distributions>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_subscription=>1, no_issuance=>1 })
- } @{ $self->obj->distributions }
- ) . " </distributions>\n";
-
- } else {
- $xml .= " <distributions/>\n";
- }
- }
-
- if (!$args->{no_captions_and_patterns}) {
- if (ref($self->obj->scaps) && @{ $self->obj->scaps }) {
- $xml .= " <captions_and_patterns>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_subscription=>1 })
- } @{ $self->obj->scaps }
- ) . " </captions_and_patterns>\n";
-
- } else {
- $xml .= " <captions_and_patterns/>\n";
- }
- }
-
- if (!$args->{no_issuances}) {
- if (ref($self->obj->issuances) && @{ $self->obj->issuances }) {
- $xml .= " <issuances>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_subscription=>1, no_items=>1 })
- } @{ $self->obj->issuances }
- ) . " </issuances>\n";
-
- } else {
- $xml .= " <issuances/>\n";
- }
- }
-
-
- $xml .= ' <owning_lib xmlns="http://open-ils.org/spec/actors/v1" ';
- $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->owning_lib->id . '" ';
- $xml .= 'shortname="'.$self->escape( $self->obj->owning_lib->shortname ) .'" ';
- $xml .= 'name="'.$self->escape( $self->obj->owning_lib->name ) .'"/>';
- $xml .= "\n";
-
- unless ($args->{no_record}) {
- my $rec_tag = "tag:open-ils.org:biblio-record_entry/".$self->obj->record->id.'/'.$self->escape( $self->obj->owning_lib->shortname ) ;
-
- my $r_doc = $parser->parse_string($self->obj->record_entry->marc);
- $r_doc->documentElement->setAttribute( id => $rec_tag );
- $xml .= $U->entityize($r_doc->documentElement->toString);
- }
-
- $xml .= " </subscription>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::ssum_base;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- (my $type = ref($self)) =~ s/^.+([^:]+)$/$1/;
-
- my $xml = " <serial_summary xmlns=\"http://open-ils.org/spec/holdings/v1\" type=\"$type\" ";
-
- $xml .= "id=\"tag:open-ils.org:serial-summary-$type/" . $self->obj->id . '" ';
- $xml .= 'generated_coverage="' . $self->escape( $self->obj->generated_coverage ) . '" ';
- $xml .= 'show_generated="' . $self->escape( $self->obj->show_generated ) . '" ';
- $xml .= 'textual_holdings="' . $self->escape( $self->obj->textual_holdings ) . '">';
- $xml .= "\n";
-
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->distribution )->as_xml({ %$args, no_summaries=>1 }) if (!$args->{no_distribution});
-
- $xml .= " </serial_summary>\n";
-
- return $xml;
-}
-
-
-package OpenILS::Application::SuperCat::unAPI::sssum;
-use base qw/OpenILS::Application::SuperCat::unAPI::ssum_base/;
-
-package OpenILS::Application::SuperCat::unAPI::sbsum;
-use base qw/OpenILS::Application::SuperCat::unAPI::ssum_base/;
-
-package OpenILS::Application::SuperCat::unAPI::sisum;
-use base qw/OpenILS::Application::SuperCat::unAPI::ssum_base/;
-
-package OpenILS::Application::SuperCat::unAPI::sdist;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <distribution xmlns="http://open-ils.org/spec/holdings/v1" ';
-
- $xml .= 'id="tag:open-ils.org:serial-distribution/' . $self->obj->id . '" ';
- $xml .= 'label="' . $self->escape( $self->obj->label ) . '" ';
- $xml .= 'unit_label_prefix="' . $self->escape( $self->obj->unit_label_prefix ) . '" ';
- $xml .= 'unit_label_suffix="' . $self->escape( $self->obj->unit_label_suffix ) . '">';
- $xml .= "\n";
-
- if (!$args->{no_distributions}) {
- if (ref($self->obj->streams) && @{ $self->obj->streams }) {
- $xml .= " <streams>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_distribution=>1 })
- } @{ $self->obj->streams }
- ) . " </streams>\n";
-
- } else {
- $xml .= " <streams/>\n";
- }
- }
-
- if (!$args->{no_summaries}) {
- $xml .= " <summaries>\n";
- $xml .= join ('',
- map {
- defined $_ ?
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_distribution=>1 }) : ""
- } ($self->obj->basic_summary, $self->obj->supplement_summary, $self->obj->index_summary)
- );
-
- $xml .= " </summaries>\n";
- }
-
-
- $xml .= ' <holding_lib xmlns="http://open-ils.org/spec/actors/v1" ';
- $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->holding_lib->id . '" ';
- $xml .= 'shortname="'.$self->escape( $self->obj->holding_lib->shortname ) .'" ';
- $xml .= 'name="'.$self->escape( $self->obj->holding_lib->name ) .'"/>';
- $xml .= "\n";
-
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->subscription )->as_xml({ %$args, no_distributions=>1 }) if (!$args->{no_subscription});
-
- if (!$args->{no_record} && $self->obj->record_entry) {
- my $rec_tag = "tag:open-ils.org:serial-record_entry/".$self->obj->record_entry->id ;
-
- my $r_doc = $parser->parse_string($self->obj->record_entry->marc);
- $r_doc->documentElement->setAttribute( id => $rec_tag );
- $xml .= $U->entityize($r_doc->documentElement->toString);
- }
-
- $xml .= " </distribution>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::sstr;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <stream xmlns="http://open-ils.org/spec/holdings/v1" ';
-
- $xml .= 'id="tag:open-ils.org:serial-stream/' . $self->obj->id . '" ';
- $xml .= 'routing_label="' . $self->escape( $self->obj->routing_label ) . '">';
- $xml .= "\n";
-
- if (!$args->{no_items}) {
- if (ref($self->obj->items) && @{ $self->obj->items }) {
- $xml .= " <items>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_stream=>1 })
- } @{ $self->obj->items }
- ) . " </items>\n";
-
- } else {
- $xml .= " <items/>\n";
- }
- }
-
- #XXX routing_list_user's?
-
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->distribution )->as_xml({ %$args, no_streams=>1 }) if (!$args->{no_distribution});
-
- $xml .= " </stream>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::sitem;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <serial_item xmlns="http://open-ils.org/spec/holdings/v1" ';
-
- $xml .= 'id="tag:open-ils.org:serial-item/' . $self->obj->id . '" ';
- $xml .= 'date_expected="' . $self->escape( $self->obj->date_expected ) . '"';
- $xml .= ' date_received="' . $self->escape( $self->obj->date_received ) .'"'if ($self->obj->date_received);
-
- if ($args->{no_issuance}) {
- my $siss = ref($self->obj->issuance) ? $self->obj->issuance->id : $self->obj->issuance;
- $xml .= ' issuance="tag:open-ils.org:serial-issuance/' . $siss . '"';
- }
-
- $xml .= ">\n";
-
- if (ref($self->obj->notes) && $self->obj->notes) {
- $xml .= " <notes>\n";
- for my $note ( @{$self->obj->notes} ) {
- next unless ( $note->pub eq 't' );
- $xml .= sprintf(' <note date="%s" title="%s">%s</note>',$note->create_date, $self->escape($note->title), $self->escape($note->value));
- $xml .= "\n";
- }
- $xml .= " </notes>\n";
- } else {
- $xml .= " <notes/>\n";
- }
-
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->issuance )->as_xml({ %$args, no_items=>1 }) if (!$args->{no_issuance});
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->stream )->as_xml({ %$args, no_items=>1 }) if (!$args->{no_stream});
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->unit )->as_xml({ %$args, no_items=>1, no_volumes=>1 }) if ($self->obj->unit && !$args->{no_unit});
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->uri )->as_xml({ %$args, no_items=>1, no_volumes=>1 }) if ($self->obj->uri && !$args->{no_uri});
-
- $xml .= " </serial_item>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::sunit;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <serial_unit xmlns="http://open-ils.org/spec/holdings/v1" '.
- 'id="tag:open-ils.org:serial-unit/' . $self->obj->id . '" ';
-
- $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" ' for (qw/
- create_date edit_date copy_number circulate deposit ref holdable deleted
- deposit_amount price barcode circ_modifier circ_as_type opac_visible cost
- status_changed_time floating mint_condition detailed_contents sort_key summary_contents
- /);
-
- $xml .= ">\n";
-
- $xml .= ' <status ident="' . $self->obj->status->id . '">' . $self->escape( $self->obj->status->name ) . "</status>\n";
- $xml .= ' <location ident="' . $self->obj->location->id . '">' . $self->escape( $self->obj->location->name ) . "</location>\n";
- $xml .= ' <circlib ident="' . $self->obj->circ_lib->id . '">' . $self->escape( $self->obj->circ_lib->name ) . "</circlib>\n";
-
- $xml .= ' <circ_lib xmlns="http://open-ils.org/spec/actors/v1" ';
- $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->circ_lib->id . '" ';
- $xml .= 'shortname="'.$self->escape( $self->obj->circ_lib->shortname ) .'" ';
- $xml .= 'name="'.$self->escape( $self->obj->circ_lib->name ) .'"/>';
- $xml .= "\n";
-
- $xml .= " <copy_notes>\n";
- if (ref($self->obj->notes) && $self->obj->notes) {
- for my $note ( @{$self->obj->notes} ) {
- next unless ( $note->pub eq 't' );
- $xml .= sprintf(' <copy_note date="%s" title="%s">%s</copy_note>',$note->create_date, $self->escape($note->title), $self->escape($note->value));
- $xml .= "\n";
- }
- }
-
- $xml .= " </copy_notes>\n";
- $xml .= " <statcats>\n";
-
- if (ref($self->obj->stat_cat_entries) && $self->obj->stat_cat_entries) {
- for my $sce ( @{$self->obj->stat_cat_entries} ) {
- next unless ( $sce->stat_cat->opac_visible eq 't' );
- $xml .= sprintf(' <statcat name="%s">%s</statcat>',$self->escape($sce->stat_cat->name) ,$self->escape($sce->value));
- $xml .= "\n";
- }
- }
- $xml .= " </statcats>\n";
-
- unless ($args->{no_volume}) {
- if (ref($self->obj->call_number)) {
- $xml .= OpenILS::Application::SuperCat::unAPI
- ->new( $self->obj->call_number )
- ->as_xml({ %$args, no_copies=>1 });
- } else {
- $xml .= " <volume/>\n";
- }
- }
-
- $xml .= " </serial_unit>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::scap;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <caption_and_pattern xmlns="http://open-ils.org/spec/holdings/v1" '.
- 'id="tag:open-ils.org:serial-caption_and_pattern/' . $self->obj->id . '" ';
-
- $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" ' for (qw/
- create_date type active pattern_code enum_1 enum_2 enum_3 enum_4
- enum_5 enum_6 chron_1 chron_2 chron_3 chron_4 chron_5 start_date end_date
- /);
- $xml .= ">\n";
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->subscription )->as_xml({ %$args, no_captions_and_patterns=>1 }) if (!$args->{no_subscription});
- $xml .= " </caption_and_pattern>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::siss;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <issuance xmlns="http://open-ils.org/spec/holdings/v1" '.
- 'id="tag:open-ils.org:serial-issuance/' . $self->obj->id . '" ';
-
- $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" '
- for (qw/create_date edit_date label date_published holding_code holding_type holding_link_id/);
-
- $xml .= ">\n";
-
- if (!$args->{no_items}) {
- if (ref($self->obj->items) && @{ $self->obj->items }) {
- $xml .= " <items>\n" . join(
- '',
- map {
- OpenILS::Application::SuperCat::unAPI
- ->new( $_ )
- ->as_xml({ %$args, no_stream=>1 })
- } @{ $self->obj->items }
- ) . " </items>\n";
-
- } else {
- $xml .= " <items/>\n";
- }
- }
-
- $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->subscription )->as_xml({ %$args, no_issuances=>1 }) if (!$args->{no_subscription});
- $xml .= " </issuance>\n";
-
- return $xml;
-}
-
-package OpenILS::Application::SuperCat::unAPI::acp;
-use base qw/OpenILS::Application::SuperCat::unAPI/;
-
-sub as_xml {
- my $self = shift;
- my $args = shift;
-
- my $xml = ' <copy xmlns="http://open-ils.org/spec/holdings/v1" '.
- 'id="tag:open-ils.org:asset-copy/' . $self->obj->id . '" ';
-
- $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" ' for (qw/
- create_date edit_date copy_number circulate deposit ref holdable deleted
- deposit_amount price barcode circ_modifier circ_as_type opac_visible
- /);
-
- $xml .= ">\n";
-
- $xml .= ' <status ident="' . $self->obj->status->id . '">' . $self->escape( $self->obj->status->name ) . "</status>\n";
- $xml .= ' <location ident="' . $self->obj->location->id . '" opac_visible="'.$self->obj->location->opac_visible.'">' . $self->escape( $self->obj->location->name ) . "</location>\n";
- $xml .= ' <circlib ident="' . $self->obj->circ_lib->id . '" opac_visible="'.$self->obj->circ_lib->opac_visible.'">' . $self->escape( $self->obj->circ_lib->name ) . "</circlib>\n";
-
- $xml .= ' <circ_lib xmlns="http://open-ils.org/spec/actors/v1" ';
- $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->circ_lib->id . '" ';
- $xml .= 'shortname="'.$self->escape( $self->obj->circ_lib->shortname ) .'" ';
- $xml .= 'name="'.$self->escape( $self->obj->circ_lib->name ) .'" opac_visible="'.$self->obj->circ_lib->opac_visible.'"/>';
- $xml .= "\n";
-
- $xml .= " <copy_notes>\n";
- if (ref($self->obj->notes) && $self->obj->notes) {
- for my $note ( @{$self->obj->notes} ) {
- next unless ( $note->pub eq 't' );
- $xml .= sprintf(' <copy_note date="%s" title="%s">%s</copy_note>',$note->create_date, $self->escape($note->title), $self->escape($note->value));
- $xml .= "\n";
- }
- }
-
- $xml .= " </copy_notes>\n";
- $xml .= " <statcats>\n";
-
- if (ref($self->obj->stat_cat_entries) && $self->obj->stat_cat_entries) {
- for my $sce ( @{$self->obj->stat_cat_entries} ) {
- next unless ( $sce->stat_cat->opac_visible eq 't' );
- $xml .= sprintf(' <statcat name="%s">%s</statcat>',$self->escape($sce->stat_cat->name) ,$self->escape($sce->value));
- $xml .= "\n";
- }
- }
- $xml .= " </statcats>\n";
-
- unless ($args->{no_volume}) {
- if (ref($self->obj->call_number)) {
- $xml .= OpenILS::Application::SuperCat::unAPI
- ->new( $self->obj->call_number )
- ->as_xml({ %$args, no_copies=>1 });
- } else {
- $xml .= " <volume/>\n";
- }
- }
-
- $xml .= " </copy>\n";
-
- return $xml;
-}
-
-
-1;
-# vim: et:ts=4:sw=4
+++ /dev/null
-package OpenILS::Application::Trigger;
-use strict; use warnings;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils::JSON;
-
-use OpenSRF::AppSession;
-use OpenSRF::MultiSession;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils qw/:datetime/;
-
-use DateTime;
-use DateTime::Format::ISO8601;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::Trigger::Event;
-use OpenILS::Application::Trigger::EventGroup;
-
-
-my $log = 'OpenSRF::Utils::Logger';
-my $parallel_collect;
-my $parallel_react;
-
-sub initialize {
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- $parallel_collect = $conf->config_value( apps => 'open-ils.trigger' => app_settings => parallel => 'collect') || 1;
- $parallel_react = $conf->config_value( apps => 'open-ils.trigger' => app_settings => parallel => 'react') || 1;
-
-}
-sub child_init {}
-
-sub create_active_events_for_object {
- my $self = shift;
- my $client = shift;
- my $key = shift;
- my $target = shift;
- my $location = shift;
- my $granularity = shift;
- my $user_data = shift;
-
- my $ident = $target->Identity;
- my $ident_value = $target->$ident();
-
- my $editor = new_editor(xact=>1);
-
- my $hooks = $editor->search_action_trigger_hook(
- { key => $key,
- core_type => $target->json_hint
- }
- );
-
- unless(@$hooks) {
- $editor->rollback;
- return undef;
- }
-
- my %hook_hash = map { ($_->key, $_) } @$hooks;
-
- my $orgs = $editor->json_query({ from => [ 'actor.org_unit_ancestors' => $location ] });
- my $defs = $editor->search_action_trigger_event_definition(
- { hook => [ keys %hook_hash ],
- owner => [ map { $_->{id} } @$orgs ],
- active => 't'
- }
- );
-
- for my $def ( @$defs ) {
- next if ($granularity && $def->granularity ne $granularity );
-
- if ($def->usr_field && $def->opt_in_setting) {
- my $ufield = $def->usr_field;
- my $uid = $target->$ufield;
- $uid = $uid->id if (ref $uid); # fleshed user object, unflesh it
-
- my $opt_in_setting = $editor->search_actor_user_setting(
- { usr => $uid,
- name => $def->opt_in_setting,
- value => 'true'
- }
- );
-
- next unless (@$opt_in_setting);
- }
-
- my $date = DateTime->now;
-
- if ($hook_hash{$def->hook}->passive eq 'f') {
-
- if (my $dfield = $def->delay_field) {
- if ($target->$dfield()) {
- $date = DateTime::Format::ISO8601->new->parse_datetime( cleanse_ISO8601($target->$dfield) );
- } else {
- next;
- }
- }
-
- $date->add( seconds => interval_to_seconds($def->delay) );
- }
-
- my $event = Fieldmapper::action_trigger::event->new();
- $event->target( $ident_value );
- $event->event_def( $def->id );
- $event->run_time( $date->strftime( '%F %T%z' ) );
- $event->user_data( OpenSRF::Utils::JSON->perl2JSON($user_data) ) if (defined($user_data));
-
- $editor->create_action_trigger_event( $event );
-
- $client->respond( $event->id );
- }
-
- $editor->commit;
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.autocreate',
- method => 'create_active_events_for_object',
- api_level=> 1,
- stream => 1,
- argc => 3
-);
-
-sub create_event_for_object_and_def {
- my $self = shift;
- my $client = shift;
- my $definitions = shift;
- my $target = shift;
- my $location = shift;
- my $user_data = shift;
-
- my $ident = $target->Identity;
- my $ident_value = $target->$ident();
-
- my @active = ($self->api_name =~ /inactive/o) ? () : ( active => 't' );
-
- my $editor = new_editor(xact=>1);
-
- my $orgs = $editor->json_query({ from => [ 'actor.org_unit_ancestors' => $location ] });
- my $defs = $editor->search_action_trigger_event_definition(
- { id => $definitions,
- owner => [ map { $_->{id} } @$orgs ],
- @active
- }
- );
-
- my $hooks = $editor->search_action_trigger_hook(
- { key => [ map { $_->hook } @$defs ],
- core_type => $target->json_hint
- }
- );
-
- my %hook_hash = map { ($_->key, $_) } @$hooks;
-
- for my $def ( @$defs ) {
-
- if ($def->usr_field && $def->opt_in_setting) {
- my $ufield = $def->usr_field;
- my $uid = $target->$ufield;
- $uid = $uid->id if (ref $uid); # fleshed user object, unflesh it
-
- my $opt_in_setting = $editor->search_actor_user_setting(
- { usr => $uid,
- name => $def->opt_in_setting,
- value => 'true'
- }
- );
-
- next unless (@$opt_in_setting);
- }
-
- my $date = DateTime->now;
-
- if ($hook_hash{$def->hook}->passive eq 'f') {
-
- if (my $dfield = $def->delay_field) {
- if ($target->$dfield()) {
- $date = DateTime::Format::ISO8601->new->parse_datetime( cleanse_ISO8601($target->$dfield) );
- } else {
- next;
- }
- }
-
- $date->add( seconds => interval_to_seconds($def->delay) );
- }
-
- my $event = Fieldmapper::action_trigger::event->new();
- $event->target( $ident_value );
- $event->event_def( $def->id );
- $event->run_time( $date->strftime( '%F %T%z' ) );
- $event->user_data( OpenSRF::Utils::JSON->perl2JSON($user_data) ) if (defined($user_data));
-
- $editor->create_action_trigger_event( $event );
-
- $client->respond( $event->id );
- }
-
- $editor->commit;
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.autocreate.by_definition',
- method => 'create_event_for_object_and_def',
- api_level=> 1,
- stream => 1,
- argc => 3
-);
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.autocreate.by_definition.include_inactive',
- method => 'create_event_for_object_and_def',
- api_level=> 1,
- stream => 1,
- argc => 3
-);
-
-
-# Retrieves events by object, or object type + filter
-# $object : a target object or object type (class hint)
-#
-# $filter : an optional hash of filters ... top level keys:
-# event
-# filters on the atev objects, such as states or null-ness of timing
-# fields. contains the effective default of:
-# { state => 'pending' }
-# an example, which overrides the default, and will find
-# stale 'found' events:
-# { state => 'found', update_time => { '<' => 'yesterday' } }
-#
-# event_def
-# filters on the atevdef object. contains the effective default of:
-# { active => 't' }
-#
-# hook
-# filters on the hook object. no defaults, but there is a pinned,
-# unchangeable filter based on the passed hint or object type (see
-# $object above). an example for finding passive events:
-# { passive => 't' }
-#
-# target
-# filters against the target field on the event. this can contain
-# either an array of target ids (if you passed an object type, and
-# not an object) or can contain a json_query that will return exactly
-# a list of target-type ids. If you pass an object, the pkey value of
-# that object will be used as a filter in addition to the filter passed
-# in here. example filter for circs of user 1234 that are open:
-# { select => { circ => ['id'] },
-# from => 'circ',
-# where => {
-# usr => 1234,
-# checkin_time => undef,
-# '-or' => [
-# { stop_fines => undef },
-# { stop_fines => { 'not in' => ['LOST','LONGOVERDUE','CLAIMSRETURNED'] } }
-# ]
-# }
-
-sub events_by_target {
- my $self = shift;
- my $client = shift;
- my $object = shift;
- my $filter = shift || {};
- my $flesh_fields = shift || {};
- my $flesh_depth = shift || 1;
-
- my $obj_class = ref($object) || _fm_class_by_hint($object);
- my $obj_hint = ref($object) ? _fm_hint_by_class(ref($object)) : $object;
-
- my $object_ident_field = $obj_class->Identity;
-
- my $query = {
- select => { atev => ["id"] },
- from => {
- atev => {
- atevdef => {
- field => "id",
- fkey => "event_def",
- join => {
- ath => { field => "key", fkey => "hook" }
- }
- }
- }
- },
- where => {
- "+ath" => { core_type => $obj_hint },
- "+atevdef" => { active => 't' },
- "+atev" => { state => 'pending' }
- },
- order_by => { "atev" => [ 'run_time', 'add_time' ] }
- };
-
- $query->{limit} = $filter->{limit} if defined $filter->{limit};
- $query->{offset} = $filter->{offset} if defined $filter->{offset};
- $query->{order_by} = $filter->{order_by} if defined $filter->{order_by};
-
-
- # allow multiple 'target' filters
- $query->{where}->{'+atev'}->{'-and'} = [];
-
- # if we got a real object, filter on its pkey value
- if (ref($object)) { # pass an object, require that target
- push @{ $query->{where}->{'+atev'}->{'-and'} },
- { target => $object->$object_ident_field }
- }
-
- # we have a fancy complex target filter or a list of target ids
- if ($$filter{target}) {
- push @{ $query->{where}->{'+atev'}->{'-and'} },
- { target => {in => $$filter{target} } };
- }
-
- # pass no target filter or object, you get no events
- if (!@{ $query->{where}->{'+atev'}->{'-and'} }) {
- return undef;
- }
-
- # any hook filters, other than the required core_type filter
- if ($$filter{hook}) {
- $query->{where}->{'+ath'}->{$_} = $$filter{hook}{$_}
- for (grep { $_ ne 'core_type' } keys %{$$filter{hook}});
- }
-
- # any event_def filters. defaults to { active => 't' }
- if ($$filter{event_def}) {
- $query->{where}->{'+atevdef'}->{$_} = $$filter{event_def}{$_}
- for (keys %{$$filter{event_def}});
- }
-
- # any event filters. defaults to { state => 'pending' }.
- # don't overwrite '-and' used for multiple target filters above
- if ($$filter{event}) {
- $query->{where}->{'+atev'}->{$_} = $$filter{event}{$_}
- for (grep { $_ ne '-and' } keys %{$$filter{event}});
- }
-
- my $e = new_editor(xact=>1);
-
- my $events = $e->json_query($query);
-
- $flesh_fields->{atev} = ['event_def'] unless $flesh_fields->{atev};
-
- for my $id (@$events) {
- my $event = $e->retrieve_action_trigger_event([
- $id->{id},
- {flesh => $flesh_depth, flesh_fields => $flesh_fields}
- ]);
-
- (my $meth = $obj_class) =~ s/^Fieldmapper:://o;
- $meth =~ s/::/_/go;
- $meth = 'retrieve_'.$meth;
-
- $event->target($e->$meth($event->target));
- $client->respond($event);
- }
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.events_by_target',
- method => 'events_by_target',
- api_level=> 1,
- stream => 1,
- argc => 2
-);
-
-sub _fm_hint_by_class {
- my $class = shift;
- return Fieldmapper->publish_fieldmapper->{$class}->{hint};
-}
-
-sub _fm_class_by_hint {
- my $hint = shift;
-
- my ($class) = grep {
- Fieldmapper->publish_fieldmapper->{$_}->{hint} eq $hint
- } keys %{ Fieldmapper->publish_fieldmapper };
-
- return $class;
-}
-
-sub create_batch_events {
- my $self = shift;
- my $client = shift;
- my $key = shift;
- my $location_field = shift; # where to look for event_def.owner filtering ... circ_lib, for instance, where hook.core_type = circ
- my $filter = shift || {};
- my $granularity = shift;
- my $user_data = shift;
-
- my $active = ($self->api_name =~ /active/o) ? 1 : 0;
- if ($active && !keys(%$filter)) {
- $log->info("Active batch event creation requires a target filter but none was supplied to create_batch_events");
- return undef;
- }
-
- return undef unless ($key && $location_field);
-
- my $editor = new_editor(xact=>1);
- my $hooks = $editor->search_action_trigger_hook(
- { passive => $active ? 'f' : 't', key => $key }
- );
-
- my %hook_hash = map { ($_->key, $_) } @$hooks;
-
- my $defs = $editor->search_action_trigger_event_definition(
- { hook => [ keys %hook_hash ], active => 't' },
- );
-
- my $orig_filter_and = [];
- if ($$filter{'-and'}) {
- for my $f ( @{ $$filter{'-and'} } ) {
- push @$orig_filter_and, $f;
- }
- }
-
- for my $def ( @$defs ) {
- next if ($granularity && $def->granularity ne $granularity );
-
- my $date = DateTime->now->subtract( seconds => interval_to_seconds($def->delay) );
-
- # we may need to do some work to backport this to 1.2
- $filter->{ $location_field } = { 'in' =>
- {
- select => { aou => [{ column => 'id', transform => 'actor.org_unit_descendants', result_field => 'id' }] },
- from => 'aou',
- where => { id => $def->owner }
- }
- };
-
- my $run_time = 'now';
- if ($active) {
- $run_time =
- DateTime
- ->now
- ->add( seconds => interval_to_seconds($def->delay) )
- ->strftime( '%F %T%z' );
- } else {
- if ($def->max_delay) {
- my @times = sort {$a <=> $b} interval_to_seconds($def->delay), interval_to_seconds($def->max_delay);
- $filter->{ $def->delay_field } = {
- 'between' => [
- DateTime->now->subtract( seconds => $times[1] )->strftime( '%F %T%z' ),
- DateTime->now->subtract( seconds => $times[0] )->strftime( '%F %T%z' )
- ]
- };
- } else {
- $filter->{ $def->delay_field } = {
- '<=' => DateTime->now->subtract( seconds => interval_to_seconds($def->delay) )->strftime( '%F %T%z' )
- };
- }
- }
-
- my $class = _fm_class_by_hint($hook_hash{$def->hook}->core_type);
-
- # filter where this target has an event (and it's pending, for active hooks)
- $$filter{'-and'} = [];
- for my $f ( @$orig_filter_and ) {
- push @{ $$filter{'-and'} }, $f;
- }
-
- my $join = { 'join' => {
- atev => {
- field => 'target',
- fkey => $class->Identity,
- type => 'left',
- filter => { event_def => $def->id }
- }
- }};
-
- push @{ $filter->{'-and'} }, { '+atev' => { id => undef } };
-
- if ($def->usr_field && $def->opt_in_setting) {
- push @{ $filter->{'-and'} }, {
- '-exists' => {
- from => 'aus',
- where => {
- name => $def->opt_in_setting,
- usr => { '=' => { '+' . $hook_hash{$def->hook}->core_type => $def->usr_field } },
- value=> 'true'
- }
- }
- };
- }
-
- $class =~ s/^Fieldmapper:://o;
- $class =~ s/::/_/go;
- my $method = 'search_'. $class;
-
- # for cleaner logging
- my $def_id = $def->id;
- my $hook = $def->hook;
-
- $logger->info("trigger: create_batch_events() collecting object IDs for def=$def_id / hook=$hook");
-
- my $object_ids = $editor->$method( [$filter, $join], {idlist => 1, timeout => 10800} );
-
- if($object_ids) {
- $logger->info("trigger: create_batch_events() fetched ".scalar(@$object_ids)." object IDs for def=$def_id / hook=$hook");
- } else {
- $logger->warn("trigger: create_batch_events() timeout occurred collecting object IDs for def=$def_id / hook=$hook");
- }
-
- for my $o_id (@$object_ids) {
-
- my $event = Fieldmapper::action_trigger::event->new();
- $event->target( $o_id );
- $event->event_def( $def->id );
- $event->run_time( $run_time );
- $event->user_data( OpenSRF::Utils::JSON->perl2JSON($user_data) ) if (defined($user_data));
-
- $editor->create_action_trigger_event( $event );
-
- $client->respond( $event->id );
- }
-
- $logger->info("trigger: create_batch_events() successfully created events for def=$def_id / hook=$hook");
- }
-
- $logger->info("trigger: create_batch_events() done creating events");
-
- $editor->commit;
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.passive.event.autocreate.batch',
- method => 'create_batch_events',
- api_level=> 1,
- stream => 1,
- argc => 2
-);
-
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.active.event.autocreate.batch',
- method => 'create_batch_events',
- api_level=> 1,
- stream => 1,
- argc => 2
-);
-
-sub fire_single_event {
- my $self = shift;
- my $client = shift;
- my $event_id = shift;
-
- my $e = OpenILS::Application::Trigger::Event->new($event_id);
-
- if ($e->validate->valid) {
- $logger->info("trigger: Event is valid, reacting...");
- $e->react->cleanup;
- }
-
- $e->editor->disconnect;
- OpenILS::Application::Trigger::Event->ClearObjectCache();
-
- return {
- valid => $e->valid,
- reacted => $e->reacted,
- cleanedup => $e->cleanedup,
- event => $e->event
- };
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.fire',
- method => 'fire_single_event',
- api_level=> 1,
- argc => 1
-);
-
-sub fire_event_group {
- my $self = shift;
- my $client = shift;
- my $events = shift;
-
- my $e = OpenILS::Application::Trigger::EventGroup->new(@$events);
-
- if ($e->validate->valid) {
- $logger->info("trigger: Event group is valid, reacting...");
- $e->react->cleanup;
- }
-
- $e->editor->disconnect;
- OpenILS::Application::Trigger::Event->ClearObjectCache();
-
- return {
- valid => $e->valid,
- reacted => $e->reacted,
- cleanedup => $e->cleanedup,
- events => [map { $_->event } @{$e->events}]
- };
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event_group.fire',
- method => 'fire_event_group',
- api_level=> 1,
- argc => 1
-);
-
-sub pending_events {
- my $self = shift;
- my $client = shift;
- my $granularity = shift;
- my $granflag = shift;
-
- my $query = [{ state => 'pending', run_time => {'<' => 'now'} }, { order_by => { atev => [ qw/run_time add_time/] }, 'join' => 'atevdef' }];
-
- if (defined $granularity) {
- if ($granflag) {
- $query->[0]->{'+atevdef'} = {granularity => $granularity};
- } else {
- $query->[0]->{'+atevdef'} = {'-or' => [ {granularity => $granularity}, {granularity => undef} ] };
- }
- } else {
- $query->[0]->{'+atevdef'} = {granularity => undef};
- }
-
- return new_editor(xact=>1)->search_action_trigger_event(
- $query, { idlist=> 1, timeout => 7200, substream => 1 }
- );
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.find_pending',
- method => 'pending_events',
- api_level=> 1
-);
-
-sub gather_events {
- my $self = shift;
- my $client = shift;
- my $e_ids = shift;
-
- $e_ids = [$e_ids] if (!ref($e_ids));
-
- my @events;
- for my $e_id (@$e_ids) {
- my $e;
- try {
- $e = OpenILS::Application::Trigger::Event->new($e_id);
- } catch Error with {
- $logger->error("trigger: Event creation failed with ".shift());
- };
-
- next if !$e or $e->event->state eq 'invalid';
-
- try {
- $e->build_environment;
- } catch Error with {
- $logger->error("trigger: Event environment building failed with ".shift());
- };
-
- $e->editor->disconnect;
- $e->environment->{EventProcessor} = undef; # remove circular ref for json encoding
- $client->respond($e);
- }
-
- OpenILS::Application::Trigger::Event->ClearObjectCache();
-
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.gather',
- method => 'gather_events',
- api_level=> 1
-);
-
-sub grouped_events {
- my $self = shift;
- my $client = shift;
- my $granularity = shift;
- my $granflag = shift;
-
- my ($events) = $self->method_lookup('open-ils.trigger.event.find_pending')->run($granularity, $granflag);
-
- my %groups = ( '*' => [] );
-
- if($events) {
- $logger->info("trigger: grouped_events found ".scalar(@$events)." pending events to process");
- } else {
- $logger->warn("trigger: grouped_events timed out loading pending events");
- return \%groups;
- }
-
- my @fleshed_events;
-
- if ($parallel_collect == 1 or @$events == 1) { # use method lookup
- @fleshed_events = $self->method_lookup('open-ils.trigger.event.gather')->run($events);
- } else {
- my $self_multi = OpenSRF::MultiSession->new(
- app => 'open-ils.trigger',
- cap => $parallel_collect,
- success_handler => sub {
- my $self = shift;
- my $req = shift;
-
- push @fleshed_events,
- map { OpenILS::Application::Trigger::Event->new($_) }
- map { $_->content }
- @{ $req->{response} };
- },
- );
-
- $self_multi->request( 'open-ils.trigger.event.gather' => $_ ) for ( @$events );
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- $self_multi->session_wait(1);
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
- }
-
- for my $e (@fleshed_events) {
- if (my $group = $e->event->event_def->group_field) {
-
- # split the grouping link steps
- my @steps = split /\./, $group;
- my $group_field = pop(@steps); # we didn't flesh to this, it's a field not an object
-
- my $node;
- eval {
- $node = $e->target;
- $node = $node->$_() for ( @steps );
- };
-
- unless($node) { # should not get here, but to be safe..
- $e->update_state('invalid');
- next;
- }
-
- # get the grouping value for the grouping object on this event
- my $ident_value = $node->$group_field();
- if(ref $ident_value) {
- my $ident_field = $ident_value->Identity;
- $ident_value = $ident_value->$ident_field()
- }
-
- # push this event onto the event+grouping_value stack
- $groups{$e->event->event_def->id}{$ident_value} ||= [];
- push @{ $groups{$e->event->event_def->id}{$ident_value} }, $e;
- } else {
- # it's a non-grouped event
- push @{ $groups{'*'} }, $e;
- }
- }
-
-
- return \%groups;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.find_pending_by_group',
- method => 'grouped_events',
- api_level=> 1
-);
-
-sub run_all_events {
- my $self = shift;
- my $client = shift;
- my $granularity = shift;
- my $granflag = shift;
-
- my ($groups) = $self->method_lookup('open-ils.trigger.event.find_pending_by_group')->run($granularity, $granflag);
- $client->respond({"status" => "found"}) if (keys(%$groups) > 1 || @{$$groups{'*'}});
-
- my $self_multi;
- if ($parallel_react > 1 and (keys(%$groups) > 1 || @{$$groups{'*'}} > 1)) {
- $self_multi = OpenSRF::MultiSession->new(
- app => 'open-ils.trigger',
- cap => $parallel_react,
- session_hash_function => sub {
- my $args = shift;
- return $args->{target_id};
- },
- success_handler => sub {
- my $me = shift;
- my $req = shift;
- $client->respond( $req->{response}->[0]->content );
- }
- );
- }
-
- for my $def ( keys %$groups ) {
- if ($def eq '*') {
- $logger->info("trigger: run_all_events firing un-grouped events");
- for my $event ( @{ $$groups{'*'} } ) {
- try {
- if ($self_multi) {
- $event->environment->{EventProcessor} = undef; # remove circular ref for json encoding
- $self_multi->request({target_id => $event->id}, 'open-ils.trigger.event.fire', $event);
- } else {
- $client->respond(
- $self
- ->method_lookup('open-ils.trigger.event.fire')
- ->run($event)
- );
- }
- } catch Error with {
- $logger->error("trigger: event firing failed with ".shift());
- };
- }
- $logger->info("trigger: run_all_events completed queuing un-grouped events");
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
-
- } else {
- my $defgroup = $$groups{$def};
- $logger->info("trigger: run_all_events firing events for grouped event def=$def");
- for my $ident ( keys %$defgroup ) {
- $logger->info("trigger: run_all_events firing group for grouped event def=$def and grp ident $ident");
- try {
- if ($self_multi) {
- $_->environment->{EventProcessor} = undef for @{$$defgroup{$ident}}; # remove circular ref for json encoding
- $self_multi->request({target_id => $ident}, 'open-ils.trigger.event_group.fire', $$defgroup{$ident});
- } else {
- $client->respond(
- $self
- ->method_lookup('open-ils.trigger.event_group.fire')
- ->run($$defgroup{$ident})
- );
- }
- $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
- } catch Error with {
- $logger->error("trigger: event firing failed with ".shift());
- };
- }
- $logger->info("trigger: run_all_events completed queuing events for grouped event def=$def");
- }
- }
-
- $self_multi->session_wait(1) if ($self_multi);
- $logger->info("trigger: run_all_events completed firing events");
-
- $client->respond_complete();
- return undef;
-}
-__PACKAGE__->register_method(
- api_name => 'open-ils.trigger.event.run_all_pending',
- method => 'run_all_events',
- api_level=> 1
-);
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Cleanup;
-use strict; use warnings;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenSRF::Utils::Logger qw/:logger/;
-
-sub fourty_two { return 42 }
-sub NOOP_True { return 1 }
-sub NOOP_False { return 0 }
-
-sub DeleteTempBiblioBucket {
- my($self, $env) = @_;
- my $e = new_editor(xact => 1);
- my $buckets = $env->{target};
-
- for my $bucket (@$buckets) {
-
- foreach my $item (@{ $bucket->items }) {
- $e->delete_container_biblio_record_entry_bucket_item($item);
- }
-
- $e->delete_container_biblio_record_entry_bucket($bucket);
- }
-
- $e->commit or $e->die_event;
-
- return 1;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Collector;
-use strict; use warnings;
-sub fourty_two { return 42 }
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Event;
-use strict; use warnings;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::Trigger::ModRunner;
-use Safe;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub new {
- my $class = shift;
- my $id = shift;
- my $editor = shift;
- $class = ref($class) || $class;
-
- my $standalone = $editor ? 0 : 1;
- $editor ||= new_editor();
-
- if (ref($id) && ref($id) eq $class) {
- $id->environment->{EventProcessor} = $id
- if ($id->environment->{complete}); # in case it came over an opensrf tube
- $id->editor( $editor );
- $id->standalone( $standalone );
- return $id;
- }
-
- my $self = bless { id => $id, editor => $editor, standalone => $standalone } => $class;
-
- return $self->init()
-}
-
-sub init {
- my $self = shift;
- my $id = shift;
-
- return $self if ($self->event);
-
- $self->id( $id );
- $self->environment( {} );
-
- if (!$self->id) {
- $log->error("No Event ID provided");
- die "No Event ID provided";
- }
-
- return $self if (!$self->id);
-
- if ($self->standalone) {
- $self->editor->xact_begin || return undef;
- }
-
- $self->event(
- $self->editor->retrieve_action_trigger_event([
- $self->id, {
- flesh => 2,
- flesh_fields => {
- atev => [ qw/event_def/ ],
- atevdef => [ qw/hook env params/ ]
- }
- }
- ])
- );
-
- if ($self->standalone) {
- $self->editor->xact_rollback || return undef;
- }
-
- $self->user_data(OpenSRF::Utils::JSON->JSON2perl( $self->event->user_data ))
- if (defined( $self->event->user_data ));
-
- if ($self->event->state eq 'valid') {
- $self->valid(1);
- } elsif ($self->event->state eq 'invalid') {
- $self->valid(0);
- } elsif ($self->event->state eq 'reacting') {
- $self->valid(1);
- } elsif ($self->event->state eq 'reacted') {
- $self->valid(1);
- $self->reacted(1);
- } elsif ($self->event->state eq 'cleaning') {
- $self->valid(1);
- $self->reacted(1);
- } elsif ($self->event->state eq 'complete') {
- $self->valid(1);
- $self->reacted(1);
- $self->cleanedup(1);
- } elsif ($self->event->state eq 'error') {
- $self->valid(0);
- $self->reacted(0);
- $self->cleanedup(0);
- }
-
-
- $self->update_state('found') || die 'Unable to update event state';
-
- my $class = $self->_fm_class_by_hint( $self->event->event_def->hook->core_type );
-
- my $meth = "retrieve_" . $class;
- $meth =~ s/Fieldmapper:://;
- $meth =~ s/::/_/;
-
- if ($self->standalone) {
- $self->editor->xact_begin || return undef;
- }
-
- $self->target( $self->editor->$meth( $self->event->target ) );
-
- if ($self->standalone) {
- $self->editor->xact_rollback || return undef;
- }
-
- unless($self->target) {
- $self->update_state('invalid');
- $self->valid(0);
- }
-
- return $self;
-}
-
-sub cleanup {
- my $self = shift;
- my $env = shift || $self->environment;
-
- return $self if (defined $self->cleanedup);
-
- if (defined $self->reacted) {
- $self->update_state( 'cleaning') || die 'Unable to update event state';
- try {
- my $cleanup = $self->reacted ? $self->event->event_def->cleanup_success : $self->event->event_def->cleanup_failure;
- if($cleanup) {
- $self->cleanedup(
- OpenILS::Application::Trigger::ModRunner::Cleanup
- ->new( $cleanup, $env)
- ->run
- ->final_result
- );
- } else {
- $self->cleanedup(1);
- }
- } otherwise {
- $log->error("Event cleanup failed with ". shift() );
- $self->update_state( 'error' ) || die 'Unable to update event state';
- };
-
- if ($self->cleanedup) {
- $self->update_state( 'complete' ) || die 'Unable to update event state';
- } else {
- $self->update_state( 'error' ) || die 'Unable to update event state';
- }
-
- } else {
- $self->{cleanedup} = undef;
- }
- return $self;
-}
-
-sub react {
- my $self = shift;
- my $env = shift || $self->environment;
-
- return $self if (defined $self->reacted);
-
- if ($self->valid) {
- if ($self->event->event_def->group_field) { # can't react individually to a grouped definition
- $self->{reacted} = undef;
- } else {
- $self->update_state( 'reacting') || die 'Unable to update event state';
- try {
- $self->reacted(
- OpenILS::Application::Trigger::ModRunner::Reactor
- ->new( $self->event->event_def->reactor, $env )
- ->run
- ->final_result
- );
- } otherwise {
- $log->error("Event reacting failed with ". shift() );
- $self->update_state( 'error' ) || die 'Unable to update event state';
- };
-
- if (defined $self->reacted) {
- $self->update_state( 'reacted' ) || die 'Unable to update event state';
- } else {
- $self->update_state( 'error' ) || die 'Unable to update event state';
- }
- }
- } else {
- $self->{reacted} = undef;
- }
- return $self;
-}
-
-sub validate {
- my $self = shift;
-
- return $self if (defined $self->valid);
-
- if ($self->build_environment->environment->{complete}) {
- $self->update_state( 'validating') || die 'Unable to update event state';
- try {
- $self->valid(
- OpenILS::Application::Trigger::ModRunner::Validator
- ->new( $self->event->event_def->validator, $self->environment )
- ->run
- ->final_result
- );
- } otherwise {
- $log->error("Event validation failed with ". shift() );
- $self->update_state( 'error' ) || die 'Unable to update event state';
- };
-
- if (defined $self->valid) {
- if ($self->valid) {
- $self->update_state( 'valid' ) || die 'Unable to update event state';
- } else {
- $self->update_state( 'invalid' ) || die 'Unable to update event state';
- }
- } else {
- $self->update_state( 'error' ) || die 'Unable to update event state';
- }
- } else {
- $self->{valid} = undef
- }
-
- return $self;
-}
-
-sub cleanedup {
- my $self = shift;
- return undef unless (ref $self);
-
- my $c = shift;
- $self->{cleanedup} = $c if (defined $c);
- return $self->{cleanedup};
-}
-
-sub user_data {
- my $self = shift;
- return undef unless (ref $self);
-
- my $r = shift;
- $self->{user_data} = $r if (defined $r);
- return $self->{user_data};
-}
-
-sub reacted {
- my $self = shift;
- return undef unless (ref $self);
-
- my $r = shift;
- $self->{reacted} = $r if (defined $r);
- return $self->{reacted};
-}
-
-sub valid {
- my $self = shift;
- return undef unless (ref $self);
-
- my $v = shift;
- $self->{valid} = $v if (defined $v);
- return $self->{valid};
-}
-
-sub event {
- my $self = shift;
- return undef unless (ref $self);
-
- my $e = shift;
- $self->{event} = $e if (defined $e);
- return $self->{event};
-}
-
-sub id {
- my $self = shift;
- return undef unless (ref $self);
-
- my $i = shift;
- $self->{id} = $i if (defined $i);
- return $self->{id};
-}
-
-sub environment {
- my $self = shift;
- return undef unless (ref $self);
-
- my $e = shift;
- $self->{environment} = $e if (defined $e);
- return $self->{environment};
-}
-
-sub editor {
- my $self = shift;
- return undef unless (ref $self);
-
- my $e = shift;
- $self->{editor} = $e if (defined $e);
- return $self->{editor};
-}
-
-sub unfind {
- my $self = shift;
- return undef unless (ref $self);
-
- die 'Cannot unfind a reacted event' if (defined $self->reacted);
-
- $self->update_state( 'pending' ) || die 'Unable to update event state';
- $self->{id} = undef;
- $self->{event} = undef;
- $self->{environment} = undef;
- return $self;
-}
-
-sub target {
- my $self = shift;
- return undef unless (ref $self);
-
- my $t = shift;
- $self->{target} = $t if (defined $t);
- return $self->{target};
-}
-
-sub standalone {
- my $self = shift;
- return undef unless (ref $self);
-
- my $t = shift;
- $self->{standalone} = $t if (defined $t);
- return $self->{standalone};
-}
-
-sub update_state {
- my $self = shift;
- return undef unless ($self && ref $self);
-
- my $state = shift;
- return undef unless ($state);
-
- my $fields = shift;
-
- if ($self->standalone) {
- $self->editor->xact_begin || return undef;
- }
-
- my $e = $self->editor->retrieve_action_trigger_event( $self->id );
- if (!$e) {
- $log->error( "Could not retrieve object ".$self->id." for update" ) if (!$e);
- return undef;
- }
-
- if ($fields && ref($fields)) {
- $e->$_($$fields{$_}) for (keys %$fields);
- }
-
- $log->info( "Retrieved object ".$self->id." for update" );
- $e->start_time( 'now' ) unless $e->start_time;
- $e->update_time( 'now' );
- $e->update_process( $$ );
- $e->state( $state );
-
- $e->clear_start_time() if ($e->state eq 'pending');
- $e->complete_time( 'now' ) if ($e->state eq 'complete');
-
- my $ok = $self->editor->update_action_trigger_event( $e );
- if (!$ok) {
- $self->editor->xact_rollback if ($self->standalone);
- $log->error( "Update of event ".$self->id." failed" );
- return undef;
- } else {
- $e = $self->editor->data;
- $e = $self->editor->retrieve_action_trigger_event( $e ) if (!ref($e));
- if (!$e) {
- $log->error( "Update of event ".$self->id." did not return an object" );
- return undef;
- }
- $log->info( "Update of event ".$e->id." suceeded" );
- $ok = $self->editor->xact_commit if ($self->standalone);
- }
-
- if ($ok) {
- $self->event->start_time( $e->start_time );
- $self->event->update_time( $e->update_time );
- $self->event->update_process( $e->update_process );
- $self->event->state( $e->state );
- }
-
- return $ok || undef;
-}
-
-my $current_environment;
-
-sub build_environment {
- my $self = shift;
- return $self if ($self->environment->{complete});
-
- $self->update_state( 'collecting') || die 'Unable to update event state';
-
- try {
-
- my $compartment = new Safe;
- $compartment->permit(':default','require','dofile','caller');
- $compartment->share('$current_environment');
-
- $self->environment->{EventProcessor} = $self;
- $self->environment->{target} = $self->target;
- $self->environment->{event} = $self->event;
- $self->environment->{template} = $self->event->event_def->template;
- $self->environment->{user_data} = $self->user_data;
-
- $current_environment = $self->environment;
-
- $self->environment->{params}{ $_->param } = $compartment->reval($_->value) for ( @{$self->event->event_def->params} );
-
- for my $e ( @{$self->event->event_def->env} ) {
- my (@label, @path);
- @path = split(/\./, $e->path) if ($e->path);
- @label = split(/\./, $e->label) if ($e->label);
-
- $self->_object_by_path( $self->target, $e->collector, \@label, \@path );
- }
-
- if ($self->event->event_def->group_field) {
- my @group_path = split(/\./, $self->event->event_def->group_field);
- pop(@group_path); # the last part is a field, should not get fleshed
- my $group_object = $self->_object_by_path( $self->target, undef, [], \@group_path ) if (@group_path);
- }
-
- $self->environment->{complete} = 1;
- } otherwise {
- $log->error( shift() );
- $self->update_state( 'error' ) || die 'Unable to update event state';
- };
-
- if ($self->environment->{complete}) {
- $self->update_state( 'collected' ) || die 'Unable to update event state';
- } else {
- $self->update_state( 'error' ) || die 'Unable to update event state';
- }
-
- return $self;
-}
-
-sub _fm_class_by_hint {
- my $self = shift;
- my $hint = shift;
-
- my ($class) = grep {
- Fieldmapper->publish_fieldmapper->{$_}->{hint} eq $hint
- } keys %{ Fieldmapper->publish_fieldmapper };
-
- return $class;
-}
-
-my %_object_by_path_cache = ();
-sub ClearObjectCache {
- for my $did ( keys %_object_by_path_cache ) {
- my $phash = $_object_by_path_cache{$did};
- for my $path ( keys %$phash ) {
- my $shash = $$phash{$path};
- for my $step ( keys %$shash ) {
- my $fhash = $$shash{$step};
- for my $ffield ( keys %$fhash ) {
- my $lhash = $$fhash{$ffield};
- for my $lfield ( keys %$lhash ) {
- delete $$lhash{$lfield};
- }
- delete $$fhash{$ffield};
- }
- delete $$shash{$step};
- }
- delete $$phash{$path};
- }
- delete $_object_by_path_cache{$did};
- }
-}
-
-sub _object_by_path {
- my $self = shift;
- my $context = shift;
- my $collector = shift;
- my $label = shift;
- my $path = shift;
- my $ed = shift;
- my $red = shift;
-
- my $outer = 0;
- if (!$ed) {
- $ed = new_editor(xact=>1);
- $outer = 1;
- }
-
- my $step = shift(@$path);
-
- my $fhint = Fieldmapper->publish_fieldmapper->{$context->class_name}{links}{$step}{class};
- my $fclass = $self->_fm_class_by_hint( $fhint );
-
- OpenSRF::EX::ERROR->throw(
- "$step is not a field on ".$context->class_name." Please repair the environment.")
- unless $fhint;
-
- my $ffield = Fieldmapper->publish_fieldmapper->{$context->class_name}{links}{$step}{key};
- my $rtype = Fieldmapper->publish_fieldmapper->{$context->class_name}{links}{$step}{reltype};
-
- my $meth = 'retrieve_';
- my $multi = 0;
- my $lfield = $step;
- if ($rtype ne 'has_a') {
- $meth = 'search_';
- $multi = 1;
- $lfield = $context->Identity;
- }
-
- $meth .= $fclass;
- $meth =~ s/Fieldmapper:://;
- $meth =~ s/::/_/g;
-
- my $obj = $context->$step();
-
- $logger->debug(
- sprintf "_object_by_path(): meth=%s, obj=%s, multi=%s, step=%s, lfield=%s",
- map {defined($_)? $_ : ''} ($meth, $obj, $multi, $step, $lfield)
- );
-
- if (!ref $obj) {
-
- my $lval = $context->$lfield();
-
- if(defined $lval) {
-
- my $def_id = $self->event->event_def->id;
- my $str_path = join('.', @$path);
-
- $obj = $_object_by_path_cache{$def_id}{$str_path}{$step}{$ffield}{$lval} ||
- (
- (grep /cstore/, @{
- Fieldmapper->publish_fieldmapper->{$fclass}{controller}
- }) ? $ed : ($red ||= new_rstore_editor(xact=>1))
- )->$meth( ($multi) ? { $ffield => $lval } : $lval);
-
- $_object_by_path_cache{$def_id}{$str_path}{$step}{$ffield}{$lval} ||= $obj;
- }
- }
-
- if (@$path) {
-
- my $obj_list = [];
- if (!$multi) {
- $obj_list = [$obj] if ($obj);
- } else {
- $obj_list = $obj;
- }
-
- for (@$obj_list) {
- my @path_clone = @$path;
- $self->_object_by_path( $_, $collector, $label, \@path_clone, $ed, $red );
- }
-
- $obj = $$obj_list[0] if (!$multi || $rtype eq 'might_have');
- $context->$step( $obj ) if ($obj && (!$label || !@$label));
-
- } else {
-
- if ($collector) {
- my $obj_list = [$obj] if ($obj && !$multi);
- $obj_list = $obj if ($multi);
-
- my @new_obj_list;
- for my $o ( @$obj_list ) {
- push @new_obj_list,
- OpenILS::Application::Trigger::ModRunner::Collector
- ->new( $collector, $o )
- ->run
- ->final_result
- }
-
- if (!$multi) {
- $obj = $new_obj_list[0];
- } else {
- $obj = \@new_obj_list;
- }
- }
-
- if ($label && @$label) {
- my $node = $self->environment;
- my $i = 0; my $max = scalar(@$label);
- for (; $i < $max; $i++) {
- my $part = $$label[$i];
- $$node{$part} ||= {};
- $node = $$node{$part};
- }
- $$node{$$label[-1]} = $obj;
- } else {
- $obj = $$obj[0] if $rtype eq 'might_have';
- $context->$step( $obj ) if ($obj);
- }
- }
-
- if ($outer) {
- $ed->rollback;
- $red->rollback if $red;
- }
- return $obj;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::EventGroup;
-use strict; use warnings;
-use OpenILS::Application::Trigger::Event;
-use base 'OpenILS::Application::Trigger::Event';
-use OpenSRF::EX qw/:try/;
-
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::Trigger::ModRunner;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub new {
- my $class = shift;
- my @ids = @_;
- $class = ref($class) || $class;
-
- my $editor = new_editor(xact=>1);
-
- my $self = bless {
- environment => {},
- events => [
- map {
- ref($_) ?
- do { $_->standalone(0); $_->editor($editor); $_ } :
- OpenILS::Application::Trigger::Event->new($_, $editor)
- } @ids
- ],
- ids => [ map { ref($_) ? $_->id : $_ } @ids ],
- editor => $editor
- } => $class;
-
-
- $self->editor->xact_commit; # flush out those updates
- $self->editor->xact_begin;
-
- return $self;
-}
-
-sub react {
- my $self = shift;
-
- return $self if (defined $self->reacted);
-
- if ($self->valid) {
- $self->update_state( 'reacting') || die 'Unable to update event group state';
- $self->build_environment;
-
- try {
- $self->reacted(
- OpenILS::Application::Trigger::ModRunner::Reactor
- ->new( $self->event->event_def->reactor, $self->environment )
- ->run
- ->final_result
- );
- } otherwise {
- $log->error("Event reacting failed with ". shift() );
- $self->update_state( 'error' ) || die 'Unable to update event group state';
- };
-
- if (defined $self->reacted) {
- $self->update_state( 'reacted' ) || die 'Unable to update event group state';
- } else {
- $self->update_state( 'error' ) || die 'Unable to update event group state';
- }
- } else {
- $self->{reacted} = undef;
- }
- return $self;
-}
-
-sub validate {
- my $self = shift;
-
- return $self if (defined $self->valid);
-
- $self->update_state( 'validating') || die 'Unable to update event group state';
- $self->editor->xact_begin;
-
- my @valid_events;
- try {
- for my $event ( @{ $self->events } ) {
- $event->validate;
- push @valid_events, $event if ($event->valid);
- }
- $self->valid(1) if (@valid_events);
- $self->{events} = \@valid_events;
- $self->{ids} = [ map { $_->id } @valid_events ];
- $self->editor->xact_commit;
- } otherwise {
- $log->error("Event group validation failed with ". shift() );
- $self->editor->xact_rollback;
- $self->update_state( 'error' ) || die 'Unable to update event group state';
- };
-
- return $self;
-}
-
-sub cleanedup {
- my $self = shift;
- return undef unless (ref $self);
-
- my $c = shift;
- $self->{cleanedup} = $c if (defined $c);
- return $self->{cleanedup};
-}
-
-sub reacted {
- my $self = shift;
- return undef unless (ref $self);
-
- my $r = shift;
- $self->{reacted} = $r if (defined $r);
- return $self->{reacted};
-}
-
-sub valid {
- my $self = shift;
- return undef unless (ref $self);
-
- my $v = shift;
- $self->{valid} = $v if (defined $v);
- return $self->{valid};
-}
-
-sub event {
- my $self = shift;
- return undef unless (ref $self);
-
- return $self->{events}[0]->event;
-}
-
-sub events {
- my $self = shift;
- return undef unless (ref $self);
-
- return $self->{events};
-}
-
-sub ids {
- my $self = shift;
- return undef unless (ref $self);
-
- return $self->{ids};
-}
-
-sub environment {
- my $self = shift;
- return undef unless (ref $self);
-
- my $e = shift;
- $self->{environment} = $e if (defined $e);
- return $self->{environment};
-}
-
-sub editor {
- my $self = shift;
- return undef unless (ref $self);
-
- my $e = shift;
- $self->{editor} = $e if (defined $e);
- return $self->{editor};
-}
-
-sub unfind {
- my $self = shift;
- return undef unless (ref $self);
-
- die 'Cannot unfind a reacted event group' if (defined $self->reacted);
-
- $self->update_state( 'pending' ) || die 'Unable to update event group state';
- $self->{events} = undef;
- return $self;
-}
-
-sub update_state {
- my $self = shift;
- return undef unless ($self && ref $self);
-
- my $state = shift;
- return undef unless ($state);
-
- my $fields = shift;
-
- $self->editor->xact_begin || return undef;
-
- my @oks;
- my $ok;
- my $last_updated;
- for my $event ( @{ $self->events } ) {
- my $e = $self->editor->retrieve_action_trigger_event( $event->id );
- $e->start_time( 'now' ) unless $e->start_time;
- $e->update_time( 'now' );
- $e->update_process( $$ );
- $e->state( $state );
-
- $e->clear_start_time() if ($e->state eq 'pending');
-
- if ($fields && ref($fields)) {
- $e->$_($$fields{$_}) for (keys %$fields);
- }
-
- my $ok = $self->editor->update_action_trigger_event( $e );
- if ($ok) {
- push @oks, $ok;
- $last_updated = $e->id;
- }
- }
-
- if (scalar(@oks) < scalar(@{ $self->ids })) {
- $self->editor->xact_rollback;
- return undef;
- }
-
- my $updated = $self->editor->retrieve_action_trigger_event($last_updated);
- $ok = $self->editor->xact_commit;
-
- if ($ok) {
- for my $event ( @{ $self->events } ) {
- my $e = $event->event;
- $e->start_time( $updated->start_time );
- $e->update_time( $updated->update_time );
- $e->update_process( $updated->update_process );
- $e->state( $updated->state );
- }
- }
-
- return $ok || undef;
-}
-
-sub findEvent {
- my $self = shift;
- my $member = shift;
-
- $member = $member->id if (ref($member));
-
- my @list = grep { $member == $_->id } @{ $self->events };
-
- return shift(@list);
-}
-
-sub build_environment {
- my $self = shift;
- my $env = $self->environment;
-
- $$env{EventProcessor} = $self;
- $$env{target} = [];
- $$env{event} = [];
- $$env{user_data} = [];
- for my $e ( @{ $self->events } ) {
- for my $env_part ( keys %{ $e->environment } ) {
- next if ($env_part eq 'EventProcessor');
- if ($env_part eq 'target') {
- push @{ $$env{target} }, $e->environment->{target};
- } elsif ($env_part eq 'event') {
- push @{ $$env{event} }, $e->environment->{event};
- } elsif ($env_part eq 'user_data') {
- push @{ $$env{user_data} }, $e->environment->{user_data};
- } else {
- $$env{$env_part} = $e->environment->{$env_part};
- }
- }
- }
-
- return $self;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::ModLoader;
-use strict; use warnings;
-use UNIVERSAL::require;
-
-sub prefix { return 'OpenILS::Application::Trigger' }
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $mod = shift;
- return undef unless ($mod);
-
- my $self = bless {
- module => ref $mod ? $mod->module() : $mod,
- handler => 'handler'
- } => $class;
-
- return $self->load;
-}
-
-sub loaded {
- my $self = shift;
- return undef unless (ref $self);
-
- my $l = shift;
- $self->{loaded} = $l if (defined $l);
- return $self->{loaded};
-}
-
-sub handler {
- my $self = shift;
- return undef unless (ref $self);
-
- my $h = shift;
- $self->{handler} = $h if $h;
- return $self->{handler};
-}
-
-sub module {
- my $self = shift;
- return undef unless (ref $self);
-
- my $m = shift;
- $self->{module} = $m if $m;
- return $self->{module};
-}
-
-sub load {
- my $self = shift;
- return undef unless (ref $self);
-
- my $m = shift || $self->module;
- my $h = shift || $self->handler;
- return 1 unless $m;
-
- my $loaded = $m->use;
-
- if (!$loaded) {
- my $builtin_m = $self->prefix . "::$m";
- $loaded = $builtin_m->use;
-
- if (!$loaded) {
- if ($m =~ /::/o) {
- ($h = $m) =~ s/^.+::([^:]+)$/$1/o;
- $m =~ s/^(.+)::[^:]+$/$1/o;
-
- $loaded = $m->use;
-
- if (!$loaded) {
- $h = $self->handler;
- $builtin_m = $self->prefix . "::$m";
- $loaded = $m->use;
-
- $m = $builtin_m if ($loaded);
- }
- } else {
- $loaded = $m->use;
-
- # The following is an escape hatch for builtin dummy handlers
- if (!$loaded) {
- $loaded = $self->prefix->use;
- if ($loaded && $self->prefix->can( $self->module ) ) {
- $m = $self->prefix;
- $h = $self->module;
- }
- }
- }
- } else {
- $m = $builtin_m;
- }
- }
-
- if ($loaded) {
- $self->module( $m );
- $self->handler( $h );
- }
-
- $self->loaded($loaded);
- return $self;
-}
-
-package OpenILS::Application::Trigger::ModRunner;
-use base 'OpenILS::Application::Trigger::ModLoader';
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $m = shift;
- my $e = shift || {};
-
- my $self = $class->SUPER::new( $m );
- return undef unless ($self && $self->loaded);
-
- $self->environment( $e );
- return $self;
-}
-
-sub pass {
- my $old = shift;
- return undef unless (ref $old);
-
- my $class = ref($old);
- my $m = shift;
-
- my $self = $class->SUPER::new( $m );
- return undef unless ($self && $self->loaded);
-
- $self->environment( $old->environment );
- return $self;
-}
-
-sub environment {
- my $self = shift;
- return undef unless (ref $self);
-
- my $e = shift;
- $self->{environment} = $e if (defined $e);
- return $self->{environment};
-}
-
-sub final_result {
- my $self = shift;
- return undef unless (ref $self);
-
- my $r = shift;
- $self->{final_result} = $r if (defined $r);
- return $self->{final_result};
-}
-
-sub run {
- my $self = shift;
- return undef unless (ref $self && $self->loaded);
-
- $self->environment( shift );
-
- my $m = $self->module;
- my $h = $self->handler;
- my $e = $self->environment;
- $self->final_result( $m->$h( $e ) );
-
- return $self;
-};
-
-package OpenILS::Application::Trigger::ModRunner::Collector;
-use base 'OpenILS::Application::Trigger::ModRunner';
-sub prefix { return 'OpenILS::Application::Trigger::Collector' }
-
-package OpenILS::Application::Trigger::ModRunner::Validator;
-use base 'OpenILS::Application::Trigger::ModRunner';
-sub prefix { return 'OpenILS::Application::Trigger::Validator' }
-
-package OpenILS::Application::Trigger::ModRunner::Reactor;
-use base 'OpenILS::Application::Trigger::ModRunner';
-sub prefix { return 'OpenILS::Application::Trigger::Reactor' }
-
-package OpenILS::Application::Trigger::ModRunner::Cleanup;
-use base 'OpenILS::Application::Trigger::ModRunner';
-sub prefix { return 'OpenILS::Application::Trigger::Cleanup' }
-
-package OpenILS::Application::Trigger::ModStackRunner;
-use base 'OpenILS::Application::Trigger::ModRunner';
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- my $m = shift;
- $m = [$m] unless (ref($m) =~ /ARRAY/o);
-
- my $e = shift || {};
-
- my $self = bless {
- runners => []
- } => $class;
-
- for my $mod ( @$m ) {
- my $r = $self->SUPER::new( $m );
- return undef unless ($r && $r->loaded);
- push @{$self->{runners}}, $r;
- }
-
- $self->loaded(1);
-
- return $self;
-}
-
-sub pass {
- my $old = shift;
- return undef unless (ref $old);
-
- my $class = ref($old);
- my $m = shift;
-
- my $self = $class->new( $m );
- return undef unless ($self && $self->loaded);
-
- $self->environment( $old->environment );
- return $self;
-}
-
-sub run {
- my $self = shift;
- return undef unless (ref $self && $self->loaded);
-
- $self->environment( shift );
- my $e = $self->environment;
-
- for my $r (@{$self->{runners}}) {
- my $m = $r->module;
- my $h = $r->handler;
- $r->final_result( $m->$h( $e ) );
- }
-
- return $self;
-};
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor;
-use strict; use warnings;
-use Template;
-use DateTime;
-use DateTime::Format::ISO8601;
-use Unicode::Normalize;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-my $U = 'OpenILS::Application::AppUtils';
-
-sub fourty_two { return 42 }
-sub NOOP_True { return 1 }
-sub NOOP_False { return 0 }
-
-
-
-# helper functions inserted into the TT environment
-my $_TT_helpers = {
-
- # turns a date into something TT can understand
- format_date => sub {
- my $date = shift;
- $date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($date));
- return sprintf(
- "%0.2d:%0.2d:%0.2d %0.2d-%0.2d-%0.4d",
- $date->hour,
- $date->minute,
- $date->second,
- $date->day,
- $date->month,
- $date->year
- );
- },
-
- # escapes a string for inclusion in an XML document. escapes &, <, and > characters
- escape_xml => sub {
- my $str = shift;
- $str =~ s/&/&/sog;
- $str =~ s/</</sog;
- $str =~ s/>/>/sog;
- return $str;
- },
-
- escape_json => sub {
- my $str = shift;
- $str =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
- return $str;
- },
-
- # strip non-ASCII characters after splitting base characters and diacritics
- # least common denominator for EDIFACT messages using the UNOB character set
- force_jedi_unob => sub {
- my $str = shift;
- $str = NFD($str);
- $str =~ s/[\x{0080}-\x{fffd}]//g;
- return $str;
- },
-
- # returns the calculated user locale
- get_user_locale => sub {
- my $user_id = shift;
- return $U->get_user_locale($user_id);
- },
-
- # returns the calculated copy price
- get_copy_price => sub {
- my $copy_id = shift;
- return $U->get_copy_price(new_editor(xact=>1), $copy_id);
- },
-
- # given a copy, returns the title and author in a hash
- get_copy_bib_basics => sub {
- my $copy_id = shift;
- my $copy = new_editor(xact=>1)->retrieve_asset_copy([
- $copy_id,
- {
- flesh => 2,
- flesh_fields => {
- acp => ['call_number'],
- acn => ['record']
- }
- }
- ]);
- if($copy->call_number->id == -1) {
- return {
- title => $copy->dummy_title,
- author => $copy->dummy_author,
- };
- } else {
- my $mvr = $U->record_to_mvr($copy->call_number->record);
- return {
- title => $mvr->title,
- author => $mvr->author
- };
- }
- },
-
- # returns the org unit setting value
- get_org_setting => sub {
- my($org_id, $setting) = @_;
- return $U->ou_ancestor_setting_value($org_id, $setting);
- },
-
- # This basically greps/maps out ths isbn string values, but also promotes the first isbn-13 to the
- # front of the line (so that the EDI translator takes it as primary) if there is one.
- get_li_isbns => sub {
- my $attrs = shift;
- my @isbns;
- my $primary;
- foreach (@$attrs) {
- $_->attr_name eq 'isbn' or next;
- my $val = $_->attr_value;
- if (! $primary and length($val) == 13) {
- $primary = $val;
- } else {
- push @isbns, $val;
- }
- }
- $primary and unshift @isbns, $primary;
- $logger->debug("get_li_isbns returning isbns: " . join(', ', @isbns));
- return @isbns;
- },
-
- # helpers.get_li_attr('isbn_13', li.attributes)
- # returns matching line item attribute, or undef
- get_li_attr => sub {
- my $name = shift or return; # the first arg is always the name
- my ($type, $attr) = (scalar(@_) == 1) ? (undef, $_[0]) : @_;
- # if the next is the last, it's the attributes, otherwise type
- # use Data::Dumper; $logger->warn("get_li_attr: " . Dumper($attr));
- ($name and @$attr) or return;
- my $length;
- $name =~ s/^(\D+)_(\d+)$/$1/ and $length = $2;
- foreach (@$attr) {
- $_->attr_name eq $name or next;
- next if $length and $length != length($_->attr_value);
- return $_->attr_value if (! $type) or $type eq $_->attr_type;
- }
- return;
- },
-};
-
-
-# processes templates. Returns template output on success, undef on error
-sub run_TT {
- my $self = shift;
- my $env = shift;
- my $nostore = shift;
- return undef unless $env->{template};
-
- my $error;
- my $output = '';
- my $tt = Template->new;
- # my $tt = Template->new(ENCODING => 'utf8'); # ??
- $env->{helpers} = $_TT_helpers;
-
- unless( $tt->process(\$env->{template}, $env, \$output) ) {
- $output = undef;
- ($error = $tt->error) =~ s/\n/ /og;
- $logger->error("Error processing Trigger template: $error");
- }
-
- if ( $error or (!$nostore && $output) ) {
- my $t_o = Fieldmapper::action_trigger::event_output->new;
- $t_o->data( ($error) ? $error : $output );
- $t_o->is_error( ($error) ? 't' : 'f' );
- $logger->info("trigger: writing " . length($t_o->data) . " bytes to template output");
-
- $env->{EventProcessor}->editor->xact_begin;
- $t_o = $env->{EventProcessor}->editor->create_action_trigger_event_output( $t_o );
-
- my $state = (ref $$env{event} eq 'ARRAY') ? $$env{event}->[0]->state : $env->{event}->state;
- my $key = ($error) ? 'error_output' : 'template_output';
- $env->{EventProcessor}->update_state( $state, { $key => $t_o->id } );
- }
-
- return $output;
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::ApplyCircFee;
-use base 'OpenILS::Application::Trigger::Reactor';
-use strict; use warnings;
-use Error qw/:try/;
-use OpenILS::Const qw/:const/;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-
-
-sub ABOUT {
- return <<ABOUT;
-
- Creates a bill (money.billing) for the configured amount, linked to the circulation.
- This reactor uses the Notification Fee billing type.
- If an event definition template is defined, it will be used to generate the bill note.
-
- Required event parameters:
- "amount" The amount to bill
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
-
- my $e = new_editor(xact => 1);
- my $btype = $e->retrieve_config_billing_type(OILS_BILLING_TYPE_NOTIFICATION_FEE);
-
- my $circ = $$env{target};
- my $amount = $$env{params}{amount} || $btype->default_price;
-
- unless($amount) {
- $logger->error("ApplyCircFee needs a fee amount");
- $e->rollback;
- return 0;
- }
-
- my $bill = Fieldmapper::money::billing->new;
- $bill->xact($circ->id);
- $bill->amount($amount);
- $bill->btype(OILS_BILLING_TYPE_NOTIFICATION_FEE);
- $bill->billing_type($btype->name);
- $bill->note($self->run_TT($env));
-
- unless( $e->create_money_billing($bill) ) {
- $e->rollback;
- return 0;
- }
-
- $e->commit;
- return 1;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::ApplyPatronPenalty;
-use base 'OpenILS::Application::Trigger::Reactor';
-use strict; use warnings;
-use Error qw/:try/;
-use OpenILS::Const qw/:const/;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::AppUtils;
-my $U = "OpenILS::Application::AppUtils";
-
-
-sub ABOUT {
- return <<ABOUT;
-
- Applies a standing penalty to a patron. If there is a template, the template is
- used as the value for the note
-
- Required named (with labels) environment variables:
- "user" -- User object fleshed into the environment
- "context_org" -- Org unit object fleshed into the environment
-
- Note: Using named env variables with a grouped event definition where the
- env vars may be different depending on the target produces undefined behavior.
- Don't use this reactor if more than one User or Org Unit object may be
- referenced accross the set of target objects.
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
-
- my $pname = $$env{params}{standing_penalty};
- my $user = $$env{environment}{user};
- my $context_org = $$env{environment}{context_org};
-
- unless($pname and ref $user and ref $context_org) {
- $logger->error("ApplyPatronPenalty: missing parameters");
- return 0;
- }
-
- my $e = new_editor(xact => 1);
-
- my $ptype = $e->search_config_standing_penalty({name => $pname})->[0];
-
- unless($ptype) {
- $logger->error("ApplyPatronPenalty: invalid penalty name '$pname'");
- $e->rollback;
- return 0;
- }
-
- $context_org = (defined $ptype->org_depth) ?
- $U->org_unit_ancestor_at_depth($context_org->id, $ptype->org_depth) :
- $context_org->id;
-
- # apply the penalty
- my $penalty = Fieldmapper::actor::usr_standing_penalty->new;
- $penalty->usr($user->id);
- $penalty->org_unit($context_org);
- $penalty->standing_penalty($ptype->id);
- $penalty->note($self->run_TT($env));
-
- unless($e->create_actor_user_standing_penalty($penalty)) {
- $e->rollback;
- return 0;
- }
-
- $e->commit;
- return 1;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::AstCall;
-use base 'OpenILS::Application::Trigger::Reactor';
-use OpenSRF::Utils::Logger qw($logger);
-# use OpenILS::Application::AppUtils;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-
-use strict; use warnings;
-use Error qw/:try/;
-use Data::Dumper;
-
-use OpenSRF::Utils::SettingsClient;
-use RPC::XML::Client;
-$Data::Dumper::Indent = 0;
-
-my $U = 'OpenILS::Application::AppUtils';
-
-my $e = new_editor(xact => 1);
-
-# $last_channel_used is:
-# ~ index (not literal value) of last channel used in a callfile
-# ~ index is of position in @channels (zero-based)
-# ~ cached at package level
-# ~ typically for Zap (PSTN), not VOIP
-
-our @channels;
-our $last_channel_used = 0;
-our $telephony;
-
-sub ABOUT {
- return <<ABOUT;
-
- The AstCall reactor module creates a callfile for Asterisk, given a
- template describing the message and an environment defining
- necessary information for contacting the Asterisk server and scheduling
- a call with it.
-
-ABOUT
-}
-
-sub get_conf {
- # $logger->info(__PACKAGE__ . ": get_conf()");
- $telephony and return $telephony;
- my $config = OpenSRF::Utils::SettingsClient->new;
- # config object cached by package
- $telephony = $config->config_value('notifications', 'telephony');
- return $telephony;
-}
-
-sub get_channels {
- @channels and return @channels;
- my $config = get_conf(); # populated $telephony object
- @channels = @{ $config->{channels} };
- return @channels;
-}
-
-sub next_channel {
- # Increments $last_channel_used, or resets it to zero, as necessary.
- # Returns appropriate value from channels array.
- my @chans = get_channels();
- unless(@chans) {
- $logger->error(__PACKAGE__ . ": Cannot build call using " .
- (shift ||'driver') .
- ", no notifications.telephony.channels found in config!");
- return;
- }
- if (++$last_channel_used > $#chans) {
- $last_channel_used = 0;
- }
- return $chans[$last_channel_used]; # say, 'Zap/1' or 'Zap/12'
-}
-
-sub channel {
- my $tech = get_conf()->{driver} || 'SIP';
- if ($tech !~ /^SIP/) {
- return next_channel($tech);
- }
- return $tech; # say, 'SIP' or 'SIP/ubab33'
-}
-
-sub get_extra_lines {
- my $lines = get_conf()->{callfile_lines} or return '';
- my @fixed;
- foreach (split "\n", $lines) {
- s/^\s*//g; # strip leading spaces
- /\S/ or next; # skip empty lines
- push @fixed, $_;
- }
- (scalar @fixed) or return '';
- return join("\n", @fixed) . "\n";
-}
-
-sub host_string {
- my $conf = get_conf();
- my $host = $conf->{host};
- unless ($host) {
- $logger->error(__PACKAGE__ . ": No telephony/host in config.");
- return;
- }
-
- # prepend http:// if no protocol specified
- $host =~ /^\S+:\/\// or $host = 'http://' . $host;
- # append port number if specified
- $conf->{port} and $host .= ":" . $conf->{port};
-
- return $host;
-}
-sub rpc_client {
- # TODO: caching? (would take testing to ensure memory and
- # connections are clean/stable)
- my $host = (@_ ? shift : host_string()) or return;
- return new RPC::XML::Client($host);
-}
-
-sub handler {
- my ($self, $env) = @_;
-
- $logger->info(__PACKAGE__ . ": entered handler");
-
- # assignment, not comparison
- unless ($env->{channel_prefix} = channel()) {
- $logger->error(__PACKAGE__ . ": Cannot find tech/resource in config");
- return 0;
- }
-
- $env->{extra_lines} = get_extra_lines() || '';
- my $tmpl_output = $self->run_TT($env);
- if (not $tmpl_output) {
- $logger->error(__PACKAGE__ . ": no template input");
- return 0;
- }
-
- my @eventids = map {$_->id} @{$env->{event}};
- @eventids or push @eventids, '';
-
- my $eo = Fieldmapper::action_trigger::event_output->new;
-
- # XXX we have to actually create this in the DB now if we expect to use the
- # ID later
- $eo->data("");
- $eo = $e->create_action_trigger_event_output($eo) or return $e->die_event;
- if ($env->{"extra_lines"}) {
- $tmpl_output .= ";; added by handler:\n";
- $tmpl_output .= $env->{"extra_lines"};
- }
-
- # or would we prefer distinct lines instead of comma-separated?
- $tmpl_output .= "; event_ids = " . join(",",@eventids) . "\n";
- $tmpl_output .= "; event_output = " . $eo->id . "\n";
-
- #my $filename_fragment = $userid . '_' . $eventids[0] . 'uniq' . time;
- # not $noticetype,
- # the event_output.id tells us all we need to know
- # XXX why is id in here twice?
- my $filename_fragment = $eo->id . '_' . $eo->id;
-
- # TODO: add scheduling intelligence and use it here... or not if
- # relying only on crontab
- my $client = rpc_client();
- my $resp = $client->send_request(
- 'inject', $tmpl_output, $filename_fragment, 0
- ); # FIXME: 0 could be seconds-from-epoch UTC if deferred call needed
-
- $logger->debug(
- ref $resp ? ("Response: " . Dumper($resp->value)) : "Error: $resp"
- );
-
- if ($resp->{code} and $resp->{code}->value == 200) {
- $eo->is_error('f');
- $eo->data('filename: ' . $resp->{spooled_filename}->value);
- # could look for the file that replaced it
- } else {
- $eo->is_error('t');
- my $msg = $resp->{faultcode} ? $resp->{faultcode}->value :
- $resp->{ code} ? $resp->{ code}->value :
- " -- UNKNOWN response '$resp'";
- $msg .= " for $filename_fragment";
- $eo->data("Error " . $msg);
- $logger->error(__PACKAGE__ . ": Mediator Error " . $msg);
- }
-
- # Now point all our events' async_output to the newly made row
-# $eo = $env->{EventProcessor}->editor->
-# create_action_trigger_event_output( $eo );
- $e->update_action_trigger_event_output($eo) or return $e->die_event;
- foreach (@eventids) {
- my $event = $e->retrieve_action_trigger_event($_);
- $event->async_output($eo->id);
- $e->update_action_trigger_event($event);
- }
- $e->commit; # defer till after loop?
-
- # TODO: a sub for saving async_output might belong in Trigger.pm
- 1;
-}
-
-sub _files {
- my $response = shift or return;
- return map {$response->{$_}} sort grep {/^file_\d*/} keys %$response;
-}
-
-=head1 EXAMPLE CALFILES
-
-Note: all lines start flush left (no leading whitespace)
-
-=head2 Example callfile (successful)
-
- Channel: SIP/ubab33/17707775555
- Context: overdue-test
- MaxRetries: 1
- RetryTime: 60
- WaitTime: 30
- Extension: 10
- Archive: 1
- Set: items=1
- Set: titlestring=chez nos gens;; added by OpenILS::Application::Trigger::Reactor::AstCall handler:
- ; event_ids = 123,145
- ; event_output = 14;; added by inject() in the mediator
- Set: callfilename=EG_1258060382_6.call
-
- StartRetry: 2139 1 (1258060442)
- Status: Completed
- Channel: SIP/ubab33/17707775555
-
-=head2 Example callfile (FAILED)
-
- CallerID: "Jack Jackson" <17707775555>
- Context: overdue-test
- MaxRetries: 1
- RetryTime: 60
- WaitTime: 30
- Extension: 10
- Archive: 1
- Set: items=1
- Set: titlestring=Land Before Time;; added by OpenILS::Application::Trigger::Reactor::AstCall handler:
- Set: LOOP=1
- Set: callfilename=EG_joe_20091109145355.call
-
- StartRetry: 2139 1 (1257907526)
- ; FAILED: 0
-
- EndRetry: 2139 1 (1257907496)
-
- StartRetry: 2139 2 (1257907617)
- ; FAILED: 0
- Status: Expired
-
-=head2 Possible data structure:
-
- $feedback = {
- status => val,
- attempts => [ $attempt1, $attempt2 ... $attemptN ],
- anything_else => scalar,
- }
- ...
- $attempt = {
- time => secs from epoch (UTC) for the BEGINNING of the call,
- duration => secs,
- failed => code,
- }
-
-=cut
-
-sub feedback_hash {
- # parses the done callfile comments from Mediator
- # return ref to hash
- my $content = shift or return;
- my %hash = ();
- # my @attempts = ();
- my @lines = split "\n", $content;
- foreach (shift @lines) {
- s/^\s*(Set:\s*)?//i; # strip leading whitespace, and possible "Set:"
- if (/^StartRetry: \d+ (\d+) \((\d+)\)/) {
- # go parse an attempt;
- # go record an attempt;
- }
- if (/^(Status):\s*(\S+)/i or /^;+\s*(FAILED):\s*(\S*)/i) {
- $hash{lc $1} = $2;
- next;
- }
-
- /^;+\s*(\S+)\s*[=:]\s*([^;]*)$/ and $hash{lc $1} = $2;
- }
- if (exists $hash{failed}) {
- $hash{failcode} = $hash{failed};
- # b/c "0" is a common failcode and we want a more binary indicator
- $hash{failed} = 1;
- }
- return \%hash;
-}
-
-sub cleanup {
- my $self = shift or return;
- my $files = join(',',@_) or return;
- my $client = rpc_client();
- return $client->send_request('cleanup', $files);
- # TODO: more error checking
-}
-
-sub retrieve {
- my $self = shift or return;
- my $client = rpc_client();
- my $resp = $client->send_request('retrieve');
- unless ($resp and ref $resp) {
- $logger->error(
- __PACKAGE__ . ": Mediator Error: " .
- ($resp ? 'Bad' : 'No') . " response to retrieve request"
- );
- return;
- }
-
- # my $count = $resp{match_count}; # how many files we should have
- # my @rm_list = ();
- my @files = _files($resp);
- foreach (@files) {
- my $content = $resp->{$_}->content;
- my $filename = $resp->{$_}->filename;
- unless ($content) {
- $logger->error(__PACKAGE__ .
- ": Mediator sent incomplete/unintelligible message for " .
- "filename " . ($filename || 'UNKNOWN'));
- next;
- }
- my $feedback = feedback_hash($content);
- my $output = $e->retrieve_action_trigger_event_output(
- $feedback->{event_output}
- );
- if ($content == $output->data) {
- $logger->error(
- __PACKAGE__ . ": Mediator sent duplicate file "
- . $resp->{$_}->filename . " for event_output " .
- $feedback->{event_output}
- );
- } else {
- $output->data($content);
- }
- $e->commit; # defer until after loop? probably not
- my $clean = $client->send_request('cleanup', $filename);
- # TODO: deletion by (comma-separated) filenames in chunks
- # instead of individually?
- # push @rm_list, $_; $client->send_request('cleanup', join(',',@rm_list));
- unless ($clean and ref $clean) {
- $logger->error(
- __PACKAGE__ . ": Mediator Error: " .
- ($clean ? 'Bad' : 'No') .
- " response to cleanup $filename request");
- next;
- }
- unless ($clean->{code}->value == 200 and $clean->{delete_count}) {
- $logger->error(__PACKAGE__ . ": cleanup $filename returned " . (
- $resp->{faultcode} ? $resp->{faultcode}->value :
- $resp->{ code} ? $resp->{ code}->value :
- " -- UNKNOWN response '$resp'"
- ) . " with delete_count " .
- (defined $clean->{delete_count} ? $clean->{delete_count} : 'UNDEF'));
- }
- }
- return @files;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::GeneratePurchaseOrderJEDI;
-use base 'OpenILS::Application::Trigger::Reactor';
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/:logger/;
-
-sub ABOUT {
- return <<ABOUT;
-
-Generates PO JEDI (JSON EDI) output for subsequent processing and EDI delivery
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
- return 1 if $self->run_TT($env);
- return 0;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::MarkItemLost;
-use base 'OpenILS::Application::Trigger::Reactor';
-use strict; use warnings;
-use Error qw/:try/;
-use Data::Dumper;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-use OpenILS::Application::Cat::AssetCommon;
-$Data::Dumper::Indent = 0;
-
-
-sub ABOUT {
- return <<ABOUT;
-
- Marks circulation and corresponding item as lost. This uses
- the standard mark-lost functionality, creating billings where appropriate.
-
- Required event parameters:
- "editor" which points to a user ID. This is the user that effectively
- performs the action. For example, when the copy status is updated,
- this user is entered as the last editor of the copy.
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
- my $e = new_editor(xact => 1);
- $e->requestor($e->retrieve_actor_user($$env{params}{editor}));
-
- my $circ = $$env{target};
- my $evt = OpenILS::Application::Cat::AssetCommon->set_item_lost($e, $circ->target_copy);
- if($evt) {
- $logger->error("trigger: MarkItemLost failed with event ".$evt->{textcode});
- return 0;
- }
-
- $e->commit;
-
- my $ses = OpenSRF::AppSession->create('open-ils.trigger');
- $ses->request('open-ils.trigger.event.autocreate', 'lost.auto', $circ, $circ->circ_lib);
-
- return 1;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::ProcessTemplate;
-use base 'OpenILS::Application::Trigger::Reactor';
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/:logger/;
-
-sub ABOUT {
- return <<ABOUT;
-
-The ProcessTemplate Reactor Module simply processes the configured template.
-The output, like all processed templates, is stored in the event_output table.
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
- return 1 if $self->run_TT($env);
- return 0;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::SendEmail;
-use strict; use warnings;
-use Error qw/:try/;
-use Data::Dumper;
-use Email::Send;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::Trigger::Reactor;
-use OpenSRF::Utils::Logger qw/:logger/;
-use utf8;
-$Data::Dumper::Indent = 0;
-
-use base 'OpenILS::Application::Trigger::Reactor';
-
-my $log = 'OpenSRF::Utils::Logger';
-
-sub ABOUT {
- return <<ABOUT;
-
-The SendEmail Reactor Module attempts to email out, via Email::Send,
-whatever is constructed by the template passed in from the Event Definition.
-
-The SMTP server specified by the /opensrf/default/email_notify/smtp_server
-setting is used to send the email, and the value at
-/opensrf/default/email_notify/sender_address is passed into the template as
-the 'default_sender' variable.
-
-No default template is assumed, and all information other than the
-default_sender that the system provides is expected to be gathered by the
-Event Definition through either Environment or Parameter definitions.
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $smtp = $conf->config_value('email_notify', 'smtp_server');
- $$env{default_sender} = $conf->config_value('email_notify', 'sender_address');
-
- my $text = $self->run_TT($env);
- return 0 if (!$text);
-
- my $sender = Email::Send->new({mailer => 'SMTP'});
- $sender->mailer_args([Host => $smtp]);
-
- my $stat;
- my $err;
-
- utf8::encode($text); # prevent "Wide character" errors in Email::Send
-
- try {
- $stat = $sender->send($text);
- } catch Error with {
- $err = $stat = shift;
- $logger->error("SendEmail Reactor: Email failed with error: $err");
- };
-
- if( !$err and $stat and $stat->type eq 'success' ) {
- $logger->info("SendEmail Reactor: successfully sent email");
- return 1;
- } else {
- $logger->warn("SendEmail Reactor: unable to send email: ".Dumper($stat));
- $text =~ s/\n//og;
- $logger->warn("SendEmail Reactor: failed email template: $text");
- return 0;
- }
-
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::SendFile;
-use OpenILS::Application::Trigger::Reactor;
-use base 'OpenILS::Application::Trigger::Reactor';
-
-# use OpenSRF::Utils::SettingsClient;
-use OpenILS::Utils::RemoteAccount;
-
-use strict;
-use warnings;
-
-sub ABOUT {
- return <<ABOUT;
-
-The SendFile Reactor Module attempts to transfer a file to a remote server via
-SCP, FTP or SFTP.
-
-No default template is assumed, and all information is expected to be gathered
-by the Event Definition through event parameters:
- ~ remote_host (required)
- ~ remote_user
- ~ remote_password
- ~ remote_account
- ~ remote_filename
- ~ ssh_privatekey
- ~ ssh_publickey
- ~ type (FTP, SFTP or SCP -- default FTP)
- ~ port
- ~ debug
-
-The processed template is passed as "content" with the other params to
-OpenILS::Utils::RemoteAccount. See perldoc OpenILS::Utils::RemoteAccount for more.
-
-TODO: allow config.remote_account.id to specify options.
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
- my $params = $env->{params};
-
- $params->{content} = $self->run_TT($env) or return;
- my $connection = OpenILS::Utils::RemoteAccount->new(%$params) or return;
- return $connection->put;
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Trigger::Reactor::StaticEmail;
-use strict; use warnings;
-use Error qw/:try/;
-use Data::Dumper;
-use Email::Send;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::Trigger::Reactor;
-use OpenSRF::Utils::Logger qw/:logger/;
-
-use base 'OpenILS::Application::Trigger::Reactor';
-
-my $log = 'OpenSRF::Utils::Logger';
-
-my $default_template = <<TT;
-To: [%- params.recipient %]
-From: [%- params.sender %]
-Subject: [%- params.subject %]
-
-[% params.body %]
-TT
-
-sub ABOUT {
- return <<ABOUT;
-
-The StagicEmail Reactor Module sends an email to the address specified by the
-"recipient" parameter. This is the only required parameter (in fact the
-template is not even required), though sender, subject and body parameters are
-also accepted and used by the default template.
-
-The default template looks like:
--------
-$default_template
--------
-
-ABOUT
-}
-
-sub handler {
- my $self = shift;
- my $env = shift;
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $smtp = $conf->config_value('email_notify', 'smtp_server');
- $$env{params}{sender} ||= $conf->config_value('email_notify', 'sender_address');
- $$env{params}{subject} ||= 'Test subject -- StaticEmail Reactor';
- $$env{params}{body} ||= 'Test body -- StaticEmail Reactor';
- $$env{template} ||= $default_template;
-
- $$env{params}{recipient} or return 0;
-
- my $text = $self->run_TT($env);
- return 0 if (!$text);
-
- $logger->info("StaticEmail Reactor: sending email to ".
- $$env{params}{recipient}." via SMTP server $smtp");
-
- my $sender = Email::Send->new({mailer => 'SMTP'});
- $sender->mailer_args([Host => $smtp]);
-
-
- my $stat;
- my $err;
-
- try {
- $stat = $sender->send($text);
- } catch Error with {
- $err = $stat = shift;
- $logger->error("StaticEmail Reactor: Email failed with error: $err");
- };
-
- if( !$err and $stat and $stat->type eq 'success' ) {
- $logger->info("StaticEmail Reactor: successfully sent email");
- return 1;
- } else {
- $logger->warn("StaticEmail Reactor: unable to send email: ".Dumper($stat));
- return 0;
- }
-
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Application::Trigger::Validator;
-use strict; use warnings;
-use DateTime;
-use DateTime::Format::ISO8601;
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Const qw/:const/;
-sub fourty_two { return 42 }
-sub NOOP_True { return 1 }
-sub NOOP_False { return 0 }
-
-sub CircIsOpen {
- my $self = shift;
- my $env = shift;
-
- return 0 if (defined($env->{target}->checkin_time));
-
- if ($env->{params}->{min_target_age}) {
- $env->{params}->{target_age_field} = 'xact_start';
- return 0 if (!$self->MinPassiveTargetAge($env));
- }
-
- return 1;
-}
-
-sub MinPassiveTargetAge {
- my $self = shift;
- my $env = shift;
- my $target = $env->{target};
- my $delay_field = $env->{params}->{target_age_field} || $env->{event}->event_def->delay_field;
-
- unless($env->{params}->{min_target_age}) {
- $logger->warn("'min_target_age' parameter required for MinPassiveTargetAge validator");
- return 0; # no-op false
- }
-
- unless($delay_field) {
- $logger->warn("'target_age_field' parameter or delay_field required for MinPassiveTargetAge validator");
- return 0; # no-op false
- }
-
- my $delay_field_ts = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($target->$delay_field()));
-
- # to get the minimum time that the target must have aged to, add the min age to the delay field
- $delay_field_ts->add( seconds => interval_to_seconds( $env->{params}->{min_target_age} ) );
-
- return 1 if $delay_field_ts <= DateTime->now;
- return 0;
-}
-
-sub CircIsOverdue {
- my $self = shift;
- my $env = shift;
- my $circ = $env->{target};
-
- return 0 if $circ->checkin_time;
- return 0 if $circ->stop_fines and not $circ->stop_fines =~ /MAXFINES|LONGOVERDUE/;
-
- if ($env->{params}->{min_target_age}) {
- $env->{params}->{target_age_field} = 'xact_start';
- return 0 if (!$self->MinPassiveTargetAge($env));
- }
-
- my $due_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($circ->due_date));
- return 0 if $due_date > DateTime->now;
-
- return 1;
-}
-
-sub HoldIsAvailable {
- my $self = shift;
- my $env = shift;
-
- my $hold = $env->{target};
-
- return 1 if
- !$hold->cancel_time and
- $hold->capture_time and
- $hold->current_copy and
- $hold->current_copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF;
-
- return 0;
-}
-
-sub HoldIsCancelled {
- my $self = shift;
- my $env = shift;
-
- my $hold = $env->{target};
-
- return ($hold->cancel_time) ? 1 : 0;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Validator::Acq;
-use strict; use warnings;
-# use OpenSRF::Utils::Logger qw/:logger/;
-
-sub get_lineitem_from_req {
- my($self, $env) = @_;
- my $req = $env->{target};
- return (ref $env->{target}->lineitem) ?
- $env->{target}->lineitem :
- $self->editor->retrieve_acq_lineitem($$env->{target}->lineitem);
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Validator::Acq::PurchaseOrderEDIRequired;
-use strict; use warnings;
-# use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Utils::CStoreEditor qw/ new_editor /;
-use OpenILS::Application::AppUtils;
-my $U = 'OpenILS::Application::AppUtils';
-
-sub handler {
- my $self = shift;
- my $env = shift;
- my $po = $env->{target};
-
- my $provider =
- ref($po->provider) ?
- $po->provider :
- new_editor->retrieve_acq_provider($po->provider);
-
- return 1 if
- ($po->state eq 'on-order' or
- $po->state eq 'retry' ) and
- $provider and
- $provider->edi_default and
- $U->is_true($provider->active);
-
- return 0;
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Validator::Acq::UserRequestCancelled;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Application::Trigger::Validator::Acq;
-
-sub handler {
- my $self = shift;
- my $env = shift;
- return OpenILS::Application::Trigger::Validator::Acq::get_lineitem_from_req($self, $env)->state eq 'cancelled';
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Validator::Acq::UserRequestOrdered;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Application::Trigger::Validator::Acq;
-
-sub handler {
- my $self = shift;
- my $env = shift;
- return OpenILS::Application::Trigger::Validator::Acq::get_lineitem_from_req($self, $env)->state eq 'on-order';
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Trigger::Validator::Acq::UserRequestReceived;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/:logger/;
-use OpenILS::Application::Trigger::Validator::Acq;
-
-sub handler {
- my $self = shift;
- my $env = shift;
- return OpenILS::Application::Trigger::Validator::Acq::get_lineitem_from_req($self, $env)->state eq 'received';
-}
-
-1;
+++ /dev/null
-package OpenILS::Application::Vandelay;
-use strict; use warnings;
-use OpenILS::Application;
-use base qw/OpenILS::Application/;
-use Unicode::Normalize;
-use OpenSRF::EX qw/:try/;
-use OpenSRF::AppSession;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Cache;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use MARC::Batch;
-use MARC::Record;
-use MARC::File::XML;
-use OpenILS::Utils::Fieldmapper;
-use Time::HiRes qw(time);
-use OpenSRF::Utils::Logger qw/$logger/;
-use MIME::Base64;
-use OpenILS::Const qw/:const/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Cat::BibCommon;
-use OpenILS::Application::Cat::AuthCommon;
-use OpenILS::Application::Cat::AssetCommon;
-my $U = 'OpenILS::Application::AppUtils';
-
-# A list of LDR/06 values from http://loc.gov/marc
-my %record_types = (
- a => 'bib',
- c => 'bib',
- d => 'bib',
- e => 'bib',
- f => 'bib',
- g => 'bib',
- i => 'bib',
- j => 'bib',
- k => 'bib',
- m => 'bib',
- o => 'bib',
- p => 'bib',
- r => 'bib',
- t => 'bib',
- u => 'holdings',
- v => 'holdings',
- x => 'holdings',
- y => 'holdings',
- z => 'auth',
- ' ' => 'bib',
-);
-
-sub initialize {}
-sub child_init {}
-
-# --------------------------------------------------------------------------------
-# Biblio ingest
-
-sub create_bib_queue {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $name = shift;
- my $owner = shift;
- my $type = shift;
- my $import_def = shift;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
-
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_BIB_IMPORT_QUEUE');
- $owner ||= $e->requestor->id;
-
- if ($e->search_vandelay_bib_queue( {name => $name, owner => $owner, queue_type => $type})->[0]) {
- $e->rollback;
- return OpenILS::Event->new('BIB_QUEUE_EXISTS')
- }
-
- my $queue = new Fieldmapper::vandelay::bib_queue();
- $queue->name( $name );
- $queue->owner( $owner );
- $queue->queue_type( $type ) if ($type);
- $queue->item_attr_def( $import_def ) if ($import_def);
-
- my $new_q = $e->create_vandelay_bib_queue( $queue );
- return $e->die_event unless ($new_q);
- $e->commit;
-
- return $new_q;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.create",
- method => "create_bib_queue",
- api_level => 1,
- argc => 4,
-);
-
-
-sub create_auth_queue {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $name = shift;
- my $owner = shift;
- my $type = shift;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
-
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE');
- $owner ||= $e->requestor->id;
-
- if ($e->search_vandelay_bib_queue({name => $name, owner => $owner, queue_type => $type})->[0]) {
- $e->rollback;
- return OpenILS::Event->new('AUTH_QUEUE_EXISTS')
- }
-
- my $queue = new Fieldmapper::vandelay::authority_queue();
- $queue->name( $name );
- $queue->owner( $owner );
- $queue->queue_type( $type ) if ($type);
-
- my $new_q = $e->create_vandelay_authority_queue( $queue );
- $e->die_event unless ($new_q);
- $e->commit;
-
- return $new_q;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.authority_queue.create",
- method => "create_auth_queue",
- api_level => 1,
- argc => 3,
-);
-
-sub add_record_to_bib_queue {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $queue = shift;
- my $marc = shift;
- my $purpose = shift;
- my $bib_source = shift;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
-
- $queue = $e->retrieve_vandelay_bib_queue($queue);
-
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless
- ($e->allowed('CREATE_BIB_IMPORT_QUEUE', undef, $queue) ||
- $e->allowed('CREATE_BIB_IMPORT_QUEUE'));
-
- my $new_rec = _add_bib_rec($e, $marc, $queue->id, $purpose, $bib_source);
-
- return $e->die_event unless ($new_rec);
- $e->commit;
- return $new_rec;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.queued_bib_record.create",
- method => "add_record_to_bib_queue",
- api_level => 1,
- argc => 3,
-);
-
-sub _add_bib_rec {
- my $e = shift;
- my $marc = shift;
- my $queue = shift;
- my $purpose = shift;
- my $bib_source = shift;
-
- my $rec = new Fieldmapper::vandelay::queued_bib_record();
- $rec->marc( $marc );
- $rec->queue( $queue );
- $rec->purpose( $purpose ) if ($purpose);
- $rec->bib_source($bib_source);
-
- return $e->create_vandelay_queued_bib_record( $rec );
-}
-
-sub add_record_to_authority_queue {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $queue = shift;
- my $marc = shift;
- my $purpose = shift;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
-
- $queue = $e->retrieve_vandelay_authority_queue($queue);
-
- return $e->die_event unless $e->checkauth;
- return $e->die_event unless
- ($e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE', undef, $queue) ||
- $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE'));
-
- my $new_rec = _add_auth_rec($e, $marc, $queue->id, $purpose);
-
- return $e->die_event unless ($new_rec);
- $e->commit;
- return $new_rec;
-}
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.queued_authority_record.create",
- method => "add_record_to_authority_queue",
- api_level => 1,
- argc => 3,
-);
-
-sub _add_auth_rec {
- my $e = shift;
- my $marc = shift;
- my $queue = shift;
- my $purpose = shift;
-
- my $rec = new Fieldmapper::vandelay::queued_authority_record();
- $rec->marc( $marc );
- $rec->queue( $queue );
- $rec->purpose( $purpose ) if ($purpose);
-
- return $e->create_vandelay_queued_authority_record( $rec );
-}
-
-sub process_spool {
- my $self = shift;
- my $client = shift;
- my $auth = shift;
- my $fingerprint = shift || '';
- my $queue_id = shift;
- my $purpose = shift;
- my $filename = shift;
- my $bib_source = shift;
-
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
-
- my $queue;
- my $type = $self->{record_type};
-
- if($type eq 'bib') {
- $queue = $e->retrieve_vandelay_bib_queue($queue_id) or return $e->die_event;
- } else {
- $queue = $e->retrieve_vandelay_authority_queue($queue_id) or return $e->die_event;
- }
-
- my $evt = check_queue_perms($e, $type, $queue);
- return $evt if ($evt);
-
- my $cache = new OpenSRF::Utils::Cache();
-
- if($fingerprint) {
- my $data = $cache->get_cache('vandelay_import_spool_' . $fingerprint);
- $purpose = $data->{purpose};
- $filename = $data->{path};
- $bib_source = $data->{bib_source};
- }
-
- unless(-r $filename) {
- $logger->error("unable to read MARC file $filename");
- return -1; # make this an event XXX
- }
-
- $logger->info("vandelay spooling $fingerprint purpose=$purpose file=$filename");
-
- my $marctype = 'USMARC';
-
- open F, $filename;
- $marctype = 'XML' if (getc(F) =~ /^\D/o);
- close F;
-
- my $batch = new MARC::Batch ($marctype, $filename);
- $batch->strict_off;
-
- my $response_scale = 10;
- my $count = 0;
- my $r = -1;
- while (try { $r = $batch->next } otherwise { $r = -1 }) {
- if ($r == -1) {
- $logger->warn("Processing of record $count in set $filename failed. Skipping this record");
- $count++;
- }
-
- $logger->info("processing record $count");
-
- try {
- (my $xml = $r->as_xml_record()) =~ s/\n//sog;
- $xml =~ s/^<\?xml.+\?\s*>//go;
- $xml =~ s/>\s+</></go;
- $xml =~ s/\p{Cc}//go;
- $xml = $U->entityize($xml);
- $xml =~ s/[\x00-\x1f]//go;
-
- my $qrec;
- # Check the leader to ensure we've got something resembling the expected
- # Allow spaces to give records the benefit of the doubt
- my $ldr_type = substr($r->leader(), 6, 1);
- if ($type eq 'bib' && ($record_types{$ldr_type}) eq 'bib' || $ldr_type eq ' ') {
- $qrec = _add_bib_rec( $e, $xml, $queue_id, $purpose, $bib_source ) or return $e->die_event;
- } elsif ($type eq 'auth' && ($record_types{$ldr_type}) eq 'auth' || $ldr_type eq ' ') {
- $qrec = _add_auth_rec( $e, $xml, $queue_id, $purpose ) or return $e->die_event;
- } else {
- # I don't know how to handle this type; rock on
- $logger->error("In process_spool(), type was $type and leader type was $ldr_type ; not currently supported");
- next;
- }
-
- if($self->api_name =~ /stream_results/ and $qrec) {
- $client->respond($qrec->id)
- } else {
- $client->respond($count) if (++$count % $response_scale) == 0;
- $response_scale *= 10 if ($count == ($response_scale * 10));
- }
- } catch Error with {
- my $error = shift;
- $logger->warn("Encountered a bad record at Vandelay ingest: ".$error);
- }
- }
-
- $e->commit;
- unlink($filename);
- $cache->delete_cache('vandelay_import_spool_' . $fingerprint) if $fingerprint;
- return $count;
-}
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib.process_spool",
- method => "process_spool",
- api_level => 1,
- argc => 3,
- max_chunk_size => 0,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth.process_spool",
- method => "process_spool",
- api_level => 1,
- argc => 3,
- max_chunk_size => 0,
- record_type => 'auth'
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib.process_spool.stream_results",
- method => "process_spool",
- api_level => 1,
- argc => 3,
- stream => 1,
- max_chunk_size => 0,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth.process_spool.stream_results",
- method => "process_spool",
- api_level => 1,
- argc => 3,
- stream => 1,
- max_chunk_size => 0,
- record_type => 'auth'
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.records.retrieve",
- method => 'retrieve_queued_records',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_queue.records.retrieve",
- method => 'retrieve_queued_records',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'auth'
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.records.matches.retrieve",
- method => 'retrieve_queued_records',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'bib',
- signature => {
- desc => q/Only retrieve queued bib records that have matches against existing records/
- }
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_queue.records.matches.retrieve",
- method => 'retrieve_queued_records',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'auth',
- signature => {
- desc => q/Only retrieve queued authority records that have matches against existing records/
- }
-
-);
-
-sub retrieve_queued_records {
- my($self, $conn, $auth, $queue_id, $options) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- $options ||= {};
- my $limit = $$options{limit} || 20;
- my $offset = $$options{offset} || 0;
-
- my $type = $self->{record_type};
- my $queue;
- if($type eq 'bib') {
- $queue = $e->retrieve_vandelay_bib_queue($queue_id) or return $e->die_event;
- } else {
- $queue = $e->retrieve_vandelay_authority_queue($queue_id) or return $e->die_event;
- }
- my $evt = check_queue_perms($e, $type, $queue);
- return $evt if ($evt);
-
- my $class = ($type eq 'bib') ? 'vqbr' : 'vqar';
- my $search = ($type eq 'bib') ?
- 'search_vandelay_queued_bib_record' : 'search_vandelay_queued_authority_record';
- my $retrieve = ($type eq 'bib') ?
- 'retrieve_vandelay_queued_bib_record' : 'retrieve_vandelay_queued_authority_record';
-
- my $filter = ($$options{non_imported}) ? {import_time => undef} : {};
-
- my $record_ids;
- if($self->api_name =~ /matches/) {
- # fetch only matched records
- $record_ids = queued_records_with_matches($e, $type, $queue_id, $limit, $offset, $filter);
- } else {
- # fetch all queue records
- $record_ids = $e->$search([
- {queue => $queue_id, %$filter},
- {order_by => {$class => 'id'}, limit => $limit, offset => $offset}
- ],
- {idlist => 1}
- );
- }
-
-
- for my $rec_id (@$record_ids) {
- my $params = {
- flesh => 1,
- flesh_fields => {$class => ['attributes', 'matches']},
- };
- my $rec = $e->$retrieve([$rec_id, $params]);
- $rec->clear_marc if $$options{clear_marc};
- $conn->respond($rec);
- }
- $e->rollback;
- return undef;
-}
-
-sub check_queue_perms {
- my($e, $type, $queue) = @_;
- if ($type eq 'bib') {
- return $e->die_event unless
- ($e->allowed('CREATE_BIB_IMPORT_QUEUE', undef, $queue) ||
- $e->allowed('CREATE_BIB_IMPORT_QUEUE'));
- } else {
- return $e->die_event unless
- ($e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE', undef, $queue) ||
- $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE'));
- }
-
- return undef;
-}
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_record.list.import",
- method => 'import_record_list',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'bib'
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_record.list.import",
- method => 'import_record_list',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'auth'
-);
-
-sub import_record_list {
- my($self, $conn, $auth, $rec_ids, $args) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- $args ||= {};
- my $err = import_record_list_impl($self, $conn, $rec_ids, $e->requestor, $args);
- $e->rollback;
- return $err if $err;
- return {complete => 1};
-}
-
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.import",
- method => 'import_queue',
- api_level => 1,
- argc => 2,
- stream => 1,
- max_chunk_size => 0,
- record_type => 'bib'
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_queue.import",
- method => 'import_queue',
- api_level => 1,
- argc => 2,
- stream => 1,
- max_chunk_size => 0,
- record_type => 'auth'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.nomatch.import",
- method => 'import_queue',
- api_level => 1,
- argc => 2,
- stream => 1,
- signature => {
- desc => q/Only import records that have no collisions/
- },
- max_chunk_size => 0,
- record_type => 'bib'
-);
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_queue.nomatch.import",
- method => 'import_queue',
- api_level => 1,
- argc => 2,
- stream => 1,
- signature => {
- desc => q/Only import records that have no collisions/
- },
- max_chunk_size => 0,
- record_type => 'auth'
-);
-sub import_queue {
- my($self, $conn, $auth, $q_id, $options) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- $options ||= {};
- my $type = $self->{record_type};
- my $class = ($type eq 'bib') ? 'vqbr' : 'vqar';
-
- my $query = {queue => $q_id, import_time => undef};
-
- if($self->api_name =~ /nomatch/) {
- my $matched_recs = queued_records_with_matches($e, $type, $q_id, undef, undef, {import_time => undef});
- $query->{id} = {'not in' => $matched_recs} if @$matched_recs;
- }
-
- my $search = ($type eq 'bib') ?
- 'search_vandelay_queued_bib_record' : 'search_vandelay_queued_authority_record';
- my $rec_ids = $e->$search($query, {idlist => 1});
- my $err = import_record_list_impl($self, $conn, $rec_ids, $e->requestor, $options);
- try {$e->rollback} otherwise {}; # only using this to make the read authoritative -- don't die from it
- return $err if $err;
- return {complete => 1};
-}
-
-# returns a list of queued record IDs for a given queue that
-# have at least one entry in the match table
-sub queued_records_with_matches {
- my($e, $type, $q_id, $limit, $offset, $filter) = @_;
-
- my $match_class = 'vbm';
- my $rec_class = 'vqbr';
- if($type eq 'auth') {
- $match_class = 'vam';
- $rec_class = 'vqar';
- }
-
- $filter ||= {};
- $filter->{queue} = $q_id;
-
- my $query = {
- distinct => 1,
- select => {$match_class => ['queued_record']},
- from => {
- $match_class => {
- $rec_class => {
- field => 'id',
- fkey => 'queued_record',
- filter => $filter,
- }
- }
- }
- };
-
- if($limit or defined $offset) {
- $limit ||= 20;
- $offset ||= 0;
- $query->{limit} = $limit;
- $query->{offset} = $offset;
- }
-
- my $data = $e->json_query($query);
- return [ map {$_->{queued_record}} @$data ];
-}
-
-sub import_record_list_impl {
- my($self, $conn, $rec_ids, $requestor, $args) = @_;
-
- my $overlay_map = $args->{overlay_map} || {};
- my $type = $self->{record_type};
- my $total = @$rec_ids;
- my $count = 0;
- my %queues;
-
- my $step = 1;
-
- my $auto_overlay_exact = $$args{auto_overlay_exact};
- my $auto_overlay_1match = $$args{auto_overlay_1match};
- my $merge_profile = $$args{merge_profile};
- my $bib_source = $$args{bib_source};
- my $report_all = $$args{report_all};
-
- my $overlay_func = 'vandelay.overlay_bib_record';
- my $auto_overlay_func = 'vandelay.auto_overlay_bib_record';
- my $retrieve_func = 'retrieve_vandelay_queued_bib_record';
- my $update_func = 'update_vandelay_queued_bib_record';
- my $search_func = 'search_vandelay_queued_bib_record';
- my $retrieve_queue_func = 'retrieve_vandelay_bib_queue';
- my $update_queue_func = 'update_vandelay_bib_queue';
- my $rec_class = 'vqbr';
-
- my %bib_sources;
- my $editor = new_editor();
- my $sources = $editor->search_config_bib_source({id => {'!=' => undef}});
-
- foreach my $src (@$sources) {
- $bib_sources{$src->id} = $src->source;
- }
-
- if($type eq 'auth') {
- $overlay_func =~ s/bib/auth/o;
- $auto_overlay_func = s/bib/auth/o;
- $retrieve_func =~ s/bib/authority/o;
- $retrieve_queue_func =~ s/bib/authority/o;
- $update_queue_func =~ s/bib/authority/o;
- $update_func =~ s/bib/authority/o;
- $search_func =~ s/bib/authority/o;
- $rec_class = 'vqar';
- }
-
- my @success_rec_ids;
- for my $rec_id (@$rec_ids) {
-
- my $overlay_target = $overlay_map->{$rec_id};
-
- my $error = 0;
- my $e = new_editor(xact => 1);
- $e->requestor($requestor);
-
- my $rec = $e->$retrieve_func([
- $rec_id,
- { flesh => 1,
- flesh_fields => { $rec_class => ['matches']},
- }
- ]);
-
- unless($rec) {
- $conn->respond({total => $total, progress => ++$count, imported => $rec_id, err_event => $e->event});
- $e->rollback;
- next;
- }
-
- if($rec->import_time) {
- $e->rollback;
- next;
- }
-
- $queues{$rec->queue} = 1;
-
- my $record;
- my $imported = 0;
-
- if(defined $overlay_target) {
- # Caller chose an explicit overlay target
-
- my $res = $e->json_query(
- {
- from => [
- $overlay_func,
- $rec->id,
- $overlay_target,
- $merge_profile
- ]
- }
- );
-
- if($res and ($res = $res->[0])) {
-
- if($res->{$overlay_func} eq 't') {
- $logger->info("vl: $type direct overlay succeeded for queued rec " .
- $rec->id . " and overlay target $overlay_target");
- $imported = 1;
- }
-
- } else {
- $error = 1;
- $logger->error("vl: Error attempting overlay with func=$overlay_func, profile=$merge_profile, record=$rec_id");
- }
-
- } else {
-
- if($auto_overlay_1match) {
- # caller says to overlay if there is exactly 1 match
-
- my %match_recs = map { $_->eg_record => 1 } @{$rec->matches};
-
- if( scalar(keys %match_recs) == 1) { # all matches point to the same record
-
- my $res = $e->json_query(
- {
- from => [
- $overlay_func,
- $rec->id,
- $rec->matches->[0]->eg_record,
- $merge_profile
- ]
- }
- );
-
- if($res and ($res = $res->[0])) {
-
- if($res->{$overlay_func} eq 't') {
- $logger->info("vl: $type overlay-1match succeeded for queued rec " . $rec->id);
- $imported = 1;
- }
-
- } else {
- $error = 1;
- $logger->error("vl: Error attempting overlay with func=$overlay_func, profile=$merge_profile, record=$rec_id");
- }
- }
- }
-
- if(!$imported and !$error and $auto_overlay_exact and scalar(@{$rec->matches}) == 1 ) {
-
- # caller says to overlay if there is an /exact/ match
-
- my $res = $e->json_query(
- {
- from => [
- $auto_overlay_func,
- $rec->id,
- $merge_profile
- ]
- }
- );
-
- if($res and ($res = $res->[0])) {
-
- if($res->{$auto_overlay_func} eq 't') {
- $logger->info("vl: $type auto-overlay succeeded for queued rec " . $rec->id);
- $imported = 1;
- }
-
- } else {
- $error = 1;
- $logger->error("vl: Error attempting overlay with func=$auto_overlay_func, profile=$merge_profile, record=$rec_id");
- }
- }
-
- if(!$imported and !$error) {
-
- # No overlay / merge occurred. Do a traditional record import by creating a new record
-
- if($type eq 'bib') {
- $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import($e, $rec->marc, $bib_sources{$rec->bib_source});
- } else {
-
- $record = OpenILS::Application::Cat::AuthCommon->import_authority_record($e, $rec->marc); #$source);
- }
-
- if($U->event_code($record)) {
-
- $e->event($record);
- $e->rollback;
-
- } else {
-
- $logger->info("vl: successfully imported new $type record");
- $rec->imported_as($record->id);
- $rec->import_time('now');
-
- $imported = 1 if $e->$update_func($rec);
- }
- }
- }
-
- if($imported) {
- push @success_rec_ids, $rec_id;
- $e->commit;
- } else {
- # Send an update whenever there's an error
- $conn->respond({total => $total, progress => ++$count, imported => $rec_id, err_event => $e->event});
- }
-
- if($report_all or (++$count % $step) == 0) {
- $conn->respond({total => $total, progress => $count, imported => $rec_id});
- # report often at first, climb quickly, then hold steady
- $step *= 2 unless $step == 256;
- }
- }
-
- # see if we need to mark any queues as complete
- for my $q_id (keys %queues) {
-
- my $e = new_editor(xact => 1);
- my $remaining = $e->$search_func(
- [{queue => $q_id, import_time => undef}, {limit =>1}], {idlist => 1});
-
- unless(@$remaining) {
- my $queue = $e->$retrieve_queue_func($q_id);
-
- unless($U->is_true($queue->complete)) {
- $queue->complete('t');
- $e->$update_queue_func($queue) or return $e->die_event;
- $e->commit;
- next;
- }
- }
- $e->rollback;
- }
-
- import_record_asset_list_impl($conn, \@success_rec_ids, $requestor);
-
- $conn->respond({total => $total, progress => $count});
- return undef;
-}
-
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.owner.retrieve",
- method => 'owner_queue_retrieve',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.authority_queue.owner.retrieve",
- method => 'owner_queue_retrieve',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'auth'
-);
-
-sub owner_queue_retrieve {
- my($self, $conn, $auth, $owner_id, $filters) = @_;
- my $e = new_editor(authtoken => $auth, xact => 1);
- return $e->die_event unless $e->checkauth;
- $owner_id = $e->requestor->id; # XXX add support for viewing other's queues?
- my $queues;
- $filters ||= {};
- my $search = {owner => $owner_id};
- $search->{$_} = $filters->{$_} for keys %$filters;
-
- if($self->{record_type} eq 'bib') {
- $queues = $e->search_vandelay_bib_queue(
- [$search, {order_by => {vbq => 'lower(name)'}}]);
- } else {
- $queues = $e->search_vandelay_authority_queue(
- [$search, {order_by => {vaq => 'lower(name)'}}]);
- }
- $conn->respond($_) for @$queues;
- $e->rollback;
- return undef;
-}
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.delete",
- method => "delete_queue",
- api_level => 1,
- argc => 2,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_queue.delete",
- method => "delete_queue",
- api_level => 1,
- argc => 2,
- record_type => 'auth'
-);
-
-sub delete_queue {
- my($self, $conn, $auth, $q_id) = @_;
- my $e = new_editor(xact => 1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- if($self->{record_type} eq 'bib') {
- return $e->die_event unless $e->allowed('CREATE_BIB_IMPORT_QUEUE');
- my $queue = $e->retrieve_vandelay_bib_queue($q_id)
- or return $e->die_event;
- $e->delete_vandelay_bib_queue($queue)
- or return $e->die_event;
- } else {
- return $e->die_event unless $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE');
- my $queue = $e->retrieve_vandelay_authority_queue($q_id)
- or return $e->die_event;
- $e->delete_vandelay_authority_queue($queue)
- or return $e->die_event;
- }
- $e->commit;
- return 1;
-}
-
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.queued_bib_record.html",
- method => 'queued_record_html',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.queued_authority_record.html",
- method => 'queued_record_html',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'auth'
-);
-
-sub queued_record_html {
- my($self, $conn, $auth, $rec_id) = @_;
- my $e = new_editor(xact=>1,authtoken => $auth);
- return $e->die_event unless $e->checkauth;
- my $rec;
- if($self->{record_type} eq 'bib') {
- $rec = $e->retrieve_vandelay_queued_bib_record($rec_id)
- or return $e->die_event;
- } else {
- $rec = $e->retrieve_vandelay_queued_authority_record($rec_id)
- or return $e->die_event;
- }
-
- $e->rollback;
- return $U->simplereq(
- 'open-ils.search',
- 'open-ils.search.biblio.record.html', undef, 1, $rec->marc);
-}
-
-
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.bib_queue.summary.retrieve",
- method => 'retrieve_queue_summary',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'bib'
-);
-__PACKAGE__->register_method(
- api_name => "open-ils.vandelay.auth_queue.summary.retrieve",
- method => 'retrieve_queue_summary',
- api_level => 1,
- argc => 2,
- stream => 1,
- record_type => 'auth'
-);
-
-sub retrieve_queue_summary {
- my($self, $conn, $auth, $queue_id) = @_;
- my $e = new_editor(xact=>1, authtoken => $auth);
- return $e->die_event unless $e->checkauth;
-
- my $queue;
- my $type = $self->{record_type};
- if($type eq 'bib') {
- $queue = $e->retrieve_vandelay_bib_queue($queue_id)
- or return $e->die_event;
- } else {
- $queue = $e->retrieve_vandelay_authority_queue($queue_id)
- or return $e->die_event;
- }
-
- my $evt = check_queue_perms($e, $type, $queue);
- return $evt if $evt;
-
- my $search = 'search_vandelay_queued_bib_record';
- $search =~ s/bib/authority/ if $type ne 'bib';
-
- return {
- queue => $queue,
- total => scalar(@{$e->$search({queue => $queue_id}, {idlist=>1})}),
- imported => scalar(@{$e->$search({queue => $queue_id, import_time => {'!=' => undef}}, {idlist=>1})}),
- };
-}
-
-# --------------------------------------------------------------------------------
-# Given a list of queued record IDs, imports all items attached to those records
-# --------------------------------------------------------------------------------
-sub import_record_asset_list_impl {
- my($conn, $rec_ids, $requestor) = @_;
-
- my $total = @$rec_ids;
- my $try_count = 0;
- my $in_count = 0;
- my $roe = new_editor(xact=> 1, requestor => $requestor);
-
- for my $rec_id (@$rec_ids) {
- my $rec = $roe->retrieve_vandelay_queued_bib_record($rec_id);
- next unless $rec and $rec->import_time;
- my $item_ids = $roe->search_vandelay_import_item({record => $rec->id}, {idlist=>1});
-
- for my $item_id (@$item_ids) {
- my $e = new_editor(requestor => $requestor, xact => 1);
- my $item = $e->retrieve_vandelay_import_item($item_id);
- $try_count++;
-
- # --------------------------------------------------------------------------------
- # Find or create the volume
- # --------------------------------------------------------------------------------
- my ($vol, $evt) =
- OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
- $e, $item->call_number, $rec->imported_as, $item->owning_lib);
-
- if($evt) {
- respond_with_status($conn, $total, $try_count, $in_count, $evt);
- next;
- }
-
- # --------------------------------------------------------------------------------
- # Create the new copy
- # --------------------------------------------------------------------------------
- my $copy = Fieldmapper::asset::copy->new;
- $copy->loan_duration(2);
- $copy->fine_level(2);
- $copy->barcode($item->barcode);
- $copy->location($item->location);
- $copy->circ_lib($item->circ_lib || $item->owning_lib);
- $copy->status($item->status || OILS_COPY_STATUS_IN_PROCESS);
- $copy->circulate($item->circulate);
- $copy->deposit($item->deposit);
- $copy->deposit_amount($item->deposit_amount);
- $copy->ref($item->ref);
- $copy->holdable($item->holdable);
- $copy->price($item->price);
- $copy->circ_as_type($item->circ_as_type);
- $copy->alert_message($item->alert_message);
- $copy->opac_visible($item->opac_visible);
- $copy->circ_modifier($item->circ_modifier);
-
- # --------------------------------------------------------------------------------
- # see if a valid circ_modifier was provided
- # --------------------------------------------------------------------------------
- #if($copy->circ_modifier and not $e->retrieve_config_circ_modifier($item->circ_modifier)) {
- if($copy->circ_modifier and not $e->search_config_circ_modifier({code=>$item->circ_modifier})->[0]) {
- respond_with_status($conn, $total, $try_count, $in_count, $e->die_event);
- next;
- }
-
- if($evt = OpenILS::Application::Cat::AssetCommon->create_copy($e, $vol, $copy)) {
- try { $e->rollback } otherwise {}; # sometimes calls die_event, sometimes not
- respond_with_status($conn, $total, $try_count, $in_count, $evt);
- next;
- }
-
- # --------------------------------------------------------------------------------
- # create copy notes
- # --------------------------------------------------------------------------------
- $evt = OpenILS::Application::Cat::AssetCommon->create_copy_note(
- $e, $copy, '', $item->pub_note, 1) if $item->pub_note;
-
- if($evt) {
- respond_with_status($conn, $total, $try_count, $in_count, $evt);
- next;
- }
-
- $evt = OpenILS::Application::Cat::AssetCommon->create_copy_note(
- $e, $copy, '', $item->priv_note, 1) if $item->priv_note;
-
- if($evt) {
- respond_with_status($conn, $total, $try_count, $in_count, $evt);
- next;
- }
-
- # --------------------------------------------------------------------------------
- # Item import succeeded
- # --------------------------------------------------------------------------------
- $e->commit;
- respond_with_status($conn, $total, $try_count, ++$in_count, undef, imported_as => $copy->id);
- }
- }
- $roe->rollback;
- return undef;
-}
-
-
-sub respond_with_status {
- my($conn, $total, $try_count, $success_count, $err, %args) = @_;
- $conn->respond({
- total => $total,
- progress => $try_count,
- err_event => $err,
- success_count => $success_count, %args }) if $err or ($try_count % 5 == 0);
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Const;
-use strict; use warnings;
-use vars qw(@EXPORT_OK %EXPORT_TAGS);
-use Exporter;
-use base qw/Exporter/;
-
-
-# ---------------------------------------------------------------------
-# Shoves defined constants into the export array
-# so they don't have to be listed twice in the code
-# ---------------------------------------------------------------------
-sub econst {
- my($name, $value) = @_;
- my $caller = caller;
- no strict;
- *{$name} = sub () { $value };
- push @{$caller.'::EXPORT_OK'}, $name;
-}
-
-# ---------------------------------------------------------------------
-# CONSTANTS
-# ---------------------------------------------------------------------
-
-
-
-# ---------------------------------------------------------------------
-# Copy Statuses
-# ---------------------------------------------------------------------
-econst OILS_COPY_STATUS_AVAILABLE => 0;
-econst OILS_COPY_STATUS_CHECKED_OUT => 1;
-econst OILS_COPY_STATUS_BINDERY => 2;
-econst OILS_COPY_STATUS_LOST => 3;
-econst OILS_COPY_STATUS_MISSING => 4;
-econst OILS_COPY_STATUS_IN_PROCESS => 5;
-econst OILS_COPY_STATUS_IN_TRANSIT => 6;
-econst OILS_COPY_STATUS_RESHELVING => 7;
-econst OILS_COPY_STATUS_ON_HOLDS_SHELF=> 8;
-econst OILS_COPY_STATUS_ON_ORDER => 9;
-econst OILS_COPY_STATUS_ILL => 10;
-econst OILS_COPY_STATUS_CATALOGING => 11;
-econst OILS_COPY_STATUS_RESERVES => 12;
-econst OILS_COPY_STATUS_DISCARD => 13;
-econst OILS_COPY_STATUS_DAMAGED => 14;
-econst OILS_COPY_STATUS_ON_RESV_SHELF => 15;
-
-
-# ---------------------------------------------------------------------
-# Circ defaults for pre-cataloged copies
-# ---------------------------------------------------------------------
-econst OILS_PRECAT_COPY_FINE_LEVEL => 2;
-econst OILS_PRECAT_COPY_LOAN_DURATION => 2;
-econst OILS_PRECAT_CALL_NUMBER => -1;
-econst OILS_PRECAT_RECORD => -1;
-
-
-# ---------------------------------------------------------------------
-# Circ constants
-# ---------------------------------------------------------------------
-econst OILS_CIRC_DURATION_SHORT => 1;
-econst OILS_CIRC_DURATION_NORMAL => 2;
-econst OILS_CIRC_DURATION_EXTENDED => 3;
-econst OILS_REC_FINE_LEVEL_LOW => 1;
-econst OILS_REC_FINE_LEVEL_NORMAL => 2;
-econst OILS_REC_FINE_LEVEL_HIGH => 3;
-econst OILS_STOP_FINES_CHECKIN => 'CHECKIN';
-econst OILS_STOP_FINES_RENEW => 'RENEW';
-econst OILS_STOP_FINES_LOST => 'LOST';
-econst OILS_STOP_FINES_CLAIMSRETURNED => 'CLAIMSRETURNED';
-econst OILS_STOP_FINES_LONGOVERDUE => 'LONGOVERDUE';
-econst OILS_STOP_FINES_MAX_FINES => 'MAXFINES';
-econst OILS_STOP_FINES_CLAIMS_NEVERCHECKEDOUT => 'CLAIMSNEVERCHECKEDOUT';
-econst OILS_UNLIMITED_CIRC_DURATION => 'unlimited';
-
-# ---------------------------------------------------------------------
-# Settings
-# ---------------------------------------------------------------------
-econst OILS_SETTING_LOST_PROCESSING_FEE => 'circ.lost_materials_processing_fee';
-econst OILS_SETTING_DEF_ITEM_PRICE => 'cat.default_item_price';
-econst OILS_SETTING_ORG_BOUNCED_EMAIL => 'org.bounced_emails';
-econst OILS_SETTING_CHARGE_LOST_ON_ZERO => 'circ.charge_lost_on_zero';
-econst OILS_SETTING_VOID_OVERDUE_ON_LOST => 'circ.void_overdue_on_lost';
-econst OILS_SETTING_HOLD_SOFT_STALL => 'circ.hold_stalling.soft';
-econst OILS_SETTING_HOLD_HARD_STALL => 'circ.hold_stalling.hard';
-econst OILS_SETTING_HOLD_SOFT_BOUNDARY => 'circ.hold_boundary.soft';
-econst OILS_SETTING_HOLD_HARD_BOUNDARY => 'circ.hold_boundary.hard';
-econst OILS_SETTING_HOLD_EXPIRE => 'circ.hold_expire_interval';
-econst OILS_SETTING_HOLD_ESIMATE_WAIT_INTERVAL => 'circ.holds.default_estimated_wait_interval';
-econst OILS_SETTING_VOID_LOST_ON_CHECKIN => 'circ.void_lost_on_checkin';
-econst OILS_SETTING_MAX_ACCEPT_RETURN_OF_LOST => 'circ.max_accept_return_of_lost';
-econst OILS_SETTING_VOID_LOST_PROCESS_FEE_ON_CHECKIN => 'circ.void_lost_proc_fee_on_checkin';
-econst OILS_SETTING_RESTORE_OVERDUE_ON_LOST_RETURN => 'circ.restore_overdue_on_lost_return';
-econst OILS_SETTING_LOST_IMMEDIATELY_AVAILABLE => 'circ.lost_immediately_available';
-econst OILS_SETTING_BLOCK_HOLD_FOR_EXPIRED_PATRON => 'circ.holds.expired_patron_block';
-
-
-
-
-econst OILS_HOLD_TYPE_COPY => 'C';
-econst OILS_HOLD_TYPE_FORCE => 'F';
-econst OILS_HOLD_TYPE_RECALL => 'R';
-econst OILS_HOLD_TYPE_ISSUANCE => 'I';
-econst OILS_HOLD_TYPE_VOLUME => 'V';
-econst OILS_HOLD_TYPE_TITLE => 'T';
-econst OILS_HOLD_TYPE_METARECORD => 'M';
-
-
-econst OILS_BILLING_TYPE_OVERDUE_MATERIALS => 'Overdue materials';
-econst OILS_BILLING_TYPE_COLLECTION_FEE => 'Long Overdue Collection Fee';
-econst OILS_BILLING_TYPE_DEPOSIT => 'System: Deposit';
-econst OILS_BILLING_TYPE_RENTAL => 'System: Rental';
-econst OILS_BILLING_NOTE_SYSTEM => 'SYSTEM GENERATED';
-
-econst OILS_ACQ_DEBIT_TYPE_PURCHASE => 'purchase';
-econst OILS_ACQ_DEBIT_TYPE_TRANSFER => 'xfer';
-
-# all penalties with ID < 100 are managed automatically
-econst OILS_PENALTY_AUTO_ID => 100;
-econst OILS_PENALTY_PATRON_EXCEEDS_FINES => 1;
-econst OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT => 2;
-econst OILS_PENALTY_INVALID_PATRON_ADDRESS => 29;
-
-
-econst OILS_BILLING_TYPE_NOTIFICATION_FEE => 9;
-
-
-
-# ---------------------------------------------------------------------
-# finally, export all the constants
-# ---------------------------------------------------------------------
-%EXPORT_TAGS = ( const => [ @EXPORT_OK ] );
-
+++ /dev/null
-package OpenILS::Event;
-# vim:noet:ts=4
-use strict; use warnings;
-use XML::LibXML;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger;
-my $logger = "OpenSRF::Utils::Logger";
-
-
-# Returns a new Event data hash (not a blessed object)
-# The first param is the event name
-# Following the first param is an optional hash of params:
-# perm => the name of the permission error for permimssion errors
-# permloc => the location of the permission error for permission errors
-# payload => the payload to be returned on successfull events
-
-
-my $events = undef;
-my $descs = undef;
-
-sub new {
- my( $class, $event, %params ) = @_;
- _load_events() unless $events;
-
- throw OpenSRF::EX ("Bad event name: $event") unless $event;
- my $e = $events->{$event};
- $e = '' unless defined $e;
-
- my( $m, $f, $l ) = caller(0);
- my( $mm, $ff, $ll ) = caller(1);
- my( $mmm, $fff, $lll ) = caller(2);
-
- $f ||= "";
- $l ||= "";
- $ff ||= "";
- $ll ||= "";
- $fff ||= "";
- $lll ||= "";
-
- my $lang = 'en-US'; # assume english for now
-
- my $t = CORE::localtime();
-
- return {
- ilsevent => $e,
- textcode => $event,
- stacktrace => "$f:$l $ff:$ll $fff:$lll",
- desc => $descs->{$lang}->{$e || ''} || '',
- servertime => $t,
- pid => $$, %params
- };
-}
-
-sub _load_events {
- my $settings_client = OpenSRF::Utils::SettingsClient->new();
- my $eventsxml = $settings_client->config_value( "ils_events" );
-
- if(!$eventsxml) {
- throw OpenSRF::EX ("No ils_events file found in settings config");
- }
-
- $logger->info("Loading events xml file $eventsxml");
-
- my $doc = XML::LibXML->new->parse_file($eventsxml);
-
- my @nodes = $doc->documentElement->findnodes('//event');
- for my $node (@nodes) {
- $events->{$node->getAttribute('textcode')} =
- $node->getAttribute('code');
- }
-
- $descs = {};
- my @desc = $doc->documentElement->findnodes('//desc');
- for my $d (@desc) {
- my $lang = $d->getAttributeNS('http://www.w3.org/XML/1998/namespace', 'lang');
- my $code = $d->parentNode->getAttribute('code');
- unless ($descs && $lang && exists $descs->{$lang}) {
- $descs->{$lang} = {};
- if (!$descs) {
- $logger->error("No error description nodes found in $eventsxml.");
- }
- if (!$lang) {
- $logger->error("No xml:lang attribute found for node in $eventsxml.");
- }
- }
- $descs->{$lang}->{$code} = $d->textContent;
- }
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Perm;
-use strict; use warnings;
-use Template;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::EX qw(:try);
-use OpenSRF::AppSession;
-use OpenSRF::Utils::Logger;
-
-# ----------------------------------------------------------------------------------
-# These permission strings
-# ----------------------------------------------------------------------------------
-
-# returns a new fieldmapper::perm_ex
-my $logger = 'OpenSRF::Utils::Logger';
-
-sub new {
- my($class, $type) = @_;
- $logger->warn("Returning permission error: $type");
- return bless( { ilsevent => 5000, ilsperm => $type }, 'OpenILS::Perm');
-}
-
-1;
+++ /dev/null
-package OpenILS::Reporter::Proxy;
-use strict; use warnings;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(REDIRECT FORBIDDEN OK NOT_FOUND DECLINED :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use CGI;
-use Data::Dumper;
-use Digest::MD5 qw/md5_hex/;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-
-
-# set the bootstrap config and template include directory when
-# this module is loaded
-my $bootstrap;
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-}
-
-sub handler {
- my $apache = shift;
- my $cgi = new CGI;
- my $auth_ses = $cgi->cookie('ses');
- my $ws_ou = $cgi->cookie('ws_ou') || 1;
-
- my $url = $cgi->url;
-
- # push everyone to the secure site
- if ($url =~ /^http:/o) {
- $url =~ s/^http:/https:/o;
- print "Location: $url\n\n";
- return Apache2::Const::OK;
- }
-
- if (!$auth_ses) {
- my $u = $cgi->param('user');
- my $p = $cgi->param('passwd');
-
- if (!$u) {
-
- print $cgi->header(-type=>'text/html', -expires=>'-1d');
- print <<" HTML";
-
-<html>
- <head>
- <title>Report Output Login</title>
- </head>
- <body>
- <br/><br/><br/>
- <center>
- <form method='POST'>
- <table style='border-collapse: collapse; border: 1px solid black;'>
- <tr>
- <th colspan='2' align='center'><u>Please log in to view reports</u></th>
- </tr>
- <tr>
- <th align="right">Username or barcode:</th>
- <td><input type="text" name="user"/></td>
- </tr>
- <tr>
- <th align="right">Password:</th>
- <td><input type="password" name="passwd"/></td>
- </tr>
- </table>
- <input type="submit" value="Log in"/>
- </form>
- </center>
- </body>
-</html>
-
- HTML
- return Apache2::Const::OK;
- }
-
- $auth_ses = oils_login($u, $p);
- if ($auth_ses) {
- print $cgi->redirect(
- -uri=>$url,
- -cookie=>$cgi->cookie(
- -name=>'ses',
- -value=>$auth_ses,
- -path=>'/',-expires=>'+1h'
- )
- );
- return Apache2::Const::REDIRECT;
- }
- }
-
- my $user = verify_login($auth_ses);
- return Apache2::Const::FORBIDDEN unless ($user);
-
- my $failures = OpenSRF::AppSession
- ->create('open-ils.actor')
- ->request('open-ils.actor.user.perm.check', $auth_ses, $user->id, $ws_ou, ['VIEW_REPORT_OUTPUT'])
- ->gather(1);
-
- return Apache2::Const::FORBIDDEN if (@$failures > 0);
-
- # they're good, let 'em through
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- # oops, file not found
- return Apache2::Const::NOT_FOUND;
-}
-
-# returns the user object if the session is valid, 0 otherwise
-sub verify_login {
- my $auth_token = shift;
- return undef unless $auth_token;
-
- my $user = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( "open-ils.auth.session.retrieve", $auth_token )
- ->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return undef;
- }
-
- return $user if ref($user);
- return undef;
-}
-
-sub oils_login {
- my( $username, $password, $type ) = @_;
-
- $type |= "staff";
- my $nametype = 'username';
- $nametype = 'barcode' if ($username =~ /^\d+$/o);
-
- my $seed = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( 'open-ils.auth.authenticate.init', $username )
- ->gather(1);
-
- return undef unless $seed;
-
- my $response = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( 'open-ils.auth.authenticate.complete',
- { $nametype => $username,
- password => md5_hex($seed . md5_hex($password)),
- type => $type })
- ->gather(1);
-
- return undef unless $response;
-
- return $response->{payload}->{authtoken};
-}
-
-
-
-1;
+++ /dev/null
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder;
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
-
- return bless { _sql => undef } => $class;
-}
-
-sub register_params {
- my $self = shift;
- my $p = shift;
- $self->{_params} = $p;
-}
-
-sub get_param {
- my $self = shift;
- my $p = shift;
- return $self->{_builder}->{_params}->{$p};
-}
-
-sub set_builder {
- my $self = shift;
- $self->{_builder} = shift;
- return $self;
-}
-
-sub builder {
- my $self = shift;
- return $self->{_builder};
-}
-
-sub relative_time {
- my $self = shift;
- my $t = shift;
- $self->builder->{_relative_time} = $t if (defined $t);
- return $self->builder->{_relative_time};
-}
-
-sub resolve_param {
- my $self = shift;
- my $val = shift;
-
- if (defined($val) && $val =~ /^::(.+)$/o) {
- $val = $self->get_param($1);
- }
-
- if (defined($val) && !ref($val)) {
- $val =~ s/\\/\\\\/go;
- $val =~ s/"/\\"/go;
- }
-
- return $val;
-}
-
-sub parse_report {
- my $self = shift;
- my $report = shift;
-
- my $rs = OpenILS::Reporter::SQLBuilder::ResultSet->new;
-
- if (!$report->{order_by} || @{$report->{order_by}} == 0) {
- $report->{order_by} = $report->{select};
- }
-
- $rs->is_subquery( 1 ) if ( $report->{alias} );
-
- $rs ->set_builder( $self )
- ->set_subquery_alias( $report->{alias} )
- ->set_select( $report->{select} )
- ->set_from( $report->{from} )
- ->set_where( $report->{where} )
- ->set_having( $report->{having} )
- ->set_order_by( $report->{order_by} )
- ->set_pivot_data( $report->{pivot_data} )
- ->set_pivot_label( $report->{pivot_label} )
- ->set_pivot_default( $report->{pivot_default} );
-
- return $rs;
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::ResultSet;
-use base qw/OpenILS::Reporter::SQLBuilder/;
-
-sub is_subquery {
- my $self = shift;
- my $flag = shift;
- $self->{_is_subquery} = $flag if (defined $flag);
- return $self->{_is_subquery};
-}
-
-sub pivot_data {
- my $self = shift;
- return $self->builder->{_pivot_data};
-}
-
-sub pivot_label {
- my $self = shift;
- return $self->builder->{_pivot_label};
-}
-
-sub pivot_default {
- my $self = shift;
- return $self->builder->{_pivot_default};
-}
-
-sub set_pivot_default {
- my $self = shift;
- my $p = shift;
- $self->builder->{_pivot_default} = $p if (defined $p);
- return $self;
-}
-
-sub set_pivot_data {
- my $self = shift;
- my $p = shift;
- $self->builder->{_pivot_data} = $p if (defined $p);
- return $self;
-}
-
-sub set_pivot_label {
- my $self = shift;
- my $p = shift;
- $self->builder->{_pivot_label} = $p if (defined $p);
- return $self;
-}
-
-sub set_subquery_alias {
- my $self = shift;
- my $alias = shift;
- $self->{_alias} = $alias if (defined $alias);
- return $self;
-}
-
-sub set_select {
- my $self = shift;
- my @cols = @_;
-
- $self->{_select} = [];
-
- return $self unless (@cols && defined($cols[0]));
- @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
-
- push @{ $self->{_select} }, map { OpenILS::Reporter::SQLBuilder::Column::Select->new( $_ )->set_builder( $self->builder ) } @cols;
-
- return $self;
-}
-
-sub set_from {
- my $self = shift;
- my $f = shift;
-
- $self->{_from} = OpenILS::Reporter::SQLBuilder::Relation->parse( $f, $self->builder );
-
- return $self;
-}
-
-sub set_where {
- my $self = shift;
- my @cols = @_;
-
- $self->{_where} = [];
-
- return $self unless (@cols && defined($cols[0]));
- @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
-
- push @{ $self->{_where} }, map { OpenILS::Reporter::SQLBuilder::Column::Where->new( $_ )->set_builder( $self->builder ) } @cols;
-
- return $self;
-}
-
-sub set_having {
- my $self = shift;
- my @cols = @_;
-
- $self->{_having} = [];
-
- return $self unless (@cols && defined($cols[0]));
- @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
-
- push @{ $self->{_having} }, map { OpenILS::Reporter::SQLBuilder::Column::Having->new( $_ )->set_builder( $self->builder ) } @cols;
-
- return $self;
-}
-
-sub set_order_by {
- my $self = shift;
- my @cols = @_;
-
- $self->{_order_by} = [];
-
- return $self unless (@cols && defined($cols[0]));
- @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
-
- push @{ $self->{_order_by} }, map { OpenILS::Reporter::SQLBuilder::Column::OrderBy->new( $_ )->set_builder( $self->builder ) } @cols;
-
- return $self;
-}
-
-sub column_label_list {
- my $self = shift;
-
- my @labels;
- push @labels, $self->resolve_param( $_->{_alias} ) for ( @{ $self->{_select} } );
- return @labels;
-}
-
-sub group_by_list {
- my $self = shift;
- my $base = shift;
- $base = 1 unless (defined $base);
-
- my $seen_label = 0;
- my $gcount = $base;
- my @group_by;
- for my $c ( @{ $self->{_select} } ) {
- if ($base == 0 && !$seen_label && defined($self->pivot_label) && $gcount == $self->pivot_label - 1) {
- $seen_label++;
- next;
- }
- push @group_by, $gcount if (!$c->is_aggregate);
- $gcount++;
- }
-
- return @group_by;
-}
-
-sub toSQL {
- my $self = shift;
-
- return $self->{_sql} if ($self->{_sql});
-
- my $sql = '';
-
- if ($self->is_subquery) {
- $sql = '(';
- }
-
- $sql .= "SELECT\t" . join(",\n\t", map { $_->toSQL } @{ $self->{_select} }) . "\n" if (@{ $self->{_select} });
- $sql .= " FROM\t" . $self->{_from}->toSQL . "\n" if ($self->{_from});
- $sql .= " WHERE\t" . join("\n\tAND ", map { $_->toSQL } @{ $self->{_where} }) . "\n" if (@{ $self->{_where} });
-
- my @group_by = $self->group_by_list;
-
- $sql .= ' GROUP BY ' . join(', ', @group_by) . "\n" if (@group_by);
- $sql .= " HAVING " . join("\n\tAND ", map { $_->toSQL } @{ $self->{_having} }) . "\n" if (@{ $self->{_having} });
- $sql .= ' ORDER BY ' . join(', ', map { $_->toSQL } @{ $self->{_order_by} }) . "\n" if (@{ $self->{_order_by} });
-
- if ($self->is_subquery) {
- $sql .= ') '. $self->{_alias} . "\n";
- }
-
- return $self->{_sql} = $sql;
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input;
-use base qw/OpenILS::Reporter::SQLBuilder/;
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
-
- my $col_data = shift;
-
- if (ref($col_data)) {
- $self->{params} = $col_data->{params};
- my $trans = $col_data->{transform} || 'Bare';
- my $pkg = "OpenILS::Reporter::SQLBuilder::Input::Transform::$trans";
- if (UNIVERSAL::can($pkg => 'toSQL')) {
- $self->{_transform} = $trans;
- } else {
- $self->{_transform} = 'GenericTransform';
- }
- } elsif( defined($col_data) ) {
- $self->{_transform} = 'Bare';
- $self->{params} = $col_data;
- } else {
- $self->{_transform} = 'NULL';
- }
-
-
-
- return $self;
-}
-
-sub toSQL {
- my $self = shift;
- my $type = $self->{_transform};
- return $self->{_sql} if ($self->{_sql});
- my $toSQL = "OpenILS::Reporter::SQLBuilder::Input::Transform::${type}::toSQL";
- return $self->{_sql} = $self->$toSQL;
-}
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::GenericTransform;
-
-sub toSQL {
- my $self = shift;
- my $func = $self->{transform};
-
- my @params;
- @params = @{ $self->{params} } if ($self->{params});
-
- my $sql = $func . '(\'';
- $sql .= join("','", @params) if (@params);
- $sql .= '\')';
-
- return $sql;
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::NULL;
-
-sub toSQL {
- return "NULL";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::Bare;
-
-sub toSQL {
- my $self = shift;
-
- my $val = $self->{params};
- $val = $$val[0] if (ref($val));
-
- $val =~ s/\\/\\\\/go;
- $val =~ s/'/\\'/go;
-
- return "'$val'";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::age;
-
-sub toSQL {
- my $self = shift;
-
- my $val = $self->{params};
- $val = $$val[0] if (ref($val));
-
- $val =~ s/\\/\\\\/go;
- $val =~ s/'/\\'/go;
-
- return "AGE(NOW(),'" . $val . "'::TIMESTAMPTZ)";
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_year;
-
-sub toSQL {
- my $self = shift;
-
- my $rtime = $self->relative_time || 'now';
-
- $rtime =~ s/\\/\\\\/go;
- $rtime =~ s/'/\\'/go;
-
- my $val = $self->{params};
- $val = $$val[0] if (ref($val));
-
- $val =~ s/\\/\\\\/go;
- $val =~ s/'/\\'/go;
-
- return "EXTRACT(YEAR FROM '$rtime'::TIMESTAMPTZ + '$val years')";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_month;
-
-sub toSQL {
- my $self = shift;
-
- my $rtime = $self->relative_time || 'now';
-
- $rtime =~ s/\\/\\\\/go;
- $rtime =~ s/'/\\'/go;
-
- my $val = $self->{params};
- $val = $$val[0] if (ref($val));
-
- $val =~ s/\\/\\\\/go;
- $val =~ s/'/\\'/go;
-
- return "EXTRACT(YEAR FROM '$rtime'::TIMESTAMPTZ + '$val months')" .
- " || '-' || LPAD(EXTRACT(MONTH FROM '$rtime'::TIMESTAMPTZ + '$val months')::text,2,'0')";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_date;
-
-sub toSQL {
- my $self = shift;
-
- my $rtime = $self->relative_time || 'now';
-
- $rtime =~ s/\\/\\\\/go;
- $rtime =~ s/'/\\'/go;
-
- my $val = $self->{params};
- $val = $$val[0] if (ref($val));
-
- $val =~ s/\\/\\\\/go;
- $val =~ s/'/\\'/go;
-
- return "DATE('$rtime'::TIMESTAMPTZ + '$val days')";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_week;
-
-sub toSQL {
- my $self = shift;
-
- my $rtime = $self->relative_time || 'now';
-
- $rtime =~ s/\\/\\\\/go;
- $rtime =~ s/'/\\'/go;
-
- my $val = $self->{params};
- $val = $$val[0] if (ref($val));
-
- $val =~ s/\\/\\\\/go;
- $val =~ s/'/\\'/go;
-
- return "EXTRACT(WEEK FROM '$rtime'::TIMESTAMPTZ + '$val weeks')";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column;
-use base qw/OpenILS::Reporter::SQLBuilder/;
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
-
- my $col_data = shift;
- $self->{_relation} = $col_data->{relation};
- $self->{_column} = $col_data->{column};
-
- $self->{_aggregate} = $col_data->{aggregate};
-
- if (ref($self->{_column})) {
- my $trans = $self->{_column}->{transform} || 'Bare';
- my $pkg = "OpenILS::Reporter::SQLBuilder::Column::Transform::$trans";
- if (UNIVERSAL::can($pkg => 'toSQL')) {
- $self->{_transform} = $trans;
- } else {
- $self->{_transform} = 'GenericTransform';
- }
- } elsif( defined($self->{_column}) ) {
- $self->{_transform} = 'Bare';
- } else {
- $self->{_transform} = 'NULL';
- }
-
-
- return $self;
-}
-
-sub find_relation {
- my $self = shift;
- return $self->builder->{_rels}->{$self->{_relation}};
-}
-
-sub name {
- my $self = shift;
- if (ref($self->{_column})) {
- return $self->{_column}->{colname};
- } else {
- return $self->{_column};
- }
-}
-
-sub toSQL {
- my $self = shift;
- my $type = $self->{_transform};
- return $self->{_sql} if ($self->{_sql});
- my $toSQL = "OpenILS::Reporter::SQLBuilder::Column::Transform::${type}::toSQL";
- return $self->{_sql} = $self->$toSQL;
-}
-
-sub is_aggregate {
- my $self = shift;
- my $type = $self->{_transform};
- my $is_agg = "OpenILS::Reporter::SQLBuilder::Column::Transform::${type}::is_aggregate";
- return $self->$is_agg;
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::OrderBy;
-use base qw/OpenILS::Reporter::SQLBuilder::Column/;
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- my $col_data = shift;
- $self->{_direction} = $col_data->{direction} || 'ascending';
- return $self;
-}
-
-sub toSQL {
- my $self = shift;
- my $dir = ($self->{_direction} =~ /^d/oi) ? 'DESC' : 'ASC';
- return $self->{_sql} if ($self->{_sql});
- return $self->{_sql} = $self->SUPER::toSQL . " $dir";
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Select;
-use base qw/OpenILS::Reporter::SQLBuilder::Column/;
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- my $col_data = shift;
- $self->{_alias} = $col_data->{alias} || $self->name;
- return $self;
-}
-
-sub toSQL {
- my $self = shift;
- return $self->{_sql} if ($self->{_sql});
- return $self->{_sql} = $self->SUPER::toSQL . ' AS "' . $self->resolve_param( $self->{_alias} ) . '"';
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::GenericTransform;
-
-sub toSQL {
- my $self = shift;
- my $name = $self->name;
- my $func = $self->{_column}->{transform};
-
- my @params;
- @params = @{ $self->resolve_param( $self->{_column}->{params} ) } if ($self->{_column}->{params});
-
- my $sql = $func . '("' . $self->{_relation} . '"."' . $self->name . '"';
- $sql .= ",'" . join("','", @params) . "'" if (@params);
- $sql .= ')';
-
- return $sql;
-}
-
-sub is_aggregate { return $self->{_aggregate} }
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::Bare;
-
-sub toSQL {
- my $self = shift;
- return '"' . $self->{_relation} . '"."' . $self->name . '"';
-}
-
-sub is_aggregate { return 0 }
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::upper;
-
-sub toSQL {
- my $self = shift;
- my $params = $self->resolve_param( $self->{_column}->{params} );
- my $start = $$params[0];
- my $len = $$params[1];
- return 'UPPER("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::lower;
-
-sub toSQL {
- my $self = shift;
- my $params = $self->resolve_param( $self->{_column}->{params} );
- my $start = $$params[0];
- my $len = $$params[1];
- return 'LOWER("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::substring;
-
-sub toSQL {
- my $self = shift;
- my $params = $self->resolve_param( $self->{_column}->{params} );
- my $start = $$params[0];
- my $len = $$params[1];
- return 'SUBSTRING("' . $self->{_relation} . '"."' . $self->name . "\",$start,$len)";
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::day_name;
-
-sub toSQL {
- my $self = shift;
- return 'TO_CHAR("' . $self->{_relation} . '"."' . $self->name . '", \'Day\')';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::month_name;
-
-sub toSQL {
- my $self = shift;
- return 'TO_CHAR("' . $self->{_relation} . '"."' . $self->name . '", \'Month\')';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::doy;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(DOY FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::woy;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(WEEK FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::moy;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(MONTH FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::qoy;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(QUARTER FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::dom;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(DAY FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::dow;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(DOW FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::year_trunc;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(YEAR FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::month_trunc;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(YEAR FROM "' . $self->{_relation} . '"."' . $self->name . '")' .
- ' || \'-\' || LPAD(EXTRACT(MONTH FROM "' . $self->{_relation} . '"."' . $self->name . '")::text,2,\'0\')';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::date_trunc;
-
-sub toSQL {
- my $self = shift;
- return 'DATE("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::hour_trunc;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(HOUR FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::quarter;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(YEAR FROM "' . $self->{_relation} . '"."' . $self->name . '")' .
- ' || \'-Q\' || EXTRACT(QUARTER FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::months_ago;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(MONTH FROM AGE(NOW(),"' . $self->{_relation} . '"."' . $self->name . '"))';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::hod;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(HOUR FROM "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::quarters_ago;
-
-sub toSQL {
- my $self = shift;
- return 'EXTRACT(QUARTER FROM AGE(NOW(),"' . $self->{_relation} . '"."' . $self->name . '"))';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::age;
-
-sub toSQL {
- my $self = shift;
- return 'AGE(NOW(),"' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 0 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::first;
-
-sub toSQL {
- my $self = shift;
- return 'FIRST("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::last;
-
-sub toSQL {
- my $self = shift;
- return 'LAST("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::min;
-
-sub toSQL {
- my $self = shift;
- return 'MIN("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::max;
-
-sub toSQL {
- my $self = shift;
- return 'MAX("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::count;
-
-sub toSQL {
- my $self = shift;
- return 'COUNT("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::count_distinct;
-
-sub toSQL {
- my $self = shift;
- return 'COUNT(DISTINCT "' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::sum;
-
-sub toSQL {
- my $self = shift;
- return 'SUM("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Transform::average;
-
-sub toSQL {
- my $self = shift;
- return 'AVG("' . $self->{_relation} . '"."' . $self->name . '")';
-}
-
-sub is_aggregate { return 1 }
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Where;
-use base qw/OpenILS::Reporter::SQLBuilder::Column/;
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new(@_);
-
- my $col_data = shift;
- $self->{_condition} = $col_data->{condition};
-
- return $self;
-}
-
-sub _flesh_conditions {
- my $cond = shift;
- my $builder = shift;
- $cond = [$cond] unless (ref($cond) eq 'ARRAY');
-
- my @out;
- for my $c (@$cond) {
- push @out, OpenILS::Reporter::SQLBuilder::Input->new( $c )->set_builder( $builder );
- }
-
- return \@out;
-}
-
-sub toSQL {
- my $self = shift;
-
- return $self->{_sql} if ($self->{_sql});
-
- my $sql = '';
-
- my $rel = $self->find_relation();
- if ($rel && $rel->is_nullable) {
- $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
- }
-
- $sql .= $self->SUPER::toSQL;
-
- my ($op) = keys %{ $self->{_condition} };
- my $val = _flesh_conditions( $self->resolve_param( $self->{_condition}->{$op} ), $self->builder );
-
- if (lc($op) eq 'in') {
- $sql .= " IN (". join(",", map { $_->toSQL } @$val).")";
-
- } elsif (lc($op) eq 'not in') {
- $sql .= " NOT IN (". join(",", map { $_->toSQL } @$val).")";
-
- } elsif (lc($op) eq '= any') {
- $val = $$val[0] if (ref($val) eq 'ARRAY');
- $val = $val->toSQL;
- if ($rel && $rel->is_nullable) { # need to redo this
- $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
- } else {
- $sql = '';
- }
- $sql .= "$val = ANY (".$self->SUPER::toSQL.")";
-
- } elsif (lc($op) eq '<> any') {
- $val = $$val[0] if (ref($val) eq 'ARRAY');
- $val = $val->toSQL;
- if ($rel && $rel->is_nullable) { # need to redo this
- $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
- } else {
- $sql = '';
- }
- $sql .= "$val <> ANY (".$self->SUPER::toSQL.")";
-
- } elsif (lc($op) eq 'is blank') {
- if ($rel && $rel->is_nullable) { # need to redo this
- $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
- } else {
- $sql = '';
- }
- $sql .= '('. $self->SUPER::toSQL ." IS NULL OR ". $self->SUPER::toSQL ." = '')";
-
- } elsif (lc($op) eq 'is not blank') {
- if ($rel && $rel->is_nullable) { # need to redo this
- $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
- } else {
- $sql = '';
- }
- $sql .= '('. $self->SUPER::toSQL ." IS NOT NULL AND ". $self->SUPER::toSQL ." <> '')";
-
- } elsif (lc($op) eq 'between') {
- $sql .= " BETWEEN ". join(" AND ", map { $_->toSQL } @$val);
-
- } elsif (lc($op) eq 'not between') {
- $sql .= " NOT BETWEEN ". join(" AND ", map { $_->toSQL } @$val);
-
- } elsif (lc($op) eq 'like') {
- $val = $$val[0] if (ref($val) eq 'ARRAY');
- $val = $val->toSQL;
- $val =~ s/^'(.*)'$/$1/o;
- $val =~ s/%/\\\\%/o;
- $val =~ s/_/\\\\_/o;
- $sql .= " LIKE '\%$val\%'";
-
- } elsif (lc($op) eq 'ilike') {
- $val = $$val[0] if (ref($val) eq 'ARRAY');
- $val = $val->toSQL;
- $val =~ s/^'(.*)'$/$1/o;
- $val =~ s/%/\\\\%/o;
- $val =~ s/_/\\\\_/o;
- $sql .= " ILIKE '\%$val\%'";
-
- } else {
- $val = $$val[0] if (ref($val) eq 'ARRAY');
- $sql .= " $op " . $val->toSQL;
- }
-
- if ($rel && $rel->is_nullable) {
- $sql .= ")";
- }
-
- return $self->{_sql} = $sql;
-}
-
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Column::Having;
-use base qw/OpenILS::Reporter::SQLBuilder::Column::Where/;
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Relation;
-use base qw/OpenILS::Reporter::SQLBuilder/;
-
-sub parse {
- my $self = shift;
- $self = $self->SUPER::new if (!ref($self));
-
- my $rel_data = shift;
- my $b = shift;
- $self->set_builder($b);
-
- $self->{_table} = $rel_data->{table};
- $self->{_alias} = $rel_data->{alias} || $self->{_table};
- $self->{_join} = [];
- $self->{_columns} = [];
-
- $self->builder->{_rels}{$self->{_alias}} = $self;
-
- if ($rel_data->{join}) {
- $self->add_join(
- $_ => OpenILS::Reporter::SQLBuilder::Relation->parse( $rel_data->{join}->{$_}, $b ) => $rel_data->{join}->{$_}->{key} => $rel_data->{join}->{$_}->{type}
- ) for ( keys %{ $rel_data->{join} } );
- }
-
- return $self;
-}
-
-sub add_column {
- my $self = shift;
- my $col = shift;
-
- push @{ $self->{_columns} }, $col;
-}
-
-sub find_column {
- my $self = shift;
- my $col = shift;
- return (grep { $_->name eq $col} @{ $self->{_columns} })[0];
-}
-
-sub add_join {
- my $self = shift;
- my $col = shift;
- my $frel = shift;
- my $fkey = shift;
- my $type = lc(shift()) || 'inner';
-
- if (UNIVERSAL::isa($col,'OpenILS::Reporter::SQLBuilder::Join')) {
- push @{ $self->{_join} }, $col;
- } else {
- push @{ $self->{_join} }, OpenILS::Reporter::SQLBuilder::Join->build( $self => $col, $frel => $fkey, $type );
- }
-
- return $self;
-}
-
-sub is_nullable {
- my $self = shift;
- return $self->{_nullable};
-}
-
-sub is_join {
- my $self = shift;
- my $j = shift;
- $self->{_is_join} = $j if ($j);
- return $self->{_is_join};
-}
-
-sub join_type {
- my $self = shift;
- my $j = shift;
- $self->{_join_type} = $j if ($j);
- return $self->{_join_type};
-}
-
-sub toSQL {
- my $self = shift;
- return $self->{_sql} if ($self->{_sql});
-
- my $sql = $self->{_table} .' AS "'. $self->{_alias} .'"';
-
- if (!$self->is_join) {
- for my $j ( @{ $self->{_join} } ) {
- $sql .= $j->toSQL;
- }
- }
-
- return $self->{_sql} = $sql;
-}
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Join;
-use base qw/OpenILS::Reporter::SQLBuilder/;
-
-sub build {
- my $class = shift;
- my $self = $class->SUPER::new if (!ref($class));
-
- $self->{_left_rel} = shift;
- ($self->{_left_col}) = split(/-/,shift());
-
- $self->{_right_rel} = shift;
- $self->{_right_col} = shift;
-
- $self->{_join_type} = shift;
-
- $self->{_right_rel}->set_builder($self->{_left_rel}->builder);
-
- $self->{_right_rel}->is_join(1);
- $self->{_right_rel}->join_type($self->{_join_type});
-
- bless $self => "OpenILS::Reporter::SQLBuilder::Join::$self->{_join_type}";
-
- if ( $self->{_join_type} eq 'inner' or !$self->{_join_type}) {
- $self->{_join_type} = 'i';
- } else {
- if ($self->{_join_type} eq 'left') {
- $self->{_right_rel}->{_nullable} = 'l';
- } elsif ($self->{_join_type} eq 'right') {
- $self->{_left_rel}->{_nullable} = 'r';
- } else {
- $self->{_right_rel}->{_nullable} = 'f';
- $self->{_left_rel}->{_nullable} = 'f';
- }
- }
-
- return $self;
-}
-
-sub toSQL {
- my $self = shift;
- my $dir = shift;
-
- my $sql = "JOIN " . $self->{_right_rel}->toSQL .
- ' ON ("' . $self->{_left_rel}->{_alias} . '"."' . $self->{_left_col} .
- '" = "' . $self->{_right_rel}->{_alias} . '"."' . $self->{_right_col} . '")';
-
- $sql .= $_->toSQL($dir) for (@{ $self->{_right_rel}->{_join} });
-
- return $sql;
-}
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Join::left;
-use base qw/OpenILS::Reporter::SQLBuilder::Join/;
-
-sub toSQL {
- my $self = shift;
- my $dir = shift;
- #return $self->{_sql} if ($self->{_sql});
-
- my $j = $dir && $dir eq 'r' ? 'FULL OUTER' : 'LEFT OUTER';
-
- my $sql = "\n\t$j ". $self->SUPER::toSQL('l');
-
- #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
-
- return $self->{_sql} = $sql;
-}
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Join::right;
-use base qw/OpenILS::Reporter::SQLBuilder::Join/;
-
-sub toSQL {
- my $self = shift;
- my $dir = shift;
- #return $self->{_sql} if ($self->{_sql});
-
- my $_nullable_rel = $dir && $dir eq 'l' ? '_right_rel' : '_left_rel';
- $self->{_left_rel}->{_nullable} = 'r';
- $self->{$_nullable_rel}->{_nullable} = $dir;
-
- my $j = $dir && $dir eq 'l' ? 'FULL OUTER' : 'RIGHT OUTER';
-
- my $sql = "\n\t$j ". $self->SUPER::toSQL('r');
-
- #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
-
- return $self->{_sql} = $sql;
-}
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Join::inner;
-use base qw/OpenILS::Reporter::SQLBuilder::Join/;
-
-sub toSQL {
- my $self = shift;
- my $dir = shift;
- #return $self->{_sql} if ($self->{_sql});
-
- my $_nullable_rel = $dir && $dir eq 'l' ? '_right_rel' : '_left_rel';
- $self->{$_nullable_rel}->{_nullable} = $dir;
-
- my $j = $dir ? ( $dir eq 'l' ? 'LEFT OUTER' : ( $dir eq 'r' ? 'RIGHT OUTER' : 'FULL OUTER' ) ) : 'INNER';
-
- my $sql = "\n\t$j ". $self->SUPER::toSQL;
-
- #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
-
- return $self->{_sql} = $sql;
-}
-
-#-------------------------------------------------------------------------------------------------
-package OpenILS::Reporter::SQLBuilder::Join::cross;
-use base qw/OpenILS::Reporter::SQLBuilder::Join/;
-
-sub toSQL {
- my $self = shift;
- #return $self->{_sql} if ($self->{_sql});
-
- $self->{_right_rel}->{_nullable} = 'f';
- $self->{_left_rel}->{_nullable} = 'f';
-
- my $sql = "\n\tFULL OUTER ". $self->SUPER::toSQL('f');
-
- #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
-
- return $self->{_sql} = $sql;
-}
-
-1;
+++ /dev/null
-#
-# ILS.pm: Test ILS interface module
-#
-
-package OpenILS::SIP;
-use warnings; use strict;
-
-use Sys::Syslog qw(syslog);
-use Time::HiRes q/time/;
-
-use OpenILS::SIP::Item;
-use OpenILS::SIP::Patron;
-use OpenILS::SIP::Transaction;
-use OpenILS::SIP::Transaction::Checkout;
-use OpenILS::SIP::Transaction::Checkin;
-use OpenILS::SIP::Transaction::Renew;
-
-use OpenSRF::System;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils qw/:datetime/;
-use DateTime::Format::ISO8601;
-use Encode;
-use Unicode::Normalize;
-my $U = 'OpenILS::Application::AppUtils';
-
-my $editor;
-my $config;
-my $target_encoding; # FIXME: this is configured at the institution level.
-
-use Digest::MD5 qw(md5_hex);
-
-sub new {
- my ($class, $institution, $login) = @_;
- my $type = ref($class) || $class;
- my $self = {};
-
- $self->{login} = $login;
-
- $config = $institution;
- syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
- $self->{institution} = $institution;
-
- my $bsconfig = $institution->{implementation_config}->{bootstrap};
- $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
-
- syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
-
- local $/ = "\n"; # why?
- OpenSRF::System->bootstrap_client(config_file => $bsconfig);
- syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
-
- $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
-
- Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
-
- bless( $self, $type );
-
- return undef unless
- $self->login( $login->{id}, $login->{password} );
-
- return $self;
-}
-
-sub fetch_session {
- my $self = shift;
-
- my $ses = $U->simplereq(
- 'open-ils.auth',
- 'open-ils.auth.session.retrieve', $self->{authtoken});
-
- return undef if $U->event_code($ses); # auth timed out
- return $self->{login_session} = $ses;
-}
-
-sub verify_session {
- my $self = shift;
-
- return 1 if $self->fetch_session;
-
- syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
- return $self->login( $self->{login}->{id}, $self->{login}->{password} );
-}
-
-sub editor {
- return $editor = make_editor();
-}
-
-sub config {
- return $config;
-}
-
-sub get_option_value {
- my($self, $option) = @_;
- my $ops = $config->{implementation_config}->{options}->{option};
- $ops = [$ops] unless ref $ops eq 'ARRAY';
- my @vals = grep { $_->{name} eq $option } @$ops;
- return @vals ? $vals[0]->{value} : undef;
-}
-
-
-# Creates the global editor object
-my $cstore_init = 1; # call init on first use
-sub make_editor {
- OpenILS::Utils::CStoreEditor::init() if $cstore_init;
- $cstore_init = 0;
- return OpenILS::Utils::CStoreEditor->new;
-}
-
-=head2 clean_text(scalar)
-
-Evergreen uses the UTF8 encoding for everything from the database up. Perl
-doesn't know this, however, so we have to convince it to treat our UTF8 strings
-as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
-for UTF8 text for SIP clients that support such modern options.
-
-The target encoding is set in the <encoding> element of the SIPServer.pm
-configuration file.
-
-=cut
-
-sub clean_text {
- my $text = shift || '';
-
- # Convert our incoming UTF8 data into Perl's internal string format
-
- # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
- # and latin-1 encodings (at least) require this to substitute
- # characters rather than simply returning a string truncated
- # after the first non-ASCII character
- $text = NFD(decode_utf8($text));
-
- if ($target_encoding eq 'ascii') {
-
- # Try to maintain a reasonable version of the content by
- # stripping diacritics from the text, given that the SIP client
- # wants just plain ASCII. This is the base requirement according
- # to the SIP2 specification.
-
- # Stripping the combining characters converts ""béè♁ts"
- # into "bee?ts" instead of "b???ts" - better, eh?
- $text =~ s/\pM+//og;
- }
-
- # Characters that cannot be represented in the target encoding will
- # generally be replaced with a question mark (?) character.
- $text = encode($target_encoding, $text);
-
- return $text;
-}
-
-my %org_sn_cache;
-sub shortname_from_id {
- my $id = shift or return;
- return $id->shortname if ref $id;
- return $org_sn_cache{$id} if $org_sn_cache{$id};
- return $org_sn_cache{$id} = editor()->retrieve_actor_org_unit($id)->shortname;
-}
-sub patron_barcode_from_id {
- my $id = shift or return;
- return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
-}
-
-sub format_date {
- my $class = shift;
- my $date = shift;
- my $type = shift || 'dob';
-
- return "" unless $date;
-
- $date = DateTime::Format::ISO8601->new->
- parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
- my @time = localtime($date->epoch);
-
- my $year = $time[5]+1900;
- my $mon = $time[4]+1;
- my $day = $time[3];
- my $hour = $time[2];
- my $minute = $time[1];
- my $second = $time[0];
-
- $date = sprintf("%04d%02d%02d", $year, $mon, $day);
-
- # Due dates need hyphen separators and time of day as well
- if ($type eq 'due') {
- $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
- }
-
- syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
- return $date;
-}
-
-
-
-sub login {
- my( $self, $username, $password ) = @_;
- syslog('LOG_DEBUG', "OILS: Logging in with username $username");
-
- my $seed = $U->simplereq(
- 'open-ils.auth',
- 'open-ils.auth.authenticate.init', $username );
-
- my $response = $U->simplereq(
- 'open-ils.auth',
- 'open-ils.auth.authenticate.complete',
- {
- username => $username,
- password => md5_hex($seed . md5_hex($password)),
- type => 'opac',
- }
- );
-
- if( my $code = $U->event_code($response) ) {
- my $txt = $response->{textcode};
- syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
- return undef;
- }
-
- my $key = $response->{payload}->{authtoken};
- syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
-
- $self->fetch_session; # to cache the login
-
- return $self->{authtoken} = $key;
-}
-
-
-sub find_patron {
- my $self = shift;
- return OpenILS::SIP::Patron->new(@_);
-}
-
-
-sub find_item {
- my $self = shift;
- return OpenILS::SIP::Item->new(@_);
-}
-
-
-sub institution {
- my $self = shift;
- return $self->{institution}->{id}; # consider making this return the whole institution
-}
-
-sub institution_id {
- my $self = shift;
- return $self->{institution}->{id}; # then use this for just the ID
-}
-
-sub supports {
- my ($self, $op) = @_;
- my ($i) = grep { $_->{name} eq $op }
- @{$config->{implementation_config}->{supports}->{item}};
- return to_bool($i->{value});
-}
-
-sub check_inst_id {
- my ($self, $id, $whence) = @_;
- if ($id ne $self->{institution}->{id}) {
- syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
- # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
- }
-}
-
-
-sub to_bool {
- my $bool = shift;
- # If it's defined, and matches a true sort of string, or is
- # a non-zero number, then it's true.
- defined($bool) or return; # false
- ($bool =~ /true|y|yes/i) and return 1; # true
- return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
-}
-
-sub checkout_ok {
- return to_bool($config->{policy}->{checkout});
-}
-
-sub checkin_ok {
- return to_bool($config->{policy}->{checkin});
-}
-
-sub renew_ok {
- return to_bool($config->{policy}->{renew});
-}
-
-sub status_update_ok {
- return to_bool($config->{policy}->{status_update});
-}
-
-sub offline_ok {
- return to_bool($config->{policy}->{offline});
-}
-
-
-
-##
-## Checkout(patron_id, item_id, sc_renew):
-## patron_id & item_id are the identifiers send by the terminal
-## sc_renew is the renewal policy configured on the terminal
-## returns a status opject that can be queried for the various bits
-## of information that the protocol (SIP or NCIP) needs to generate
-## the response.
-##
-
-sub checkout {
- my ($self, $patron_id, $item_id, $sc_renew) = @_;
- $sc_renew = 0;
-
- $self->verify_session;
-
- syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
-
- my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
- my $patron = $self->find_patron($patron_id);
- my $item = $self->find_item($item_id);
-
- $xact->patron($patron);
- $xact->item($item);
-
- if (!$patron) {
- $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
- return $xact;
- }
-
- if (!$patron->charge_ok) {
- $xact->screen_msg("Patron Blocked");
- return $xact;
- }
-
- if( !$item ) {
- $xact->screen_msg("Invalid Item Barcode: '$item_id'");
- return $xact;
- }
-
- syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
-
- if ($item->{patron} && ($item->{patron} eq $patron_id)) {
- syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
- $sc_renew = 1;
- } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
- # I can't deal with this right now
- # XXX check in then check out?
- $xact->screen_msg("Item checked out to another patron");
- $xact->ok(0);
- }
-
- $xact->do_checkout($sc_renew);
- $xact->desensitize(!$item->magnetic);
-
- if( $xact->ok ) {
- #editor()->commit;
- syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
- "patron %s checkout %s succeeded", $patron_id, $item_id);
- } else {
- #editor()->xact_rollback;
- syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
- "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
- }
-
- return $xact;
-}
-
-
-sub checkin {
- my ($self, $item_id, $inst_id, $trans_date, $return_date,
- $current_loc, $item_props, $cancel) = @_;
-
- my $start_time = time();
-
- $self->verify_session;
-
- syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
-
- my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
- my $item = OpenILS::SIP::Item->new($item_id);
-
- unless ( $xact->item($item) ) {
- $xact->ok(0);
- # $circ->alert(1); $circ->alert_type(99);
- $xact->screen_msg("Invalid Item Barcode: '$item_id'");
- syslog('LOG_INFO', "OILS: Checkin failed. " . $xact->screen_msg() );
- return $xact;
- }
-
- $xact->do_checkin( $self, $inst_id, $trans_date, $return_date, $current_loc, $item_props );
-
- if ($xact->ok) {
- $xact->patron($self->find_patron(usr => $xact->{circ_user_id}, slim_user => 1)) if $xact->{circ_user_id};
- delete $item->{patron};
- delete $item->{due_date};
- syslog('LOG_INFO', "OILS: Checkin succeeded");
- } else {
- syslog('LOG_WARNING', "OILS: Checkin failed");
- }
-
- syslog('LOG_INFO', "OILS: SIP Checkin request took %0.3f seconds", (time() - $start_time));
- return $xact;
-}
-
-## If the ILS caches patron information, this lets it free it up.
-## Also, this could be used for centrally logging session duration.
-## We don't do anything with it.
-sub end_patron_session {
- my ($self, $patron_id) = @_;
- return (1, 'Thank you!', '');
-}
-
-
-#sub pay_fee {
-# my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
-# $pay_type, $fee_id, $trans_id, $currency) = @_;
-# my $trans;
-# my $patron;
-#
-# $trans = new ILS::Transaction::FeePayment;
-#
-# $patron = new ILS::Patron $patron_id;
-#
-# $trans->transaction_id($trans_id);
-# $trans->patron($patron);
-# $trans->ok(1);
-#
-# return $trans;
-#}
-#
-#sub add_hold {
-# my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
-# $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
-# my ($patron, $item);
-# my $hold;
-# my $trans;
-#
-#
-# $trans = new ILS::Transaction::Hold;
-#
-# # BEGIN TRANSACTION
-# $patron = new ILS::Patron $patron_id;
-# if (!$patron
-# || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
-# $trans->screen_msg("Invalid Patron.");
-#
-# return $trans;
-# }
-#
-# $item = new ILS::Item ($item_id || $title_id);
-# if (!$item) {
-# $trans->screen_msg("No such item.");
-#
-# # END TRANSACTION (conditionally)
-# return $trans;
-# } elsif ($item->fee && ($fee_ack ne 'Y')) {
-# $trans->screen_msg = "Fee required to place hold.";
-#
-# # END TRANSACTION (conditionally)
-# return $trans;
-# }
-#
-# $hold = {
-# item_id => $item->id,
-# patron_id => $patron->id,
-# expiration_date => $expiry_date,
-# pickup_location => $pickup_location,
-# hold_type => $hold_type,
-# };
-#
-# $trans->ok(1);
-# $trans->patron($patron);
-# $trans->item($item);
-# $trans->pickup_location($pickup_location);
-#
-# push(@{$item->hold_queue}, $hold);
-# push(@{$patron->{hold_items}}, $hold);
-#
-#
-# # END TRANSACTION
-# return $trans;
-#}
-#
-#sub cancel_hold {
-# my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
-# my ($patron, $item, $hold);
-# my $trans;
-#
-# $trans = new ILS::Transaction::Hold;
-#
-# # BEGIN TRANSACTION
-# $patron = new ILS::Patron $patron_id;
-# if (!$patron) {
-# $trans->screen_msg("Invalid patron barcode.");
-#
-# return $trans;
-# } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
-# $trans->screen_msg('Invalid patron password.');
-#
-# return $trans;
-# }
-#
-# $item = new ILS::Item ($item_id || $title_id);
-# if (!$item) {
-# $trans->screen_msg("No such item.");
-#
-# # END TRANSACTION (conditionally)
-# return $trans;
-# }
-#
-# # Remove the hold from the patron's record first
-# $trans->ok($patron->drop_hold($item_id));
-#
-# if (!$trans->ok) {
-# # We didn't find it on the patron record
-# $trans->screen_msg("No such hold on patron record.");
-#
-# # END TRANSACTION (conditionally)
-# return $trans;
-# }
-#
-# # Now, remove it from the item record. If it was on the patron
-# # record but not on the item record, we'll treat that as success.
-# foreach my $i (0 .. scalar @{$item->hold_queue}) {
-# $hold = $item->hold_queue->[$i];
-#
-# if ($hold->{patron_id} eq $patron->id) {
-# # found it: delete it.
-# splice @{$item->hold_queue}, $i, 1;
-# last;
-# }
-# }
-#
-# $trans->screen_msg("Hold Cancelled.");
-# $trans->patron($patron);
-# $trans->item($item);
-#
-# return $trans;
-#}
-#
-#
-## The patron and item id's can't be altered, but the
-## date, location, and type can.
-#sub alter_hold {
-# my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
-# $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
-# my ($patron, $item);
-# my $hold;
-# my $trans;
-#
-# $trans = new ILS::Transaction::Hold;
-#
-# # BEGIN TRANSACTION
-# $patron = new ILS::Patron $patron_id;
-# if (!$patron) {
-# $trans->screen_msg("Invalid patron barcode.");
-#
-# return $trans;
-# }
-#
-# foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
-# $hold = $patron->{hold_items}[$i];
-#
-# if ($hold->{item_id} eq $item_id) {
-# # Found it. So fix it.
-# $hold->{expiration_date} = $expiry_date if $expiry_date;
-# $hold->{pickup_location} = $pickup_location if $pickup_location;
-# $hold->{hold_type} = $hold_type if $hold_type;
-#
-# $trans->ok(1);
-# $trans->screen_msg("Hold updated.");
-# $trans->patron($patron);
-# $trans->item(new ILS::Item $hold->{item_id});
-# last;
-# }
-# }
-#
-# # The same hold structure is linked into both the patron's
-# # list of hold items and into the queue of outstanding holds
-# # for the item, so we don't need to search the hold queue for
-# # the item, since it's already been updated by the patron code.
-#
-# if (!$trans->ok) {
-# $trans->screen_msg("No such outstanding hold.");
-# }
-#
-# return $trans;
-#}
-
-
-sub renew {
- my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
- $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
-
- $self->verify_session;
-
- my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
- $trans->patron($self->find_patron($patron_id));
- $trans->item($self->find_item($item_id));
-
- if(!$trans->patron) {
- $trans->screen_msg("Invalid patron barcode.");
- $trans->ok(0);
- return $trans;
- }
-
- if(!$trans->patron->renew_ok) {
- $trans->screen_msg("Renewals not allowed.");
- $trans->ok(0);
- return $trans;
- }
-
- if(!$trans->item) {
- if( $title_id ) {
- $trans->screen_msg("Title ID renewal not supported. Use item barcode.");
- } else {
- $trans->screen_msg("Invalid item barcode.");
- }
- $trans->ok(0);
- return $trans;
- }
-
- if(!$trans->item->{patron} or
- $trans->item->{patron} ne $patron_id) {
- $trans->screen_msg("Item not checked out to " . $trans->patron->name);
- $trans->ok(0);
- return $trans;
- }
-
- # Perform the renewal
- $trans->do_renew();
-
- $trans->desensitize(0); # It's already checked out
- $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
- $trans->item->{sip_item_properties} = $item_props if $item_props;
-
- return $trans;
-}
-
-
-
-
-
-#
-#sub renew_all {
-# my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
-# my ($patron, $item_id);
-# my $trans;
-#
-# $trans = new ILS::Transaction::RenewAll;
-#
-# $trans->patron($patron = new ILS::Patron $patron_id);
-# if (defined $patron) {
-# syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
-# $patron->name, $patron->renew_ok);
-# } else {
-# syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
-# $patron_id);
-# }
-#
-# if (!defined($patron)) {
-# $trans->screen_msg("Invalid patron barcode.");
-# return $trans;
-# } elsif (!$patron->renew_ok) {
-# $trans->screen_msg("Renewals not allowed.");
-# return $trans;
-# } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
-# $trans->screen_msg("Invalid patron password.");
-# return $trans;
-# }
-#
-# foreach $item_id (@{$patron->{items}}) {
-# my $item = new ILS::Item $item_id;
-#
-# if (!defined($item)) {
-# syslog("LOG_WARNING",
-# "renew_all: Invalid item id associated with patron '%s'",
-# $patron->id);
-# next;
-# }
-#
-# if (@{$item->hold_queue}) {
-# # Can't renew if there are outstanding holds
-# push @{$trans->unrenewed}, $item_id;
-# } else {
-# $item->{due_date} = time + (14*24*60*60); # two weeks hence
-# push @{$trans->renewed}, $item_id;
-# }
-# }
-#
-# $trans->ok(1);
-#
-# return $trans;
-#}
-
-1;
+++ /dev/null
-package OpenILS::SIP::Item;
-use strict; use warnings;
-
-use Sys::Syslog qw(syslog);
-use Carp;
-
-use OpenILS::SIP;
-use OpenILS::SIP::Transaction;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Circ::ScriptBuilder;
-# use Data::Dumper;
-use OpenILS::Const qw/:const/;
-use OpenSRF::Utils qw/:datetime/;
-use DateTime::Format::ISO8601;
-use OpenSRF::Utils::SettingsClient;
-my $U = 'OpenILS::Application::AppUtils';
-
-my %item_db;
-
-# 0 means read-only
-# 1 means read/write Actually, gloves are off. Set what you like.
-
-my %fields = (
- id => 0,
-# sip_media_type => 0,
- sip_item_properties => 0,
-# magnetic_media => 0,
- permanent_location => 0,
- current_location => 0,
-# print_line => 1,
-# screen_msg => 1,
-# itemnumber => 0,
-# biblionumber => 0,
- hold => 0,
- hold_patron_bcode => 0,
- hold_patron_name => 0,
- barcode => 0,
- onloan => 0,
- collection_code => 0,
- destination_loc => 0,
- call_number => 0,
- enumchron => 0,
- location => 0,
- author => 0,
- title => 0,
- copy => 0,
- volume => 0,
- record => 0,
- mods => 0,
-);
-
-our $AUTOLOAD;
-sub DESTROY { } # keeps AUTOLOAD from catching inherent DESTROY calls
-
-sub AUTOLOAD {
- my $self = shift;
- my $class = ref($self) or croak "$self is not an object";
- my $name = $AUTOLOAD;
-
- $name =~ s/.*://;
-
- unless (exists $fields{$name}) {
- croak "Cannot access '$name' field of class '$class'";
- }
-
- if (@_) {
- # $fields{$name} or croak "Field '$name' of class '$class' is READ ONLY."; # nah, go ahead
- return $self->{$name} = shift;
- } else {
- return $self->{$name};
- }
-}
-
-
-sub new {
- my ($class, $item_id) = @_;
- my $type = ref($class) || $class;
- my $self = bless( {}, $type );
-
- syslog('LOG_DEBUG', "OILS: Loading item $item_id...");
- return undef unless $item_id;
-
- my $e = OpenILS::SIP->editor();
-
- my $copy = $e->search_asset_copy(
- [
- { barcode => $item_id, deleted => 'f' },
- {
- flesh => 3,
- flesh_fields => {
- acp => [ 'circ_lib', 'call_number', 'status' ],
- acn => [ 'owning_lib', 'record' ],
- }
- }
- ]
- )->[0];
-
- if(!$copy) {
- syslog("LOG_DEBUG", "OILS: Item '%s' : not found", $item_id);
- return undef;
- }
-
- my $circ = $e->search_action_circulation([
- {
- target_copy => $copy->id,
- stop_fines_time => undef,
- checkin_time => undef
- },
- {
- flesh => 2,
- flesh_fields => {
- circ => ['usr'],
- au => ['card']
- }
- }
- ])->[0];
-
- if($circ) {
-
- my $user = $circ->usr;
- my $bc = ($user->card) ? $user->card->barcode : '';
- $self->{patron} = $bc;
- $self->{patron_object} = $user;
-
- syslog('LOG_DEBUG', "OILS: Open circulation exists on $item_id : user = $bc");
- }
-
- $self->{id} = $item_id;
- $self->{copy} = $copy;
- $self->{volume} = $copy->call_number;
- $self->{record} = $copy->call_number->record;
- $self->{call_number} = $copy->call_number->label;
- $self->{mods} = $U->record_to_mvr($self->{record}) if $self->{record}->marc;
- $self->{transit} = $self->fetch_transit;
- $self->{hold} = $self->fetch_hold;
-
-
- # use the non-translated version of the copy location as the
- # collection code, since it may be used for additional routing
- # purposes by the SIP client. Config option?
- $self->{collection_code} =
- $e->retrieve_asset_copy_location([
- $copy->location, {no_i18n => 1}])->name;
-
-
- if($self->{transit}) {
- $self->{destination_loc} = $self->{transit}->dest->shortname;
-
- } elsif($self->{hold}) {
- $self->{destination_loc} = $self->{hold}->pickup_lib->shortname;
- }
-
- syslog("LOG_DEBUG", "OILS: Item('$item_id'): found with title '%s'", $self->title_id);
-
- my $config = OpenILS::SIP->config(); # FIXME : will not always match!
- my $legacy = $config->{implementation_config}->{legacy_script_support} || undef;
-
- if( defined $legacy ) {
- $self->{legacy_script_support} = ($legacy =~ /t(rue)?/io) ? 1 : 0;
- syslog("LOG_DEBUG", "legacy_script_support is set in SIP config: " . $self->{legacy_script_support});
-
- } else {
- my $lss = OpenSRF::Utils::SettingsClient->new->config_value(
- apps => 'open-ils.circ',
- app_settings => 'legacy_script_support'
- );
- $self->{legacy_script_support} = ($lss =~ /t(rue)?/io) ? 1 : 0;
- syslog("LOG_DEBUG", "legacy_script_support is set in SRF config: " . $self->{legacy_script_support});
- }
-
- return $self;
-}
-
-# fetch copy transit
-sub fetch_transit {
- my $self = shift;
- my $copy = $self->{copy} or return;
- my $e = OpenILS::SIP->editor();
-
- if ($copy->status->id == OILS_COPY_STATUS_IN_TRANSIT) {
- my $transit = $e->search_action_transit_copy([
- {
- target_copy => $copy->id, # NOT barcode ($self->id)
- dest_recv_time => undef
- },
- {
- flesh => 1,
- flesh_fields => {
- atc => ['dest']
- }
- }
- ])->[0];
-
- syslog('LOG_WARNING', "OILS: Item(".$copy->barcode.
- ") status is In Transit, but no action.transit_copy found!") unless $transit;
-
- return $transit;
- }
-
- return undef;
-}
-
-# fetch captured hold.
-# Assume transit has already beeen fetched
-sub fetch_hold {
- my $self = shift;
- my $copy = $self->{copy} or return;
- my $e = OpenILS::SIP->editor();
-
- if( ($copy->status->id == OILS_COPY_STATUS_ON_HOLDS_SHELF) ||
- ($self->{transit} and $self->{transit}->copy_status == OILS_COPY_STATUS_ON_HOLDS_SHELF) ) {
- # item has been captured for a hold
-
- my $hold = $e->search_action_hold_request([
- {
- current_copy => $copy->id,
- capture_time => {'!=' => undef},
- cancel_time => undef,
- fulfillment_time => undef
- },
- {
- limit => 1,
- flesh => 1,
- flesh_fields => {
- ahr => ['pickup_lib']
- }
- }
- ])->[0];
-
- syslog('LOG_WARNING', "OILS: Item(".$copy->barcode.
- ") is captured for a hold, but there is no matching hold request") unless $hold;
-
- return $hold;
- }
-
- return undef;
-}
-
-sub run_attr_script {
- my $self = shift;
- return 1 if $self->{ran_script};
- $self->{ran_script} = 1;
-
- if($self->{legacy_script_support}){
-
- syslog('LOG_DEBUG', "Legacy script support is ON");
- my $config = OpenILS::SIP->config();
- my $path = $config->{implementation_config}->{scripts}->{path};
- my $item_config_script = $config->{implementation_config}->{scripts}->{item_config};
-
- $path = ref($path) eq 'ARRAY' ? $path : [$path];
- my $path_str = join(", ", @$path);
-
- syslog('LOG_DEBUG', "OILS: Script path = [$path_str], Item config script = $item_config_script");
-
- my $runner = OpenILS::Application::Circ::ScriptBuilder->build({
- copy => $self->{copy},
- editor => OpenILS::SIP->editor(),
- });
-
- $runner->add_path($_) for @$path;
- $runner->load($item_config_script);
-
- unless( $self->{item_config_result} = $runner->run ) { # assignment, not comparison
- $runner->cleanup;
- warn "Item config script [$path_str : $item_config_script] failed to run: $@\n";
- syslog('LOG_ERR', "OILS: Item config script [$path_str : $item_config_script] failed to run: $@");
- return undef;
- }
-
- $runner->cleanup;
-
- } else {
-
- # use the in-db circ modifier configuration
- my $config = {magneticMedia => 'f', SIPMediaType => '001'}; # defaults
- my $mod = $self->{copy}->circ_modifier;
-
- if($mod) {
- my $mod_obj = OpenILS::SIP->editor()->retrieve_config_circ_modifier($mod);
- if($mod_obj) {
- $config->{magneticMedia} = $mod_obj->magnetic_media;
- $config->{SIPMediaType} = $mod_obj->sip2_media_type;
- }
- }
-
- $self->{item_config_result} = { item_config => $config };
- }
-
- return 1;
-}
-
-sub magnetic_media {
- my $self = shift;
- $self->magnetic(@_);
-}
-sub magnetic {
- my $self = shift;
- return 0 unless $self->run_attr_script;
- my $mag = $self->{item_config_result}->{item_config}->{magneticMedia} || '';
- syslog('LOG_DEBUG', "OILS: magnetic = $mag");
- return ($mag and $mag =~ /t(rue)?/io) ? 1 : 0;
-}
-
-sub sip_media_type {
- my $self = shift;
- return 0 unless $self->run_attr_script;
- my $media = $self->{item_config_result}->{item_config}->{SIPMediaType} || '';
- syslog('LOG_DEBUG', "OILS: media type = $media");
- return ($media) ? $media : '001';
-}
-
-sub title_id {
- my $self = shift;
- my $t = ($self->{mods}) ? $self->{mods}->title : $self->{copy}->dummy_title;
- return OpenILS::SIP::clean_text($t);
-}
-
-sub permanent_location {
- my $self = shift;
- return OpenILS::SIP::clean_text($self->{copy}->circ_lib->shortname);
-}
-
-sub current_location {
- my $self = shift;
- return OpenILS::SIP::clean_text($self->{copy}->circ_lib->shortname);
-}
-
-
-# 2 chars 0-99
-# 01 Other
-# 02 On order
-# 03 Available
-# 04 Charged
-# 05 Charged; not to be recalled until earliest recall date
-# 06 In process
-# 07 Recalled
-# 08 Waiting on hold shelf
-# 09 Waiting to be re-shelved
-# 10 In transit between library locations
-# 11 Claimed returned
-# 12 Lost
-# 13 Missing
-sub sip_circulation_status {
- my $self = shift;
- my $stat = $self->{copy}->status->id;
-
- return '02' if $stat == OILS_COPY_STATUS_ON_ORDER;
- return '03' if $stat == OILS_COPY_STATUS_AVAILABLE;
- return '04' if $stat == OILS_COPY_STATUS_CHECKED_OUT;
- return '06' if $stat == OILS_COPY_STATUS_IN_PROCESS;
- return '08' if $stat == OILS_COPY_STATUS_ON_HOLDS_SHELF;
- return '09' if $stat == OILS_COPY_STATUS_RESHELVING;
- return '10' if $stat == OILS_COPY_STATUS_IN_TRANSIT;
- return '12' if $stat == OILS_COPY_STATUS_LOST;
- return '13' if $stat == OILS_COPY_STATUS_MISSING;
-
- return 01;
-}
-
-sub sip_security_marker {
- return '02'; # FIXME? 00-other; 01-None; 02-Tattle-Tape Security Strip (3M); 03-Whisper Tape (3M)
-}
-
-sub sip_fee_type {
- return '01'; # FIXME? 01-09 enumerated in spec. We just use O1-other/unknown.
-}
-
-sub fee { # TODO
- my $self = shift;
- return 0;
-}
-
-
-sub fee_currency {
- my $self = shift;
- return OpenILS::SIP->config()->{implementation_config}->{currency};
-}
-
-sub owner {
- my $self = shift;
- return OpenILS::SIP::clean_text($self->{copy}->circ_lib->shortname);
-}
-
-sub hold_queue {
- my $self = shift;
- return [];
-}
-
-sub hold_queue_position { # TODO
- my ($self, $patron_id) = @_;
- return 1;
-}
-
-sub due_date {
- my $self = shift;
-
- # this should force correct circ fetching
- require OpenILS::Utils::CStoreEditor;
- my $e = OpenILS::Utils::CStoreEditor->new(xact => 1);
- #my $e = OpenILS::SIP->editor();
-
- my $circ = $e->search_action_circulation(
- { target_copy => $self->{copy}->id, checkin_time => undef } )->[0];
-
- $e->rollback;
-
- if( !$circ ) {
- syslog('LOG_INFO', "OILS: No open circ found for copy");
- return 0;
- }
-
- my $due = OpenILS::SIP->format_date($circ->due_date, 'due');
- syslog('LOG_DEBUG', "OILS: Found item due date = $due");
- return $due;
-}
-
-sub recall_date { # TODO
- my $self = shift;
- return 0;
-}
-
-
-# Note: If the held item is in transit, this will be an approximation of shelf
-# expire time, since the time is not set until the item is checked in at the pickup location
-my %shelf_expire_setting_cache;
-sub hold_pickup_date {
- my $self = shift;
- my $copy = $self->{copy};
- my $hold = $self->{hold} or return 0;
-
- my $date = $hold->shelf_expire_time;
-
- if(!$date) {
- # hold has not hit the shelf. create a best guess.
-
- my $interval = $shelf_expire_setting_cache{$hold->pickup_lib->id} ||
- $U->ou_ancestor_setting_value(
- $hold->pickup_lib->id,
- 'circ.holds.default_shelf_expire_interval');
-
- $shelf_expire_setting_cache{$hold->pickup_lib->id} = $interval;
-
- if($interval) {
- my $seconds = OpenSRF::Utils->interval_to_seconds($interval);
- $date = DateTime->now->add(seconds => $seconds);
- $date = $date->strftime('%FT%T%z') if $date;
- }
- }
-
- return OpenILS::SIP->format_date($date) if $date;
-
- return 0;
-}
-
-# message to display on console
-sub screen_msg {
- my $self = shift;
- return OpenILS::SIP::clean_text($self->{screen_msg}) || '';
-}
-
-
-# reciept printer
-sub print_line {
- my $self = shift;
- return OpenILS::SIP::clean_text($self->{print_line}) || '';
-}
-
-
-# An item is available for a patron if
-# 1) It's not checked out and (there's no hold queue OR patron
-# is at the front of the queue)
-# OR
-# 2) It's checked out to the patron and there's no hold queue
-sub available {
- my ($self, $for_patron) = @_;
-
- my $stat = $self->{copy}->status->id;
- return 1 if
- $stat == OILS_COPY_STATUS_AVAILABLE or
- $stat == OILS_COPY_STATUS_RESHELVING;
-
- return 0;
-}
-
-
-1;
-__END__
-
-=head1 NAME
-
-OpenILS::SIP::Item - SIP abstraction layer for OpenILS Items.
-
-=head1 DESCRIPTION
-
-=head2 owning_lib vs. circ_lib
-
-In Evergreen, owning_lib is the org unit that purchased the item, the place to which the item
-should return after it's done rotating/floating to other branches (via staff intervention),
-or some combination of those. The owning_lib, however, is not necessarily where the item
-should be going "right now" or where it should return to by default. That would be the copy
-circ_lib or the transit destination. (In fact, the item may B<never> go to the owning_lib for
-its entire existence). In the context of SIP, the circ_lib more accurately describes the item's
-permanent location, i.e. where it needs to be sent if it's not en route to somewhere else.
-
-This confusion extends also to the SIP extension field of "owner". It means that the SIP owner does not
-correspond to EG's asset.volume.owning_lib, mainly because owning_lib is effectively the "ultimate
-owner" but not necessarily the "current owner". Because we populate SIP fields with circ_lib, the
-owning_lib is unused by SIP.
-
-=head1 TODO
-
-Holds queue logic
-
-=cut
+++ /dev/null
-package OpenILS::SIP::Msg;
-use strict; use warnings;
-# -------------------------------------------------------
-# Defines the various screen messages
-# Currently they are just constants.. they need to be
-# moved to an external lang-specific source
-# -------------------------------------------------------
-use vars qw(@EXPORT_OK %EXPORT_TAGS);
-use Exporter;
-use base qw/Exporter/;
-
-
-# ---------------------------------------------------------------------
-# Shoves defined constants into the export array
-# so they don't have to be listed twice in the code
-# ---------------------------------------------------------------------
-sub econst {
- my($name, $value) = @_;
- my $caller = caller;
- no strict;
- *{$name} = sub () { $value };
- push @{$caller.'::EXPORT_OK'}, $name;
-}
-
-
-econst OILS_SIP_MSG_CIRC_EXISTS => 'This item is already checked out';
-econst OILS_SIP_MSG_CIRC_PERMIT_FAILED => 'Patron is not allowed to check out the selected item';
-
-%EXPORT_TAGS = ( const => [ @EXPORT_OK ] );
-
-
+++ /dev/null
-#
-#
-# A Class for hiding the ILS's concept of the patron from the OpenSIP
-# system
-#
-
-package OpenILS::SIP::Patron;
-
-use strict;
-use warnings;
-use Exporter;
-
-use Sys::Syslog qw(syslog);
-use Data::Dumper;
-use Digest::MD5 qw(md5_hex);
-
-use OpenILS::SIP;
-use OpenILS::Application::AppUtils;
-use OpenILS::Application::Actor;
-use OpenSRF::Utils qw/:datetime/;
-use DateTime::Format::ISO8601;
-my $U = 'OpenILS::Application::AppUtils';
-
-our (@ISA, @EXPORT_OK);
-
-@ISA = qw(Exporter);
-
-@EXPORT_OK = qw(invalid_patron);
-
-my $INET_PRIVS;
-
-#
-# OpenILS::SIP::Patron->new($barcode);
-# OpenILS::SIP::Patron->new(barcode => $barcode); # same as above
-# OpenILS::SIP::Patron->new( usr => $id);
-
-sub new {
- my $class = shift;
- my $key = (@_ > 1) ? shift : 'barcode'; # if we have multiple args, the first is the key index (default barcode)
- my $patron_id = shift;
- my %args = @_;
-
- if ($key ne 'usr' and $key ne 'barcode') {
- syslog("LOG_ERROR", "Patron (card) lookup requested by illegeal key '$key'");
- return undef;
- }
-
- unless(defined $patron_id) {
- syslog("LOG_WARNING", "No patron ID provided to ILS::Patron->new");
- return undef;
- }
-
- my $type = ref($class) || $class;
- my $self = bless({}, $type);
-
- syslog("LOG_DEBUG", "OILS: new OpenILS Patron(%s => %s): searching...", $key, $patron_id);
-
- my $e = OpenILS::SIP->editor();
-
- my $usr_flesh = {
- flesh => 2,
- flesh_fields => {
- au => [
- "card",
- "addresses",
- "billing_address",
- "mailing_address",
- 'profile',
- ],
- }
- };
-
- # in some cases, we don't need all of this data. Only fetch the user + barcode
- $usr_flesh = {flesh => 1, flesh_fields => {au => ['card']}} if $args{slim_user};
-
- my $user;
- if($key eq 'barcode') { # retrieve user by barcode
-
- $$usr_flesh{flesh} += 1;
- $$usr_flesh{flesh_fields}{ac} = ['usr'];
-
- my $card = $e->search_actor_card([{barcode => $patron_id}, $usr_flesh])->[0];
-
- if(!$card) {
- syslog("LOG_WARNING", "No such patron barcode: $patron_id");
- return undef;
- }
-
- $user = $card->usr;
-
- } else {
- $user = $e->retrieve_actor_user([$patron_id, $usr_flesh]);
- }
-
- if(!$user) {
- syslog("LOG_WARNING", "OILS: Unable to find patron %s => %s", $key, $patron_id);
- return undef;
- }
-
- # now grab the user's penalties
-
- $self->flesh_user_penalties($user, $e) unless $args{slim_user};
-
- $self->{editor} = $e;
- $self->{user} = $user;
- $self->{id} = ($key eq 'barcode') ? $patron_id : $user->card->barcode; # The barcode IS the ID to SIP.
- # We give back the passed barcode if the key was indeed a barcode, just to be safe. Otherwise pull it from the card.
-
- syslog("LOG_DEBUG", "OILS: new OpenILS Patron(%s => %s): found patron : barred=%s, card:active=%s",
- $key, $patron_id, $user->barred, $user->card->active );
-
- return $self;
-}
-
-# grab patron penalties. Only grab non-archived penalties that are for fines,
-# excessive overdues, or otherwise block circluation activity
-sub flesh_user_penalties {
- my ($self, $user, $e) = @_;
-
- $user->standing_penalties(
- $e->search_actor_user_standing_penalty([
- {
- usr => $user->id,
- '-or' => [
-
- # ignore "archived" penalties
- {stop_date => undef},
- {stop_date => {'>' => 'now'}}
- ],
-
- org_unit => {
- in => {
- select => {
- aou => [{
- column => 'id',
- transform => 'actor.org_unit_ancestors',
- result_field => 'id'
- }]
- },
- from => 'aou',
-
- # at this point, there is no concept of "here", so fetch penalties
- # for the patron's home lib plus ancestors
- where => {id => $user->home_ou},
- distinct => 1
- }
- },
-
- # in addition to fines and excessive overdue penalties,
- # we only care about penalties that result in blocks
- standing_penalty => {
- in => {
- select => {csp => ['id']},
- from => 'csp',
- where => {
- '-or' => [
- {id => [1,2]}, # fines / overdues
- {block_list => {'!=' => undef}}
- ]
- },
- }
- }
- },
- ])
- );
-}
-
-sub id {
- my $self = shift;
- return $self->{id};
-}
-
-sub name {
- my $self = shift;
- return format_name($self->{user});
-}
-
-sub format_name {
- my $u = shift;
- return OpenILS::SIP::clean_text(
- sprintf('%s %s %s',
- ($u->first_given_name || ''),
- ($u->second_given_name || ''),
- ($u->family_name || '')));
-}
-
-sub home_library {
- my $self = shift;
- my $lib = OpenILS::SIP::shortname_from_id($self->{user}->home_ou);
- syslog('LOG_DEBUG', "OILS: Patron->home_library() = $lib");
- return $lib;
-}
-
-sub __addr_string {
- my $addr = shift;
- return "" unless $addr;
- my $return = OpenILS::SIP::clean_text(
- join( ' ', map {$_ || ''} (
- $addr->street1,
- $addr->street2,
- $addr->city . ',',
- $addr->county,
- $addr->state,
- $addr->country,
- $addr->post_code
- )
- )
- );
- $return =~ s/\s+/ /sg; # Compress any run of of whitespace to one space
- return $return;
-}
-
-sub internal_id {
- my $self = shift;
- return $self->{user}->id;
-}
-
-sub address {
- my $self = shift;
- my $u = $self->{user};
- my $str = __addr_string($u->billing_address || $u->mailing_address);
- syslog('LOG_DEBUG', "OILS: Patron address: $str");
- return $str;
-}
-
-sub email_addr {
- my $self = shift;
- return OpenILS::SIP::clean_text($self->{user}->email);
-}
-
-sub home_phone {
- my $self = shift;
- return $self->{user}->day_phone;
-}
-
-sub sip_birthdate {
- my $self = shift;
- my $dob = OpenILS::SIP->format_date($self->{user}->dob);
- syslog('LOG_DEBUG', "OILS: Patron DOB = $dob");
- return $dob;
-}
-
-sub ptype {
- my $self = shift;
-
- my $use_code = OpenILS::SIP->get_option_value('patron_type_uses_code') || '';
-
- # should we use the no_i18n version of patron profile name (as a 'code')?
- return $self->{editor}->retrieve_permission_grp_tree(
- [$self->{user}->profile->id, {no_i18n => 1}])->name
- if $use_code =~ /true/io;
-
- return OpenILS::SIP::clean_text($self->{user}->profile->name);
-}
-
-sub language {
- my $self = shift;
- return '000'; # Unspecified
-}
-
-# How much more detail do we need to check here?
-sub charge_ok {
- my $self = shift;
- my $u = $self->{user};
- return (($u->barred eq 'f') and ($u->card->active eq 't'));
-}
-
-# How much more detail do we need to check here?
-sub renew_ok {
- my $self = shift;
- return $self->charge_ok;
-}
-
-sub recall_ok {
- my $self = shift;
- return 0;
-}
-
-sub hold_ok {
- my $self = shift;
- return $self->charge_ok;
-}
-
-# return true if the card provided is marked as lost
-sub card_lost {
- my $self = shift;
- return $self->{user}->card->active eq 'f';
-}
-
-sub recall_overdue { # not implemented
- my $self = shift;
- return 0;
-}
-
-sub check_password {
- my ($self, $pwd) = @_;
- syslog('LOG_DEBUG', 'OILS: Patron->check_password()');
- return 0 unless (defined $pwd and $self->{user});
- return md5_hex($pwd) eq $self->{user}->passwd;
-}
-
-sub currency { # not really implemented
- my $self = shift;
- syslog('LOG_DEBUG', 'OILS: Patron->currency()');
- return 'USD';
-}
-
-sub fee_amount {
- my $self = shift;
- syslog('LOG_DEBUG', 'OILS: Patron->fee_amount()');
- my $user_id = $self->{user}->id;
-
- my $e = $self->{editor};
- $e->xact_begin;
- my $summary = $e->retrieve_money_open_user_summary($user_id);
- $e->rollback; # xact_rollback + disconnect
-
- my $total = ($summary) ? $summary->balance_owed : 0;
- syslog('LOG_INFO', "User ".$self->{id} .":$user_id has a fee amount of \$$total");
- return $total;
-}
-
-sub screen_msg {
- my $self = shift;
- my $u = $self->{user};
-
- return 'barred' if $u->barred eq 't';
-
- my $b = 'blocked';
-
- return $b if $u->active eq 'f';
- return $b if $u->card->active eq 'f';
-
- # if we have any penalties at this point, they are blocking penalties
- return $b if $u->standing_penalties and @{$u->standing_penalties};
-
- # has the patron account expired?
- my $expire = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($u->expire_date));
- return $b if CORE::time > $expire->epoch;
-
- return 'OK';
-}
-
-sub print_line { # not implemented
- my $self = shift;
- return '';
-}
-
-sub too_many_charged { # not implemented
- my $self = shift;
- return 0;
-}
-
-sub too_many_overdue {
- my $self = shift;
- return scalar( # PATRON_EXCEEDS_OVERDUE_COUNT
- grep { $_->standing_penalty == 2 } @{$self->{user}->standing_penalties}
- );
-}
-
-# not completely sure what this means
-sub too_many_renewal {
- my $self = shift;
- return 0;
-}
-
-# not relevant, handled by fines/fees
-sub too_many_claim_return {
- my $self = shift;
- return 0;
-}
-
-# not relevant, handled by fines/fees
-sub too_many_lost {
- my $self = shift;
- return 0;
-}
-
-sub excessive_fines {
- my $self = shift;
- return scalar( # PATRON_EXCEEDS_FINES
- grep { $_->standing_penalty == 1 } @{$self->{user}->standing_penalties}
- );
-}
-
-# Until someone suggests otherwise, fees and fines are the same
-
-sub excessive_fees {
- my $self = shift;
- return $self->excessive_fines;
-}
-
-# not relevant, handled by fines/fees
-sub too_many_billed {
- my $self = shift;
- return 0;
-}
-
-
-
-#
-# List of outstanding holds placed
-#
-sub hold_items {
- my ($self, $start, $end) = @_;
- syslog('LOG_DEBUG', 'OILS: Patron->hold_items()');
-
- my $holds = $self->{editor}->search_action_hold_request(
- { usr => $self->{user}->id, fulfillment_time => undef, cancel_time => undef }
- );
-
- my @holds;
- push( @holds, OpenILS::SIP::clean_text($self->__hold_to_title($_)) ) for @$holds;
-
- return (defined $start and defined $end) ?
- [ $holds[($start-1)..($end-1)] ] :
- \@holds;
-}
-
-sub __hold_to_title {
- my $self = shift;
- my $hold = shift;
- my $e = $self->{editor};
-
- my( $id, $mods, $title, $volume, $copy );
-
- return __copy_to_title($e,
- $e->retrieve_asset_copy($hold->target))
- if $hold->hold_type eq 'C';
-
- return __volume_to_title($e,
- $e->retrieve_asset_call_number($hold->target))
- if $hold->hold_type eq 'V';
-
- return __record_to_title(
- $e, $hold->target) if $hold->hold_type eq 'T';
-
- return __metarecord_to_title(
- $e, $hold->target) if $hold->hold_type eq 'M';
-}
-
-sub __copy_to_title {
- my( $e, $copy ) = @_;
- #syslog('LOG_DEBUG', "OILS: copy_to_title(%s)", $copy->id);
- return $copy->dummy_title if $copy->call_number == -1;
-
- my $vol = (ref $copy->call_number) ?
- $copy->call_number :
- $e->retrieve_asset_call_number($copy->call_number);
-
- return __volume_to_title($e, $vol);
-}
-
-
-sub __volume_to_title {
- my( $e, $volume ) = @_;
- #syslog('LOG_DEBUG', "OILS: volume_to_title(%s)", $volume->id);
- return __record_to_title($e, $volume->record);
-}
-
-
-sub __record_to_title {
- my( $e, $title_id ) = @_;
- #syslog('LOG_DEBUG', "OILS: record_to_title($title_id)");
- my $mods = $U->simplereq(
- 'open-ils.search',
- 'open-ils.search.biblio.record.mods_slim.retrieve', $title_id );
- return ($mods) ? $mods->title : "";
-}
-
-sub __metarecord_to_title {
- my( $e, $m_id ) = @_;
- #syslog('LOG_DEBUG', "OILS: metarecord_to_title($m_id)");
- my $mods = $U->simplereq(
- 'open-ils.search',
- 'open-ils.search.biblio.metarecord.mods_slim.retrieve', $m_id);
- return ($U->event_code($mods)) ? "<unknown>" : $mods->title;
-}
-
-
-#
-# remove the hold on item item_id from my hold queue.
-# return true if I was holding the item, false otherwise.
-#
-sub drop_hold {
- my ($self, $item_id) = @_;
- return 0;
-}
-
-sub __patron_items_info {
- my $self = shift;
- return if $self->{item_info};
- $self->{item_info} =
- OpenILS::Application::Actor::_checked_out(
- 0, $self->{editor}, $self->{user}->id);;
-}
-
-
-
-sub overdue_items {
- my ($self, $start, $end) = @_;
-
- $self->__patron_items_info();
- my @overdues = @{$self->{item_info}->{overdue}};
- #$overdues[$_] = __circ_to_title($self->{editor}, $overdues[$_]) for @overdues;
-
- my @o;
- syslog('LOG_DEBUG', "OILS: overdue_items() fleshing circs @overdues");
-
- my $return_datatype = OpenILS::SIP->get_option_value('msg64_summary_datatype') || '';
-
- for my $circid (@overdues) {
- next unless $circid;
- if($return_datatype eq 'barcode') {
- push( @o, __circ_to_barcode($self->{editor}, $circid));
- } else {
- push( @o, OpenILS::SIP::clean_text(__circ_to_title($self->{editor}, $circid)));
- }
- }
- @overdues = @o;
-
- return (defined $start and defined $end) ?
- [ $overdues[($start-1)..($end-1)] ] : \@overdues;
-}
-
-sub __circ_to_barcode {
- my ($e, $circ) = @_;
- return unless $circ;
- $circ = $e->retrieve_action_circulation($circ);
- my $copy = $e->retrieve_asset_copy($circ->target_copy);
- return $copy->barcode;
-}
-
-sub __circ_to_title {
- my( $e, $circ ) = @_;
- return unless $circ;
- $circ = $e->retrieve_action_circulation($circ);
- return __copy_to_title( $e,
- $e->retrieve_asset_copy($circ->target_copy) );
-}
-
-sub charged_items {
- my ($self, $start, $end) = shift;
-
- $self->__patron_items_info();
-
- my @charges = (
- @{$self->{item_info}->{out}},
- @{$self->{item_info}->{overdue}}
- );
-
- #$charges[$_] = __circ_to_title($self->{editor}, $charges[$_]) for @charges;
-
- my @c;
- syslog('LOG_DEBUG', "OILS: charged_items() fleshing circs @charges");
-
- my $return_datatype = OpenILS::SIP->get_option_value('msg64_summary_datatype') || '';
-
- for my $circid (@charges) {
- next unless $circid;
- if($return_datatype eq 'barcode') {
- push( @c, __circ_to_barcode($self->{editor}, $circid));
- } else {
- push( @c, OpenILS::SIP::clean_text(__circ_to_title($self->{editor}, $circid)));
- }
- }
-
- @charges = @c;
-
- return (defined $start and defined $end) ?
- [ $charges[($start-1)..($end-1)] ] :
- \@charges;
-}
-
-sub fine_items {
- my ($self, $start, $end) = @_;
- my @fines;
- syslog('LOG_DEBUG', 'OILS: Patron->fine_items()');
- return (defined $start and defined $end) ?
- [ $fines[($start-1)..($end-1)] ] : \@fines;
-}
-
-# not currently supported
-sub recall_items {
- my ($self, $start, $end) = @_;
- return [];
-}
-
-sub unavail_holds {
- my ($self, $start, $end) = @_;
- my @holds;
- syslog('LOG_DEBUG', 'OILS: Patron->unavail_holds()');
- return (defined $start and defined $end) ?
- [ $holds[($start-1)..($end-1)] ] : \@holds;
-}
-
-sub block {
- my ($self, $card_retained, $blocked_card_msg) = @_;
- $blocked_card_msg ||= '';
-
- my $e = $self->{editor};
- my $u = $self->{user};
-
- syslog('LOG_INFO', "OILS: Blocking user %s", $u->card->barcode );
-
- return $self if $u->card->active eq 'f';
-
- $e->xact_begin; # connect and start a new transaction
-
- $u->card->active('f');
- if( ! $e->update_actor_card($u->card) ) {
- syslog('LOG_ERR', "OILS: Block card update failed: %s", $e->event->{textcode});
- $e->rollback; # rollback + disconnect
- return $self;
- }
-
- # retrieve the un-fleshed user object for update
- $u = $e->retrieve_actor_user($u->id);
- my $note = OpenILS::SIP::clean_text($u->alert_message) || "";
- $note = "<sip> CARD BLOCKED BY SELF-CHECK MACHINE. $blocked_card_msg</sip>\n$note"; # XXX Config option
- $note =~ s/\s*$//; # kill trailng whitespace
- $u->alert_message($note);
-
- if( ! $e->update_actor_user($u) ) {
- syslog('LOG_ERR', "OILS: Block: patron alert update failed: %s", $e->event->{textcode});
- $e->rollback; # rollback + disconnect
- return $self;
- }
-
- # stay in synch
- $self->{user}->alert_message( $note );
-
- $e->commit; # commits and disconnects
- return $self;
-}
-
-# Testing purposes only
-sub enable {
- my ($self, $card_retained) = @_;
- $self->{screen_msg} = "All privileges restored.";
-
- # Un-mark card as inactive, grep out the patron alert
- my $e = $self->{editor};
- my $u = $self->{user};
-
- syslog('LOG_INFO', "OILS: Unblocking user %s", $u->card->barcode );
-
- return $self if $u->card->active eq 't';
-
- $e->xact_begin; # connect and start a new transaction
-
- $u->card->active('t');
- if( ! $e->update_actor_card($u->card) ) {
- syslog('LOG_ERR', "OILS: Unblock card update failed: %s", $e->event->{textcode});
- $e->rollback; # rollback + disconnect
- return $self;
- }
-
- # retrieve the un-fleshed user object for update
- $u = $e->retrieve_actor_user($u->id);
- my $note = OpenILS::SIP::clean_text($u->alert_message) || "";
- $note =~ s#<sip>.*</sip>##;
- $note =~ s/^\s*//; # kill leading whitespace
- $note =~ s/\s*$//; # kill trailng whitespace
- $u->alert_message($note);
-
- if( ! $e->update_actor_user($u) ) {
- syslog('LOG_ERR', "OILS: Unblock: patron alert update failed: %s", $e->event->{textcode});
- $e->rollback; # rollback + disconnect
- return $self;
- }
-
- # stay in synch
- $self->{user}->alert_message( $note );
-
- $e->commit; # commits and disconnects
- return $self;
-}
-
-#
-# Messages
-#
-
-sub invalid_patron {
- return "Please contact library staff";
-}
-
-sub charge_denied {
- return "Please contact library staff";
-}
-
-sub inet_privileges {
- my( $self ) = @_;
- my $e = OpenILS::SIP->editor();
- $INET_PRIVS = $e->retrieve_all_config_net_access_level() unless $INET_PRIVS;
- my ($level) = grep { $_->id eq $self->{user}->net_access_level } @$INET_PRIVS;
- my $name = OpenILS::SIP::clean_text($level->name);
- syslog('LOG_DEBUG', "OILS: Patron inet_privs = $name");
- return $name;
-}
-
-
-1;
+++ /dev/null
-#
-# Transaction: Superclass of all the transactional status objects
-#
-
-package OpenILS::SIP::Transaction;
-
-use Carp;
-use strict; use warnings;
-use Sys::Syslog qw(syslog);
-
-use OpenILS::SIP;
-use OpenILS::SIP::Msg qw/:const/;
-
-
-my %fields = (
- ok => 0,
- patron => undef,
- item => undef,
- desensitize => 0,
- alert => '',
- transation_id => undef,
- sip_fee_type => '01', # Other/Unknown
- fee_amount => undef,
- sip_currency => 'CAD',
- screen_msg => '',
- print_line => '',
- editor => undef,
- authtoken => '',
-);
-
-our $AUTOLOAD;
-
-sub new {
- my( $class, %args ) = @_;
-
- my $self = { _permitted => \%fields, %fields };
-
- bless $self, $class;
- $self->authtoken($args{authtoken});
-
- syslog('LOG_DEBUG', "OILS: Created new transaction with authtoken %s", $self->authtoken);
-
- my $e = OpenILS::SIP->editor();
- $e->{authtoken} = $self->authtoken;
-
- return $self;
-}
-
-sub DESTROY {
- # be cool
-}
-
-sub AUTOLOAD {
- my $self = shift;
- my $class = ref($self) or croak "$self is not an object";
- my $name = $AUTOLOAD;
-
- $name =~ s/.*://;
-
- unless (exists $self->{_permitted}->{$name}) {
- croak "Can't access '$name' field of class '$class'";
- }
-
- if (@_) {
- return $self->{$name} = shift;
- } else {
- return $self->{$name};
- }
-}
-
-1;
+++ /dev/null
-package OpenILS::SIP::Transaction::Checkin;
-use warnings; use strict;
-
-use POSIX qw(strftime);
-use Sys::Syslog qw(syslog);
-use Data::Dumper;
-use Time::HiRes q/time/;
-
-use OpenILS::SIP;
-use OpenILS::SIP::Transaction;
-use OpenILS::Const qw/:const/;
-use OpenILS::Application::AppUtils;
-my $U = 'OpenILS::Application::AppUtils';
-
-use base qw(OpenILS::SIP::Transaction);
-
-my $debug = 0;
-
-my %fields = (
- magnetic => 0,
- sort_bin => undef,
- # 3M extensions: (most of the data is stored under Item)
-# collection_code => undef,
-# call_number => undef,
- destination_loc => undef,
- alert_type => undef, # 00,01,02,03,04 or 99
-# hold_patron_id => undef,
-# hold_patron_name => "",
-# hold => undef,
-);
-
-sub new {
- my $class = shift;;
- my $self = $class->SUPER::new(@_); # start with an Transaction object
-
- foreach (keys %fields) {
- $self->{_permitted}->{$_} = $fields{$_}; # overlaying _permitted
- }
-
- @{$self}{keys %fields} = values %fields; # copying defaults into object
-
- $self->load_override_events;
-
- return bless $self, $class;
-}
-
-sub resensitize {
- my $self = shift;
- return 0 if !$self->{item};
- return !$self->{item}->magnetic;
-}
-
-my %override_events;
-sub load_override_events {
- return if %override_events;
- my $override = OpenILS::SIP->config->{implementation_config}->{checkin_override};
- return unless $override;
- my $events = $override->{event};
- $events = [$events] unless ref $events eq 'ARRAY';
- $override_events{$_} = 1 for @$events;
-}
-
-my %org_sn_cache;
-sub do_checkin {
- my $self = shift;
- my ($sip_handler, $inst_id, $trans_date, $return_date, $current_loc, $item_props) = @_; # most unused
-
- unless($self->{item}) {
- $self->ok(0);
- return undef;
- }
-
- $inst_id ||= '';
-
- # physical location defaults to ws ou of the logged in sip user,
- # which currently defaults to home_ou, since ws's aren't used.
- my $phys_location = $sip_handler->{login_session}->ws_ou;
-
- my $args = {barcode => $self->{item}->id};
-
- if($return_date) {
- # SIP date format is YYYYMMDD. Translate to ISO8601
- $return_date =~ s/(\d{4})(\d{2})(\d{2}).*/$1-$2-$3/;
- syslog('LOG_INFO', "Checking in with backdate $return_date");
- $args->{backdate} = $return_date;
- }
-
- if($current_loc) { # SIP client specified a physical location
-
- my $org_id = (defined $org_sn_cache{$current_loc}) ?
- $org_sn_cache{$current_loc} :
- OpenILS::SIP->editor()->search_actor_org_unit({shortname => $current_loc}, {idlist => 1})->[0];
-
- $org_sn_cache{$current_loc} = $org_id;
-
- # if the caller specifies a physical location, use it as the checkin circ lib
- $args->{circ_lib} = $phys_location = $org_id if defined $org_id;
- }
-
- my $override = 0;
- my ($resp, $txt, $code);
-
- while(1) {
-
- my $method = 'open-ils.circ.checkin';
- $method .= '.override' if $override;
-
- my $start_time = time();
- $resp = $U->simplereq('open-ils.circ', $method, $self->{authtoken}, $args);
- syslog('LOG_INFO', "OILS: Checkin API call took %0.3f seconds", (time() - $start_time));
-
- if ($debug) {
- my $s = Dumper($resp);
- $s =~ s/\n//mog;
- syslog('LOG_INFO', "OILS: Checkin response: $s");
- }
-
- # In oddball cases, we can receive an array of events.
- # The first event received should be treated as the main result.
- $resp = $$resp[0] if ref($resp) eq 'ARRAY';
- $code = $U->event_code($resp);
- $txt = (defined $code) ? $resp->{textcode} : '';
-
- last if $override;
-
- if ( $override_events{$txt} ) {
- $override = 1;
- } else {
- last;
- }
- }
-
- syslog('LOG_INFO', "OILS: Checkin resulted in event: $txt, phys_location: $phys_location");
-
- $resp->{org} &&= OpenILS::SIP::shortname_from_id($resp->{org}); # Convert id to shortname
-
- $self->destination_loc($resp->{org}) if $resp->{org};
-
- if ($txt eq 'ROUTE_ITEM') {
- # Note, this alert_type will be overridden below if this is a hold transit
- $self->alert_type('04'); # send to other branch
-
- } elsif ($txt and $txt ne 'NO_CHANGE' and $txt ne 'SUCCESS') {
- syslog('LOG_WARNING', "OILS: Checkin returned unexpected event $code : $txt");
- $self->alert_type('00'); # unknown
- }
-
- my $payload = $resp->{payload} || {};
-
- my ($circ, $copy);
-
- if(ref $payload eq 'HASH') {
-
- # Two places to look for hold data. These are more important and more definitive than above.
- if ($payload->{remote_hold}) {
- # actually only used for checkin at non-owning branch w/ hold at same branch
- $self->item->hold($payload->{remote_hold});
-
- } elsif ($payload->{hold}) {
- $self->item->hold($payload->{hold});
- }
-
- $circ = $resp->{payload}->{circ} || '';
- $copy = $resp->{payload}->{copy} || '';
- }
-
- if ($self->item->hold) {
- my ($pickup_lib_id, $pickup_lib_sn);
-
- my $holder = OpenILS::SIP->editor()->retrieve_actor_user(
- [$self->item->hold->usr, {flesh => 1, flesh_fields => {au => ['card']}}]);
-
- my $holder_name = OpenILS::SIP::Patron::format_name($holder);
-
- if (ref $self->item->hold->pickup_lib) {
- $pickup_lib_id = $self->item->hold->pickup_lib->id;
- $pickup_lib_sn = $self->item->hold->pickup_lib->shortname;
-
- } else {
- $pickup_lib_id = $self->item->hold->pickup_lib;
- $pickup_lib_sn = OpenILS::SIP::shortname_from_id($pickup_lib_id);
- }
-
- $self->item->hold_patron_bcode( ($holder->card) ? $holder->card->barcode : '');
- $self->item->hold_patron_name($holder_name);
- $self->item->destination_loc($pickup_lib_sn);
-
- my $atype = ($pickup_lib_id == $phys_location) ? '01' : '02';
- $self->alert_type($atype);
- }
-
- $self->alert(1) if defined $self->alert_type; # alert_type could be "00", hypothetically
-
- if ( $circ ) {
- $self->{circ_user_id} = $circ->usr;
- $self->ok(1);
- } elsif ($txt eq 'NO_CHANGE' or $txt eq 'SUCCESS' or $txt eq 'ROUTE_ITEM') {
- $self->ok(1); # NO_CHANGE means it wasn't checked out anyway, no problem
- } else {
- $self->alert(1);
- $self->alert_type('00') unless $self->alert_type; # wasn't checked out, but *something* changed
- # $self->ok(0); # maybe still ok?
- }
-}
-
-1;
-__END__
-
-Successful Checkin event payload includes:
- $payload->{copy} (unfleshed)
- $payload->{record}
- $payload->{circ}
- $payload->{transit}
- $payload->{cancelled_hold_transit}
- $payload->{hold}
- $payload->{patron}
-
-Some EVENT strings:
- SUCCESS => ,
- ASSET_COPY_NOT_FOUND => ,
- NO_CHANGE => ,
- PERM_FAILURE => ,
- CIRC_CLAIMS_RETURNED => ,
- COPY_ALERT_MESSAGE => ,
- COPY_STATUS_LOST => ,
- COPY_STATUS_MISSING => ,
- COPY_BAD_STATUS => ,
- ITEM_DEPOSIT_PAID => ,
- ROUTE_ITEM => ,
- DATABASE_UPDATE_FAILED => ,
- DATABASE_QUERY_FAILED => ,
-
-# alert_type:
-# 00 - Unknown
-# 01 - hold in local library
-# 02 - hold for other branch
-# 03 - hold for ILL (not used in EG)
-# 04 - send to other branch (no hold)
-# 99 - Other
+++ /dev/null
-#
-# An object to handle checkout status
-#
-
-package OpenILS::SIP::Transaction::Checkout;
-
-use warnings;
-use strict;
-
-use POSIX qw(strftime);
-
-use OpenILS::SIP;
-use OpenILS::SIP::Transaction;
-use OpenILS::SIP::Msg qw/:const/;
-use Sys::Syslog qw(syslog);
-
-use OpenILS::Application::AppUtils;
-my $U = 'OpenILS::Application::AppUtils';
-
-
-our @ISA = qw(OpenILS::SIP::Transaction);
-
-# Most fields are handled by the Transaction superclass
-my %fields = (
- security_inhibit => 0,
- due => undef,
- renew_ok => 0,
- );
-
-sub new {
- my $class = shift;
-
- my $self = $class->SUPER::new(@_);
-
- my $element;
-
- foreach $element (keys %fields) {
- $self->{_permitted}->{$element} = $fields{$element};
- }
-
- @{$self}{keys %fields} = values %fields;
-
- return bless $self, $class;
-}
-
-
-# if this item is already checked out to the requested patron,
-# renew the item and set $self->renew_ok to true.
-# XXX if it's a renewal and the renewal is not permitted, set
-# $self->screen_msg("Item on Hold for Another User"); (or somesuch)
-# XXX Set $self->ok(0) on any errors
-sub do_checkout {
- my $self = shift;
- my $is_renew = shift || 0;
-
- $self->ok(0);
-
- my $args = {
- barcode => $self->{item}->id,
- patron_barcode => $self->{patron}->id
- };
-
- my $resp;
-
- if ($is_renew) {
- $resp = $U->simplereq(
- 'open-ils.circ',
- 'open-ils.circ.renew', $self->{authtoken},
- { barcode => $self->item->id, patron_barcode => $self->patron->id });
- } else {
- $resp = $U->simplereq(
- 'open-ils.circ',
- 'open-ils.circ.checkout.permit',
- $self->{authtoken}, $args );
-
- $resp = [$resp] unless ref $resp eq 'ARRAY';
-
- my $key;
-
- syslog('LOG_DEBUG', "OILS: Checkout permit returned event: " . OpenSRF::Utils::JSON->perl2JSON($resp));
-
- if( @$resp == 1 and ! $U->event_code($$resp[0]) ) {
- $key = $$resp[0]->{payload};
- syslog('LOG_INFO', "OILS: circ permit key => $key");
-
- } else {
-
- # We got one or more non-success events
- $self->screen_msg('');
- for my $r (@$resp) {
-
- if( my $code = $U->event_code($resp) ) {
- my $txt = $resp->{textcode};
- syslog('LOG_INFO', "OILS: Checkout permit failed with event $code : $txt");
-
- if( $txt eq 'OPEN_CIRCULATION_EXISTS' ) {
- $self->screen_msg(OILS_SIP_MSG_CIRC_EXISTS);
- return 0;
- } else {
- $self->screen_msg(OILS_SIP_MSG_CIRC_PERMIT_FAILED);
- }
- }
- }
- return 0;
- }
-
- # --------------------------------------------------------------------
- # Now do the actual checkout
- # --------------------------------------------------------------------
-
- $args = {
- permit_key => $key,
- patron_barcode => $self->{patron}->id,
- barcode => $self->{item}->id
- };
-
- $resp = $U->simplereq(
- 'open-ils.circ',
- 'open-ils.circ.checkout', $self->{authtoken}, $args );
- }
-
- syslog('LOG_INFO', "OILS: Checkout returned event: " . OpenSRF::Utils::JSON->perl2JSON($resp));
-
- # XXX Check for events
- if( $resp ) {
-
- if( my $code = $U->event_code($resp) ) {
- my $txt = $resp->{textcode};
- syslog('LOG_INFO', "OILS: Checkout failed with event $code : $txt");
- $self->screen_msg('Checkout failed. Please contact a librarian');
- return 0;
- }
-
- syslog('LOG_INFO', "OILS: Checkout succeeded");
-
- my $circ = $resp->{payload}->{circ};
- $self->{'due'} = OpenILS::SIP->format_date($circ->due_date, 'due');
- $self->ok(1);
-
- return 1;
- }
-
- return 0;
-}
-
-
-
-1;
+++ /dev/null
-#
-# Status of a Renew Transaction
-#
-
-package OpenILS::SIP::Transaction::Renew;
-use warnings; use strict;
-
-use Sys::Syslog qw(syslog);
-use OpenILS::SIP;
-use OpenILS::SIP::Transaction;
-use OpenILS::Application::AppUtils;
-my $U = 'OpenILS::Application::AppUtils';
-
-our @ISA = qw(OpenILS::SIP::Transaction);
-
-my %fields = (
- renewal_ok => 0,
- );
-
-sub new {
- my $class = shift;;
- my $self = $class->SUPER::new(@_);
-
- $self->{_permitted}->{$_} = $fields{$_} for keys %fields;
- @{$self}{keys %fields} = values %fields;
-
- return bless $self, $class;
-}
-
-sub do_renew {
- my $self = shift;
-
- my $resp = $U->simplereq(
- 'open-ils.circ',
- 'open-ils.circ.renew', $self->{authtoken},
- { barcode => $self->item->id, patron_barcode => $self->patron->id });
-
- if( my $code = $U->event_code($resp) ) {
- syslog('LOG_INFO', "OILS: Renewal failed with event $code : " . $resp->{textcode});
- $self->renewal_ok(0);
- $self->ok(0);
- return $self;
- }
-
- $self->item->{due_date} = $resp->{payload}->{circ}->due_date;
- syslog('LOG_INFO', "OILS: Renewal succeeded with due_date = " . $self->item->{due_date});
-
- $self->renewal_ok(1);
- $self->ok(1);
-
- return $self;
-}
-
-
-
-
-1;
+++ /dev/null
-package OpenILS::Template::Plugin::Unicode;
-use Unicode::Normalize;
-
-sub new { return bless {}, __PACKAGE__ }
-sub load { return __PACKAGE__ }
-
-sub C { shift; return NFC(@_); }
-sub D { shift; return NFD(@_); }
-sub entityDecode { shift; $_ = shift; s/&#x([0-9a-fA-F]+);/chr(hex($1))/egos; return $_ }
-sub entityEncode { shift; $_ = shift; s/(\PM\pM+)/sprintf('&#x%0.4x;',ord(NFC($1)))/sgoe; return $_ }
-
-1;
+++ /dev/null
-package OpenILS::Template::Plugin::WebSession;
-use strict; use warnings;
-use OpenILS::Utils::Fieldmapper;
-
-use Template::Plugin;
-use base qw/Template::Plugin/;
-use OpenSRF::AppSession;
-use OpenSRF::System;
-
-sub new {
- my ($class) = @_;
- $class = ref($class) || $class;
- my $self = {};
- return bless($self,$class);
-}
-
-my $bootstrapped = 0;
-sub bootstrap_client {
- my( $self, $config_file ) = @_;
- if(!$bootstrapped) {
- OpenSRF::System->bootstrap_client( config_file => $config_file );
- $bootstrapped = 1;
- }
-}
-
-sub init_app_session {
- my($self, $service) = @_;
- return undef unless $service;
- return OpenSRF::AppSession->create($service);
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::Template::Plugin::WebUtils;
-use strict; use warnings;
-use OpenILS::Utils::Fieldmapper;
-
-use Template::Plugin;
-use base qw/Template::Plugin/;
-use OpenSRF::AppSession;
-use OpenSRF::System;
-use XML::LibXML;
-use OpenSRF::Utils::SettingsParser;
-use OpenSRF::Utils::JSON;
-
-sub new {
- my ($class) = @_;
- $class = ref($class) || $class;
- my $self = {};
- return bless($self,$class);
-}
-
-
-sub XML2perl {
- my( $self, $doc ) = @_;
- return OpenSRF::Utils::SettingsParser::XML2perl($doc);
-}
-
-
-sub perl2JSON {
- my( $self, $perl ) = @_;
- my $json = OpenSRF::Utils::JSON->perl2JSON($perl);
- warn "Created JSON from perl:\n$json\n";
- return $json;
-}
-
-sub JSON2perl {
- my( $self, $perl ) = @_;
- warn "Turning JSON into perl:\n$perl\n";
- my $obj = OpenSRF::Utils::JSON->JSON2perl($perl);
- warn "Created Perl from JSON: $obj \n";
- return $obj;
-}
-
-sub perl2prettyJSON {
- my( $self, $perl ) = @_;
- return OpenSRF::Utils::JSON->perl2prettyJSON($perl);
-}
-
-
-
-1;
+++ /dev/null
-use strict; use warnings;
-package OpenILS::Utils::CStoreEditor;
-use OpenILS::Application::AppUtils;
-use OpenSRF::AppSession;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Event;
-use Data::Dumper;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw($logger);
-my $U = "OpenILS::Application::AppUtils";
-my %PERMS;
-my $cache;
-my %xact_ed_cache;
-
-our $always_xact = 0;
-our $_loaded = 1;
-
-#my %PERMS = (
-# 'biblio.record_entry' => { update => 'UPDATE_MARC' },
-# 'asset.copy' => { update => 'UPDATE_COPY'},
-# 'asset.call_number' => { update => 'UPDATE_VOLUME'},
-# 'action.circulation' => { retrieve => 'VIEW_CIRCULATIONS'},
-#);
-
-sub flush_forced_xacts {
- for my $k ( keys %xact_ed_cache ) {
- try {
- $xact_ed_cache{$k}->rollback;
- } catch Error with {
- # rollback failed
- };
- delete $xact_ed_cache{$k};
- }
-}
-
-# -----------------------------------------------------------------------------
-# Export some useful functions
-# -----------------------------------------------------------------------------
-use vars qw(@EXPORT_OK %EXPORT_TAGS);
-use Exporter;
-use base qw/Exporter/;
-push @EXPORT_OK, ( 'new_editor', 'new_rstore_editor' );
-%EXPORT_TAGS = ( funcs => [ qw/ new_editor new_rstore_editor / ] );
-
-sub new_editor { return OpenILS::Utils::CStoreEditor->new(@_); }
-
-sub new_rstore_editor {
- my $e = OpenILS::Utils::CStoreEditor->new(@_);
- $e->app('open-ils.reporter-store');
- return $e;
-}
-
-
-# -----------------------------------------------------------------------------
-# Log levels
-# -----------------------------------------------------------------------------
-use constant E => 'error';
-use constant W => 'warn';
-use constant I => 'info';
-use constant D => 'debug';
-use constant A => 'activity';
-
-
-
-# -----------------------------------------------------------------------------
-# Params include:
-# xact=><true> : creates a storage transaction
-# authtoken=>$token : the login session key
-# -----------------------------------------------------------------------------
-sub new {
- my( $class, %params ) = @_;
- $class = ref($class) || $class;
- my $self = bless( \%params, $class );
- $self->{checked_perms} = {};
- return $self;
-}
-
-sub DESTROY {
- my $self = shift;
- $self->reset;
- return undef;
-}
-
-sub app {
- my( $self, $app ) = @_;
- $self->{app} = $app if $app;
- $self->{app} = 'open-ils.cstore' unless $self->{app};
- return $self->{app};
-}
-
-
-# -----------------------------------------------------------------------------
-# Log the editor metadata along with the log string
-# -----------------------------------------------------------------------------
-sub log {
- my( $self, $lev, $str ) = @_;
- my $s = "editor[";
- if ($always_xact) {
- $s .= "!|";
- } elsif ($self->{xact}) {
- $s .= "1|";
- } else {
- $s .= "0|";
- }
- $s .= "0" unless $self->requestor;
- $s .= $self->requestor->id if $self->requestor;
- $s .= "]";
- $logger->$lev("$s $str");
-}
-
-# -----------------------------------------------------------------------------
-# Verifies the auth token and fetches the requestor object
-# -----------------------------------------------------------------------------
-sub checkauth {
- my $self = shift;
- $self->log(D, "checking auth token ".$self->authtoken);
- my ($reqr, $evt) = $U->checkses($self->authtoken);
- $self->event($evt) if $evt;
- return $self->{requestor} = $reqr;
-}
-
-
-=head test
-sub checkauth {
- my $self = shift;
- $cache = OpenSRF::Utils::Cache->new('global') unless $cache;
- $self->log(D, "checking cached auth token ".$self->authtoken);
- my $user = $cache->get_cache("oils_auth_".$self->authtoken);
- return $self->{requestor} = $user->{userobj} if $user;
- $self->event(OpenILS::Event->new('NO_SESSION'));
- return undef;
-}
-=cut
-
-
-# -----------------------------------------------------------------------------
-# Returns the last generated event
-# -----------------------------------------------------------------------------
-sub event {
- my( $self, $evt ) = @_;
- $self->{event} = $evt if $evt;
- return $self->{event};
-}
-
-# -----------------------------------------------------------------------------
-# Destroys the transaction and disconnects where necessary,
-# then returns the last event that occurred
-# -----------------------------------------------------------------------------
-sub die_event {
- my $self = shift;
- my $evt = shift;
- $self->rollback;
- $self->died(1);
- $self->event($evt);
- return $self->event;
-}
-
-
-# -----------------------------------------------------------------------------
-# Clears the last caught event
-# -----------------------------------------------------------------------------
-sub clear_event {
- my $self = shift;
- $self->{event} = undef;
-}
-
-sub died {
- my($self, $died) = @_;
- $self->{died} = $died if defined $died;
- return $self->{died};
-}
-
-sub authtoken {
- my( $self, $auth ) = @_;
- $self->{authtoken} = $auth if $auth;
- return $self->{authtoken};
-}
-
-sub timeout {
- my($self, $to) = @_;
- $self->{timeout} = $to if defined $to;
- return defined($self->{timeout}) ? $self->{timeout} : 60;
-}
-
-# -----------------------------------------------------------------------------
-# fetches the session, creating if necessary. If 'xact' is true on this
-# object, a db session is created
-# -----------------------------------------------------------------------------
-sub session {
- my( $self, $session ) = @_;
- $self->{session} = $session if $session;
-
- if(!$self->{session}) {
- $self->{session} = OpenSRF::AppSession->create($self->app);
-
- if( ! $self->{session} ) {
- my $str = "Error creating cstore session with OpenSRF::AppSession->create()!";
- $self->log(E, $str);
- throw OpenSRF::EX::ERROR ($str);
- }
-
- $self->{session}->connect if $self->{xact} or $self->{connect} or $always_xact;
- $self->xact_begin if $self->{xact} or $always_xact;
- }
-
- $xact_ed_cache{$self->{xact_id}} = $self if $always_xact and $self->{xact_id};
- return $self->{session};
-}
-
-
-# -----------------------------------------------------------------------------
-# Starts a storage transaction
-# -----------------------------------------------------------------------------
-sub xact_begin {
- my $self = shift;
- return $self->{xact_id} if $self->{xact_id};
- $self->session->connect unless $self->session->state == OpenSRF::AppSession::CONNECTED();
- $self->log(D, "starting new database transaction");
- unless($self->{xact_id}) {
- my $stat = $self->request($self->app . '.transaction.begin');
- $self->log(E, "error starting database transaction") unless $stat;
- $self->{xact_id} = $stat;
- }
- $self->{xact} = 1;
- return $self->{xact_id};
-}
-
-# -----------------------------------------------------------------------------
-# Commits a storage transaction
-# -----------------------------------------------------------------------------
-sub xact_commit {
- my $self = shift;
- return unless $self->{xact_id};
- $self->log(D, "comitting db session");
- my $stat = $self->request($self->app.'.transaction.commit');
- $self->log(E, "error comitting database transaction") unless $stat;
- delete $self->{xact_id};
- delete $self->{xact};
- return $stat;
-}
-
-# -----------------------------------------------------------------------------
-# Rolls back a storage stransaction
-# -----------------------------------------------------------------------------
-sub xact_rollback {
- my $self = shift;
- return unless $self->{session} and $self->{xact_id};
- $self->log(I, "rolling back db session");
- my $stat = $self->request($self->app.".transaction.rollback");
- $self->log(E, "error rolling back database transaction") unless $stat;
- delete $self->{xact_id};
- delete $self->{xact};
- return $stat;
-}
-
-
-# -----------------------------------------------------------------------------
-# Savepoint functions. If no savepoint name is provided, the same name is used
-# for each successive savepoint, in which case only the last savepoint set can
-# be released or rolled back.
-# -----------------------------------------------------------------------------
-sub set_savepoint {
- my $self = shift;
- my $name = shift || 'savepoint';
- return unless $self->{session} and $self->{xact_id};
- $self->log(I, "setting savepoint '$name'");
- my $stat = $self->request($self->app.".savepoint.set", $name)
- or $self->log(E, "error setting savepoint '$name'");
- return $stat;
-}
-
-sub release_savepoint {
- my $self = shift;
- my $name = shift || 'savepoint';
- return unless $self->{session} and $self->{xact_id};
- $self->log(I, "releasing savepoint '$name'");
- my $stat = $self->request($self->app.".savepoint.release", $name)
- or $self->log(E, "error releasing savepoint '$name'");
- return $stat;
-}
-
-sub rollback_savepoint {
- my $self = shift;
- my $name = shift || 'savepoint';
- return unless $self->{session} and $self->{xact_id};
- $self->log(I, "rollback savepoint '$name'");
- my $stat = $self->request($self->app.".savepoint.rollback", $name)
- or $self->log(E, "error rolling back savepoint '$name'");
- return $stat;
-}
-
-
-# -----------------------------------------------------------------------------
-# Rolls back the transaction and disconnects
-# -----------------------------------------------------------------------------
-sub rollback {
- my $self = shift;
- my $err;
- my $ret;
- try {
- $self->xact_rollback;
- } catch Error with {
- $err = shift
- } finally {
- $ret = $self->disconnect
- };
- throw $err if ($err);
- return $ret;
-}
-
-sub disconnect {
- my $self = shift;
- $self->session->disconnect if
- $self->{session} and
- $self->{session}->state == OpenSRF::AppSession::CONNECTED();
- delete $self->{session};
-}
-
-
-# -----------------------------------------------------------------------------
-# commits the db session and destroys the session
-# returns the status of the commit call
-# -----------------------------------------------------------------------------
-sub commit {
- my $self = shift;
- return unless $self->{xact_id};
- my $stat = $self->xact_commit;
- $self->disconnect;
- return $stat;
-}
-
-# -----------------------------------------------------------------------------
-# clears all object data. Does not commit the db transaction.
-# -----------------------------------------------------------------------------
-sub reset {
- my $self = shift;
- $self->disconnect;
- $$self{$_} = undef for (keys %$self);
-}
-
-
-# -----------------------------------------------------------------------------
-# commits and resets
-# -----------------------------------------------------------------------------
-sub finish {
- my $self = shift;
- my $err;
- my $ret;
- try {
- $self->commit;
- } catch Error with {
- $err = shift
- } finally {
- $ret = $self->reset
- };
- throw $err if ($err);
- return $ret;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Does a simple storage request
-# -----------------------------------------------------------------------------
-sub request {
- my( $self, $method, @params ) = @_;
-
- my $val;
- my $err;
- my $argstr = __arg_to_string( (scalar(@params)) == 1 ? $params[0] : \@params);
- my $locale = $self->session->session_locale;
-
- $self->log(I, "request $locale $method $argstr");
-
- if( ($self->{xact} or $always_xact) and
- $self->session->state != OpenSRF::AppSession::CONNECTED() ) {
- #$logger->error("CStoreEditor lost it's connection!!");
- throw OpenSRF::EX::ERROR ("CStore connection timed out - transaction cannot continue");
- }
-
-
- try {
-
- my $req = $self->session->request($method, @params);
-
- if($self->substream) {
- $self->log(D,"running in substream mode");
- $val = [];
- while( my $resp = $req->recv(timeout => $self->timeout) ) {
- push(@$val, $resp->content) if $resp->content and not $self->discard;
- }
-
- } else {
- my $resp = $req->recv(timeout => $self->timeout);
- if($req->failed) {
- $err = $resp;
- $self->log(E, "request error $method : $argstr : $err");
- } else {
- $val = $resp->content if $resp;
- }
- }
-
- $req->finish;
-
- } catch Error with {
- $err = shift;
- $self->log(E, "request error $method : $argstr : $err");
- };
-
- throw $err if $err;
- return $val;
-}
-
-sub substream {
- my( $self, $bool ) = @_;
- $self->{substream} = $bool if defined $bool;
- return $self->{substream};
-}
-
-# -----------------------------------------------------------------------------
-# discard response data instead of returning it to the caller. currently only
-# works in conjunction with substream mode.
-# -----------------------------------------------------------------------------
-sub discard {
- my( $self, $bool ) = @_;
- $self->{discard} = $bool if defined $bool;
- return $self->{discard};
-}
-
-
-# -----------------------------------------------------------------------------
-# Sets / Returns the requestor object. This is set when checkauth succeeds.
-# -----------------------------------------------------------------------------
-sub requestor {
- my($self, $requestor) = @_;
- $self->{requestor} = $requestor if $requestor;
- return $self->{requestor};
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Holds the last data received from a storage call
-# -----------------------------------------------------------------------------
-sub data {
- my( $self, $data ) = @_;
- $self->{data} = $data if defined $data;
- return $self->{data};
-}
-
-
-# -----------------------------------------------------------------------------
-# True if this perm has already been checked at this org
-# -----------------------------------------------------------------------------
-sub perm_checked {
- my( $self, $perm, $org ) = @_;
- $self->{checked_perms}->{$org} = {}
- unless $self->{checked_perms}->{$org};
- my $checked = $self->{checked_perms}->{$org}->{$perm};
- if(!$checked) {
- $self->{checked_perms}->{$org}->{$perm} = 1;
- return 0;
- }
- return 1;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Returns true if the requested perm is allowed. If the perm check fails,
-# $e->event is set and undef is returned
-# The perm user is $e->requestor->id and perm org defaults to the requestor's
-# ws_ou
-# if perm is an array of perms, method will return true at the first allowed
-# permission. If none of the perms are allowed, the perm_failure event
-# is created with the last perm to fail
-# -----------------------------------------------------------------------------
-my $PERM_QUERY = {
- select => {
- au => [ {
- transform => 'permission.usr_has_perm',
- alias => 'has_perm',
- column => 'id',
- params => []
- } ]
- },
- from => 'au',
- where => {},
-};
-
-my $OBJECT_PERM_QUERY = {
- select => {
- au => [ {
- transform => 'permission.usr_has_object_perm',
- alias => 'has_perm',
- column => 'id',
- params => []
- } ]
- },
- from => 'au',
- where => {},
-};
-
-sub allowed {
- my( $self, $perm, $org, $object, $hint ) = @_;
- my $uid = $self->requestor->id;
- $org ||= $self->requestor->ws_ou;
-
- my $perms = (ref($perm) eq 'ARRAY') ? $perm : [$perm];
-
- for $perm (@$perms) {
- $self->log(I, "checking perms user=$uid, org=$org, perm=$perm");
-
- if($object) {
- my $params;
- if(ref $object) {
- # determine the ID field and json_hint from the object
- my $id_field = $object->Identity;
- $params = [$perm, $object->json_hint, $object->$id_field];
- } else {
- # we were passed an object-id and json_hint
- $params = [$perm, $hint, $object];
- }
- push(@$params, $org) if $org;
- $OBJECT_PERM_QUERY->{select}->{au}->[0]->{params} = $params;
- $OBJECT_PERM_QUERY->{where}->{id} = $uid;
- return 1 if $U->is_true($self->json_query($OBJECT_PERM_QUERY)->[0]->{has_perm});
-
- } else {
- $PERM_QUERY->{select}->{au}->[0]->{params} = [$perm, $org];
- $PERM_QUERY->{where}->{id} = $uid;
- return 1 if $U->is_true($self->json_query($PERM_QUERY)->[0]->{has_perm});
- }
- }
-
- # set the perm failure event if the permission check returned false
- my $e = OpenILS::Event->new('PERM_FAILURE', ilsperm => $perm, ilspermloc => $org);
- $self->event($e);
- return undef;
-}
-
-
-# -----------------------------------------------------------------------------
-# Returns the list of object IDs this user has object-specific permissions for
-# -----------------------------------------------------------------------------
-sub objects_allowed {
- my($self, $perm, $obj_type) = @_;
-
- my $perms = (ref($perm) eq 'ARRAY') ? $perm : [$perm];
- my @ids;
-
- for $perm (@$perms) {
- my $query = {
- select => {puopm => ['object_id']},
- from => {
- puopm => {
- ppl => {field => 'id',fkey => 'perm'}
- }
- },
- where => {
- '+puopm' => {usr => $self->requestor->id, object_type => $obj_type},
- '+ppl' => {code => $perm}
- }
- };
-
- my $list = $self->json_query($query);
- push(@ids, 0+$_->{object_id}) for @$list;
- }
-
- my %trim;
- $trim{$_} = 1 for @ids;
- return [ keys %trim ];
-}
-
-
-# -----------------------------------------------------------------------------
-# checks the appropriate perm for the operation
-# -----------------------------------------------------------------------------
-sub _checkperm {
- my( $self, $ptype, $action, $org ) = @_;
- $org ||= $self->requestor->ws_ou;
- my $perm = $PERMS{$ptype}{$action};
- if( $perm ) {
- return undef if $self->perm_checked($perm, $org);
- return $self->event unless $self->allowed($perm, $org);
- } else {
- $self->log(I, "no perm provided for $ptype.$action");
- }
- return undef;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Logs update actions to the activity log
-# -----------------------------------------------------------------------------
-sub log_activity {
- my( $self, $type, $action, $arg ) = @_;
- my $str = "$type.$action";
- $str .= _prop_string($arg);
- $self->log(A, $str);
-}
-
-
-
-sub _prop_string {
- my $obj = shift;
- my @props = $obj->properties;
- my $str = "";
- for(@props) {
- my $prop = $obj->$_() || "";
- $prop = substr($prop, 0, 128) . "..." if length $prop > 131;
- $str .= " $_=$prop";
- }
- return $str;
-}
-
-
-sub __arg_to_string {
- my $arg = shift;
- return "" unless defined $arg;
- if( UNIVERSAL::isa($arg, "Fieldmapper") ) {
- my $idf = $arg->Identity;
- return (defined $arg->$idf) ? $arg->$idf : '<new object>';
- }
- return OpenSRF::Utils::JSON->perl2JSON($arg);
- return "";
-}
-
-
-# -----------------------------------------------------------------------------
-# This does the actual storage query.
-#
-# 'search' calls become search_where calls and $arg can be a search hash or
-# an array-ref of storage search options.
-#
-# 'retrieve' expects an id
-# 'update' expects an object
-# 'create' expects an object
-# 'delete' expects an object
-#
-# All methods return true on success and undef on failure. On failure,
-# $e->event is set to the generated event.
-# Note: this method assumes that updating a non-changed object and
-# thereby receiving a 0 from storage, is a successful update.
-#
-# The method will therefore return true so the caller can just do
-# $e->update_blah($x) or return $e->event;
-# The true value returned from storage for all methods will be stored in
-# $e->data, until the next method is called.
-#
-# not-found events are generated on retrieve and serach methods.
-# action=search methods will return [] (==true) if no data is found. If the
-# caller is interested in the not found event, they can do:
-# return $e->event unless @$results;
-# -----------------------------------------------------------------------------
-sub runmethod {
- my( $self, $action, $type, $arg, $options ) = @_;
-
- $options ||= {};
-
- if( $action eq 'retrieve' ) {
- if(! defined($arg) ) {
- $self->log(W,"$action $type called with no ID...");
- $self->event(_mk_not_found($type, $arg));
- return undef;
- } elsif( ref($arg) =~ /Fieldmapper/ ) {
- $self->log(D,"$action $type called with an object.. attempting Identity retrieval..");
- my $idf = $arg->Identity;
- $arg = $arg->$idf;
- }
- }
-
- my @arg = ( ref($arg) eq 'ARRAY' ) ? @$arg : ($arg);
- my $method = $self->app.".direct.$type.$action";
-
- if( $action eq 'search' ) {
- $method .= '.atomic';
-
- } elsif( $action eq 'batch_retrieve' ) {
- $action = 'search';
- @arg = ( { id => $arg } );
- $method =~ s/batch_retrieve/search/o;
- $method .= '.atomic';
-
- } elsif( $action eq 'retrieve_all' ) {
- $action = 'search';
- $method =~ s/retrieve_all/search/o;
- my $tt = $type;
- $tt =~ s/\./::/og;
- my $fmobj = "Fieldmapper::$tt";
- @arg = ( { $fmobj->Identity => { '!=' => undef } } );
- $method .= '.atomic';
- }
-
- $method =~ s/search/id_list/o if $options->{idlist};
-
- $method =~ s/\.atomic$//o if $self->substream($$options{substream} || 0);
- $self->timeout($$options{timeout});
- $self->discard($$options{discard});
-
- # remove any stale events
- $self->clear_event;
-
- if( $action eq 'update' or $action eq 'delete' or $action eq 'create' ) {
- if(!($self->{xact} or $always_xact)) {
- $logger->error("Attempt to update DB while not in a transaction : $method");
- throw OpenSRF::EX::ERROR ("Attempt to update DB while not in a transaction : $method");
- }
- $self->log_activity($type, $action, $arg);
- }
-
- if($$options{checkperm}) {
- my $a = ($action eq 'search') ? 'retrieve' : $action;
- my $e = $self->_checkperm($type, $a, $$options{permorg});
- if($e) {
- $self->event($e);
- return undef;
- }
- }
-
- my $obj;
- my $err = '';
-
- try {
- $obj = $self->request($method, @arg);
- } catch Error with { $err = shift; };
-
-
- if(!defined $obj) {
- $self->log(I, "request returned no data : $method");
-
- if( $action eq 'retrieve' ) {
- $self->event(_mk_not_found($type, $arg));
-
- } elsif( $action eq 'update' or
- $action eq 'delete' or $action eq 'create' ) {
- my $evt = OpenILS::Event->new(
- 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
- $self->event($evt);
- }
-
- if( $err ) {
- $self->event(
- OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
- payload => $arg, debug => "$err" ));
- return undef;
- }
-
- return undef;
- }
-
- if( $action eq 'create' and $obj == 0 ) {
- my $evt = OpenILS::Event->new(
- 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
- $self->event($evt);
- return undef;
- }
-
- # If we havn't dealt with the error in a nice way, go ahead and throw it
- if( $err ) {
- $self->event(
- OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
- payload => $arg, debug => "$err" ));
- return undef;
- }
-
- if( $action eq 'search' ) {
- $self->log(I, "$type.$action : returned ".scalar(@$obj). " result(s)");
- $self->event(_mk_not_found($type, $arg)) unless @$obj;
- }
-
- if( $action eq 'create' ) {
- my $idf = $obj->Identity;
- $self->log(I, "created a new $type object with Identity " . $obj->$idf);
- $arg->$idf($obj->$idf);
- }
-
- $self->data($obj); # cache the data for convenience
-
- return ($obj) ? $obj : 1;
-}
-
-
-sub _mk_not_found {
- my( $type, $arg ) = @_;
- (my $t = $type) =~ s/\./_/og;
- $t = uc($t);
- return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
-}
-
-
-
-# utility method for loading
-sub __fm2meth {
- my $str = shift;
- my $sep = shift;
- $str =~ s/Fieldmapper:://o;
- $str =~ s/::/$sep/g;
- return $str;
-}
-
-
-# -------------------------------------------------------------
-# Load up the methods from the FM classes
-# -------------------------------------------------------------
-
-sub init {
- no warnings; # Here we potentially redefine subs via eval
- my $map = $Fieldmapper::fieldmap;
- for my $object (keys %$map) {
- my $obj = __fm2meth($object, '_');
- my $type = __fm2meth($object, '.');
- foreach my $command (qw/ update retrieve search create delete batch_retrieve retrieve_all /) {
- eval "sub ${command}_$obj {return shift()->runmethod('$command', '$type', \@_);}\n";
- }
- # TODO: performance test against concatenating a big string of all the subs and eval'ing only ONCE.
- }
-}
-
-init(); # Add very many subs to this namespace
-
-sub json_query {
- my( $self, $arg, $options ) = @_;
- $options ||= {};
- my @arg = ( ref($arg) eq 'ARRAY' ) ? @$arg : ($arg);
- my $method = $self->app.'.json_query.atomic';
- $method =~ s/\.atomic$//o if $self->substream($$options{substream} || 0);
-
- $self->timeout($$options{timeout});
- $self->discard($$options{discard});
- $self->clear_event;
- my $obj;
- my $err;
-
- try {
- $obj = $self->request($method, @arg);
- } catch Error with { $err = shift; };
-
- if( $err ) {
- $self->event(
- OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
- payload => $arg, debug => "$err" ));
- return undef;
- }
-
- $self->log(I, "json_query : returned ".scalar(@$obj). " result(s)") if (ref($obj));
- return $obj;
-}
-
-
-
-1;
-
-
+++ /dev/null
-package OpenILS::Utils::Cronscript;
-
-# ---------------------------------------------------------------
-# Copyright (C) 2010 Equinox Software, Inc
-# Author: Joe Atzberger <jatzberger@esilibrary.com>
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-# The purpose of this module is to consolidate the common aspects
-# of various cron tasks that all need the same things:
-# ~ non-duplicative processing, i.e. lockfiles and lockfile checking
-# ~ opensrf_core.xml file location
-# ~ common options like help and debug
-
-use strict;
-use warnings;
-
-use Getopt::Long qw(:DEFAULT GetOptionsFromArray);
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use OpenSRF::Utils::JSON;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Utils::Lockfile;
-use OpenILS::Utils::CStoreEditor q/:funcs/;
-
-use File::Basename qw/fileparse/;
-
-use Data::Dumper;
-use Carp;
-
-our @extra_opts = ( # additional keys are stored here
- # 'addlopt'
-);
-
-our $debug = 0;
-
-sub _default_self {
- return {
- # opts => {},
- # opts_clean => {},
- # default_opts_clean => {},
- default_opts => {
- 'lock-file=s' => OpenILS::Utils::Lockfile::default_filename,
- 'osrf-config=s' => '@sysconfdir@/opensrf_core.xml',
- 'debug' => 0,
- 'verbose+' => 0,
- 'help' => 0,
- # 'internal_var' => 'XYZ',
- },
- # lockfile => undef,
- # session => undef,
- # bootstrapped => 0,
- # got_options => 0,
- auto_get_options_4_bootstrap => 1,
- };
-}
-
-sub is_clean {
- my $key = shift or return 1;
- $key =~ /[=:].*$/ and return 0;
- $key =~ /[+!]$/ and return 0;
- return 1;
-}
-
-sub clean {
- my $key = shift or return;
- $key =~ s/[=:].*$//;
- $key =~ s/[+!]$//;
- return $key;
-}
-
-sub fuzzykey { # when you know the hash you want from, but not the exact key
- my $self = shift or return;
- my $key = shift or return;
- my $target = @_ ? shift : 'opts_clean';
- foreach (map {clean($_)} keys %{$self->{default_opts}}) { # TODO: cache
- $key eq $_ and return $self->{$target}->{$_};
- }
-}
-
-# MyGetOptions
-# A wrapper around GetOptions
-# {opts} does two things for GetOptions (see Getopt::Long)
-# (1) maps command-line options to the *other* variables where values are stored (in opts_clean)
-# (2) provides hashspace for the rest of the arbitrary options from the command-line
-#
-# TODO: allow more options to be passed here, maybe mimic Getopt::Long::GetOptions style
-#
-# If an arrayref argument is passed, then @ARGV will NOT be touched.
-# Instead, the array will be passed to GetOptionsFromArray.
-#
-
-sub MyGetOptions {
- my $self = shift;
- my $arrayref = @_ ? shift : undef;
- if ($arrayref and ref($arrayref) ne 'ARRAY') {
- carp "MyGetOptions argument is not an array ref. Expect GetOptionsFromArray to explode";
- }
- $self->{got_options} and carp "MyGetOptions called after options were already retrieved previously";
- my @keys = sort {is_clean($b) <=> is_clean($a)} keys %{$self->{default_opts}};
- $debug and print "KEYS: ", join(", ", @keys), "\n";
- foreach (@keys) {
- my $clean = clean($_);
- my $place = $self->{default_opts_clean}->{$clean};
- $self->{opts_clean}->{$clean} = $place; # prepopulate default
- # $self->{opts}->{$_} = $self->{opts_clean}->{$clean}; # pointer for GetOptions
- $self->{opts}->{$_} = sub {
- my $opt = shift;
- my $val = shift;
- ref ( $self->{opts_clean}->{$opt} ) and ref($self->{opts_clean}->{$opt}) eq 'SCALAR'
- and ${$self->{opts_clean}->{$opt}} = $val; # set the referent's value
- $self->{opts_clean}->{$opt} = $val; # burn the map, stick the value there
- }; # pointer for GetOptions
- }
- $arrayref ? GetOptionsFromArray($arrayref, $self->{opts}, @keys)
- : GetOptions( $self->{opts}, @keys) ;
-
- foreach (@keys) {
- delete $self->{opts}->{$_}; # now remove the mappings from (1) so we just have (2)
- }
- $self->clean_mirror('opts'); # populate clean_opts w/ cleaned versions of (2), plus everything else
-
- print $self->help() and exit if $self->{opts_clean}->{help};
- $self->new_lockfile();
- $self->{got_options}++;
- return wantarray ? %{$self->{opts_clean}} : $self->{opts_clean};
-}
-
-sub new_lockfile {
- my $self = shift;
- $debug and $OpenILS::Utils::Lockfile::debug = $debug;
- unless ($self->{opts_clean}->{nolockfile} || $self->{default_opts_clean}->{nolockfile}) {
- $self->{lockfile_obj} = OpenILS::Utils::Lockfile->new($self->first_defined('lock-file'));
- $self->{lockfile} = $self->{lockfile_obj}->filename;
- }
-}
-
-sub first_defined {
- my $self = shift;
- my $key = shift or return;
- foreach (qw(opts_clean opts default_opts_clean default_opts)) {
- defined $self->{$_}->{$key} and return $self->{$_}->{$key};
- }
- return;
-}
-
-sub clean_mirror {
- my $self = shift;
- my $dirty = @_ ? shift : 'default_opts';
- foreach (keys %{$self->{$dirty}}) {
- defined $self->{$dirty}->{$_} or next;
- $self->{$dirty . '_clean'}->{clean($_)} = $self->{$dirty}->{$_};
- }
-}
-
-sub new {
- my $class = shift;
- my $self = _default_self;
- bless ($self, $class);
- $self->init(@_);
- $debug and print "new ", __PACKAGE__, " obj: ", Dumper($self);
- return $self;
-}
-
-sub add_and_purge {
- my $self = shift;
- my $key = shift;
- my $val = shift;
- my $clean = clean($key);
- my @others = grep {/$clean/ and $_ ne $key} keys %{$self->{default_opts}};
- unless (@others) {
- $debug and print "unique key $key => $val\n";
- $self->{default_opts}->{$key} = $val; # no purge, just add
- return;
- }
- foreach (@others) {
- $debug and print "variant of $key => $_\n";
- if ($key ne $clean) { # if it is a dirtier key, delete the clean one
- delete $self->{default_opts}->{$_};
- $self->{default_opts}->{$key} = $val;
- } else { # else update the dirty one
- $self->{default_opts}->{$_} = $val;
- }
- }
-}
-
-sub init { # not INIT
- my $self = shift;
- my $opts = @_ ? shift : {}; # user can specify more default options to constructor
-# TODO: check $opts is hashref; then check verbose/debug first. maybe check negations e.g. "no-verbose" ?
- @extra_opts = keys %$opts;
- foreach (@extra_opts) { # add any other keys w/ default values
- $debug and print "init() adding option $_, default value: $opts->{$_}\n";
- $self->add_and_purge($_, $opts->{$_});
- }
- $self->clean_mirror;
- return $self;
-}
-
-sub usage {
- # my $self = shift;
- return "\nUSAGE: $0 [OPTIONS]";
-}
-
-sub options_help {
- my $self = shift;
- my $chunk = @_ ? shift : '';
- return <<HELP
-
-COMMON OPTIONS:
- --osrf-config </path/to/config_file> Default: $self->{default_opts_clean}->{'osrf-config'}
- Specify OpenSRF core config file.
-
- --lock-file </path/to/file_name> Default: $self->{default_opts_clean}->{'lock-file'}
- Specify lock file.
-
-HELP
- . $chunk . <<HELP;
- --debug Print server responses to STDOUT for debugging
- --verbose Set verbosity
- --help Show this help message
-HELP
-}
-
-sub help {
- my $self = shift;
- return $self->usage() . "\n" . $self->options_help(@_) . $self->example();
-}
-
-sub example {
- return "\n\nEXAMPLES:\n\n $0 --osrf-config /my/other/opensrf_core.xml\n";
-}
-
-# the proper order is: MyGetOptions, bootstrap, session.
-# But the latter subs will check to see if they need to call the preceeding one(s).
-
-sub session {
- my $self = shift or return;
- $self->{bootstrapped} or $self->bootstrap();
- @_ or croak "session() called without required argument (app_name, e.g. 'open-ils.acq')";
- return ($self->{session} ||= OpenSRF::AppSession->create(@_));
-}
-
-sub bootstrap {
- my $self = shift or return;
- if ($self->{auto_get_options_4_bootstrap} and not $self->{got_options}) {
- $debug and print "Automatically calling MyGetOptions before bootstrap\n";
- $self->MyGetOptions();
- }
- try {
- $debug and print "bootstrap lock-file : ", $self->first_defined('lock-file'), "\n";
- $debug and print "bootstrap osrf-config: ", $self->first_defined('osrf-config'), "\n";
- OpenSRF::System->bootstrap_client(config_file => $self->first_defined('osrf-config'));
- Fieldmapper->import(IDL => OpenSRF::Utils::SettingsClient->new->config_value("IDL"));
- $self->{bootstrapped} = 1;
- } otherwise {
- $self->{bootstrapped} = 0;
- warn shift;
- };
-}
-
-sub editor_init {
- my $self = shift or return;
- OpenILS::Utils::CStoreEditor::init(); # no return value to check
- $self->{editor_inited} = 1;
-}
-
-sub editor {
- my $self = shift or return;
- $self->{bootstrapped} or $self->bootstrap();
- $self->{editor_inited} or $self->editor_init();
- return new_editor(@_);
-}
-
-1;
-__END__
-
-=pod
-
-=head1 NAME
-
-OpenILS::Utils::Cronscript - Consolidated options handling for any script (not just cron, really)
-
-=head1 SYNOPSIS
-
- use OpenILS::Utils::Cronscript;
-
- my %defaults = (
- 'min=i' => 0, # keys are Getopt::Long style options
- 'max=i' => 999, # values are default values
- 'user=s' => 'admin',
- 'password=s' => '',
- 'nolockfile' => 1,
- };
-
- my $core = OpenILS::Utils::Cronscript->new(\%defaults);
- my $opts = $core->MyGetOptions(); # options now in, e.g.: $opts->{max}
- $core->bootstrap;
-
-Or if you don't need any additional options and just want to get a session going:
-
- use OpenILS::Utils::Cronscript;
- my $session = OpenILS::Utils::Cronscript->new()->session('open-ils.acq');
-
-=head1 DESCRIPTION
-
-There are a few main problems when writing a new script for Evergreen.
-
-=head2 Initialization
-
-The runtime
-environment for the application requires a lot of initialization, but during normal operation it
-has already occured (when Evergreen was started). So most of the EG code never has to deal with
-this problem, but standalone scripts do. The timing and sequence of requisite events is important and not obvious.
-
-=head2 Common Options, Consistent Options
-
-We need several common options for each script that accesses the database or
-uses EG data objects and methods. Logically, these options often deal with initialization. They
-should take the B<exact> same form(s) for each script and should not be
-dependent on the local author to copy and paste them from some reference source. We really don't want to encourage (let alone force)
-admins to use C<--config>, C<--osrf-confg>, C<-c>, and C<@ARGV[2]> for the same purpose in different scripts, with different
-default handling, help descriptions and error messages (or lack thereof).
-
-This suggests broader problem of UI consistency and uniformity, also partially addressed by this module.
-
-=head2 Lockfiles
-
-A lockfile is necessary for a script that wants to prevent possible simultaneous execution. For example, consider a script
-that is scheduled to run frequently, but that experiences occasional high load: you wouldn't want crontab to start running
-it again if the first instance had not yet finished.
-
-But the code for creating, writing to, checking for, reading and cleaning up a lockfile for the script bloats what might otherwise be a terse
-method call. Conscript handles lockfile generation and removal automatically.
-
-=head1 OPTIONS
-
-The common options (and default values) are:
-
- 'lock-file=s' => OpenILS::Utils::Lockfile::default_filename,
- 'osrf-config=s' => '/openils/conf/opensrf_core.xml',
- 'debug' => 0,
- 'verbose+' => 0,
- 'help' => 0,
-
-=head1 TODO
-
-More docs here.
-
-=head1 SEE ALSO
-
- Getopt::Long
- OpenILS::Utils::Lockfile
- oils_header.pl
-
-=head1 AUTHOR
-
-Joe Atzberger <jatzberger@esilibrary.com>
-
-=cut
-
+++ /dev/null
-use strict; use warnings;
-package OpenILS::Utils::Editor;
-use OpenILS::Application::AppUtils;
-use OpenSRF::AppSession;
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Event;
-use Data::Dumper;
-use OpenSRF::Utils::JSON;
-use OpenSRF::Utils::Logger qw($logger);
-my $U = "OpenILS::Application::AppUtils";
-
-
-# -----------------------------------------------------------------------------
-# Export some useful functions
-# -----------------------------------------------------------------------------
-use vars qw(@EXPORT_OK %EXPORT_TAGS);
-use Exporter;
-use base qw/Exporter/;
-push @EXPORT_OK, 'new_editor';
-%EXPORT_TAGS = ( funcs => [ qw/ new_editor / ] );
-
-sub new_editor { return OpenILS::Utils::Editor->new(@_); }
-
-
-# -----------------------------------------------------------------------------
-# These need to be auto-generated
-# -----------------------------------------------------------------------------
-my %PERMS = (
- 'biblio.record_entry' => { update => 'UPDATE_MARC' },
- 'asset.copy' => { update => 'UPDATE_COPY' },
- 'asset.call_number' => { update => 'UPDATE_VOLUME' },
- 'action.circulation' => { retrieve => 'VIEW_CIRCULATIONS' },
-);
-
-use constant E => 'error';
-use constant W => 'warn';
-use constant I => 'info';
-use constant D => 'debug';
-use constant A => 'activity';
-
-
-
-# -----------------------------------------------------------------------------
-# Params include:
-# xact=><true> : creates a storage transaction
-# authtoken=>$token : the login session key
-# -----------------------------------------------------------------------------
-sub new {
- my( $class, %params ) = @_;
- $class = ref($class) || $class;
- my $self = bless( \%params, $class );
- $self->{checked_perms} = {};
- return $self;
-}
-
-# -----------------------------------------------------------------------------
-# Log the editor metadata along with the log string
-# -----------------------------------------------------------------------------
-sub log {
- my( $self, $lev, $str ) = @_;
- my $s = "editor[";
- $s .= "0|" unless $self->{xact};
- $s .= "1|" if $self->{xact};
- $s .= "0" unless $self->requestor;
- $s .= $self->requestor->id if $self->requestor;
- $s .= "]";
- $logger->$lev("$s $str");
-}
-
-# -----------------------------------------------------------------------------
-# Verifies the auth token and fetches the requestor object
-# -----------------------------------------------------------------------------
-sub checkauth {
- my $self = shift;
- $self->log(D, "checking auth token ".$self->authtoken);
- my ($reqr, $evt) = $U->checkses($self->authtoken);
- $self->event($evt) if $evt;
- return $self->{requestor} = $reqr;
-}
-
-
-# -----------------------------------------------------------------------------
-# Returns the last generated event
-# -----------------------------------------------------------------------------
-sub event {
- my( $self, $evt ) = @_;
- $self->{event} = $evt if $evt;
- return $self->{event};
-}
-
-# -----------------------------------------------------------------------------
-# Clears the last caught event
-# -----------------------------------------------------------------------------
-sub clear_event {
- my $self = shift;
- $self->{event} = undef;
-}
-
-sub authtoken {
- my( $self, $auth ) = @_;
- $self->{authtoken} = $auth if $auth;
- return $self->{authtoken};
-}
-
-# -----------------------------------------------------------------------------
-# fetches the session, creating if necessary. If 'xact' is true on this
-# object, a db session is created
-# -----------------------------------------------------------------------------
-sub session {
- my( $self, $session ) = @_;
- $self->{session} = $session if $session;
-
- if(!$self->{session}) {
- $self->{session} = OpenSRF::AppSession->create('open-ils.storage');
-
- if( ! $self->{session} ) {
- my $str = "Error creating storage session with OpenSRF::AppSession->create()!";
- $self->log(E, $str);
- throw OpenSRF::EX::ERROR ($str);
- }
-
- $self->{session}->connect if $self->{xact} or $self->{connect};
- $self->xact_start if $self->{xact};
- }
- return $self->{session};
-}
-
-
-# -----------------------------------------------------------------------------
-# Starts a storage transaction
-# -----------------------------------------------------------------------------
-sub xact_start {
- my $self = shift;
- $self->log(D, "starting new db session");
- my $stat = $self->request('open-ils.storage.transaction.begin');
- $self->log(E, "error starting database transaction") unless $stat;
- return $stat;
-}
-
-# -----------------------------------------------------------------------------
-# Commits a storage transaction
-# -----------------------------------------------------------------------------
-sub xact_commit {
- my $self = shift;
- $self->log(D, "comitting db session");
- my $stat = $self->request('open-ils.storage.transaction.commit');
- $self->log(E, "error comitting database transaction") unless $stat;
- return $stat;
-}
-
-# -----------------------------------------------------------------------------
-# Rolls back a storage stransaction
-# -----------------------------------------------------------------------------
-sub xact_rollback {
- my $self = shift;
- $self->log(I, "rolling back db session");
- return $self->request("open-ils.storage.transaction.rollback");
-}
-
-
-# -----------------------------------------------------------------------------
-# commits the db session and destroys the session
-# -----------------------------------------------------------------------------
-sub commit {
- my $self = shift;
- return unless $self->{xact};
- $self->xact_commit;
- $self->session->disconnect;
- $self->{session} = undef;
-}
-
-# -----------------------------------------------------------------------------
-# clears all object data. Does not commit the db transaction.
-# -----------------------------------------------------------------------------
-sub reset {
- my $self = shift;
- $self->session->disconnect if $self->{session};
- $$self{$_} = undef for (keys %$self);
-}
-
-
-# -----------------------------------------------------------------------------
-# commits and resets
-# -----------------------------------------------------------------------------
-sub finish {
- my $self = shift;
- $self->commit;
- $self->reset;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Does a simple storage request
-# -----------------------------------------------------------------------------
-sub request {
- my( $self, $method, @params ) = @_;
-
- my $val;
- my $err;
- my $argstr = __arg_to_string( (scalar(@params)) == 1 ? $params[0] : \@params);
-
- $self->log(I, "request $method : $argstr");
-
- try {
- $val = $self->session->request($method, @params)->gather(1);
-
- } catch Error with {
- $err = shift;
- $self->log(E, "request error $method : $argstr : $err");
- };
-
- throw $err if $err;
- return $val;
-}
-
-
-# -----------------------------------------------------------------------------
-# Sets / Returns the requstor object. This is set when checkauth succeeds.
-# -----------------------------------------------------------------------------
-sub requestor {
- my($self, $requestor) = @_;
- $self->{requestor} = $requestor if $requestor;
- return $self->{requestor};
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Holds the last data received from a storage call
-# -----------------------------------------------------------------------------
-sub data {
- my( $self, $data ) = @_;
- $self->{data} = $data if defined $data;
- return $self->{data};
-}
-
-
-# -----------------------------------------------------------------------------
-# True if this perm has already been checked at this org
-# -----------------------------------------------------------------------------
-sub perm_checked {
- my( $self, $perm, $org ) = @_;
- $self->{checked_perms}->{$org} = {}
- unless $self->{checked_perms}->{$org};
- my $checked = $self->{checked_perms}->{$org}->{$perm};
- if(!$checked) {
- $self->{checked_perms}->{$org}->{$perm} = 1;
- return 0;
- }
- return 1;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Returns true if the requested perm is allowed. If the perm check fails,
-# $e->event is set and undef is returned
-# The perm user is $e->requestor->id and perm org defaults to the requestor's
-# ws_ou
-# If this perm at the given org has already been verified, true is returned
-# and the perm is not re-checked
-# -----------------------------------------------------------------------------
-sub allowed {
- my( $self, $perm, $org ) = @_;
- my $uid = $self->requestor->id;
- $org ||= $self->requestor->ws_ou;
- $self->log(I, "checking perms user=$uid, org=$org, perm=$perm");
- return 1 if $self->perm_checked($perm, $org);
- return $self->checkperm($uid, $org, $perm);
-}
-
-sub checkperm {
- my($self, $userid, $org, $perm) = @_;
- my $s = $self->request(
- "open-ils.storage.permission.user_has_perm", $userid, $perm, $org );
-
- if(!$s) {
- my $e = OpenILS::Event->new('PERM_FAILURE', ilsperm => $perm, ilspermloc => $org);
- $self->event($e);
- return undef;
- }
-
- return 1;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# checks the appropriate perm for the operation
-# -----------------------------------------------------------------------------
-sub _checkperm {
- my( $self, $ptype, $action, $org ) = @_;
- $org ||= $self->requestor->ws_ou;
- my $perm = $PERMS{$ptype}{$action};
- if( $perm ) {
- return undef if $self->perm_checked($perm, $org);
- return $self->event unless $self->allowed($perm, $org);
- } else {
- $self->log(E, "no perm provided for $ptype.$action");
- }
- return undef;
-}
-
-
-
-# -----------------------------------------------------------------------------
-# Logs update actions to the activity log
-# -----------------------------------------------------------------------------
-sub log_activity {
- my( $self, $type, $action, $arg ) = @_;
- my $str = "$type.$action";
- $str .= _prop_string($arg);
- $self->log(A, $str);
-}
-
-
-
-sub _prop_string {
- my $obj = shift;
- my @props = $obj->properties;
- my $str = "";
- for(@props) {
- my $prop = $obj->$_() || "";
- $prop = substr($prop, 0, 128) . "..." if length $prop > 131;
- $str .= " $_=$prop";
- }
- return $str;
-}
-
-
-sub __arg_to_string {
- my $arg = shift;
- return "" unless defined $arg;
- return $arg->id if UNIVERSAL::isa($arg, "Fieldmapper");
- return OpenSRF::Utils::JSON->perl2JSON($arg);
-}
-
-
-# -----------------------------------------------------------------------------
-# This does the actual storage query.
-#
-# 'search' calls become search_where calls and $arg can be a search hash or
-# an array-ref of storage search options.
-#
-# 'retrieve' expects an id
-# 'update' expects an object
-# 'create' expects an object
-# 'delete' expects an object
-#
-# All methods return true on success and undef on failure. On failure,
-# $e->event is set to the generated event.
-# Note: this method assumes that updating a non-changed object and
-# thereby receiving a 0 from storage, is a successful update.
-#
-# The method will therefore return true so the caller can just do
-# $e->update_blah($x) or return $e->event;
-# The true value returned from storage for all methods will be stored in
-# $e->data, until the next method is called.
-#
-# not-found events are generated on retrieve and serach methods.
-# action=search methods will return [] (==true) if no data is found. If the
-# caller is interested in the not found event, they can do:
-# return $e->event unless @$results;
-# -----------------------------------------------------------------------------
-sub runmethod {
- my( $self, $action, $type, $arg, $options ) = @_;
-
- my @arg = ($arg);
- my $method = "open-ils.storage.direct.$type.$action";
-
- if( $action eq 'search' ) {
- $method =~ s/search/search_where/o;
- $method =~ s/direct/id_list/o if $options->{idlist};
- $method = "$method.atomic";
- @arg = @$arg if ref($arg) eq 'ARRAY';
-
- } elsif( $action eq 'batch_retrieve' ) {
- $method =~ s/batch_retrieve/batch.retrieve/o;
- $method = "$method.atomic";
- @arg = @$arg if ref($arg) eq 'ARRAY';
-
- } elsif( $action eq 'retrieve_all' ) {
- $method =~ s/retrieve_all/retrieve.all.atomic/o;
- }
-
- # remove any stale events
- $self->clear_event;
-
- if( $action eq 'update' or $action eq 'delete' or $action eq 'create' ) {
- $self->log_activity($type, $action, $arg);
- }
-
- if($$options{checkperm}) {
- my $a = ($action eq 'search' or
- $action eq 'batch_retrieve' or $action eq 'retrieve_all') ? 'retrieve' : $action;
- my $e = $self->_checkperm($type, $a, $$options{permorg});
- if($e) {
- $self->event($e);
- return undef;
- }
- }
-
- my $obj;
- my $err;
-
- try {
- $obj = $self->request($method, @arg);
- } catch Error with { $err = shift; };
-
-
- if(!defined $obj) {
- $self->log(I, "request returned no data");
-
- if( $action eq 'retrieve' ) {
- $self->event(_mk_not_found($type, $arg));
-
- } elsif( $action eq 'update' or
- $action eq 'delete' or $action eq 'create' ) {
- my $evt = OpenILS::Event->new(
- 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
- $self->event($evt);
- }
-
- if( $err ) {
- $self->event(
- OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
- payload => $arg, debug => "$err" ));
- return undef;
- }
-
- return undef;
- }
-
- if( $action eq 'create' and $obj == 0 ) {
- my $evt = OpenILS::Event->new(
- 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
- $self->event($evt);
- return undef;
- }
-
- # If we havn't dealt with the error in a nice way, go ahead and throw it
- if( $err ) {
- $self->event(
- OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
- payload => $arg, debug => "$err" ));
- return undef;
- }
-
- if( $action eq 'search' or $action eq 'batch_retrieve' or $action eq 'retrieve_all') {
- $self->log(I, "$type.$action : returned ".scalar(@$obj). " result(s)");
- $self->event(_mk_not_found($type, $arg)) unless @$obj;
- }
-
- $arg->id($obj) if $action eq 'create'; # grabs the id on create
- $self->data($obj); # cache the data for convenience
-
- return ($obj) ? $obj : 1;
-}
-
-
-sub _mk_not_found {
- my( $type, $arg ) = @_;
- (my $t = $type) =~ s/\./_/og;
- $t = uc($t);
- return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
-}
-
-
-
-# utility method for loading
-sub __fm2meth {
- my $str = shift;
- my $sep = shift;
- $str =~ s/Fieldmapper:://o;
- $str =~ s/::/$sep/g;
- return $str;
-}
-
-
-# -------------------------------------------------------------
-# Load up the methods from the FM classes
-# -------------------------------------------------------------
-my $map = $Fieldmapper::fieldmap;
-for my $object (keys %$map) {
- my $obj = __fm2meth($object,'_');
- my $type = __fm2meth($object, '.');
-
- my $update = "update_$obj";
- my $updatef =
- "sub $update {return shift()->runmethod('update', '$type', \@_);}";
- eval $updatef;
-
- my $retrieve = "retrieve_$obj";
- my $retrievef =
- "sub $retrieve {return shift()->runmethod('retrieve', '$type', \@_);}";
- eval $retrievef;
-
- my $search = "search_$obj";
- my $searchf =
- "sub $search {return shift()->runmethod('search', '$type', \@_);}";
- eval $searchf;
-
- my $create = "create_$obj";
- my $createf =
- "sub $create {return shift()->runmethod('create', '$type', \@_);}";
- eval $createf;
-
- my $delete = "delete_$obj";
- my $deletef =
- "sub $delete {return shift()->runmethod('delete', '$type', \@_);}";
- eval $deletef;
-
- my $bretrieve = "batch_retrieve_$obj";
- my $bretrievef =
- "sub $bretrieve {return shift()->runmethod('batch_retrieve', '$type', \@_);}";
- eval $bretrievef;
-
- my $retrieveall = "retrieve_all_$obj";
- my $retrieveallf =
- "sub $retrieveall {return shift()->runmethod('retrieve_all', '$type', \@_);}";
- eval $retrieveallf;
-
-
-}
-
-
-
-1;
-
-
+++ /dev/null
-package Fieldmapper;
-use OpenSRF::Utils::JSON;
-use Data::Dumper;
-use base 'OpenSRF::Application';
-use OpenSRF::Utils::Logger;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::System;
-use XML::LibXML;
-
-my $log = 'OpenSRF::Utils::Logger';
-
-use vars qw/$fieldmap $VERSION/;
-
-sub publish_fieldmapper {
- my ($self,$client,$class) = @_;
-
- return $fieldmap unless (defined $class);
- return undef unless (exists($$fieldmap{$class}));
- return {$class => $$fieldmap{$class}};
-}
-__PACKAGE__->register_method(
- api_name => 'opensrf.open-ils.system.fieldmapper',
- api_level => 1,
- method => 'publish_fieldmapper',
-);
-
-#
-# To dump the Javascript version of the fieldmapper struct use the command:
-#
-# PERL5LIB=~/cvs/ILS/OpenSRF/src/perlmods/:~/cvs/ILS/Open-ILS/src/perlmods/ GEN_JS=1 perl -MOpenILS::Utils::Fieldmapper -e 'print "\n";'
-#
-# ... adjusted for your CVS sandbox, of course.
-#
-
-sub classes {
- return () unless (defined $fieldmap);
- return keys %$fieldmap;
-}
-
-sub get_attribute {
- my $attr_list = shift;
- my $attr_name = shift;
-
- my $attr = $attr_list->getNamedItem( $attr_name );
- if( defined( $attr ) ) {
- return $attr->getValue();
- }
- return undef;
-}
-
-sub load_fields {
- my $field_list = shift;
- my $fm = shift;
-
- # Get attributes of the field list. Since there is only one
- # <field> per class, these attributes logically belong to the
- # enclosing class, and that's where we load them.
-
- my $field_attr_list = $field_list->attributes();
-
- my $sequence = get_attribute( $field_attr_list, 'oils_persist:sequence' );
- if( ! defined( $sequence ) ) {
- $sequence = '';
- }
- my $primary = get_attribute( $field_attr_list, 'oils_persist:primary' );
-
- # Load attributes into the Fieldmapper ----------------------
-
- $$fieldmap{$fm}{ sequence } = $sequence;
- $$fieldmap{$fm}{ identity } = $primary;
-
- # Load each field -------------------------------------------
-
- my $array_position = 0;
- for my $field ( $field_list->childNodes() ) { # For each <field>
- if( $field->nodeName eq 'field' ) {
-
- my $attribute_list = $field->attributes();
-
- my $name = get_attribute( $attribute_list, 'name' );
- next if( $name eq 'isnew' || $name eq 'ischanged' || $name eq 'isdeleted' );
- my $required = get_attribute( $attribute_list, 'oils_obj:required' );
- my $validate = get_attribute( $attribute_list, 'oils_obj:validate' );
- my $virtual = get_attribute( $attribute_list, 'oils_persist:virtual' );
- if( ! defined( $virtual ) ) {
- $virtual = "false";
- }
- my $selector = get_attribute( $attribute_list, 'reporter:selector' );
-
- $$fieldmap{$fm}{fields}{ $name } =
- { virtual => ( $virtual eq 'true' ) ? 1 : 0,
- required => ( $required eq 'true' ) ? 1 : 0,
- position => $array_position,
- };
-
- $$fieldmap{$fm}{fields}{ $name }{validate} = qr/$validate/ if (defined($validate));
-
- # The selector attribute, if present at all, attaches to only one
- # of the fields in a given class. So if we see it, we store it at
- # the level of the enclosing class.
-
- if( defined( $selector ) ) {
- $$fieldmap{$fm}{selector} = $selector;
- }
-
- ++$array_position;
- }
- }
-
- # Load the standard 3 virtual fields ------------------------
-
- for my $vfield ( qw/isnew ischanged isdeleted/ ) {
- $$fieldmap{$fm}{fields}{ $vfield } =
- { position => $array_position,
- virtual => 1
- };
- ++$array_position;
- }
-}
-
-sub load_links {
- my $link_list = shift;
- my $fm = shift;
-
- for my $link ( $link_list->childNodes() ) { # For each <link>
- if( $link->nodeName eq 'link' ) {
- my $attribute_list = $link->attributes();
-
- my $field = get_attribute( $attribute_list, 'field' );
- my $reltype = get_attribute( $attribute_list, 'reltype' );
- my $key = get_attribute( $attribute_list, 'key' );
- my $class = get_attribute( $attribute_list, 'class' );
-
- $$fieldmap{$fm}{links}{ $field } =
- { class => $class,
- reltype => $reltype,
- key => $key,
- };
- }
- }
-}
-
-sub load_class {
- my $class_node = shift;
-
- # Get attributes ---------------------------------------------
-
- my $attribute_list = $class_node->attributes();
-
- my $fm = get_attribute( $attribute_list, 'oils_obj:fieldmapper' );
- $fm = 'Fieldmapper::' . $fm;
- my $id = get_attribute( $attribute_list, 'id' );
- my $controller = get_attribute( $attribute_list, 'controller' );
- my $virtual = get_attribute( $attribute_list, 'virtual' );
- if( ! defined( $virtual ) ) {
- $virtual = 'false';
- }
- my $tablename = get_attribute( $attribute_list, 'oils_persist:tablename' );
- if( ! defined( $tablename ) ) {
- $tablename = '';
- }
- my $restrict_primary = get_attribute( $attribute_list, 'oils_persist:restrict_primary' );
-
- # Load the attributes into the Fieldmapper --------------------
-
- $log->debug("Building Fieldmapper class for [$fm] from IDL");
-
- $$fieldmap{$fm}{ hint } = $id;
- $$fieldmap{$fm}{ virtual } = ( $virtual eq 'true' ) ? 1 : 0;
- $$fieldmap{$fm}{ table } = $tablename;
- $$fieldmap{$fm}{ controller } = [ split ' ', $controller ];
- $$fieldmap{$fm}{ restrict_primary } = $restrict_primary;
-
- # Load fields and links
-
- for my $child ( $class_node->childNodes() ) {
- my $nodeName = $child->nodeName;
- if( $nodeName eq 'fields' ) {
- load_fields( $child, $fm );
- } elsif( $nodeName eq 'links' ) {
- load_links( $child, $fm );
- }
- }
-}
-
-import();
-sub import {
- my $class = shift;
- my %args = @_;
-
- return if (keys %$fieldmap);
- return if (!OpenSRF::System->connected && !$args{IDL});
-
- # parse the IDL ...
- my $parser = XML::LibXML->new();
- my $file = $args{IDL} || OpenSRF::Utils::SettingsClient->new->config_value( 'IDL' );
- my $fmdoc = $parser->parse_file( $file );
- my $rootnode = $fmdoc->documentElement();
-
- for my $child ( $rootnode->childNodes() ) { # For each <class>
- my $nodeName = $child->nodeName;
- if( $nodeName eq 'class' ) {
- load_class( $child );
- }
- }
-
- #-------------------------------------------------------------------------------
- # Now comes the evil! Generate classes
-
- for my $pkg ( __PACKAGE__->classes ) {
- (my $cdbi = $pkg) =~ s/^Fieldmapper:://o;
-
- eval <<" PERL";
- package $pkg;
- use base 'Fieldmapper';
- PERL
-
- if (exists $$fieldmap{$pkg}{proto_fields}) {
- for my $pfield ( sort keys %{ $$fieldmap{$pkg}{proto_fields} } ) {
- $$fieldmap{$pkg}{fields}{$pfield} = { position => $pos, virtual => $$fieldmap{$pkg}{proto_fields}{$pfield} };
- $pos++;
- }
- }
-
- OpenSRF::Utils::JSON->register_class_hint(
- hint => $pkg->json_hint,
- name => $pkg,
- type => 'array',
- );
-
- }
-}
-
-sub new {
- my $self = shift;
- my $value = shift;
- $value = [] unless (defined $value);
- return bless $value => $self->class_name;
-}
-
-sub decast {
- my $self = shift;
- return [ @$self ];
-}
-
-sub DESTROY {}
-
-sub AUTOLOAD {
- my $obj = shift;
- my $value = shift;
- (my $field = $AUTOLOAD) =~ s/^.*://o;
- my $class_name = $obj->class_name;
-
- my $fpos = $field;
- $fpos =~ s/^clear_//og ;
-
- my $pos = $$fieldmap{$class_name}{fields}{$fpos}{position};
-
- if ($field =~ /^clear_/o) {
- { no strict 'subs';
- *{$obj->class_name."::$field"} = sub {
- my $self = shift;
- $self->[$pos] = undef;
- return 1;
- };
- }
- return $obj->$field();
- }
-
- die "No field by the name $field in $class_name!"
- unless (exists $$fieldmap{$class_name}{fields}{$field} && defined($pos));
-
-
- { no strict 'subs';
- *{$obj->class_name."::$field"} = sub {
- my $self = shift;
- my $new_val = shift;
- $self->[$pos] = $new_val if (defined $new_val);
- return $self->[$pos];
- };
- }
- return $obj->$field($value);
-}
-
-sub Selector {
- my $self = shift;
- return $$fieldmap{$self->class_name}{selector};
-}
-
-sub Identity {
- my $self = shift;
- return $$fieldmap{$self->class_name}{identity};
-}
-
-sub RestrictPrimary {
- my $self = shift;
- return $$fieldmap{$self->class_name}{restrict_primary};
-}
-
-sub Sequence {
- my $self = shift;
- return $$fieldmap{$self->class_name}{sequence};
-}
-
-sub Table {
- my $self = shift;
- return $$fieldmap{$self->class_name}{table};
-}
-
-sub Controller {
- my $self = shift;
- return $$fieldmap{$self->class_name}{controller};
-}
-
-sub RequiredField {
- my $self = shift;
- my $f = shift;
- return undef unless ($f);
- return $$fieldmap{$self->class_name}{fields}{$f}{required};
-}
-
-sub ValidateField {
- my $self = shift;
- my $f = shift;
- return undef unless ($f);
- return 1 if (!exists($$fieldmap{$self->class_name}{fields}{$f}{validate}));
- return $self->$f =~ $$fieldmap{$self->class_name}{fields}{$f}{validate};
-}
-
-sub class_name {
- my $class_name = shift;
- return ref($class_name) || $class_name;
-}
-
-sub real_fields {
- my $self = shift;
- my $class_name = $self->class_name;
- my $fields = $$fieldmap{$class_name}{fields};
-
- my @f = grep {
- !$$fields{$_}{virtual}
- } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
-
- return @f;
-}
-
-sub has_field {
- my $self = shift;
- my $field = shift;
- my $class_name = $self->class_name;
- return 1 if grep { $_ eq $field } keys %{$$fieldmap{$class_name}{fields}};
- return 0;
-}
-
-sub properties {
- my $self = shift;
- my $class_name = $self->class_name;
- return keys %{$$fieldmap{$class_name}{fields}};
-}
-
-sub to_bare_hash {
- my $self = shift;
-
- my %hash = ();
- for my $f ($self->properties) {
- my $val = $self->$f;
- $hash{$f} = $val;
- }
-
- return \%hash;
-}
-
-sub clone {
- my $self = shift;
- return $self->new( [@$self] );
-}
-
-sub api_level {
- my $self = shift;
- return $fieldmap->{$self->class_name}->{api_level};
-}
-
-sub cdbi {
- my $self = shift;
- return $fieldmap->{$self->class_name}->{cdbi};
-}
-
-sub is_virtual {
- my $self = shift;
- my $field = shift;
- return $fieldmap->{$self->class_name}->{proto_fields}->{$field} if ($field);
- return $fieldmap->{$self->class_name}->{virtual};
-}
-
-sub is_readonly {
- my $self = shift;
- my $field = shift;
- return $fieldmap->{$self->class_name}->{readonly};
-}
-
-sub json_hint {
- my $self = shift;
- return $fieldmap->{$self->class_name}->{hint};
-}
-
-
-1;
+++ /dev/null
-package OpenILS::Utils::ISBN;
-
-# ---------------------------------------------------------------
-# Copyright (C) 2010 Equinox Software, Inc
-# Author: Joe Atzberger <jatzberger@esilibrary.com>
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-use strict;
-use warnings;
-
-use Business::ISBN;
-
-use base qw/Exporter/;
-our $VERSION = '0.01';
-our @EXPORT_OK = qw/isbn_upconvert/;
-
-# Jason Stephenson <jstephenson@mvlc.org> at Merrimack Valley Library Consortium
-# Dan Scott <dscott@laurentian.ca> at Laurentian University
-
-sub isbn_upconvert {
- my $in = @_ ? shift : return;
- my $pretty = @_ ? shift : 0;
- $in =~ s/\s*//g;
- $in =~ s/-//g;
- length($in) or return;
- my $isbn = Business::ISBN->new($in) or return;
- $isbn->fix_checksum() if $isbn->is_valid_checksum() == Business::ISBN::BAD_CHECKSUM;
- $isbn->is_valid() or return;
- return $pretty ? $isbn->as_isbn13->as_string : $isbn->as_isbn13->isbn;
-}
-
-1;
-__END__
-
-For example, if you have a file isbns.txt with these lines:
-
-1598884093
- 1598884093
- 15 988 840 93
-0446357197
- 0 446 3 5 7 1 9 7
- 0 446 3 5 7 1 9 1
-0596526857
-0786222735
-0446360015
-0446350109
-0446314129
-0439139597
-0743294394
-159143047X
-1590203097
-075480965X
-0393048799
-0446831832
-0446310069
-1598883275
-0446313033
-0446360279
-
-And you run:
- perl -pe 'use OpenILS::Utils::ISBN qw/isbn_upconvert/; $_ = isbn_upconvert($_) . "\n";' <isbns.txt
-
-You get this output:
-9781598884098
-9781598884098
-9781598884098
-9780446357197
-9780446357197
-9780446357197
-9780596526856
-9780786222735
-9780446360012
-9780446350105
-9780446314121
-9780439139595
-9780743294393
-9781591430476
-9781590203095
-9780754809654
-9780393048797
-9780446831833
-9780446310062
-9781598883275
-9780446313032
-9780446360272
-
+++ /dev/null
-package OpenILS::Utils::Lockfile;
-
-# ---------------------------------------------------------------
-# Copyright (C) 2010 Equinox Software, Inc
-# Author: Joe Atzberger <jatzberger@esilibrary.com>
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-# The purpose of this module is to consolidate
-# non-duplicative processing, i.e. lockfiles and lockfile checking
-
-use strict;
-use warnings;
-use Carp;
-
-use File::Basename qw/fileparse/;
-
-sub _tempdir {
- return $ENV{TEMP} || $ENV{TMP} || '/tmp';
-}
-
-our $debug = 0;
-
-sub default_filename {
- my $tempdir = _tempdir;
- my $filename = fileparse($0, '.pl');
- return "$tempdir/$filename-LOCK";
-}
-
-sub new {
- my $class = shift;
- my $lockfile = @_ ? shift : default_filename;
-
- croak "Script already running with lockfile $lockfile" if -e $lockfile;
- $debug and print "Writing lockfile $lockfile (PID: $$)\n";
-
- open (F, ">$lockfile") or croak "Cannot write to lockfile '$lockfile': $!";
- print F $$;
- close F;
-
- my $self = {
- filename => $lockfile,
- contents => $$,
- };
- return bless ($self, $class);
-}
-
-sub filename {
- my $self = shift;
- return $self->{filename};
-}
-sub contents {
- my $self = shift;
- return $self->{contents};
-}
-
-DESTROY {
- my $self = shift;
- # lockfile cleanup
- if (-e $self->{filename}) {
- open LF, $self->{filename};
- my $contents = <LF>;
- close LF;
- $debug and print "deleting lockfile $self->{filename}\n";
- if ($contents == $self->{contents}) {
- unlink $self->{filename} or carp "Failed to remove lockfile '$self->{filename}'";
- } else {
- carp "Lockfile contents '$contents' no longer match '$self->{contents}'. Cannot remove $self->{filename}";
- }
-
- }
-}
-
-1;
+++ /dev/null
-package MFHD;
-use strict;
-use warnings;
-use integer;
-use Carp;
-use DateTime::Format::Strptime;
-use Data::Dumper;
-
-# for inherited methods to work properly, we need to force a
-# MARC::Record version greater than 2.0.0
-use MARC::Record "2.0.1";
-use base 'MARC::Record';
-
-use OpenILS::Utils::MFHD::Caption;
-use OpenILS::Utils::MFHD::Holding;
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = shift;
-
- $self->{_strp_date} = new DateTime::Format::Strptime(pattern => '%F');
-
- $self->{_mfhd_CAPTIONS} = {};
- $self->{_mfhd_COMPRESSIBLE} = (substr($self->leader, 17, 1) =~ /[45]/);
-
- foreach my $field ('853', '854', '855') {
- my $captions = {};
- foreach my $caption ($self->field($field)) {
- my $cap_id;
-
- $cap_id = $caption->subfield('8') || '0';
-
- if (exists $captions->{$cap_id}) {
- carp "Multiple MFHD captions with label '$cap_id'";
- }
-
- $captions->{$cap_id} = new MFHD::Caption($caption);
- if ($self->{_mfhd_COMPRESSIBLE}) {
- $self->{_mfhd_COMPRESSIBLE} &&=
- $captions->{$cap_id}->compressible;
- }
- }
- $self->{_mfhd_CAPTIONS}->{$field} = $captions;
- }
-
- foreach my $field ('863', '864', '865') {
- my $holdings = {};
- my $cap_field;
-
- ($cap_field = $field) =~ s/6/5/;
-
- foreach my $hfield ($self->field($field)) {
- my ($linkage, $link_id, $seqno);
- my $holding;
-
- $linkage = $hfield->subfield('8');
- ($link_id, $seqno) = split(/\./, $linkage);
-
- if (!exists $holdings->{$link_id}) {
- $holdings->{$link_id} = {};
- }
- $holding =
- new MFHD::Holding($seqno, $hfield,
- $self->{_mfhd_CAPTIONS}->{$cap_field}->{$link_id});
- $holdings->{$link_id}->{$seqno} = $holding;
-
- if ($self->{_mfhd_COMPRESSIBLE}) {
- $self->{_mfhd_COMPRESSIBLE} &&= $holding->validate;
- }
- }
- $self->{_mfhd_HOLDINGS}->{$field} = $holdings;
- }
-
- bless($self, $class);
- return $self;
-}
-
-sub compressible {
- my $self = shift;
-
- return $self->{_mfhd_COMPRESSIBLE};
-}
-
-sub caption_link_ids {
- my $self = shift;
- my $field = shift;
-
- return sort keys %{$self->{_mfhd_CAPTIONS}->{$field}};
-}
-
-# optional argument to get back a 'hashref' or an 'array' (default)
-sub captions {
- my $self = shift;
- my $tag = shift;
- my $return_type = shift;
-
- # TODO: add support for caption types as argument? (base, index, supplement)
- my @sorted_ids = $self->caption_link_ids($tag);
-
- if (defined($return_type) and $return_type eq 'hashref') {
- my %captions;
- foreach my $link_id (@sorted_ids) {
- $captions{$link_id} = $self->{_mfhd_CAPTIONS}{$tag}{$link_id};
- }
- return \%captions;
- } else {
- my @captions;
- foreach my $link_id (@sorted_ids) {
- push(@captions, $self->{_mfhd_CAPTIONS}{$tag}{$link_id});
- }
- return @captions;
- }
-}
-
-sub append_fields {
- my $self = shift;
-
- my $field_count = $self->SUPER::append_fields(@_);
- if ($field_count) {
- foreach my $field (@_) {
- $self->_avoid_link_collision($field);
- my $field_type = ref $field;
- if ($field_type eq 'MFHD::Holding') {
- $self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno} = $field;
- } elsif ($field_type eq 'MFHD::Caption') {
- $self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id} = $field;
- }
- }
- return $field_count;
- } else {
- return;
- }
-}
-
-sub delete_field {
- my $self = shift;
- my $field = shift;
-
- my $field_count = $self->SUPER::delete_field($field);
- if ($field_count) {
- my $field_type = ref($field);
- if ($field_type eq 'MFHD::Holding') {
- delete($self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno});
- } elsif ($field_type eq 'MFHD::Caption') {
- delete($self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id});
- }
- return $field_count;
- } else {
- return;
- }
-}
-
-sub insert_fields_before {
- my $self = shift;
- my $before = shift;
-
- my $field_count = $self->SUPER::insert_fields_before($before, @_);
- if ($field_count) {
- foreach my $field (@_) {
- $self->_avoid_link_collision($field);
- my $field_type = ref $field;
- if ($field_type eq 'MFHD::Holding') {
- $self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno} = $field;
- } elsif ($field_type eq 'MFHD::Caption') {
- $self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id} = $field;
- }
- }
- return $field_count;
- } else {
- return;
- }
-}
-
-sub insert_fields_after {
- my $self = shift;
- my $after = shift;
-
- my $field_count = $self->SUPER::insert_fields_after($after, @_);
- if ($field_count) {
- foreach my $field (@_) {
- $self->_avoid_link_collision($field);
- my $field_type = ref $field;
- if ($field_type eq 'MFHD::Holding') {
- $self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno} = $field;
- } elsif ($field_type eq 'MFHD::Caption') {
- $self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id} = $field;
- }
- }
- return $field_count;
- } else {
- return;
- }
-}
-
-sub _avoid_link_collision {
- my $self = shift;
- my $field = shift;
-
- my $fieldref = ref($field);
- if ($fieldref eq 'MFHD::Holding') {
- my $seqno = $field->seqno;
- my $changed_seqno = 0;
- if (exists($self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$seqno})) {
- $changed_seqno = 1;
- do {
- $seqno++;
- } while (exists($self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$seqno}));
- }
- $field->seqno($seqno) if $changed_seqno;
- } elsif ($fieldref eq 'MFHD::Caption') {
- my $link_id = $field->link_id;
- my $changed_link_id = 0;
- if (exists($self->{_mfhd_CAPTIONS}{$field->tag}{$link_id})) {
- $link_id++;
- $changed_link_id = 1;
- do {
- $link_id++;
- } while (exists($self->{_mfhd_CAPTIONS}{$field->tag}{$link_id}));
- }
- $field->link_id($link_id) if $changed_link_id;
- }
-}
-
-sub active_captions {
- my $self = shift;
- my $tag = shift;
-
- # TODO: add support for caption types as argument? (basic, index, supplement)
- my @captions;
- my @active_captions;
-
- @captions = $self->captions($tag);
-
- # TODO: for now, we will assume the last 85X field is active
- # and the rest are historical. The standard is hazy about
- # how multiple active patterns of the same 85X type should be
- # handled. We will, however, return as an array for future
- # use.
- push(@active_captions, $captions[-1]);
-
- return @active_captions;
-}
-
-sub holdings {
- my $self = shift;
- my $field = shift;
- my $capid = shift;
-
- return
- sort { $a->seqno <=> $b->seqno }
- values %{$self->{_mfhd_HOLDINGS}->{$field}->{$capid}};
-}
-
-sub _holding_date {
- my $self = shift;
- my $holding = shift;
-
- return $self->{_strp_date}->parse_datetime($holding->chron_to_date);
-}
-
-#
-# generate_predictions()
-# Accepts a hash ref of options initially defined as:
-# base_holding : reference to the holding field to predict from
-# num_to_predict : the number of issues you wish to predict
-# OR
-# end_holding : holding field ref, keep predicting until you meet or exceed it
-# OR
-# end_date : keep predicting until you exceed this
-#
-# The basic method is to first convert to a single holding if compressed, then
-# increment the holding and save the resulting values to @predictions.
-#
-# returns @predictions, an array of holding field refs (including end_holding
-# if applicable but NOT base_holding)
-#
-sub generate_predictions {
- my ($self, $options) = @_;
-
- my $base_holding = $options->{base_holding};
- my $num_to_predict = $options->{num_to_predict};
- my $end_holding = $options->{end_holding};
- my $end_date = $options->{end_date};
- my $max_to_predict = $options->{max_to_predict} || 10000; # fail-safe
-
- if (!defined($base_holding)) {
- carp("Base holding not defined in generate_predictions, returning empty set");
- return ();
- }
- if ($base_holding->is_compressed) {
- carp("Ambiguous compressed base holding in generate_predictions, returning empty set");
- return ();
- }
- my $curr_holding = $base_holding->clone; # prevent side-effects
-
- my @predictions;
-
- if ($num_to_predict) {
- for (my $i = 0; $i < $num_to_predict; $i++) {
- push(@predictions, $curr_holding->increment->clone);
- }
- } elsif (defined($end_holding)) {
- $end_holding = $end_holding->clone; # prevent side-effects
- my $next_holding = $curr_holding->increment->clone;
- my $num_predicted = 0;
- while ($next_holding le $end_holding) {
- push(@predictions, $next_holding);
- $num_predicted++;
- if ($num_predicted >= $max_to_predict) {
- carp("Maximum prediction count exceeded");
- last;
- }
- $next_holding = $curr_holding->increment->clone;
- }
- } elsif (defined($end_date)) {
- my $next_holding = $curr_holding->increment->clone;
- my $num_predicted = 0;
- while ($self->_holding_date($next_holding) <= $end_date) {
- push(@predictions, $next_holding);
- $num_predicted++;
- if ($num_predicted >= $max_to_predict) {
- carp("Maximum prediction count exceeded");
- last;
- }
- $next_holding = $curr_holding->increment->clone;
- }
- }
-
- return @predictions;
-}
-
-#
-# create an array of compressed holdings from all holdings for a given caption,
-# compressing as needed
-#
-# Optionally you can skip sorting, but the resulting compression will be compromised
-# if the current holdings are out of order
-#
-# TODO: gap marking, gap preservation
-#
-# TODO: some of this could be moved to the Caption object to allow for
-# decompression in the absense of an overarching MFHD object
-#
-sub get_compressed_holdings {
- my $self = shift;
- my $caption = shift;
- my $opts = shift;
- my $skip_sort = $opts->{'skip_sort'};
-
- # make sure none are compressed
- my @decomp_holdings;
- if ($skip_sort) {
- @decomp_holdings = $self->get_decompressed_holdings($caption, {'skip_sort' => 1});
- } else {
- # sort for best algorithm
- @decomp_holdings = $self->get_decompressed_holdings($caption, {'dedupe' => 1});
- }
-
- my $runner = $decomp_holdings[0]->clone->increment;
- my $curr_holding = shift(@decomp_holdings);
- $curr_holding = $curr_holding->clone;
- my $seqno = 1;
- $curr_holding->seqno($seqno);
- my @comp_holdings;
-# my $last_holding;
- foreach my $holding (@decomp_holdings) {
- if ($runner eq $holding) {
- $curr_holding->extend;
- $runner->increment;
-# } elsif ($holding eq $last_holding) {
-# carp("Found duplicate holding in compression set, skipping");
- } elsif ($runner gt $holding) { # should not happen unless holding is not in series
- carp("Found unexpected holding, skipping");
- } else {
- push(@comp_holdings, $curr_holding);
- while ($runner le $holding) {
- $runner->increment;
- }
- $curr_holding = $holding->clone;
- $seqno++;
- $curr_holding->seqno($seqno);
- }
-# $last_holding = $holding;
- }
- push(@comp_holdings, $curr_holding);
-
- return @comp_holdings;
-}
-
-#
-# create an array of single holdings from all holdings for a given caption,
-# decompressing as needed
-#
-# resulting array is returned as they come in the record, unsorted
-#
-# optional argument will reorder and renumber the holdings before returning
-#
-# TODO: some of this could be moved to the Caption (and/or Holding) object to
-# allow for decompression in the absense of an overarching MFHD object
-#
-sub get_decompressed_holdings {
- my $self = shift;
- my $caption = shift;
- my $opts = shift;
- my $skip_sort = $opts->{'skip_sort'};
- my $dedupe = $opts->{'dedupe'};
-
- if ($dedupe and $skip_sort) {
- carp("Attempted deduplication without sorting, failure likely");
- }
-
- my $htag = $caption->tag;
- my $link_id = $caption->link_id;
- $htag =~ s/^85/86/;
- my @holdings = $self->holdings($htag, $link_id);
- my @decomp_holdings;
-
- foreach my $holding (@holdings) {
- if (!$holding->is_compressed) {
- push(@decomp_holdings, $holding->clone);
- } else {
- my $base_holding = $holding->clone->compressed_to_first;
- my @new_holdings = $self->generate_predictions(
- {'base_holding' => $base_holding,
- 'end_holding' => $holding->clone->compressed_to_last});
- push(@decomp_holdings, $base_holding, @new_holdings);
- }
- }
-
- unless ($skip_sort) {
- my @temp_holdings = sort {$a cmp $b} @decomp_holdings;
- @decomp_holdings = @temp_holdings;
- }
-
- my @return_holdings = (shift(@decomp_holdings));
- $return_holdings[0]->seqno(1);
- my $seqno = 2;
- foreach my $holding (@decomp_holdings) { # renumber sequence
- if ($holding eq $return_holdings[-1] and $dedupe) {
- carp("Found duplicate holding in decompression set, discarding");
- next;
- }
- $holding->seqno($seqno);
- $seqno++;
- push(@return_holdings, $holding);
- }
-
- return @return_holdings;
-}
-
-#
-# format_holdings(): Generate textual display of all holdings in record
-# for given type of caption (853--855) taking into account all the
-# captions, holdings statements, and textual
-# holdings.
-#
-# returns string formatted holdings as one very long line.
-# Caller must provide any label (such as "library has:" and insert
-# line breaks as appropriate.
-
-# Translate caption field labels to the corresponding textual holdings
-# statement labels. That is, convert 853 "Basic bib unit" caption to
-# 866 "basic bib unit" text holdings label.
-
-my %cap_to_txt = (
- '853' => '866',
- '854' => '867',
- '855' => '868',
- );
-
-sub format_holdings {
- my $self = shift;
- my $field = shift;
- my $holdings_field;
- my @txt_holdings;
- my %txt_link_ids;
- my $holdings_stmt = '';
- my ($l, $start);
-
- # convert caption field id to holdings field id
- ($holdings_field = $field) =~ s/5/6/;
-
- # Textual holdings statements complicate the basic algorithm for
- # formatting the holdings: If there's a textual holdings statement
- # with the subfield "$80", then that overrides ALL the MFHD holdings
- # information and is all that is displayed. Otherwise, the textual
- # holdings statements will either replace some of the MFHD holdings
- # information, or supplement it, depending on the value of the
- # $8 linkage subfield.
-
- if (defined $self->field($cap_to_txt{$field})) {
- @txt_holdings = $self->field($cap_to_txt{$field});
-
- foreach my $txt (@txt_holdings) {
-
- # if there's a $80 subfield, then we're done, it's
- # all the formatted holdings
- if ($txt->subfield('8') eq '0') {
- # textual holdings statement that completely
- # replaces MFHD holdings in 853/863, etc.
- $holdings_stmt = $txt->subfield('a');
-
- if (defined $txt->subfield('z')) {
- $holdings_stmt .= ' -- ' . $txt->subfield('z');
- }
-
- printf("# format_holdings() returning %s txt holdings\n",
- $cap_to_txt{$field});
- return $holdings_stmt;
- }
-
- # If there are non-$80 subfields in the textual holdings
- # then we need to keep track of the subfields, so we can
- # intersperse the textual holdings in with the the calculated
- # holdings from the 853/863 fields.
- foreach my $linkid ($txt->subfield('8')) {
- $txt_link_ids{$linkid} = $txt;
- }
- }
- }
-
- # Now loop through all the captions, finding the corresponding
- # holdings statements (either MFHD or textual), and build up the
- # complete formatted holdings statement. The textual holdings statements
- # have either the same link id field as a caption, which means that
- # the text holdings win, or they have ids that are interfiled with
- # the captions, which mean they go into the middle.
-
- my @ids = sort($self->caption_link_ids($field), keys %txt_link_ids);
- foreach my $cap_id (@ids) {
- my $last_txt = undef;
-
- if (exists $txt_link_ids{$cap_id}) {
- # there's a textual holding statement with this caption ID,
- # so just use that. This covers both the "replaces" and
- # the "supplements" holdings information options.
-
- # a single textual holdings statement can replace multiple
- # captions. If the _last_ caption we saw had a textual
- # holdings statement, and this caption has the same one, then
- # we don't add the holdings again.
- if (!defined $last_txt || ($last_txt != $txt_link_ids{$cap_id})) {
- my $txt = $txt_link_ids{$cap_id};
- $holdings_stmt .= ',' if $holdings_stmt;
- $holdings_stmt .= $txt->subfield('a');
- if (defined $txt->subfield('z')) {
- $holdings_stmt .= ' -- ' . $txt->subfield('z');
- }
-
- $last_txt = $txt;
- }
- next;
- }
-
- # We found a caption that doesn't have a corresponding textual
- # holdings statement, so reset $last_txt to undef.
- $last_txt = undef;
-
- my @holdings = $self->holdings($holdings_field, $cap_id);
-
- next unless scalar @holdings;
-
- # XXX Need to format compressed holdings. see code in test.pl
- # for example. Try to do it without indexing?
- $holdings_stmt .= ',' if $holdings_stmt;
-
- if ($self->compressible) {
- $start = $l = shift @holdings;
- $holdings_stmt .= $l->format;
-
- while (my $h = shift @holdings) {
- if (!$h->matches($l->next)) {
- # this item is not part of the current run,
- # close out the run and record this item
- if ($l != $start) {
- $holdings_stmt .= '-' . $l->format;
- }
-
- $holdings_stmt .= ',' . $h->format;
- $start = $h
- } elsif (!scalar(@holdings) || defined($h->subfield('z'))) {
- # This is the end of the holdings for this caption
- # or this item has a public note that we want
- # to display
- $holdings_stmt .= '-' . $h->format;
- }
-
- if (defined $h->subfield('z')) {
- $holdings_stmt .= ' -- ' . $h->subfield('z');
- }
-
- $l = $h;
- }
- } else {
- $holdings_stmt .= ',' if $holdings_stmt;
- $holdings_stmt .= (shift @holdings)->format;
- foreach my $h (@holdings) {
- $holdings_stmt .= ',' . $h->format;
- if (defined $h->subfield('z')) {
- $holdings_stmt .= ' -- ' . $h->subfield('z');
- }
- }
- }
- }
-
- return $holdings_stmt;
-}
-
-1;
+++ /dev/null
-package MFHD::Caption;
-use strict;
-use integer;
-use Carp;
-
-use Data::Dumper;
-
-use OpenILS::Utils::MFHD::Date;
-
-use base 'MARC::Field';
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = shift;
- my $last_enum = undef;
-
- $self->{_mfhdc_ENUMS} = {};
- $self->{_mfhdc_CHRONS} = {};
- $self->{_mfhdc_PATTERN} = {};
- $self->{_mfhdc_COPY} = undef;
- $self->{_mfhdc_UNIT} = undef;
- $self->{_mfhdc_LINK_ID} = undef;
- $self->{_mfhdc_COMPRESSIBLE} = 1; # until proven otherwise
-
- foreach my $subfield ($self->subfields) {
- my ($key, $val) = @$subfield;
- if ($key eq '8') {
- $self->{_mfhdc_LINK_ID} = $val;
- } elsif ($key =~ /[a-h]/) {
- # Enumeration Captions
- $self->{_mfhdc_ENUMS}->{$key} = {
- CAPTION => $val,
- COUNT => undef,
- RESTART => undef
- };
- if ($key =~ /[ag]/) {
- $last_enum = undef;
- } else {
- $last_enum = $key;
- }
- } elsif ($key =~ /[i-m]/) {
- # Chronology captions
- $self->{_mfhdc_CHRONS}->{$key} = $val;
- } elsif ($key eq 'u') {
- # Bib units per next higher enumeration level
-
- # Some files seem to have "empty" $u subfields,
- # especially for top level of enumeration. Just drop them
- next if (!defined($val) || !$val);
-
- carp('$u specified for top-level enumeration')
- unless defined($last_enum);
- $self->{_mfhdc_ENUMS}->{$last_enum}->{COUNT} = $val;
- } elsif ($key eq 'v') {
- # Is this level of enumeration continuous, or does it restart?
-
- # Some files seem to have "empty" $v subfields,
- # especially for top level of enumeration. Just drop them
- next if (!defined($val) || !$val);
-
- carp '$v specified for top-level enumeration'
- unless defined($last_enum);
- $self->{_mfhdc_ENUMS}->{$last_enum}->{RESTART} = ($val eq 'r');
- } elsif ($key =~ /[npwz]/) {
- # Publication Pattern info ('o' == type of unit, 'q'..'t' undefined)
- $self->{_mfhdc_PATTERN}->{$key} = $val;
- } elsif ($key =~ /x/) {
- # Calendar change can have multiple comma-separated values
- $self->{_mfhdc_PATTERN}->{x} = [split /,/, $val];
- } elsif ($key eq 'y') {
- $self->{_mfhdc_PATTERN}->{y} = {}
- unless exists $self->{_mfhdc_PATTERN}->{y};
- update_pattern($self, $val);
- } elsif ($key eq 'o') {
- # Type of unit
- $self->{_mfhdc_UNIT} = $val;
- } elsif ($key eq 't') {
- $self->{_mfhdc_COPY} = $val;
- } else {
- carp "Unknown caption subfield '$key'";
- }
- }
-
- # subsequent levels of enumeration (primary and alternate)
- # If an enumeration level doesn't document the number
- # of "issues" per "volume", or whether numbering of issues
- # restarts, then we can't compress.
- foreach my $key ('b', 'c', 'd', 'e', 'f', 'h') {
- if (exists $self->{_mfhdc_ENUMS}->{$key}) {
- my $pattern = $self->{_mfhdc_ENUMS}->{$key};
- if ( !$pattern->{RESTART}
- || !$pattern->{COUNT}
- || ($pattern->{COUNT} eq 'var')
- || ($pattern->{COUNT} eq 'und')) {
- $self->{_mfhdc_COMPRESSIBLE} = 0;
- last;
- }
- }
- }
-
- my $pat = $self->{_mfhdc_PATTERN};
-
- # Sanity check publication frequency vs publication pattern:
- # if the frequency is a number, then the pattern better
- # have that number of values associated with it.
- if ( exists($pat->{w})
- && ($pat->{w} =~ /^\d+$/)
- && ($pat->{w} != scalar(@{$pat->{y}->{p}}))) {
- carp(
-"Caption::new: publication frequency '$pat->{w}' != publication pattern @{$pat->{y}->{p}}"
- );
- }
-
- # If there's a $x subfield and a $j, then it's compressible
- if (exists $pat->{x} && exists $self->{_mfhdc_CHRONS}->{'j'}) {
- $self->{_mfhdc_COMPRESSIBLE} = 1;
- }
-
- bless($self, $class);
-
- return $self;
-}
-
-sub update_pattern {
- my $self = shift;
- my $val = shift;
- my $pathash = $self->{_mfhdc_PATTERN}->{y};
- my ($pubcode, $pat) = unpack("a1a*", $val);
-
- $pathash->{$pubcode} = [] unless exists $pathash->{$pubcode};
- push @{$pathash->{$pubcode}}, $pat;
-}
-
-sub decode_pattern {
- my $self = shift;
- my $pattern = $self->{_mfhdc_PATTERN}->{y};
-
- # XXX WRITE ME (?)
-}
-
-sub compressible {
- my $self = shift;
-
- return $self->{_mfhdc_COMPRESSIBLE};
-}
-
-sub chrons {
- my $self = shift;
- my $key = shift;
-
- if (exists $self->{_mfhdc_CHRONS}->{$key}) {
- return $self->{_mfhdc_CHRONS}->{$key};
- } else {
- return undef;
- }
-}
-
-sub capfield {
- my $self = shift;
- my $key = shift;
-
- if (exists $self->{_mfhdc_ENUMS}->{$key}) {
- return $self->{_mfhdc_ENUMS}->{$key};
- } elsif (exists $self->{_mfhdc_CHRONS}->{$key}) {
- return $self->{_mfhdc_CHRONS}->{$key};
- } else {
- return undef;
- }
-}
-
-sub capstr {
- my $self = shift;
- my $key = shift;
- my $val = $self->capfield($key);
-
- if (ref $val) {
- return $val->{CAPTION};
- } else {
- return $val;
- }
-}
-
-sub type_of_unit {
- my $self = shift;
-
- return $self->{_mfhdc_UNIT};
-}
-
-sub link_id {
- my $self = shift;
-
- return $self->{_mfhdc_LINK_ID};
-}
-
-sub calendar_change {
- my $self = shift;
-
- return $self->{_mfhdc_PATTERN}->{x};
-}
-
-# If items are identified by chronology only, with no separate
-# enumeration (eg, a newspaper issue), then the chronology is
-# recorded in the enumeration subfields $a - $f. We can tell
-# that this is the case if there are $a - $f subfields and no
-# chronology subfields ($i-$k), and none of the $a-$f subfields
-# have associated $u or $v subfields, but there's a $w and no $x
-
-sub enumeration_is_chronology {
- my $self = shift;
-
- # There is always a '$a' subfield in well-formed fields.
- return 0
- if exists $self->{_mfhdc_CHRONS}->{i}
- || exists $self->{_mfhdc_PATTERN}->{x};
-
- foreach my $key ('a'..'f') {
- my $enum;
-
- last if !exists $self->{_mfhdc_ENUMS}->{$key};
-
- $enum = $self->{_mfhdc_ENUMS}->{$key};
- return 0 if defined $enum->{COUNT} || defined $enum->{RESTART};
- }
-
- return (exists $self->{_mfhdc_PATTERN}->{w});
-}
-
-sub regularity_match {
- my $self = shift;
- my $pubcode = shift;
- my @date = @_;
-
- # we can't match something that doesn't exist.
- return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{$pubcode};
-
- foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{$pubcode}}) {
- my $chroncode = substr($regularity, 0, 1);
- my $matchfunc = MFHD::Date::dispatch($chroncode);
- my @pats = split(/,/, substr($regularity, 1));
-
- if (!defined $matchfunc) {
- carp "Unrecognized chroncode '$chroncode'";
- return 0;
- }
-
- # XXX WRITE ME
- foreach my $pat (@pats) {
- $pat =~ s|/.+||; # If it's a combined date, match the start
- if ($matchfunc->($pat, @date)) {
- return 1;
- }
- }
- }
-
- return 0;
-}
-
-sub is_omitted {
- my $self = shift;
- my @date = @_;
-
- # printf("# is_omitted: testing date %s: %d\n", join('/', @date),
- # $self->regularity_match('o', @date));
- return $self->regularity_match('o', @date);
-}
-
-sub is_published {
- my $self = shift;
- my @date = @_;
-
- return $self->regularity_match('p', @date);
-}
-
-sub is_combined {
- my $self = shift;
- my @date = @_;
-
- return $self->regularity_match('c', @date);
-}
-
-sub enum_is_combined {
- my $self = shift;
- my $subfield = shift;
- my $iss = shift;
- my $level = ord($subfield) - ord('a') + 1;
-
- return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{c};
-
- foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{c}}) {
- next unless $regularity =~ m/^e$level/o;
-
- my @pats = split(/,/, substr($regularity, 2));
-
- foreach my $pat (@pats) {
- $pat =~ s|/.+||; # if it's a combined issue, match the start
- return 1 if ($iss eq $pat);
- }
- }
-
- return 0;
-}
-
-# Test to see if $dt1 is on or after $dt2
-# if length(@{$dt2} == 2, then just month/day are compared
-# if length(@{$dt2} == 1, then just the months are compared
-sub on_or_after {
- my $dt1 = shift;
- my $dt2 = shift;
-
-# printf("# on_or_after(%s, %s): ", join('/', @{$dt1}), join('/', @{$dt2}));
-
- foreach my $i (0..(scalar(@{$dt2}) - 1)) {
- if ($dt1->[$i] > $dt2->[$i]) {
- # printf("after - pass\n");
- # $dt1 occurs AFTER $dt2
- return 1;
- } elsif ($dt1->[$i] < $dt2->[$i]) {
- # printf("before - fail\n");
- # $dt1 occurs BEFORE $dt2
- return 0;
- }
- # both are still equal, keep going
- }
-
- # We fell out of the loop with them being equal, so it's 'on'
- # printf("on - pass\n");
- return 1;
-}
-
-sub calendar_increment {
- my $self = shift;
- my $cur = shift;
- my $new = shift;
- my $cal_change = $self->calendar_change;
- my $month;
- my $day;
- my $cur_before;
- my $new_on_or_after;
-
- # A calendar change is defined, need to check if it applies
- if (scalar(@{$new}) == 1) {
- carp "Can't calculate date change for ", $self->as_string;
- return 0;
- }
-
- foreach my $change (@{$cal_change}) {
- my $incr;
-
- if (length($change) == 2) {
- $month = $change;
- } elsif (length($change) == 4) {
- ($month, $day) = unpack("a2a2", $change);
- }
-
- # printf("# calendar_increment('%s', '%s'): change on '%s/%s'\n",
- # join('/', @{$cur}), join('/', @{$new}),
- # $month, defined($day) ? $day : 'UNDEF');
-
- if ($cur->[0] == $new->[0]) {
- # Same year, so a 'simple' month/day comparison will be fine
- $incr =
- ( !on_or_after([$cur->[1], $cur->[2]], [$month, $day])
- && on_or_after([$new->[1], $new->[2]], [$month, $day]));
- } else {
- # @cur is in the year before @new. There are
- # two possible cases for the calendar change date that
- # indicate that it's time to change the volume:
- # (1) the change date is AFTER @cur in the year, or
- # (2) the change date is BEFORE @new in the year.
- #
- # -------|------|------X------|------|
- # @cur (1) Jan 1 (2) @new
-
- $incr =
- (on_or_after([$new->[1], $new->[2]], [$month, $day])
- || !on_or_after([$cur->[1], $cur->[2]], [$month, $day]));
- }
- return $incr if $incr;
- }
-
- return 0;
-}
-
-sub next_chron {
- my $self = shift;
- my $next = shift;
- my $carry = shift;
- my @keys = @_;
- my @cur;
- my @new;
- my @newend; # only used for combined issues
- my $incr;
-
- my $reg = $self->{_mfhdc_REGULARITY};
- my $pattern = $self->{_mfhdc_PATTERN};
- my $freq = $pattern->{w};
-
- foreach my $i (0..$#keys) {
- $cur[$i] = $next->{$keys[$i]} if exists $next->{$keys[$i]};
- }
-
- # If the current issue has a combined date (eg, May/June)
- # get rid of the first date and base the calculation
- # on the final date in the combined issue.
- $cur[-1] =~ s|^[^/]+/||;
-
- if (defined $pattern->{y}->{p}) {
- # There is a $y publication pattern defined in the record:
- # use it to calculate the next issue date.
-
- foreach my $pubpat (@{$pattern->{y}->{p}}, @{$pattern->{y}->{c}}) {
- my $chroncode = substr($pubpat, 0, 1);
- my $genfunc = MFHD::Date::generator($chroncode);
- my @pats = split(/,/, substr($pubpat, 1));
-
- next if $chroncode eq 'e';
-
- if (!defined $genfunc) {
- carp "Unrecognized chroncode '$chroncode'";
- return undef;
- }
-
- foreach my $pat (@pats) {
- my $combined = $pat =~ m|/|;
- my ($start, $end);
- my @candidate;
-
- # printf("# next_date: generating with pattern '%s'\n", $pat);
-
- if ($combined) {
- ($start, $end) = split('/', $pat, 2);
- } else {
- ($start, $end) = (undef, undef);
- }
-
- @candidate = $genfunc->($start || $pat, @cur);
-
- while ($self->is_omitted(@candidate)) {
- # printf("# pubpat omitting date '%s'\n",
- # join('/', @candidate));
- @candidate = $genfunc->($start || $pat, @candidate);
- }
-
- # printf("# testing new candidate '%s' against '%s'\n",
- # join('/', @candidate), join('/', @new));
-
- if (!defined($new[0]) || !on_or_after(\@candidate, \@new)) {
- # first time through the loop
- # or @candidate is before @new =>
- # @candidate is the next issue.
- @new = @candidate;
- if (defined $end) {
- @newend = $genfunc->($end, @cur);
- } else {
- $newend[0] = undef;
- }
-
- # printf("# selecting candidate date '%s'\n", join('/', @new));
- }
- }
- }
-
- if (defined($newend[0])) {
- # The best match was a combined issue
- foreach my $i (0..$#new) {
- # don't combine identical fields
- next if $new[$i] eq $newend[$i];
- $new[$i] .= '/' . $newend[$i];
- }
- }
- }
-
- if (scalar @new == 0) {
- # There was no suitable publication pattern defined,
- # so use the $w frequency to figure out the next date
- if (!defined($freq)) {
- carp "Undefined frequency in next_chron!";
- } elsif (!MFHD::Date::can_increment($freq)) {
- carp "Don't know how to deal with frequency '$freq'!";
- } else {
- # One of the standard defined issue frequencies
- @new = MFHD::Date::incr_date($freq, @cur);
-
- while ($self->is_omitted(@new)) {
- @new = MFHD::Date::incr_date($freq, @new);
- }
-
- if ($self->is_combined(@new)) {
- my @second_date = MFHD::Date::incr_date($freq, @new);
-
- # I am cheating: This code assumes that only the smallest
- # time increment is combined. So, no "Apr 15/May 1" allowed.
- $new[-1] = $new[-1] . '/' . $second_date[-1];
- }
- }
- }
-
- for my $i (0..$#new) {
- $next->{$keys[$i]} = $new[$i];
- }
- # Figure out if we need to adjust volume number
- # right now just use the $carry that was passed in.
- # in long run, need to base this on ($carry or date_change)
- if ($carry) {
- # if $carry is set, the date doesn't matter: we're not
- # going to increment the v. number twice at year-change.
- $next->{a} += $carry;
- } elsif (defined $pattern->{x}) {
- $next->{a} += $self->calendar_increment(\@cur, \@new);
- }
-}
-
-sub next_alt_enum {
- my $self = shift;
- my $next = shift;
-
- # First handle any "alternative enumeration", since they're
- # a lot simpler, and don't depend on the the calendar
- foreach my $key ('h', 'g') {
- next if !exists $next->{$key};
- if (!$self->capstr($key)) {
- warn "Holding data exists for $key, but no caption specified";
- $next->{$key} += 1;
- last;
- }
-
- my $cap = $self->capfield($key);
- if ( $cap->{RESTART}
- && $cap->{COUNT}
- && ($next->{$key} == $cap->{COUNT})) {
- $next->{$key} = 1;
- } else {
- $next->{$key} += 1;
- last;
- }
- }
-}
-
-# Check caption for $ype subfield, specifying that there's a
-# particular publication pattern for the given level of enumeration
-# returns the pattern string or undef
-sub enum_pubpat {
- my $self = shift;
- my $level = shift;
-
- return undef if !exists $self->{_mfhdc_PATTERN}->{y}->{p};
-
- foreach my $reg (@{$self->{_mfhdc_PATTERN}->{y}->{p}}) {
- if ($reg =~ m/^e$level/o) {
- return substr($reg, 2);
- }
- }
- return undef;
-}
-
-sub next_enum {
- my $self = shift;
- my $next = shift;
- my $carry;
-
- # $carry keeps track of whether we need to carry into the next
- # higher level of enumeration. It's not actually necessary except
- # for when the loop ends: if we need to carry from $b into $a
- # then $carry will be set when the loop ends.
- #
- # We need to keep track of this because there are two different
- # reasons why we might increment the highest level of enumeration ($a)
- # 1) we hit the correct number of items in $b (ie, 5th iss of quarterly)
- # 2) it's the right time of the year.
- #
-
- # If there's a subfield b, then we will go through the loop at
- # least once. If there's no subfield b, then there's only a single
- # level of enumeration, so we just add one to it and we're done.
- if (exists $next->{b}) {
- $carry = 0;
- } else {
- $carry = 1;
- }
- foreach my $key (reverse('b'..'f')) {
- my $level;
- my $pubpat;
-
- next if !exists $next->{$key};
-
- # If the current issue has a combined issue number (eg, 2/3)
- # get rid of the first issue number and base the calculation
- # on the final issue number in the combined issue.
- if ($next->{$key} =~ m|/|) {
- $next->{$key} =~ s|^[^/]+/||;
- }
-
- $level = ord($key) - ord('a') + 1; # enumeration level
-
- $pubpat = $self->enum_pubpat($level);
-
- if ($pubpat) {
- # printf("# next_enum: found pubpat '%s' for subfield '%s'\n",
- # $pubpat, $key);
- my @pats = split(/,/, $pubpat);
-
- # If we fall out the bottom of the loop, then $carry
- # will still be 1, and we will reset the current
- # level to the first value in @pats and increment
- # then next higher level.
- $carry = 1;
-
- foreach my $pat (@pats) {
- my $combined = $pat =~ m|/|;
- my $end;
-
- # printf("# next_enum: checking current '%s' against pat '%s'\n",
- # $next->{$key}, $pat);
-
- if ($combined) {
- ($pat, $end) = split('/', $pat, 2);
- } else {
- $end = undef;
- }
-
- if ($pat > $next->{$key}) {
- $carry = 0;
- $next->{$key} = $pat;
- $next->{$key} .= '/' . $end if $end;
- # printf("# next_enum: selecting new issue no. %s\n", $next->{$key});
- last; # We've found the correct next issue number
- }
- }
- if ($carry) {
- $next->{$key} = $pats[0];
- } else {
- last; # exit the top level loop because we're done
- }
-
- } else {
- # No enumeration publication pattern specified for this level,
- # just keep adding one.
-
- if (!$self->capstr($key)) {
- # Just assume that it increments continuously and give up
- warn "Holding data exists for $key, but no caption specified";
- $next->{$key} += 1;
- $carry = 0;
- last;
- }
-
- # printf("# next_enum: no publication pattern, using frequency\n");
-
- my $cap = $self->capfield($key);
- if ( $cap->{RESTART}
- && $cap->{COUNT}
- && ($next->{$key} eq $cap->{COUNT})) {
- $next->{$key} = 1;
- $carry = 1;
- } else {
- # If I don't need to "carry" beyond here, then I just increment
- # this level of the enumeration and stop looping, since the
- # "next" hash has been initialized with the current values
-
- $next->{$key} += 1;
- $carry = 0;
- }
-
- # You can't have a combined issue that spans two volumes: no.12/1
- # is forbidden
- if ($self->enum_is_combined($key, $next->{$key})) {
- $next->{$key} .= '/' . ($next->{$key} + 1);
- }
-
- last if !$carry;
- }
- }
-
- # The easy part is done. There are two things left to do:
- # 1) Calculate the date of the next issue, if necessary
- # 2) Increment the highest level of enumeration (either by date
- # or because $carry is set because of the above loop
-
- if (!$self->subfield('i') || !$next->{i}) {
- # The simple case: if there is no chronology specified
- # then just check $carry and return
- $next->{'a'} += $carry;
- } else {
- # Figure out date of next issue, then decide if we need
- # to adjust top level enumeration based on that
- $self->next_chron($next, $carry, ('i'..'m'));
- }
-}
-
-sub next {
- my $self = shift;
- my $holding = shift;
- my $next = {};
-
- # If the holding is compressed and not open ended, base next() on the
- # closing date. If the holding is open-ended, next() is undefined
- my $index;
- if ($holding->is_compressed) {
- return undef if $holding->is_open_ended;
- # TODO: error on next for open-ended holdings?
- $index = 1;
- } else {
- $index = 0;
- }
-
- # Initialize $next with current enumeration & chronology, then
- # we can just operate on $next, based on the contents of the caption
- foreach my $key ('a'..'m') {
- my $holding_values = $holding->field_values($key);
- $next->{$key} = ${$holding_values}[$index] if defined $holding_values;
- }
-
- if ($self->enumeration_is_chronology) {
- $self->next_chron($next, 0, ('a'..'h'));
- return $next;
- }
-
- if (exists $next->{'h'}) {
- $self->next_alt_enum($next);
- }
-
- $self->next_enum($next);
-
- return ($next);
-}
-
-# return a simple subfields list
-sub subfields_list {
- my $self = shift;
- my @subfields;
-
- foreach my $subfield ($self->subfields) {
- push(@subfields, $subfield->[0], $subfield->[1]);
- }
- return @subfields;
-}
-
-1;
+++ /dev/null
-package MFHD::Date;
-use strict;
-use integer;
-use Carp;
-
-use Data::Dumper;
-use DateTime;
-
-use base 'Exporter';
-
-our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
-
-my %daynames = (
- 'mo' => 1,
- 'tu' => 2,
- 'we' => 3,
- 'th' => 4,
- 'fr' => 5,
- 'sa' => 6,
- 'su' => 7,
-);
-
-my $daypat = '(mo|tu|we|th|fr|sa|su)';
-my $weekpat = '(99|98|97|00|01|02|03|04|05)';
-my $weeknopat;
-my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
-my $seasonpat = '(21|22|23|24)';
-
-# Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
-$weeknopat = '(';
-foreach my $weekno (1..52) {
- $weeknopat .= sprintf('%02d|', $weekno);
-}
-$weeknopat .= '53)';
-
-sub match_day {
- my $pat = shift;
- my @date = @_;
- # Translate daynames into day of week for DateTime
- # also used to check if dayname is valid.
-
- if (exists $daynames{$pat}) {
- # dd
- # figure out day of week for date and compare
- my $dt = DateTime->new(
- year => $date[0],
- month => $date[1],
- day => $date[2]
- );
- return ($dt->day_of_week == $daynames{$pat});
- } elsif (length($pat) == 2) {
- # DD
- return $pat == $date[2];
- } elsif (length($pat) == 4) {
- # MMDD
- my ($mon, $day) = unpack("a2a2", $pat);
-
- return (($mon == $date[1]) && ($day == $date[2]));
- } else {
- carp "Invalid day pattern '$pat'";
- return 0;
- }
-}
-
-sub subsequent_day {
- my $pat = shift;
- my @cur = @_;
- my $dt = DateTime->new(
- year => $cur[0],
- month => $cur[1],
- day => $cur[2]
- );
-
- # printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
-
- if (exists $daynames{$pat}) {
- # dd: published on the given weekday
- my $dow = $dt->day_of_week;
- my $corr = ($daynames{$pat} - $dow + 7) % 7;
-
- if ($dow == $daynames{$pat}) {
- # the next one is one week hence
- $dt->add(days => 7);
- } else {
- # the next one is later this week,
- # or it is next week (ie, on or after next Monday)
- # $corr will take care of it.
- $dt->add(days => $corr);
- }
- @cur = ($dt->year, $dt->month, $dt->day);
- } elsif (length($pat) == 2) {
- # DD: published on the give day of every month
- if ($dt->day >= $pat) {
- # current date is on or after $pat: next one is next month
- $dt->set(day => $pat);
- $dt->add(months => 1);
- @cur = ($dt->year, $dt->month, $dt->day);
- } else {
- # current date is before $pat: set day to pattern
- $cur[2] = $pat;
- }
- } elsif (length($pat) == 4) {
- # MMDD: published on the given day of the given month
- my ($mon, $day) = unpack("a2a2", $pat);
-
- if (on_or_after($mon, $day, $cur[1], $cur[2])) {
- # Current date is on or after pattern; next one is next year
- $cur[0] += 1;
- }
- # Year is now right. Either it's next year (because of on_or_after)
- # or it's this year, because the current date is NOT on or after
- # the pattern. Just fix the month and day
- $cur[1] = $mon;
- $cur[2] = $day;
- } else {
- carp "Invalid day pattern '$pat'";
- return undef;
- }
-
- foreach my $i (0..$#cur) {
- $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
- }
-
- # printf("subsequent_day: returning '%s'\n", join('/', @cur));
-
- return @cur;
-}
-
-# Calculate date of 3rd Friday of the month (for example)
-# 1-5: count from beginning of month
-# 99-97: count back from end of month
-sub nth_week_of_month {
- my $dt = shift;
- my $week = shift;
- my $day = shift;
- my ($nth_day, $dow);
-
- # printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
-
- if (0 < $week && $week <= 5) {
- $nth_day = $dt->clone->set(day => 1);
- } elsif ($week >= 97) {
- $nth_day = DateTime->last_day_of_month(
- year => $dt->year,
- month => $dt->month
- );
- } else {
- return undef;
- }
-
- $dow = $nth_day->day_of_week();
-
- # If a particular day was passed in (eg, we want 3rd friday)
- # then use that day for the calculations, otherwise, just use
- # the day of the week of the original date (the date $dt).
- if (defined($day)) {
- $day = $daynames{$day};
- } else {
- $day = $dt->day_of_week;
- }
-
- if ($week <= 5) {
- # count forwards
- $nth_day->add(
- days => ($day - $dow + 7) % 7,
- weeks => $week - 1
- );
- } else {
- # count backwards
- $nth_day->subtract(days => ($day - $dow + 7) % 7);
-
- # 99: last week of month, 98: second last, etc.
- for (my $i = 99 - $week; $i > 0; $i--) {
- $nth_day->subtract(weeks => 1);
- }
- }
-
- # There is no nth "day" in the month!
- return undef if ($dt->month != $nth_day->month);
-
- return $nth_day;
-}
-
-#
-# Internal utility function to match the various different patterns
-# of month, week, and day
-#
-sub check_date {
- my $dt = shift;
- my $month = shift;
- my $weekno = shift;
- my $day = shift;
-
- # printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
-
- if (!defined $day) {
- # MMWW
- return (
- ($dt->month == $month)
- && (
- ($dt->week_of_month == $weekno)
- || (
- $weekno >= 97
- && ($dt->week_of_month ==
- nth_week_of_month($dt, $weekno, $day)->week_of_month)
- )
- )
- );
- }
-
- # simple cases first
- if ($daynames{$day} != $dt->day_of_week) {
- # if it's the wrong day of the week, rest doesn't matter
- return 0;
- }
-
- if (!defined $month) {
- # WWdd
- return (
- ($weekno == 0) # Every week
- || ($dt->weekday_of_month == $weekno) # this week
- || (
- ($weekno >= 97)
- && ($dt->weekday_of_month ==
- nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
- )
- );
- }
-
- # MMWWdd
- if ($month != $dt->month) {
- # If it's the wrong month, then we're done
- return 0;
- }
-
- # It's the right day of the week
- # It's the right month
-
- if (($weekno == 0) || ($weekno == $dt->weekday_of_month)) {
- # If this matches, then we're counting from the beginning
- # of the month and it matches and we're done.
- return 1;
- }
-
- # only case left is that the week number is counting from
- # the end of the month: eg, second last wednesday
- return (
- ($weekno >= 97)
- && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
- $dt->weekday_of_month)
- );
-}
-
-sub match_week {
- my $pat = shift;
- my @date = @_;
- my $dt = DateTime->new(
- year => $date[0],
- month => $date[1],
- day => $date[2]
- );
-
- if ($pat =~ m/^$weekpat$daypat$/) {
- # WWdd: 03we = Third Wednesday
- return check_date($dt, undef, $1, $2);
- } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
- # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
- return check_date($dt, $1, $2, $3);
- } elsif ($pat =~ m/^$monthpat$weekpat$/) {
- # MMWW: 1204: Fourth week in December XXX WRITE ME
- return check_date($dt, $1, $2, undef);
- } else {
- carp "invalid week pattern '$pat'";
- return 0;
- }
-}
-
-#
-# Use $pat to calcuate the date of the issue following $cur
-#
-sub subsequent_week {
- my $pat = shift;
- my @cur = @_;
- my $candidate;
- my $dt;
-
- # printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
-
- $dt = DateTime->new(
- year => $cur[0],
- month => $cur[1],
- day => $cur[2]
- );
-
- if ($pat =~ m/^$weekpat$daypat$/o) {
- # WWdd: published on given weekday of given week of every month
- my ($week, $day) = ($1, $2);
-
- # printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
- # $week, $day);
-
- if ($week eq '00') {
- # Every week
- $candidate = $dt->clone;
-
- if ($dt->day_of_week == $daynames{$day}) {
- # Current is right day, next one is a week hence
- $candidate->add(days => 7);
- } else {
- $candidate->add(
- days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
- }
- } else {
- # 3rd Friday of the month (eg)
- $candidate = nth_week_of_month($dt, $week, $day);
- }
-
- if ($candidate <= $dt) {
-# If the n'th week of the month happens on before the
-# current issue, then the next issue is published next
-# month, otherwise, it's published this month.
-# This will never happen for the "00: every week" pattern
-# printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
-# join('/', $candidate->year, $candidate->month, $candidate->day),
-# join('/', $dt->year, $dt->month, $dt->day));
- $candidate->set(day => 1);
- $candidate->add(months => 1);
- $candidate = nth_week_of_month($candidate, $week, $day);
- }
- } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
- # MMWWdd: published on given weekday of given week of given month
- my ($month, $week, $day) = ($1, $2, $3);
-
-# printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
-# $month, $week, $day);
-
- $candidate = DateTime->new(
- year => $dt->year,
- month => $month,
- day => 1
- );
- $candidate = nth_week_of_month($candidate, $week, $day);
- if ($candidate <= $dt) {
- # We've missed it for this year, next one that matches
- # will be next year
- $candidate->add(years => 1)->set(day => 1);
- $candidate = nth_week_of_month($candidate, $week, $day);
- }
- } elsif ($pat =~ m/^$monthpat$weekpat$/) {
- # MMWW: published during given week of given month
- my ($month, $week) = ($1, $2);
-
- $candidate = nth_week_of_month(
- DateTime->new(
- year => $dt->year,
- month => $month,
- day => 1
- ),
- $week, 'th'
- );
- if ($candidate <= $dt) {
- # Already past the pattern date this year, move to next year
- $candidate->add(years => 1)->set(day => 1);
- $candidate = nth_week_of_month($candidate, $week, 'th');
- }
- } else {
- carp "invalid week pattern '$pat'";
- return undef;
- }
-
- $cur[0] = $candidate->year;
- $cur[1] = $candidate->month;
- $cur[2] = $candidate->day;
-
- foreach my $i (0..$#cur) {
- $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
- }
-
- return @cur;
-}
-
-sub match_month {
- my $pat = shift;
- my @date = @_;
-
- return ($pat eq $date[1]);
-}
-
-sub subsequent_month {
- my $pat = shift;
- my @cur = @_;
-
- if ($cur[1] >= $pat) {
- # Current date is on or after the patter date, so the next
- # occurence is next year
- $cur[0] += 1;
- }
-
- # The year is right, just set the month to the pattern date.
- $cur[1] = $pat;
-
- return @cur;
-}
-
-sub match_season {
- my $pat = shift;
- my @date = @_;
-
- return ($pat eq $date[1]);
-}
-
-sub subsequent_season {
- my $pat = shift;
- my @cur = @_;
-
-# printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
-
- if (($pat < 21) || ($pat > 24)) {
- carp "Unexpected season '$pat'";
- return undef;
- }
-
- if ($cur[1] >= $pat) {
- # current season is on or past pattern season in this year,
- # advance to next year
- $cur[0] += 1;
- }
- # Either we've advanced to the next year or the current season
- # is before the pattern season in the current year. Either way,
- # all that remains is to set the season properly
- $cur[1] = $pat;
-
- return @cur;
-}
-
-sub match_year {
- my $pat = shift;
- my @date = @_;
-
- # XXX WRITE ME
- return 0;
-}
-
-sub subsequent_year {
- my $pat = shift;
- my $cur = shift;
-
- # XXX WRITE ME
- return undef;
-}
-
-sub match_issue {
- my $pat = shift;
- my @date = @_;
-
- # We handle enumeration patterns separately. This just
- # ensures that when we're processing chronological patterns
- # we don't match an enumeration pattern.
- return 0;
-}
-
-sub subsequent_issue {
- my $pat = shift;
- my $cur = shift;
-
- # Issue generation is handled separately
- return undef;
-}
-
-my %dispatch = (
- d => \&match_day,
- e => \&match_issue, # not really a "chron" code
- w => \&match_week,
- m => \&match_month,
- s => \&match_season,
- y => \&match_year,
-);
-
-my %generators = (
- d => \&subsequent_day,
- e => \&subsequent_issue, # not really a "chron" code
- w => \&subsequent_week,
- m => \&subsequent_month,
- s => \&subsequent_season,
- y => \&subsequent_year,
-);
-
-sub dispatch {
- my $chroncode = shift;
-
- return $dispatch{$chroncode};
-}
-
-sub generator {
- my $chroncode = shift;
-
- return $generators{$chroncode};
-}
-
-my %increments = (
- a => {years => 1}, # annual
- b => {months => 2}, # bimonthly
- c => {days => 3}, # semiweekly
- d => {days => 1}, # daily
- e => {weeks => 2}, # biweekly
- f => {months => 6}, # semiannual
- g => {years => 2}, # biennial
- h => {years => 3}, # triennial
- i => {days => 2}, # three times / week
- j => {days => 10}, # three times /month
- # k => continuous
- m => {months => 1}, # monthly
- q => {months => 3}, # quarterly
- s => {days => 15}, # semimonthly
- t => {months => 4}, # three times / year
- w => {weeks => 1}, # weekly
- # x => completely irregular
-);
-
-sub can_increment {
- my $freq = shift;
-
- return exists $increments{$freq};
-}
-
-# TODO: add support for weeks as chron level?
-sub incr_date {
- my $freq = shift;
- my $incr = $increments{$freq};
- my @new = @_;
-
- if (scalar(@new) == 1) {
- # only a year is specified. Next date is easy
- $new[0] += $incr->{years} || 1;
- } elsif (scalar(@new) == 2) {
- # Year and month or season
- if ($new[1] > 20) {
- # season
- $new[1] += ($incr->{months} / 3) || 1;
- if ($new[1] > 24) {
- # carry
- $new[0] += 1;
- $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
- }
- } else {
- # month
- $new[1] += $incr->{months} || 1;
- if ($new[1] > 12) {
- # carry
- $new[0] += 1;
- $new[1] -= 12;
- }
- }
- } elsif (scalar(@new) == 3) {
- # Year, Month, Day: now it gets complicated.
-
- if ($new[2] =~ /^[0-9]+$/) {
- # A single number for the day of month, relatively simple
- my $dt = DateTime->new(
- year => $new[0],
- month => $new[1],
- day => $new[2]
- );
- $dt->add(%{$incr});
- $new[0] = $dt->year;
- $new[1] = $dt->month;
- $new[2] = $dt->day;
- }
- } else {
- warn("Don't know how to cope with @new");
- }
-
- foreach my $i (0..$#new) {
- $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;
- }
-
- return @new;
-}
-
-1;
+++ /dev/null
-# MFHD::Holding provides some additional holdings logic to a MARC::Field
-# object. In its current state it is primarily read-only, as direct changes
-# to the underlying MARC::Field are not reflected in the MFHD logic layer, and
-# only the 'increment', 'notes', and 'seqno' methods do updates to the
-# MARC::Field layer.
-
-package MFHD::Holding;
-use strict;
-use integer;
-
-use Carp;
-use DateTime;
-use Data::Dumper;
-
-use base 'MARC::Field';
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $seqno = shift;
- my $self = shift;
- my $caption = shift;
- my $last_enum = undef;
-
- $self->{_mfhdh_SEQNO} = $seqno;
- $self->{_mfhdh_CAPTION} = $caption;
- $self->{_mfhdh_DESCR} = {};
- $self->{_mfhdh_COPY} = undef;
- $self->{_mfhdh_BREAK} = undef;
- $self->{_mfhdh_NOTES} = {};
- $self->{_mfhdh_NOTES}{public} = [];
- $self->{_mfhdh_NOTES}{private} = [];
- $self->{_mfhdh_COPYRIGHT} = [];
- $self->{_mfhdh_COMPRESSED} = ($self->indicator(2) eq '0' || $self->indicator(2) eq '2') ? 1 : 0;
- # TODO: full support for second indicators 2, 3, and 4
- $self->{_mfhdh_OPEN_ENDED} = 0;
-
- foreach my $subfield ($self->subfields) {
- my ($key, $val) = @$subfield;
-
- if ($key =~ /[a-m]/) {
- if (exists($self->{_mfhdh_FIELDS}->{$key})) {
- carp("Duplicate, non-repeatable subfield '$key' found, ignoring");
- next;
- }
- if ($self->{_mfhdh_COMPRESSED}) {
- $self->{_mfhdh_FIELDS}->{$key}{HOLDINGS} = [split(/\-/, $val)];
- } else {
- $self->{_mfhdh_FIELDS}->{$key}{HOLDINGS} = [$val];
- }
- if ($key =~ /[a-h]/) {
- # Enumeration specific details of holdings
- $self->{_mfhdh_FIELDS}->{$key}{UNIT} = undef;
- $last_enum = $key;
- }
- } elsif ($key eq 'o') {
- warn '$o specified prior to first enumeration'
- unless defined($last_enum);
- $self->{_mfhdh_FIELDS}->{$last_enum}->{UNIT} = $val;
- $last_enum = undef;
- } elsif ($key =~ /[npq]/) {
- $self->{_mfhdh_DESCR}->{$key} = $val;
- } elsif ($key eq 's') {
- push @{$self->{_mfhdh_COPYRIGHT}}, $val;
- } elsif ($key eq 't') {
- $self->{_mfhdh_COPY} = $val;
- } elsif ($key eq 'w') {
- carp "Unrecognized break indicator '$val'"
- unless $val =~ /^[gn]$/;
- $self->{_mfhdh_BREAK} = $val;
- } elsif ($key eq 'x') {
- push @{$self->{_mfhdh_NOTES}{private}}, $val;
- } elsif ($key eq 'z') {
- push @{$self->{_mfhdh_NOTES}{public}}, $val;
- }
- }
-
- if ( $self->{_mfhdh_COMPRESSED}
- && $self->{_mfhdh_FIELDS}{'a'}{HOLDINGS}[1] eq '') {
- $self->{_mfhdh_OPEN_ENDED} = 1;
- }
- bless($self, $class);
- return $self;
-}
-
-#
-# accessor to the object's field hash
-#
-# We are avoiding calling these elements 'subfields' because they are more
-# than simply the MARC subfields, although in the current implementation they
-# are indexed on the subfield key
-#
-# TODO: this accessor should probably be replaced with methods which hide the
-# underlying structure of {_mfhdh_FIELDS} (see field_values for a start)
-#
-sub fields {
- my $self = shift;
-
- return $self->{_mfhdh_FIELDS};
-}
-
-#
-# Given a field key, returns an array ref of one (for single statements)
-# or two (for compressed statements) values
-#
-# TODO: add setter functionality to replace direct {HOLDINGS} access in other
-# methods. It also makes sense to override some of the MARC::Field setter
-# methods (such as update()) to accomplish this level of encapsulation.
-#
-sub field_values {
- my ($self, $key) = @_;
-
- if (exists $self->fields->{$key}) {
- my @values = @{$self->fields->{$key}{HOLDINGS}};
- return \@values;
- } else {
- return undef;
- }
-}
-
-sub seqno {
- my $self = shift;
-
- if (@_) {
- $self->{_mfhdh_SEQNO} = $_[0];
- $self->update(8 => $self->caption->link_id . '.' . $_[0]);
- }
-
- return $self->{_mfhdh_SEQNO};
-}
-
-#
-# Optionally accepts a true/false value to set the 'compressed' attribute
-# Returns 'compressed' attribute
-#
-sub is_compressed {
- my $self = shift;
- my $is_compressed = shift;
-
- if (defined($is_compressed)) {
- if ($is_compressed) {
- $self->{_mfhdh_COMPRESSED} = 1;
- $self->update(ind2 => '0');
- } else {
- $self->{_mfhdh_COMPRESSED} = 0;
- $self->update(ind2 => '1');
- }
- }
-
- return $self->{_mfhdh_COMPRESSED};
-}
-
-sub is_open_ended {
- my $self = shift;
-
- return $self->{_mfhdh_OPEN_ENDED};
-}
-
-sub caption {
- my $self = shift;
-
- return $self->{_mfhdh_CAPTION};
-}
-
-#
-# notes: If called with no arguments, returns the public notes array ref.
-# If called with a single argument, it returns either 'public' or
-# 'private' notes based on the passed string.
-#
-# If called with more than one argument, it sets the proper note field, with
-# type being the first argument and the note value(s) as the remaining
-# argument(s).
-#
-# It is also optional to pass in an array ref of note values as the third
-# argument rather than a list.
-#
-sub notes {
- my $self = shift;
- my $type = shift;
- my @notes = @_;
-
- if (!$type) {
- $type = 'public';
- } elsif ($type ne 'public' && $type ne 'private') {
- carp("Notes being applied without specifying type");
- unshift(@notes, $type);
- $type = 'public';
- }
-
- if (ref($notes[0])) {
- $self->{_mfhdh_NOTES}{$type} = $notes[0];
- $self->_replace_note_subfields($type, @{$notes[0]});
- } elsif (@notes) {
- if ($notes[0]) {
- $self->{_mfhdh_NOTES}{$type} = \@notes;
- } else {
- $self->{_mfhdh_NOTES}{$type} = [];
- }
- $self->_replace_note_subfields($type, @notes);
- }
-
- return $self->{_mfhdh_NOTES}{$type};
-}
-
-#
-# utility function for 'notes' method
-#
-sub _replace_note_subfields {
- my $self = shift;
- my $type = shift;
- my @notes = @_;
- my %note_subfield_ids = ('public' => 'z', 'private' => 'x');
-
- $self->delete_subfield(code => $note_subfield_ids{$type});
-
- foreach my $note (@notes) {
- $self->add_subfields($note_subfield_ids{$type} => $note);
- }
-}
-
-#
-# return a simple subfields list (for easier revivification from database)
-#
-sub subfields_list {
- my $self = shift;
- my @subfields;
-
- foreach my $subfield ($self->subfields) {
- push(@subfields, $subfield->[0], $subfield->[1]);
- }
- return @subfields;
-}
-
-#
-# Called by method 'format_part' for formatting the chronology portion of
-# the holding statement
-#
-sub format_chron {
- my $self = shift;
- my $holdings = shift;
- my $caption = $self->caption;
- my @keys = @_;
- my $str = '';
- my %month = (
- '01' => 'Jan.',
- '02' => 'Feb.',
- '03' => 'Mar.',
- '04' => 'Apr.',
- '05' => 'May ',
- '06' => 'Jun.',
- '07' => 'Jul.',
- '08' => 'Aug.',
- '09' => 'Sep.',
- '10' => 'Oct.',
- '11' => 'Nov.',
- '12' => 'Dec.',
- '21' => 'Spring',
- '22' => 'Summer',
- '23' => 'Autumn',
- '24' => 'Winter'
- );
-
- foreach my $i (0..@keys) {
- my $key = $keys[$i];
- my $capstr;
- my $chron;
- my $sep;
-
- last if !defined $caption->capstr($key);
-
- $capstr = $caption->capstr($key);
- if (substr($capstr, 0, 1) eq '(') {
- # a caption enclosed in parentheses is not displayed
- $capstr = '';
- }
-
- # If this is the second level of chronology, then it's
- # likely to be a month or season, so we should use the
- # string name rather than the number given.
- if (($i == 1)) {
- # account for possible combined issue chronology
- my @chron_parts = split('/', $holdings->{$key});
- for (my $i = 0; $i < @chron_parts; $i++) {
- $chron_parts[$i] = $month{$chron_parts[$i]} if exists $month{$chron_parts[$i]};
- }
- $chron = join('/', @chron_parts);
- } else {
- $chron = $holdings->{$key};
- }
-
- $str .= (($i == 0 || $str =~ /[. ]$/) ? '' : ':') . $capstr . $chron;
- }
-
- return $str;
-}
-
-#
-# Called by method 'format' for each member of a possibly compressed holding
-#
-sub format_part {
- my $self = shift;
- my $holding_values = shift;
- my $caption = $self->caption;
- my $str = '';
-
- if ($caption->type_of_unit) {
- $str = $caption->type_of_unit . ' ';
- }
-
- if ($caption->enumeration_is_chronology) {
- # if issues are identified by chronology only, then the
- # chronology data is stored in the enumeration subfields,
- # so format those fields as if they were chronological.
- $str = $self->format_chron($holding_values, 'a'..'f');
- } else {
- # OK, there is enumeration data and maybe chronology
- # data as well, format both parts appropriately
-
- # Enumerations
- foreach my $key ('a'..'f') {
- my $capstr;
- my $chron;
- my $sep;
-
- last if !defined $caption->capstr($key);
-
- $capstr = $caption->capstr($key);
- if (substr($capstr, 0, 1) eq '(') {
- # a caption enclosed in parentheses is not displayed
- $capstr = '';
- }
- $str .=
- ($key eq 'a' ? '' : ':') . $capstr . $holding_values->{$key};
- }
-
- # Chronology
- if (defined $caption->capstr('i')) {
- $str .= '(';
- $str .= $self->format_chron($holding_values, 'i'..'l');
- $str .= ')';
- }
-
- if ($caption->capstr('g')) {
- # There's at least one level of alternative enumeration
- $str .= '=';
- foreach my $key ('g', 'h') {
- $str .=
- ($key eq 'g' ? '' : ':')
- . $caption->capstr($key)
- . $holding_values->{$key};
- }
-
- # This assumes that alternative chronology is only ever
- # provided if there is an alternative enumeration.
- if ($caption->capstr('m')) {
- # Alternative Chronology
- $str .= '(';
- $str .= $caption->capstr('m') . $holding_values->{'m'};
- $str .= ')';
- }
- }
- }
-
- # Breaks in the sequence
- if (defined($self->{_mfhdh_BREAK})) {
- if ($self->{_mfhdh_BREAK} eq 'n') {
- $str .= ' non-gap break';
- } elsif ($self->{_mfhdh_BREAK} eq 'g') {
- $str .= ' gap';
- } else {
- warn "unrecognized break indicator '$self->{_mfhdh_BREAK}'";
- }
- }
-
- return $str;
-}
-
-#
-# Create and return a string which conforms to display standard Z39.71
-#
-sub format {
- my $self = shift;
- my $subfields = $self->fields;
- my %holding_start;
- my %holding_end;
- my $formatted;
-
- foreach my $key (keys %$subfields) {
- ($holding_start{$key}, $holding_end{$key}) =
- @{$self->field_values($key)};
- }
-
- if ($self->is_compressed) {
- # deal with open-ended statements
- my $formatted_end;
- if ($self->is_open_ended) {
- $formatted_end = '';
- } else {
- $formatted_end = $self->format_part(\%holding_end);
- }
- $formatted =
- $self->format_part(\%holding_start) . ' - ' . $formatted_end;
- } else {
- $formatted = $self->format_part(\%holding_start);
- }
-
- # Public Note
- if (@{$self->notes}) {
- $formatted .= ' -- ' . join(', ', @{$self->notes});
- }
-
- return $formatted;
-}
-
-# next: Given a holding statement, return a hash containing the
-# enumeration values for the next issues, whether we hold it or not
-# Just pass through to Caption::next
-#
-sub next {
- my $self = shift;
- my $caption = $self->caption;
-
- return $caption->next($self);
-}
-
-#
-# matches($pat): check to see if $self matches the enumeration hashref passed
-# in as $pat, as returned by the 'next' method. e.g.:
-# $holding2->matches($holding1->next) # true if $holding2 directly follows
-# $holding1
-#
-# Always returns false if $self is compressed
-#
-sub matches {
- my $self = shift;
- my $pat = shift;
-
- return 0 if $self->is_compressed;
-
- foreach my $key ('a'..'f') {
- # If a subfield exists in $self but not in $pat, or vice versa
- # or if the field has different values, then fail
- if (
- defined($self->field_values($key)) != exists($pat->{$key})
- || (exists $pat->{$key}
- && ($self->field_values($key)->[0] ne $pat->{$key}))
- ) {
- return 0;
- }
- }
- return 1;
-}
-
-#
-# Check that all the fields in a holdings statement are
-# included in the corresponding caption.
-#
-sub validate {
- my $self = shift;
-
- foreach my $key (keys %{$self->fields}) {
- if (!$self->caption || !$self->caption->capfield($key)) {
- return 0;
- }
- }
- return 1;
-}
-
-#
-# Replace a single holding with it's next prediction
-# and return itself
-#
-sub increment {
- my $self = shift;
-
- if ($self->is_open_ended) {
- carp "Holding is open-ended, cannot increment";
- return $self;
- } elsif ($self->is_compressed) {
- carp "Incrementing a compressed holding is deprecated, use extend instead";
- return $self->extend;
- }
-
- my $next = $self->next();
-
- foreach my $key (keys %{$next}) {
- $self->fields->{$key}{HOLDINGS}[0] = $next->{$key};
- }
-
- $self->seqno($self->seqno + 1);
- $self->update(%{$next}); # update underlying subfields
- return $self;
-}
-
-#
-# Extends a holding (compressing if needed) to include the next
-# prediction and returns itself
-#
-sub extend {
- my $self = shift;
-
- if ($self->is_open_ended) {
- carp "Holding is open-ended, cannot extend";
- return $self;
- }
-
- my $next = $self->next();
-
- if (!$self->is_compressed) {
- $self->is_compressed(1); # add compressed state
- }
-
- foreach my $key (keys %{$next}) {
- my @values = @{$self->field_values($key)};
- $values[1] = $next->{$key};
- $self->fields->{$key}{HOLDINGS} = \@values;
- $next->{$key} = join('-', @values);
- }
-
- $self->update(%{$next}); # update underlying subfields
- return $self;
-}
-
-#
-# Turns a compressed holding into the singular form of the first member
-# in the range
-#
-sub compressed_to_first {
- my $self = shift;
-
- if (!$self->is_compressed) {
- carp "Holding not compressed, cannot convert to first member";
- return $self;
- }
-
- my %changes;
- foreach my $key (keys %{$self->fields}) {
- my @values = @{$self->field_values($key)};
- $self->fields->{$key}{HOLDINGS} = [$values[0]];
- $changes{$key} = $values[0];
- }
-
- $self->update(%changes); # update underlying subfields
- $self->is_compressed(0); # remove compressed state
-
- return $self;
-}
-
-#
-# Turns a compressed holding into the singular form of the last member
-# in the range
-#
-sub compressed_to_last {
- my $self = shift;
-
- if (!$self->is_compressed) {
- carp "Holding not compressed, cannot convert to last member";
- return $self;
- } elsif ($self->is_open_ended) {
- carp "Holding is open-ended, cannot convert to last member";
- return $self;
- }
-
- my %changes;
- foreach my $key (keys %{$self->fields}) {
- my @values = @{$self->field_values($key)};
- $self->fields->{$key}{HOLDINGS} = [$values[1]];
- $changes{$key} = $values[1];
- }
-
- $self->update(%changes); # update underlying subfields
- $self->is_compressed(0); # remove compressed state
-
- return $self;
-}
-
-#
-# Basic, working, unoptimized clone operation
-#
-sub clone {
- my $self = shift;
-
- my $clone_field = $self->SUPER::clone();
- return new MFHD::Holding($self->seqno, $clone_field, $self->caption);
-}
-
-#
-# Turn a chronology instance into date(s) in YYYY-MM-DD format
-#
-# In list context it returns a list of start and (possibly undefined)
-# end dates
-#
-# In scalar context, it returns a YYYY-MM-DD date string of either the
-# single date or the (possibly undefined) end date of a compressed holding
-#
-sub chron_to_date {
- my $self = shift;
- my $caption = $self->caption;
-
- my @keys;
- if ($caption->enumeration_is_chronology) {
- @keys = ('a'..'f');
- } else {
- @keys = ('i'..'m');
- }
-
- # @chron_start and @chron_end will hold the (year, month, day) values
- # represented by the start and optional end of the chronology instance.
- # Default to January 1 with a year of 0 as initial values.
- my @chron_start = (0, 1, 1);
- my @chron_end = (0, 1, 1);
- my @chrons = (\@chron_start, \@chron_end);
- foreach my $key (@keys) {
- my $capstr = $caption->capstr($key);
- last if !defined($capstr);
- if ($capstr =~ /year/) {
- ($chron_start[0], $chron_end[0]) = @{$self->field_values($key)};
- } elsif ($capstr =~ /month/) {
- ($chron_start[1], $chron_end[1]) = @{$self->field_values($key)};
- } elsif ($capstr =~ /day/) {
- ($chron_start[2], $chron_end[2]) = @{$self->field_values($key)};
- } elsif ($capstr =~ /season/) {
- # chrons defined as season-only will use the astronomical season
- # dates as a basic estimate.
- my @seasons = @{$self->field_values($key)};
- for (my $i = 0; $i < @seasons; $i++) {
- $seasons[$i] = &_uncombine($seasons[$i], 0);
- if ($seasons[$i] == 21) {
- $chrons[$i]->[1] = 3;
- $chrons[$i]->[2] = 20;
- } elsif ($seasons[$i] == 22) {
- $chrons[$i]->[1] = 6;
- $chrons[$i]->[2] = 21;
- } elsif ($seasons[$i] == 23) {
- $chrons[$i]->[1] = 9;
- $chrons[$i]->[2] = 22;
- } elsif ($seasons[$i] == 24) {
- $chrons[$i]->[1] = 12;
- $chrons[$i]->[2] = 21;
- }
- }
- }
- }
-
- my @dates;
- foreach my $chron (@chrons) {
- my $date = undef;
- if ($chron->[0] != 0) {
- $date =
- &_uncombine($chron->[0], 0) . '-'
- . sprintf('%02d', $chron->[1]) . '-'
- . sprintf('%02d', $chron->[2]);
- }
- push(@dates, $date);
- }
-
- if (wantarray()) {
- return @dates;
- } elsif ($self->is_compressed) {
- return $dates[1];
- } else {
- return $dates[0];
- }
-}
-
-#
-# utility function for uncombining instance parts
-#
-sub _uncombine {
- my ($combo, $pos) = @_;
-
- if (ref($combo)) {
- carp("Function '_uncombine' is not an instance method");
- return;
- }
-
- my @parts = split('/', $combo);
- return $parts[$pos];
-}
-
-#
-# Overload string comparison operators
-#
-# We are not overloading '<=>' because '==' is used liberally in MARC::Record
-# to compare field identity (i.e. is this the same exact Field object?), not value
-#
-# Other string operators are auto-generated from 'cmp'
-#
-# Please note that this comparison is based on what the holding represents,
-# not whether it is strictly identical (e.g. the seqno and link may vary)
-#
-use overload ('cmp' => \&_compare,
- 'fallback' => 1);
-sub _compare {
- my ($holding_1, $holding_2) = @_;
-
- # TODO: this needs some more consideration
- # fall back to 'built-in' comparison
- if (!UNIVERSAL::isa($holding_2, ref $holding_1)) {
- if (defined $holding_2) {
- carp("Use of non-holding in holding comparison operation");
- return ( "$holding_1" cmp "$holding_2" );
- } else {
- carp("Use of undefined value in holding comparison operation");
- return 1; # similar to built-in, something is "greater than" nothing
- }
- }
-
- # special cases for compressed holdings
- my ($holding_1_first, $holding_1_last, $holding_2_first, $holding_2_last, $found_compressed);
- # 0 for no compressed, 1 for first compressed, 2 for second compressed, 3 for both compressed
- $found_compressed = 0;
- if ($holding_1->is_compressed) {
- $holding_1_last = $holding_1->clone->compressed_to_last;
- $found_compressed += 1;
- } else {
- $holding_1_first = $holding_1;
- $holding_1_last = $holding_1;
- }
- if ($holding_2->is_compressed) {
- $holding_2_first = $holding_2->clone->compressed_to_first;
- $found_compressed += 2;
- } else {
- $holding_2_first = $holding_2;
- $holding_2_last = $holding_2;
- }
-
- if ($found_compressed) {
- my $cmp = ($holding_1_last cmp $holding_2_first); # 1 ends before 2 starts
- if ($cmp == -1) {
- return -1; # 1 is fully lt
- } elsif ($cmp == 0) {
- carp("Overlapping holdings in comparison, lt and gt based on start value only");
- return -1;
- } else { # check the opposite, 2 ends before 1 starts
- # clone is expensive, wait until we need it (here)
- if (!defined($holding_2_last)) {
- $holding_2_last = $holding_2->clone->compressed_to_last;
- }
- if (!defined($holding_1_first)) {
- $holding_1_first = $holding_1->clone->compressed_to_first;
- }
- $cmp = ($holding_2_last cmp $holding_1_first);
- if ($cmp == -1) {
- return 1; # 1 is fully gt
- } elsif ($cmp == 0) {
- carp("Overlapping holdings in comparison, lt and gt based on start value only");
- return 1;
- } else {
- $cmp = ($holding_1_first cmp $holding_2_first);
- if (!$cmp) { # they are not equal
- carp("Overlapping holdings in comparison, lt and gt based on start value only");
- return $cmp;
- } elsif ($found_compressed == 1) {
- carp("Compressed holding found with start equal to non-compressed holding");
- return 1; # compressed (first holding) is 'greater than' non-compressed
- } elsif ($found_compressed == 2) {
- carp("Compressed holding found with start equal to non-compressed holding");
- return -1; # compressed (second holding) is 'greater than' non-compressed
- } else { # both holdings compressed, check for full equality
- $cmp = ($holding_1_last cmp $holding_2_last);
- if (!$cmp) { # they are not equal
- carp("Compressed holdings in comparison have equal starts, lt and gt based on end value only");
- return $cmp;
- } else {
- return 0; # both are compressed, both ends are equal
- }
- }
- }
- }
- }
-
- # start doing the actual comparison
- my $result;
- foreach my $key ('a'..'f') {
- if (defined($holding_1->field_values($key))) {
- if (!defined($holding_2->field_values($key))) {
- return 1; # more details equals 'greater' (?)
- } else {
- $result = $holding_1->field_values($key)->[0] <=> $holding_2->field_values($key)->[0];
- }
- } elsif (defined($holding_2->field_values($key))) {
- return -1; # more details equals 'greater' (?)
- }
-
- return $result if $result;
- }
-
- # got through, return 0 for equal
- return 0;
-}
-
-1;
+++ /dev/null
-test:
- perl -I../../../.. mfhd.t
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Data::Dumper;
-use Test::More 'no_plan';
-
-use MARC::Record;
-use OpenILS::Utils::MFHD;
-
-use testlib;
-
-my $testno = 1;
-
-sub right_answer {
- my $holding = shift;
- my $answer = {};
-
- foreach my $subfield (split(/\|/, $holding->subfield('x'))) {
- next unless $subfield;
-
- my ($key, $val) = unpack('aa*', $subfield);
- $answer->{$key} = $val;
- }
-
- return $answer;
-}
-
-
-my $rec;
-my @captions;
-
-open(my $testdata, "<mfhddata.txt") or die("Cannot open 'mfhddata.txt': $!");
-
-while ($rec = testlib::load_MARC_rec($testdata, $testno++)) {
- $rec = MFHD->new($rec);
-
- foreach my $cap (sort { $a->tag <=> $b->tag } $rec->field('85.')) {
- my $htag;
- my @holdings;
-
- ($htag = $cap->tag) =~ s/^85/86/;
- @holdings = $rec->holdings($htag, $cap->subfield('8'));
-
- if (!ok(scalar @holdings, "holdings defined " . $cap->subfield('8'))) {
- next;
- }
-
- foreach my $field (@holdings) {
- TODO: {
- local $TODO = "unimplemented"
- if ($field->subfield('z') =~ /^TODO/);
- is_deeply($field->next, right_answer($field),
- $field->subfield('8') . ': ' . $field->subfield('z'));
- }
- }
- }
-}
-
-1;
+++ /dev/null
-245 00 $aMonthly, issue no. restarts, calendar change: Jan
-853 20 $81$av.$bno.$u12$vr$i(year)$j(month)$wm$x01
-863 41 $81.1$a1$b6$i1990$j06$x|a1|b7|i1990|j07$zMiddle of year, middle of vol.
-863 41 $81.2$a1$b11$i1990$j11$x|a1|b12|i1990|j12$zEnd of year, end of vol.
-863 41 $81.3$a1$b12$i1990$j12$x|a2|b1|i1991|j01$zWrap at end of year/vol.
-
-245 00 $aMonthly, issue no. restarts, calendar change: Mar
-853 20 $82$av.$bno.$u12$vr$i(year)$j(month)$wm$x03
-863 41 $82.1$a1$b6$i1990$j08$x|a1|b7|i1990|j09$zMiddle of year, middle of vol.
-863 41 $82.2$a1$b10$i1990$j12$x|a1|b11|i1991|j01$zEnd of year, middle of vol.
-863 41 $82.3$a1$b11$i1991$j01$x|a1|b12|i1991|j02$zMiddle of year, end of vol.
-863 41 $82.3$a1$b12$i1991$j02$x|a2|b1|i1991|j03$zWrap vol in mid-year
-
-245 00 $aMonthly, issue no. continuous, calendar change: Jan
-853 20 $83$av.$bno.$u12$vc$i(year)$j(month)$wm$x01
-863 41 $83.1$a1$b6$i1990$j06$x|a1|b7|i1990|j07$zMiddle of year, middle of vol.
-863 41 $83.2$a1$b11$i1990$j11$x|a1|b12|i1990|j12$zEnd of year, end of vol.
-863 41 $83.3$a1$b12$i1990$j12$x|a2|b13|i1991|j01$zwrap vol @ end of year
-
-245 00 $aMonthly, issue no. continuous, calendar change: Mar
-853 20 $84$av.$bno.$u12$vc$i(year)$j(month)$wm$x03
-863 41 $84.1$a1$b6$i1990$j08$x|a1|b7|i1990|j09$zMiddle of year, middle of vol.
-863 41 $84.2$a1$b10$i1990$j12$x|a1|b11|i1991|j01$zEnd of year, middle of vol.
-863 41 $84.3$a1$b11$i1991$j01$x|a1|b12|i1991|j02$zMiddle of year, end of vol.
-863 41 $84.4$a1$b12$i1991$j02$x|a2|b13|i1991|j03$zwrap vol mid-year
-
-245 00 $aMonthly, issue no. restarts, Calendar change: Jan, Jul
-853 20 $85$av.$bno.$u6$vr$i(year)$j(month)$wm$x01,07
-863 41 $85.1$a1$b5$i1990$j05$x|a1|b6|i1990|j06$zMiddle of year, near end of vol.
-863 41 $85.2$a1$b6$i1990$j06$x|a2|b1|i1990|j07$zMiddle of year, end of vol.
-863 41 $85.3$a2$b6$i1990$j12$x|a3|b1|i1991|j01$zEnd of year, end of vol.
-
-245 00 $aMonthly, issue no. continuous, Calendar change: Jan, Jul
-853 20 $86$av.$bno.$u6$vc$i(year)$j(month)$wm$x01,07
-863 41 $86.1$a1$b5$i1990$j05$x|a1|b6|i1990|j06$zMiddle of year, end of vol.
-863 41 $86.2$a1$b6$i1990$j06$x|a2|b7|i1990|j07$zMiddle of year, end of vol.
-863 41 $86.3$a2$b12$i1990$j12$x|a3|b13|i1991|j01$zEnd of year, end of vol.
-
-245 00 $aMonthly, issue no. restarts, Calendar change: Jan, Combined issue: Jan/Feb
-853 20 $87$av.$bno.$u11$vr$i(year)$j(month)$wm$x01$ycm01/02
-863 41 $87.1$a1$b11$i1990$j12$x|a2|b1|i1991|j01/02$z End of year, end of vol.
-863 41 $87.2$a2$b1$i1991$j01/02$x|a2|b2|i1991|j03$z Beginning of year, beginning of vol.
-
-245 00 $aMonthly, iss no. restarts, Calendar change: Jan, Combined iss: Nov/Dec
-853 20 $88$av.$bno.$u11$vr$i(year)$j(month)$wm$x01$ycm11/12
-863 41 $88.1$a1$b10$i1990$j10$x|a1|b11|i1990|j11/12$z end of year, end of vol.
-863 41 $88.2$a1$b11$i1990$j11/12$x|a2|b1|i1991|j01$z wrap vol at year end
-
-245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: Jan/Feb, Nov/Dec
-853 20 $89$av.$bno.$u10$vr$i(year)$j(month)$wm$x01$ycm01/02,11/12
-863 41 $89.1$a1$b1$i1990$j01/02$x|a1|b2|i1990|j03$z beg. of year, beg. of vol.
-863 41 $89.2$a1$b9$i1990$j10$x|a1|b10|i1990|j11/12$z end of year, end of vol.
-863 41 $89.3$a1$b10$i1990$j11/12$x|a2|b1|i1991|j01/02$z zwrap vol at year end
-
-245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: May/Jun, Jul/Aug
-853 20 $810$av.$bno.$u10$vr$i(year)$j(month)$wm$x01$ycm05/06,07/08
-863 41 $810.1$a1$b4$i1990$j04$x|a1|b5|i1990|j05/06$z next iss is combined.
-863 41 $810.2$a1$b5$i1990$j05/06$x|a1|b6|i1990|j07/08$z combined to combined
-863 41 $810.3$a1$b6$i1990$j07/08$x|a1|b7|i1990|j09$z combined to reg
-
-245 00 $aMonthly, issue no. restarts, Calendar change: Jan, Combined issue: 1/2 Jan/Feb
-853 20 $811$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm01/02$yce21/2
-863 41 $811.1$a1$b12$i1990$j12$x|a2|b1/2|i1991|j01/02$znew vol at year end regular iss to combined
-863 41 $811.2$a2$b1/2$i1991$j01/02$x|a2|b3|i1991|j03$zcombined iss to regular
-
-245 00 $aMonthly, iss no. restarts, Calendar change: Jan, Combined iss: 11/12 Nov/Dec
-853 20 $812$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm11/12$yce211/12
-863 41 $812.1$a1$b10$i1990$j10$x|a1|b11/12|i1990|j11/12$zregular to combined iss
-863 41 $812.2$a1$b11/12$i1990$j11/12$x|a2|b1|i1991|j01$zend of vol: combined to regular issue
-
-245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: 1/2 Jan/Feb, 11/12 Nov/Dec
-853 20 $813$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm01/02,11/12$yce21/2,11/12
-863 41 $813.1$a1$b10$i1990$j10$x|a1|b11/12|i1990|j11/12$zend of vol regular to combined iss
-863 41 $813.2$a1$b11/12$i1990$j11/12$x|a2|b1/2|i1991|j01/02$zwrap at volume end: combined to combined
-863 41 $813.3$a2$b1/2$i1991$j01/02$x|a2|b3|i1991|j03$zbeginning of vol: combined to regular
-
-245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: 5/6 May/Jun, 7/8 Jul/Aug
-853 20 $814$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm05/06,07/08$yce25/6,7/8
-863 41 $814.1$a1$b4$i1990$j04$x|a1|b5/6|i1990|j05/06$zmid year: reg to combined
-863 41 $814.2$a1$b5/6$i1990$j05/06$x|a1|b7/8|i1990|j07/08$zmid year: combined to combined
-863 41 $814.3$a1$b7/8$i1990$j07/08$x|a1|b9|i1990|j09$zmid year: combined to regular
-
-245 00 $aMonthly, iss no. restarts, Cal change: Jan, July issue omitted
-853 20 $815$av.$bno.$u11$vr$i(year)$j(month)$wm$x01$yom07
-863 41 $815.1$a1$b6$i1990$j06$x|a1|b7|i1990|j08$zskip july issue
-
-245 00 $aQuarterly, chronology in enumeration fields
-853 20 $816$a(year)$b(season)$wq$yps21,22,23,24
-863 41 $816.1$a2007$b21$x|a2007|b22$zChron in enum: simple case: quarterly in mid-volume
-863 41 $816.2$a2007$b24$x|a2008|b21$zChron in enum: Roll over to new year
-
-245 00 $aFour issues a year, chronology in enum fields, combined Sum/Fall issue
-853 20 $817$a(year)$b(season)$wq$ycs22/23
-863 41 $817.1$a2007$b21$x|a2007|b22/23$zChron in enum: Spring to Summer/Fall
-863 41 $817.2$a2007$b22/23$x|a2007|b24$zChron in enum: Summer/Fall to Winter
-
-245 00 $aLibrary Journal: 20 times a year, semimonthly except Jan, Jul, Aug, Dec
-853 20 $818$av.$bno.$u20$vr$i(year)$j(month)$k(day)$ws$x01$ypd01,15$yod0115,0715,0815,1215
-863 41 $818.1$a132$b20$i2007$j12$k1$x|a133|b1|i2008|j01|k01$zSkipping over missed date to beginning of next year/volume.
-863 41 $818.2$a133$b1$i2008$j01$k01$x|a133|b2|i2008|j02|k01$zSkipping over missed date at beginning of year
-863 41 $818.3$a133$b2$i2008$j02$k01$x|a133|b3|i2008|j02|k15$zPublished semimonthly, going from 1st to 15th
-863 41 $818.4$a133$b3$i2008$j02$k15$x|a133|b4|i2008|j03|k01$zPublished semimonthly, going from 15th to 1st
-
-245 00 $aBimonthly: Feb, Apr, June, Aug, Oct, Dec
-853 20 $819$av.$bno.$u6$vr$i(year)$j(month)$wb$x02$ypm02,04,06,08,10,12
-863 41 $819.1$a1$b3$i1990$j06$x|a1|b4|i1990|j08$zMiddle of year, middle of vol.
-863 41 $819.2$a1$b5$i1990$j10$x|a1|b6|i1990|j12$zEnd of year, end of vol.
-863 41 $819.3$a1$b6$i1990$j12$x|a2|b1|i1991|j02$zWrap at end of year/vol.
-
-245 00 $aBimonthly, published 5 times with combined summer issue: Feb, Apr, June/Aug, Oct, Dec
-853 20 $820$av.$bno.$u5$vr$i(year)$j(month)$wb$x02$ypm02,04,10,12$ycm06/08
-863 41 $820.1$a1$b2$i1990$j04$x|a1|b3|i1990|j06/08$zFrom Apr to Jun/Aug
-863 41 $820.2$a1$b3$i1990$j06/08$x|a1|b4|i1990|j10$zFrom Jun/Aug to Oct
-863 41 $820.3$a1$b5$i1990$j12$x|a2|b1|i1991|j02$zWrap at end of year/vol.
-
-245 00 $aEconomist: pub. w on Sa, except combined iss on last two weeks of year
-853 20 $821$av.$bno.$u12$vc$i(year)$j(month)$k(day)$ww$x01,04,07,10$ypdsa$yow1299
-863 41 $821.1$a100$b1200$i2008$j12$k06$x|a100|b1201|i2008|j12|k13$zwithin vol.
-863 41 $821.2$a100$b1201$i2008$j12$k13$x|a100|b1202|i2008|j12|k20$zwithin vol. combined iss.
-863 41 $821.3$a100$b1202$i2008$j12$k20$x|a101|b1203|i2009|j01|k03$zvolume change over omitted iss.
-
-245 00 $aMFHD example: monthly, pub. 2nd Wed of month except in April: 2nd Thu; May:1st Wednesday.
-853 20 $822$av.$bno.$u12$vr$i(year)$j(month)$k(day)$wm$x01$ypw02we$ypw0402th,0501we$yow0402we,0502we
-863 41 $822.1$a1$b2$i2009$j02$k11$x|a1|b3|i2009|j03|k11$zpublished on 2nd Wed in Mar
-863 41 $822.2$a1$b3$i2009$j03$k11$x|a1|b4|i2009|j04|k09$zpublished on 2nd Thu in Apr
-863 41 $822.3$a1$b4$i2009$j04$k09$x|a1|b5|i2009|j05|k06$zpublished on 1st Wed in May
-863 41 $822.4$a2$b4$i2013$j04$k11$x|a2|b5|i2013|j05|k01$zpublished on Wed May 1st
-
-245 00 $aMFHD example: pub. every Mon, Thu, except on New Years, July 4, Labor Day, Thanksgiving, Christmas
-853 20 $823$av.$bno.$uvar$vr$i(year)$j(month)$k(day)$wc$x07$ypw00mo,00th$yod0101,0704,1225$yow0901mo,1104th
-863 41 $823.1$a1$b100$i2009$j02$k02$x|a1|b101|i2009|j02|k05$znormal: Mon to Thu
-863 41 $823.2$a1$b101$i2009$j02$k05$x|a1|b102|i2009|j02|k09$znormal: Thu to Mon
-863 41 $823.3$a1$b150$i2009$j06$k29$x|a2|b151|i2009|j07|k02$znormal: calendar change
-863 41 $823.4$a2$b180$i2009$j09$k03$x|a2|b181|i2009|j09|k10$zSkip Labor Day
-863 41 $823.5$a2$b200$i2009$j11$k23$x|a2|b201|i2009|j11|k30$zSkip (US) Thanksgiving
-
-#
-# According to the specification and the examples at
-# http://www.loc.gov/marc/chrono_patterns.html it is possible to
-# document a combined issue in a $yp publication regularity definition,
-# like this: $yps21,22/23,24
-245 00 $aCombined date documented in publication pattern rather than combined pattern
-853 20 $824$av.$bno.$u3$vr$i(year)$j(season)$wq$x21$yps21,22/23,24
-863 41 $824.1$a1$b1$i2009$j21$x|a1|b2|i2009|j22/23$zSpring to Summer/Fall
-863 41 $824.2$a1$b2$i2009$j22/23$x|a1|b3|i2009|j24$zSummer/Fall to Winter
-
-# Item is published 6 times/year whose enumeration "skips" numbers
-# at the second level using only odd numbers that restart
-# at the turn of the calendar year.
-# (From www.loc.gov/marc/chrono_patterns.html)
-245 00 $aFunky enumeration
-853 20 $825$av.$bno.$u6$vr$i(year)$j(month)$wb$ype21,3,5,7,9,11
-863 41 $825.1$a1$b1$i1990$j01$x|a1|b3|i1990|j03$zJan to Mar
-863 41 $825.2$a1$b11$i1990$j11$x|a2|b1|i1991|j01$zNov to Jan, year & vol wrap
-
-
-# Monthly, one volume per year, issue numbering restarts in January
-# Annual supplement published in September, annual index published in
-# February
-245 00 $aSupplements and Indexes: Oh My
-853 20 $826$av.$bno.$u12$vr$i(year)$j(month)$wm
-854 20 $827$av.$i(year)$j(month)$wa$ypm09$oSupplement
-855 20 $828$av.$i(year)$j(month)$ypm02$oIndex
-863 41 $826.1$a1$b1$i1990$j01$x|a1|b2|i1990|j02$znormal issue
-864 41 $827.1$a1$i1990$j09$x|a2|i1991|j09$zAnnual supplement
-865 41 $828.1$a1$i1990$j02$x|a2|i1991|j02$zAnnual Index
+++ /dev/null
-package testlib;
-
-use strict;
-use warnings;
-
-use base 'Exporter';
-
-our @EXPORT_OK = qw(load_MARC_rec);
-
-use Data::Dumper;
-
-use MARC::Record;
-
-sub load_MARC_rec {
- my $fh = shift;
- my $testno = shift;
- my $rec;
- my $line;
- my $marc = undef;
-
- # skim to beginning of record (a non-blank, non comment line)
- while ($line = <$fh>) {
- chomp $line;
- last if (!($line =~ /^\s*$/) && !($line =~ /^#/));
- }
-
- return undef if !$line;
-
- $marc = MARC::Record->new();
- carp('No record created!') unless $marc;
-
- $marc->leader('01119nas 22003134a 4500');
- $marc->append_fields(
- MARC::Field->new('008', '970701c18439999enkwr p 0 a0eng '));
- $marc->append_fields(
- MARC::Field->new('035', '', '', a => sprintf('%04d', $testno)));
-
- while ($line) {
- next if $line =~ /^#/; # allow embedded comments
-
- return $marc if $line =~ /^\s*$/;
-
- my ($fieldno, $indicators, $rest) = split(/ /, $line, 3);
- my @inds = unpack('aa', $indicators);
- my $field;
- my @subfields;
-
- @subfields = ();
- foreach my $subfield (split(/\$/, $rest)) {
- next unless $subfield;
-
- my ($key, $val) = unpack('aa*', $subfield);
- push @subfields, $key, $val;
- }
-
- $field = MARC::Field->new(
- $fieldno, $inds[0], $inds[1],
- @subfields
- );
-
- $marc->append_fields($field);
-
- $line = <$fh>;
- chomp $line if $line;
- }
- return $marc;
-}
-
-1;
+++ /dev/null
-package OpenILS::Utils::MFHDParser;
-use strict;
-use warnings;
-
-use OpenSRF::EX qw/:try/;
-use Time::HiRes qw(time);
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use OpenILS::Utils::MFHD;
-use MARC::File::XML (BinaryEncoding => 'utf8');
-use Data::Dumper;
-
-sub new { return bless({}, shift()); }
-
-=head1 Subroutines
-
-=over
-
-=item * format_textual_holdings($field)
-
-=back
-
-Returns concatenated subfields $a with $z for textual holdings (866-868)
-
-=cut
-
-sub format_textual_holdings {
- my ($self, $field) = @_;
- my $holdings;
- my $public_note;
-
- $holdings = $field->subfield('a');
- if (!$holdings) {
- return undef;
- }
-
- $public_note = $field->subfield('z');
- if ($public_note) {
- return "$holdings -- $public_note";
- }
- return $holdings;
-}
-
-=over
-
-=item * mfhd_to_hash($mfhd_xml)
-
-=back
-
-Returns a Perl hash containing fields of interest from the MFHD record
-
-=cut
-
-sub mfhd_to_hash {
- my ($self, $mfhd_xml) = @_;
-
- my $marc;
- my $mfhd;
-
- my $location = '';
- my $basic_holdings = [];
- my $supplement_holdings = [];
- my $index_holdings = [];
- my $basic_holdings_add = [];
- my $supplement_holdings_add = [];
- my $index_holdings_add = [];
- my $online = []; # Laurentian extension to MFHD standard
- my $missing = []; # Laurentian extension to MFHD standard
- my $incomplete = []; # Laurentian extension to MFHD standard
-
- try {
- $marc = MARC::Record->new_from_xml($mfhd_xml);
- }
- otherwise {
- $logger->error("Failed to convert MFHD XML to MARC: " . shift());
- $logger->error("Failed MFHD XML: $mfhd_xml");
- };
-
- if (!$marc) {
- return undef;
- }
-
- try {
- $mfhd = MFHD->new($marc);
- }
- otherwise {
- $logger->error("Failed to parse MFHD: " . shift());
- $logger->error("Failed MFHD XML: $mfhd_xml");
- };
-
- if (!$mfhd) {
- return undef;
- }
-
- try {
- foreach my $field ($marc->field('852')) {
- foreach my $subfield_ref ($field->subfields) {
- my ($subfield, $data) = @$subfield_ref;
- $location .= $data . " -- ";
- }
- }
- }
- otherwise {
- $logger->error("MFHD location parsing error: " . shift());
- };
-
- $location =~ s/ -- $//;
-
- # TODO: for now, we will assume that textual holdings are in addition to the
- # computable holdings (that is, they have link IDs greater than the 85X fields)
- # or that they fully replace the computable holdings (checking for link ID '0').
- # Eventually this may be handled better by format_holdings() in MFHD.pm
- my %skip_computable;
- try {
- foreach my $field ($marc->field('866')) {
- my $textual_holdings = $self->format_textual_holdings($field);
- if ($textual_holdings) {
- push @$basic_holdings_add, $textual_holdings;
- if ($field->subfield('8') eq '0') {
- $skip_computable{'basic'} = 1; # link ID 0 trumps computable fields
- }
- }
- }
- foreach my $field ($marc->field('867')) {
- my $textual_holdings = $self->format_textual_holdings($field);
- if ($textual_holdings) {
- push @$supplement_holdings_add, $textual_holdings;
- if ($field->subfield('8') eq '0') {
- $skip_computable{'supplement'} = 1; # link ID 0 trumps computable fields
- }
- }
- }
- foreach my $field ($marc->field('868')) {
- my $textual_holdings = $self->format_textual_holdings($field);
- if ($textual_holdings) {
- push @$index_holdings_add, $textual_holdings;
- if ($field->subfield('8') eq '0') {
- $skip_computable{'index'} = 1; # link ID 0 trumps computable fields
- }
- }
- }
-
- if (!exists($skip_computable{'basic'})) {
- foreach my $cap_id ($mfhd->caption_link_ids('853')) {
- my @holdings = $mfhd->holdings('863', $cap_id);
- next unless scalar @holdings;
- foreach (@holdings) {
- push @$basic_holdings, $_->format();
- }
- }
- if (!@$basic_holdings) { # no computed holdings found
- $basic_holdings = $basic_holdings_add;
- $basic_holdings_add = [];
- }
- } else { # textual are non additional, but primary
- $basic_holdings = $basic_holdings_add;
- $basic_holdings_add = [];
- }
-
- if (!exists($skip_computable{'supplement'})) {
- foreach my $cap_id ($mfhd->caption_link_ids('854')) {
- my @supplements = $mfhd->holdings('864', $cap_id);
- next unless scalar @supplements;
- foreach (@supplements) {
- push @$supplement_holdings, $_->format();
- }
- }
- if (!@$supplement_holdings) { # no computed holdings found
- $supplement_holdings = $supplement_holdings_add;
- $supplement_holdings_add = [];
- }
- } else { # textual are non additional, but primary
- $supplement_holdings = $supplement_holdings_add;
- $supplement_holdings_add = [];
- }
-
- if (!exists($skip_computable{'index'})) {
- foreach my $cap_id ($mfhd->caption_link_ids('855')) {
- my @indexes = $mfhd->holdings('865', $cap_id);
- next unless scalar @indexes;
- foreach (@indexes) {
- push @$index_holdings, $_->format();
- }
- }
- if (!@$index_holdings) { # no computed holdings found
- $index_holdings = $index_holdings_add;
- $index_holdings_add = [];
- }
- } else { # textual are non additional, but primary
- $index_holdings = $index_holdings_add;
- $index_holdings_add = [];
- }
-
- # Laurentian extensions
- foreach my $field ($marc->field('530')) {
- my $online_stmt = $self->format_textual_holdings($field);
- if ($online_stmt) {
- push @$online, $online_stmt;
- }
- }
-
- foreach my $field ($marc->field('590')) {
- my $missing_stmt = $self->format_textual_holdings($field);
- if ($missing_stmt) {
- push @$missing, $missing_stmt;
- }
- }
-
- foreach my $field ($marc->field('591')) {
- my $incomplete_stmt = $self->format_textual_holdings($field);
- if ($incomplete_stmt) {
- push @$incomplete, $incomplete_stmt;
- }
- }
- }
- otherwise {
- $logger->error("MFHD statement parsing error: " . shift());
- };
-
- return {
- location => $location,
- basic_holdings => $basic_holdings,
- basic_holdings_add => $basic_holdings_add,
- supplement_holdings => $supplement_holdings,
- supplement_holdings_add => $supplement_holdings_add,
- index_holdings => $index_holdings,
- index_holdings_add => $index_holdings_add,
- missing => $missing,
- incomplete => $incomplete,
- online => $online
- };
-}
-
-=over
-
-=item * init_holdings_virtual_record()
-
-=back
-
-Initialize the serial virtual record (svr) instance
-
-=cut
-
-sub init_holdings_virtual_record {
- my $record = Fieldmapper::serial::virtual_record->new;
- $record->sre_id();
- $record->location();
- $record->owning_lib();
- $record->basic_holdings([]);
- $record->basic_holdings_add([]);
- $record->supplement_holdings([]);
- $record->supplement_holdings_add([]);
- $record->index_holdings([]);
- $record->index_holdings_add([]);
- $record->online([]);
- $record->missing([]);
- $record->incomplete([]);
- return $record;
-}
-
-=over
-
-=item * init_holdings_virtual_record($mfhd)
-
-=back
-
-Given an MFHD record, return a populated svr instance
-
-=cut
-
-sub generate_svr {
- my ($self, $id, $mfhd, $owning_lib) = @_;
-
- if (!$mfhd) {
- return undef;
- }
-
- my $record = init_holdings_virtual_record();
- my $holdings = $self->mfhd_to_hash($mfhd);
-
- $record->sre_id($id);
- $record->owning_lib($owning_lib);
-
- if (!$holdings) {
- return $record;
- }
-
- $record->location($holdings->{location});
- $record->basic_holdings($holdings->{basic_holdings});
- $record->basic_holdings_add($holdings->{basic_holdings_add});
- $record->supplement_holdings($holdings->{supplement_holdings});
- $record->supplement_holdings_add($holdings->{supplement_holdings_add});
- $record->index_holdings($holdings->{index_holdings});
- $record->index_holdings_add($holdings->{index_holdings_add});
- $record->online($holdings->{online});
- $record->missing($holdings->{missing});
- $record->incomplete($holdings->{incomplete});
-
- return $record;
-}
-
-1;
-
-# vim: ts=4:sw=4:noet
+++ /dev/null
-package OpenILS::Utils::ModsParser;
-use strict; use warnings;
-
-use OpenSRF::EX qw/:try/;
-use XML::LibXML;
-use XML::LibXSLT;
-use Time::HiRes qw(time);
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/$logger/;
-use Data::Dumper;
-
-my $parser = XML::LibXML->new();
-my $xslt = XML::LibXSLT->new();
-my $mods_sheet;
-
-# ----------------------------------------------------------------------------------------
-# XPATH for extracting info from a MODS doc
-my $isbn_xpath = "//mods:mods/mods:identifier[\@type='isbn']";
-my $resource_xpath = "//mods:mods/mods:typeOfResource";
-my $pub_xpath = "//mods:mods/mods:originInfo//mods:dateIssued[\@encoding='marc']|" .
- "//mods:mods/mods:originInfo//mods:dateIssued[1]";
-my $tcn_xpath = "//mods:mods/mods:recordInfo/mods:recordIdentifier";
-my $publisher_xpath = "//mods:mods/mods:originInfo//mods:publisher[1]";
-my $edition_xpath = "//mods:mods/mods:originInfo//mods:edition[1]";
-my $abstract_xpath = "//mods:mods/mods:abstract";
-my $related_xpath = "";
-my $online_loc_xpath = "//mods:location/mods:url";
-my $physical_desc = "(//mods:mods/mods:physicalDescription/mods:form|//mods:mods/mods:physicalDescription/mods:extent|".
- "//mods:mods/mods:physicalDescription/mods:reformattingQuality|//mods:mods/mods:physicalDescription/mods:internetMediaType|".
- "//mods:mods/mods:physicalDescription/mods:digitalOrigin)";
-my $toc_xpath = "//mods:tableOfContents";
-
-my $xpathset = {
-
- title => {
- abbreviated =>
- "//mods:mods/mods:titleInfo[mods:title and (\@type='abbreviated')]",
- translated =>
- "//mods:mods/mods:titleInfo[mods:title and (\@type='translated')]",
- uniform =>
- "//mods:mods/mods:titleInfo[mods:title and (\@type='uniform')]",
- proper =>
- "//mods:mods/mods:titleInfo[mods:title and not (\@type)]",
- any =>
- "//mods:mods/mods:titleInfo",
- },
-
- author => {
- corporate =>
- "//mods:mods/mods:name[\@type='corporate']/*[local-name()='namePart']".
- "[../mods:role/mods:text[text()='creator']".
- " or ../mods:role/mods:roleTerm[".
- " \@type='text'".
- " and \@authority='marcrelator'".
- " and text()='creator']".
- "][1]",
- personal =>
- "//mods:mods/mods:name[\@type='personal']/*[local-name()='namePart']".
- "[../mods:role/mods:text[text()='creator']".
- " or ../mods:role/mods:roleTerm[".
- " \@type='text'".
- " and \@authority='marcrelator'".
- " and text()='creator']".
- "][1]",
- conference =>
- "//mods:mods/mods:name[\@type='conference']/*[local-name()='namePart']".
- "[../mods:role/mods:text[text()='creator']".
- " or ../mods:role/mods:roleTerm[".
- " \@type='text'".
- " and \@authority='marcrelator'".
- " and text()='creator']".
- "][1]",
- other =>
- "//mods:mods/mods:name[\@type='personal']/*[local-name()='namePart']",
- any =>
- "//mods:mods/mods:name/*[local-name()='namePart'][1]",
- },
-
- subject => {
-
- topic =>
- "//mods:mods/mods:subject/*[".
- " local-name()='geographic'".
- " or local-name()='name'".
- " or local-name()='temporal'".
- " or local-name()='topic'".
- "]/parent::mods:subject",
-
-# geographic =>
-# "//mods:mods/*[local-name()='subject']/*[local-name()='geographic']",
-# name =>
-# "//mods:mods/*[local-name()='subject']/*[local-name()='name']",
-# temporal =>
-# "//mods:mods/*[local-name()='subject']/*[local-name()='temporal']",
-# topic =>
-# "//mods:mods/*[local-name()='subject']/*[local-name()='topic']",
- },
- #keyword => { keyword => "//mods:mods/*[not(local-name()='originInfo')]", },
-
- series => {
- series => "//mods:mods/mods:relatedItem[\@type='series']/mods:titleInfo"
- }
-};
-# ----------------------------------------------------------------------------------------
-
-
-
-sub new { return bless( {}, shift() ); }
-
-sub get_field_value {
-
- my( $self, $mods, $xpath, $type) = @_;
-
- my @string;
-
- my $root = $mods->documentElement;
- $root->setNamespace( "http://www.loc.gov/mods/v3", "mods", 1 );
-
- try {
- # grab the set of matching nodes
- my @nodes = $root->findnodes( $xpath );
- for my $value (@nodes) {
-
- # grab all children of the node
- my @children = $value->childNodes();
- my @child_text;
- for my $child (@children) {
- # MODS strips the punctuation from 245abc, which often
- # results in "title subtitle" rather than "title : subtitle";
- # this hack gets it back for us
- if ($type && $type eq 'title' && $child->nodeName =~ m/subTitle/) {
- push(@child_text, " : ");
- }
- next unless( $child->nodeType != 3 );
-
- if($child->childNodes) {
- my @a;
- for my $c (@{$child->childNodes}){
- push @a, $c->textContent;
- }
- push(@child_text, join(' ', @a));
-
- } else {
- push(@child_text, $child->textContent);
- }
-
- }
- if(@child_text) {
- push(@string, \@child_text);
- }
-
- if( !@child_text ) {
- push(@string, $value->textContent );
- }
- }
- } otherwise {
- $logger->info("MODS-izing failure: ".shift());
- $logger->info("Failed MODS xml: ".$root->toString);
- $logger->info("Failed MODS xpath: $xpath");
- };
- return @string;
-}
-
-=head
-sub _modsdoc_to_values {
- my( $self, $mods ) = @_;
- my $data = {};
- for my $class (keys %$xpathset) {
- $data->{$class} = {};
- for my $type(keys %{$xpathset->{$class}}) {
- my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
- if( $class eq "subject" ) {
- push( @{$data->{$class}->{$type}}, @value );
- } else {
- $data->{$class}->{$type} = $value[0];
- }
- }
- }
- return $data;
-}
-=cut
-
-sub modsdoc_to_values {
- my( $self, $mods ) = @_;
- my $data = {};
-
- {
- my $class = "subject";
- $data->{$class} = {};
- for my $type(keys %{$xpathset->{$class}}) {
- my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
- for my $arr (@value) {
- push( @{$data->{$class}->{$type}}, $arr);
- }
- }
- }
-
- {
- my $class = "title";
- $data->{$class} = {};
- for my $type(keys %{$xpathset->{$class}}) {
- my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type}, "title" );
- for my $arr (@value) {
- if( ref($arr) ) {
- $data->{$class}->{$type} = shift @$arr;
-
- my $t = lc($data->{$class}->{$type});
- if($t and $t =~ /^l[eoa]s|l[ae]|el|the|un[ae]?|an?\s?$/o ) {
- my $val = shift @$arr || "";
- $data->{$class}->{$type} .= " $val" if $data->{$class}->{$type};
- $data->{$class}->{$type} = " $val" unless $data->{$class}->{$type};
- }
-
- for my $t (@$arr) {
- $data->{$class}->{$type} .= " $t";
- }
- } else {
- $data->{$class}->{$type} = $arr;
- }
- }
- $data->{$class}->{$type} =~ s/\s+/ /go if ($data->{$class}->{$type});
- }
- }
-
- {
- my $class = "author";
- $data->{$class} = {};
- for my $type(keys %{$xpathset->{$class}}) {
- my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
- $data->{$class}->{$type} = $value[0];
- }
- }
-
- {
- my $class = "series";
- $data->{$class} = {};
- for my $type(keys %{$xpathset->{$class}}) {
- my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
- for my $arr (@value) {
- if( ref($arr) ) {
- push(@{$data->{$class}->{$type}}, join(" ", @$arr));
- } else {
- push( @{$data->{$class}->{$type}}, $arr );
- }
- }
- }
-
- }
-
- return $data;
-}
-
-
-
-
-# ---------------------------------------------------------------------------
-# Grabs the data 'we want' from the MODS doc and returns it in hash form
-# ---------------------------------------------------------------------------
-sub mods_values_to_mods_slim {
- my( $self, $modsperl ) = @_;
-
- my $title = "";
- my $author = "";
- my $subject = [];
- my $series = [];
-
- my $tmp = $modsperl->{title};
-
-
- if(!$tmp) { $title = ""; }
- else {
- ($title = $tmp->{proper}) ||
- ($title = $tmp->{translated}) ||
- ($title = $tmp->{abbreviated}) ||
- ($title = $tmp->{uniform}) ||
- ($title = $tmp->{any});
- }
-
- $tmp = $modsperl->{author};
- if(!$tmp) { $author = ""; }
- else {
- ($author = $tmp->{personal}) ||
- ($author = $tmp->{corporate}) ||
- ($author = $tmp->{conference}) ||
- ($author = $tmp->{other}) ||
- ($author = $tmp->{any});
- }
-
- $tmp = $modsperl->{subject};
- if(!$tmp) { $subject = {}; }
- else {
- for my $key( keys %{$tmp}) {
- push(@$subject, @{$tmp->{$key}}) if ($tmp->{$key});
- }
- my $subh = {};
- for my $s (@$subject) {
- if(defined($subh->{$s})) { $subh->{$s->[0]}++ } else { $subh->{$s->[0]} = 1;}
- }
- $subject = $subh
- }
-
- $tmp = $modsperl->{'series'};
- if(!$tmp) { $series = []; }
- else { $series = $tmp->{'series'}; }
-
-
- return { series => $series, title => $title,
- author => $author, subject => $subject };
-}
-
-
-
-# ---------------------------------------------------------------------------
-# Initializes a MARC -> Unified MODS batch process
-# ---------------------------------------------------------------------------
-
-sub start_mods_batch {
-
- my( $self, $master_doc ) = @_;
-
- if(!$master_doc) {
- $self->{master_doc} = undef;
- return;
- }
-
- if(!$mods_sheet) {
- my $xslt_doc = $parser->parse_file(
- OpenSRF::Utils::SettingsClient->new->config_value(dirs => 'xsl') . "/MARC21slim2MODS32.xsl");
- $mods_sheet = $xslt->parse_stylesheet( $xslt_doc );
- }
-
-
- my $xmldoc = $parser->parse_string($master_doc);
- my $mods = $mods_sheet->transform($xmldoc);
-
- $self->{master_doc} = $self->modsdoc_to_values( $mods );
- $self->{master_doc} = $self->mods_values_to_mods_slim( $self->{master_doc} );
-
- ($self->{master_doc}->{isbn}) =
- $self->get_field_value( $mods, $isbn_xpath );
-
- $self->{master_doc}->{type_of_resource} =
- [ $self->get_field_value( $mods, $resource_xpath ) ];
-
- ($self->{master_doc}->{tcn}) =
- $self->get_field_value( $mods, $tcn_xpath );
-
- ($self->{master_doc}->{pubdate}) =
- $self->get_field_value( $mods, $pub_xpath );
-
- ($self->{master_doc}->{publisher}) =
- $self->get_field_value( $mods, $publisher_xpath );
-
- ($self->{master_doc}->{edition}) =
- $self->get_field_value( $mods, $edition_xpath );
-
-
-
-# ------------------------------
- # holds an array of [ link, title, link, title, ... ]
- $self->{master_doc}->{online_loc} = [];
- for my $url ($mods->findnodes($online_loc_xpath)) {
- push(@{$self->{master_doc}->{online_loc}}, $url->textContent);
- push(@{$self->{master_doc}->{online_loc}}, $url->getAttribute('displayLabel') || '');
- push(@{$self->{master_doc}->{online_loc}}, $url->getAttribute('note') || '');
- }
-
- ($self->{master_doc}->{synopsis}) =
- $self->get_field_value( $mods, $abstract_xpath );
-
- $self->{master_doc}->{physical_description} = [];
- push(@{$self->{master_doc}->{physical_description}},
- $self->get_field_value( $mods, $physical_desc ) );
- $self->{master_doc}->{physical_description} =
- join( ' ', @{$self->{master_doc}->{physical_description}});
-
- ($self->{master_doc}->{toc}) = $self->get_field_value($mods, $toc_xpath);
-
-}
-
-
-
-# ---------------------------------------------------------------------------
-# Takes a MARCXML string and adds it to the growing MODS doc
-# ---------------------------------------------------------------------------
-sub push_mods_batch {
- my( $self, $marcxml ) = @_;
-
- my $xmldoc = $parser->parse_string($marcxml);
- my $mods = $mods_sheet->transform($xmldoc);
-
- my $xmlperl = $self->modsdoc_to_values( $mods );
- $xmlperl = $self->mods_values_to_mods_slim( $xmlperl );
-
- # for backwards compatibility, remove the array part when all is decided
- if(ref($xmlperl->{subject}) eq 'ARRAY' ) {
- for my $subject( @{$xmlperl->{subject}} ) {
- push @{$self->{master_doc}->{subject}}, $subject;
- }
- } else {
- for my $subject ( keys %{$xmlperl->{subject}} ) {
- my $s = $self->{master_doc}->{subject};
- if(defined($s->{$subject})) { $s->{$subject}++; } else { $s->{$subject} = 1; }
- }
- }
-
- push( @{$self->{master_doc}->{type_of_resource}},
- $self->get_field_value( $mods, $resource_xpath ));
-
- if(!($self->{master_doc}->{isbn}) ) {
- ($self->{master_doc}->{isbn}) =
- $self->get_field_value( $mods, $isbn_xpath );
- }
-}
-
-
-# ---------------------------------------------------------------------------
-# Completes a MARC -> Unified MODS batch process and returns the perl hash
-# ---------------------------------------------------------------------------
-sub init_virtual_record {
- my $record = Fieldmapper::metabib::virtual_record->new;
- $record->subject([]);
- $record->types_of_resource([]);
- $record->call_numbers([]);
- return $record;
-}
-
-sub finish_mods_batch {
- my $self = shift;
-
- return undef unless $self->{master_doc};
-
- my $perl = $self->{master_doc};
- my $record = init_virtual_record();
-
- # turn the hash into a fieldmapper object
- #(my $title = $perl->{title}) =~ s/\[.*?\]//og;
- #(my $author = $perl->{author}) =~ s/\(.*?\)//og;
- my $title = $perl->{title};
- my $author = $perl->{author};
-
- my @series;
- for my $s (@{$perl->{series}}) {
- push @series, (split( /\s*;/, $s ))[0];
- }
-
- # uniquify the types of resource
- my $rtypes = $perl->{type_of_resource};
- my %hash = map { ($_ => 1) } @$rtypes;
- $rtypes = [ keys %hash ];
-
- $record->title($title);
- $record->author($author);
-
- $record->doc_id($perl->{doc_id});
- $record->isbn($perl->{isbn});
- $record->pubdate($perl->{pubdate});
- $record->publisher($perl->{publisher});
- $record->tcn($perl->{tcn});
-
- $record->edition($perl->{edition});
-
- $record->subject($perl->{subject});
- $record->types_of_resource($rtypes);
- $record->series(\@series);
-
- $record->online_loc($perl->{online_loc});
- $record->synopsis($perl->{synopsis});
- $record->physical_description($perl->{physical_description});
- $record->toc($perl->{toc});
-
- $self->{master_doc} = undef;
- return $record;
-}
-
-
-
+++ /dev/null
-package OpenILS::Utils::Normalize;
-use strict;
-use warnings;
-use Unicode::Normalize;
-use Encode;
-
-use Exporter 'import';
-our @EXPORT_OK = qw( naco_normalize );
-
-sub naco_normalize {
-
- my $str = decode_utf8(shift);
- my $sf = shift;
-
- # Apply NACO normalization to input string; based on
- # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
- #
- # Note that unlike a strict reading of the NACO normalization rules,
- # output is returned as lowercase instead of uppercase for compatibility
- # with previous versions of the Evergreen naco_normalize routine.
-
- # Convert to upper-case first; even though final output will be lowercase, doing this will
- # ensure that the German eszett (ß) and certain ligatures (ff, fi, ffl, etc.) will be handled correctly.
- # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
- $str = uc $str;
-
- # remove non-filing strings
- $str =~ s/\x{0098}.*?\x{009C}//g;
-
- $str = NFKD($str);
-
- # additional substitutions - 3.6.
- $str =~ s/\x{00C6}/AE/g;
- $str =~ s/\x{00DE}/TH/g;
- $str =~ s/\x{0152}/OE/g;
- $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
-
- # transformations based on Unicode category codes
- $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
-
- if ($sf && $sf =~ /^a/o) {
- my $commapos = index($str, ',');
- if ($commapos > -1) {
- if ($commapos != length($str) - 1) {
- $str =~ s/,/\x07/; # preserve first comma
- }
- }
- }
-
- # since we've stripped out the control characters, we can now
- # use a few as placeholders temporarily
- $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
- $str =~ s/[\p{Pc}\p{Pd}\p{Pe}\p{Pf}\p{Pi}\p{Po}\p{Ps}\p{Sk}\p{Sm}\p{So}\p{Zl}\p{Zp}\p{Zs}]/ /g;
- $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
-
- # decimal digits
- $str =~ tr/\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{07C0}-\x{07C9}\x{0966}-\x{096F}\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}\x{0BE6}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}\x{1040}-\x{1049}\x{1090}-\x{1099}\x{17E0}-\x{17E9}\x{1810}-\x{1819}\x{1946}-\x{194F}\x{19D0}-\x{19D9}\x{1A80}-\x{1A89}\x{1A90}-\x{1A99}\x{1B50}-\x{1B59}\x{1BB0}-\x{1BB9}\x{1C40}-\x{1C49}\x{1C50}-\x{1C59}\x{A620}-\x{A629}\x{A8D0}-\x{A8D9}\x{A900}-\x{A909}\x{A9D0}-\x{A9D9}\x{AA50}-\x{AA59}\x{ABF0}-\x{ABF9}\x{FF10}-\x{FF19}/0-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-9/;
-
- # intentionally skipping step 8 of the NACO algorithm; if the string
- # gets normalized away, that's fine.
-
- # leading and trailing spaces
- $str =~ s/\s+/ /g;
- $str =~ s/^\s+//;
- $str =~ s/\s+$//g;
-
- return lc $str;
-}
-
-1;
+++ /dev/null
-package OpenILS::Utils::OfflineStore;
-use strict; use warnings;
-
-use UNIVERSAL::require;
-if ('Class::DBI::Frozen::301'->use) {
- use parent 'Class::DBI::Frozen::301';
-} elsif ('Class::DBI'->use) {
- use parent 'Class::DBI';
-} else {
- die $@;
-}
-
-use DBI;
-use OpenSRF::Utils::Config;
-
-our ($_dsn,$_u,$_p);
-sub DBFile {
- my $class = shift;
- my $dsn = shift;
- my $u = shift;
- my $p = shift;
- if ($dsn) {
- $_dsn = $dsn;
- $_u = $u;
- $_p = $p;
- }
- return $_dsn;
-}
-
-our $_dbh;
-sub db_Main {
- my $self = shift;
- return $_dbh if ($_dbh);
-
- $_dbh = DBI->connect($_dsn,$_u,$_p,
- {
- RootClass => 'DBIx::ContextualFetch'
- }
- );
-
- return $_dbh;
-}
-
-
-sub disconnect {
- $_dbh->disconnect;
- $_dbh = undef;
-}
-
-
-package OpenILS::Utils::OfflineStore::Session;
-use parent 'OpenILS::Utils::OfflineStore';
-
-sub _create_table {
- my $self = shift;
- $self->db_Main->do( <<" SQL" );
-
-CREATE TABLE session (
- key TEXT UNIQUE PRIMARY KEY,
- org INTEGER NOT NULL,
- description TEXT,
- creator INTEGER NOT NULL,
- create_time INTEGER NOT NULL,
- in_process INTEGER NOT NULL DEFAULT 0,
- start_time INTEGER,
- end_time INTEGER,
- num_complete INTEGER NOT NULL DEFAULT 0
-);
-CREATE INDEX IF NOT EXISTS session_pkey ON session (key);
-CREATE INDEX IF NOT EXISTS session_org ON session (org);
-CREATE INDEX IF NOT EXISTS session_creation ON session (create_time);
-
- SQL
-}
-
-__PACKAGE__->table('offline.session');
-__PACKAGE__->columns( Essential => qw/key org description
- creator create_time in_process start_time end_time num_complete/);
-__PACKAGE__->has_many(scripts => 'OpenILS::Utils::OfflineStore::Script');
-
-
-package OpenILS::Utils::OfflineStore::Script;
-use parent 'OpenILS::Utils::OfflineStore';
-
-sub _create_table {
- my $self = shift;
- $self->db_Main->do( <<" SQL" );
-
-CREATE TABLE script (
- id INTEGER UNIQUE PRIMARY KEY AUTOINCREMENT,
- session TEXT NOT NULL,
- requestor INTEGER NOT NULL,
- create_time INTEGER NOT NULL,
- workstation TEXT NOT NULL,
- logfile TEXT NOT NULL,
- time_delta INTEGER NOT NULL DEFAULT 0,
- count INTEGER NOT NULL DEFAULT 0
-);
-CREATE INDEX IF NOT EXISTS script_pkey ON script (id);
-CREATE INDEX IF NOT EXISTS script_ws ON script (workstation);
-CREATE INDEX IF NOT EXISTS script_session ON script (session);
-
- SQL
-}
-
-__PACKAGE__->table('offline.script');
-__PACKAGE__->columns( Essential => qw/id session requestor create_time workstation logfile time_delta count/);
-__PACKAGE__->has_a(session => 'OpenILS::Utils::OfflineStore::Session');
-__PACKAGE__->sequence(qw/offline.script_id_seq/);
-
-
-
-
-
+++ /dev/null
-package OpenILS::Utils::Penalty;
-use strict; use warnings;
-use DateTime;
-use Data::Dumper;
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Cache;
-use OpenSRF::Utils qw/:datetime/;
-use OpenILS::Application::AppUtils;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::Const qw/:const/;
-my $U = "OpenILS::Application::AppUtils";
-
-
-# calculate and update the well-known penalties
-sub calculate_penalties {
- my($class, $e, $user_id, $context_org) = @_;
-
- my $commit = 0;
- unless($e) {
- $e = new_editor(xact =>1);
- $commit = 1;
- }
-
- my $penalties = $e->json_query({from => ['actor.calculate_system_penalties',$user_id, $context_org]});
-
- my $user = $e->retrieve_actor_user( $user_id );
- my @existing_penalties = grep { defined $_->{id} } @$penalties;
- my @wanted_penalties = grep { !defined $_->{id} } @$penalties;
- my @trigger_events;
-
- my %csp;
- for my $pen_obj (@wanted_penalties) {
-
- my $pen = Fieldmapper::actor::user_standing_penalty->new;
- $pen->$_($pen_obj->{$_}) for keys %$pen_obj;
-
- # let's see if this penalty is accounted for already
- my ($existing) = grep {
- $_->{org_unit} == $pen_obj->{org_unit} and
- $_->{standing_penalty} == $pen_obj->{standing_penalty}
- } @existing_penalties;
-
- if($existing) {
- # we have one of these already. Leave it be, but remove it from the
- # existing set so it's not deleted in the subsequent loop
- @existing_penalties = grep { $_->{id} ne $existing->{id} } @existing_penalties;
-
- } else {
-
- # this is a new penalty
- $e->create_actor_user_standing_penalty($pen) or return $e->die_event;
-
- my $csp_obj = $csp{$pen->standing_penalty} ||
- $e->retrieve_config_standing_penalty( $pen->standing_penalty );
-
- # cache for later
- $csp{$pen->standing_penalty} = $csp_obj;
-
- push(@trigger_events, ['penalty.' . $csp_obj->name, $pen, $pen->org_unit]);
- }
- }
-
- # at this point, any penalties remaining in the existing
- # penalty set are unaccounted for and should be removed
- for my $pen_obj (@existing_penalties) {
- my $pen = Fieldmapper::actor::user_standing_penalty->new;
- $pen->$_($pen_obj->{$_}) for keys %$pen_obj;
- $e->delete_actor_user_standing_penalty($pen) or return $e->die_event;
- }
-
- $e->commit if $commit;
-
- $U->create_events_for_hook($$_[0], $$_[1], $$_[2]) for @trigger_events;
- return undef;
-}
-
-# any penalties whose block_list has an item from @fatal_mask will be sorted
-# into the fatal_penalties set. Others will be sorted into the info_penalties set
-sub retrieve_penalties {
- my($class, $e, $user_id, $context_org, @fatal_mask) = @_;
-
- my(@info, @fatal);
- my $penalties = $class->retrieve_usr_penalties($e, $user_id, $context_org);
-
- for my $p (@$penalties) {
- my $pushed = 0;
- if($p->standing_penalty->block_list) {
- for my $m (@fatal_mask) {
- if($p->standing_penalty->block_list =~ /$m/) {
- push(@fatal, $p->standing_penalty);
- $pushed = 1;
- last;
- }
- }
- }
- push(@info, $p->standing_penalty) unless $pushed;
- }
-
- return {fatal_penalties => \@fatal, info_penalties => \@info};
-}
-
-
-# Returns a list of actor_user_standing_penalty objects
-sub retrieve_usr_penalties {
- my($class, $e, $user_id, $context_org) = @_;
-
- return $e->search_actor_user_standing_penalty([
- {
- usr => $user_id,
- org_unit => $U->get_org_ancestors($context_org),
- '-or' => [
- {stop_date => undef},
- {stop_date => {'>' => 'now'}}
- ],
- },
- {flesh => 1, flesh_fields => {ausp => ['standing_penalty']}}
- ]);
-}
-
-1;
-
-
+++ /dev/null
-package OpenILS::Utils::PermitHold;
-use strict; use warnings;
-use Data::Dumper;
-use OpenSRF::Utils;
-use OpenSRF::Utils::SettingsClient;
-use OpenILS::Utils::ScriptRunner;
-use OpenILS::Application::AppUtils;
-use DateTime::Format::ISO8601;
-use OpenILS::Application::Circ::ScriptBuilder;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenILS::Event;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-my $U = "OpenILS::Application::AppUtils";
-
-my $script; # - the permit script
-my $script_libs; # - extra script libs
-my $legacy_script_support;
-
-# mental note: open-ils.storage.biblio.record_entry.ranged_tree
-
-
-# params within a hash are: copy, patron,
-# requestor, request_lib, title, title_descriptor
-sub permit_copy_hold {
- my $params = shift;
- my @allevents;
-
- unless(defined $legacy_script_support) {
- my $conf = OpenSRF::Utils::SettingsClient->new;
- $legacy_script_support = $conf->config_value(
- apps => 'open-ils.circ' => app_settings => 'legacy_script_support');
- $legacy_script_support = ($legacy_script_support and
- $legacy_script_support =~ /true/i) ? 1 : 0;
- }
-
- return indb_hold_permit($params) unless $legacy_script_support;
-
- my $ctx = {
- patron_id => $$params{patron_id},
- patron => $$params{patron},
- copy => $$params{copy},
- requestor => $$params{requestor},
- title => $$params{title},
- volume => $$params{volume},
- flesh_age_protect => 1,
- _direct => {
- requestLib => $$params{request_lib},
- pickupLib => $$params{pickup_lib},
- newHold => $$params{new_hold},
- }
- };
-
- my $runner = OpenILS::Application::Circ::ScriptBuilder->build($ctx);
-
- my $ets = $ctx->{_events};
-
- # --------------------------------------------------------------
- # Strip the expired event since holds are still allowed to be
- # captured on expired patrons.
- # --------------------------------------------------------------
- if( $ets and @$ets ) {
- $ets = [ grep { $_->{textcode} ne 'PATRON_ACCOUNT_EXPIRED' } @$ets ];
- } else { $ets = []; }
-
- if( @$ets ) {
- push( @allevents, @$ets);
-
- # --------------------------------------------------------------
- # If scriptbuilder returned any events, then the script context
- # is undefined and should not be used
- # --------------------------------------------------------------
-
- } else {
-
- # check the various holdable flags
- push( @allevents, OpenILS::Event->new('ITEM_NOT_HOLDABLE') )
- unless $U->is_true($ctx->{copy}->holdable);
-
- push( @allevents, OpenILS::Event->new('ITEM_NOT_HOLDABLE') )
- unless $U->is_true($ctx->{copy}->location->holdable);
-
- push( @allevents, OpenILS::Event->new('ITEM_NOT_HOLDABLE') )
- unless $U->is_true($ctx->{copy}->status->holdable);
-
- my $evt;
-
- # grab the data safely
- my $rlib = ref($$params{request_lib}) ? $$params{request_lib}->id : $$params{request_lib};
- my $olib = ref($ctx->{volume}) ? $ctx->{volume}->owning_lib : -1;
- my $rid = ref($ctx->{requestor}) ? $ctx->{requestor}->id : -2;
- my $pid = ($params->{patron}) ? $params->{patron}->id : $params->{patron_id};
-
- if( ($rid ne $pid) and ($olib eq $rlib) ) {
- $logger->info("Item owning lib $olib is the same as the request lib. No age_protection will be checked");
- } else {
- $logger->info("item owning lib = $olib, request lib = $rlib, requestor=$rid, patron=$pid. checking age_protection");
- $evt = check_age_protect($ctx->{patron}, $ctx->{copy});
- push( @allevents, $evt ) if $evt;
- }
-
- $logger->debug("Running permit_copy_hold on copy " . $$params{copy}->id);
-
- load_scripts($runner);
- my $result = $runner->run or
- throw OpenSRF::EX::ERROR ("Hold Copy Permit Script Died: $@");
-
- # --------------------------------------------------------------
- # Extract and uniquify the event list
- # --------------------------------------------------------------
- my $events = $result->{events};
- $logger->debug("circ_permit_hold for user $pid returned events: [@$events]");
-
- push( @allevents, OpenILS::Event->new($_)) for @$events;
- }
-
- my %hash = map { ($_->{ilsevent} => $_) } @allevents;
- @allevents = values %hash;
-
- $runner->cleanup;
-
- return \@allevents if $$params{show_event_list};
- return 1 unless @allevents;
- return 0;
-}
-
-
-sub load_scripts {
- my $runner = shift;
-
- if(!$script) {
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my @pfx = ( "apps", "open-ils.circ","app_settings" );
- my $libs = $conf->config_value(@pfx, 'script_path');
- $script = $conf->config_value(@pfx, 'scripts', 'circ_permit_hold');
- $script_libs = (ref($libs)) ? $libs : [$libs];
- }
-
- $runner->add_path($_) for(@$script_libs);
- $runner->load($script);
-}
-
-
-sub check_age_protect {
- my( $patron, $copy ) = @_;
-
- return undef unless $copy and $copy->age_protect and $patron;
-
- my $hou = (ref $patron->home_ou) ? $patron->home_ou->id : $patron->home_ou;
-
- my $prox = $U->storagereq(
- 'open-ils.storage.asset.copy.proximity', $copy->id, $hou );
-
- # If this copy is within the appropriate proximity,
- # age protect does not apply
- return undef if $prox <= $copy->age_protect->prox;
-
- my $protection_list = $U->storagereq(
- 'open-ils.storage.direct.config.rules.age_hold_protect.search_where.atomic',
- { age => { '>=' => $copy->age_protect->age },
- prox => { '>=' => $copy->age_protect->prox },
- },
- { order_by => 'age' }
- );
-
- # Now, now many seconds old is this copy
- my $create_date = DateTime::Format::ISO8601
- ->new
- ->parse_datetime( OpenSRF::Utils::cleanse_ISO8601($copy->create_date) )
- ->epoch;
-
- my $age = time - $create_date;
-
- for my $protection ( @$protection_list ) {
-
- $logger->info("analyzing age protect ".$protection->name);
-
- # age protect does not apply if within the proximity
- last if $prox <= $protection->prox;
-
- # How many seconds old does the copy have to be to escape age protection
- my $interval = OpenSRF::Utils::interval_to_seconds($protection->age);
-
- $logger->info("age_protect interval=$interval, create_date=$create_date, age=$age");
-
- if( $interval > $age ) {
- # if age of the item is less than the protection interval,
- # the item falls within the age protect range
- $logger->info("age_protect prevents copy from having a hold placed on it: ".$copy->id);
- return OpenILS::Event->new('ITEM_AGE_PROTECTED', copy => $copy->id );
- }
- }
-
- return undef;
-}
-
-my $LEGACY_HOLD_EVENT_MAP = {
- 'config.hold_matrix_test.holdable' => 'ITEM_NOT_HOLDABLE',
- 'transit_range' => 'ITEM_NOT_HOLDABLE',
- 'no_matchpoint' => 'NO_POLICY_MATCHPOINT',
- 'config.hold_matrix_test.max_holds' => 'MAX_HOLDS',
- 'config.rule_age_hold_protect.prox' => 'ITEM_AGE_PROTECTED'
-};
-
-sub indb_hold_permit {
- my $params = shift;
-
- my $function = $$params{retarget} ? 'action.hold_retarget_permit_test' : 'action.hold_request_permit_test';
- my $patron_id =
- ref($$params{patron}) ? $$params{patron}->id : $$params{patron_id};
- my $request_lib =
- ref($$params{request_lib}) ? $$params{request_lib}->id : $$params{request_lib};
-
- my $HOLD_TEST = {
- from => [
- $function,
- $$params{pickup_lib},
- $request_lib,
- $$params{copy}->id,
- $patron_id,
- $$params{requestor}->id
- ]
- };
-
- my $e = new_editor(xact=>1);
- my $results = $e->json_query($HOLD_TEST);
- $e->rollback;
-
- unless($$params{show_event_list}) {
- return 1 if $U->is_true($results->[0]->{success});
- return 0;
- }
-
- return [
- new OpenILS::Event(
- "NO_POLICY_MATCHPOINT",
- "payload" => {"fail_part" => "no_matchpoint"}
- )
- ] unless @$results;
-
- return [] if $U->is_true($results->[0]->{success});
-
- return [
- map {
- my $event = new OpenILS::Event(
- $LEGACY_HOLD_EVENT_MAP->{$_->{"fail_part"}} || $_->{"fail_part"}
- );
- $event->{"payload"} = {"fail_part" => $_->{"fail_part"}};
- $event;
- } @$results
- ];
-}
-
-
-23;
+++ /dev/null
-package OpenILS::Utils::RemoteAccount;
-
-# use OpenSRF::Utils::SettingsClient;
-use OpenSRF::Utils::Logger qw/:logger/;
-
-use Data::Dumper;
-use Net::FTP;
-use Net::SSH2;
-use File::Temp;
-use File::Basename;
-use File::Spec;
-use Text::Glob qw( match_glob glob_to_regex );
-# use Error;
-
-$Data::Dumper::Indent = 0;
-
-use strict;
-use warnings;
-
-use Carp;
-
-our $AUTOLOAD;
-
-our %keyfiles = ();
-
-my %fields = (
- account_object => undef,
- remote_host => undef,
- remote_user => undef,
- remote_password => undef,
- remote_account => undef,
- remote_file => undef,
- remote_path => undef, # not really doing anything with this... yet.
- ssh_privatekey => undef,
- ssh_publickey => undef,
- type => undef,
- port => undef,
- content => undef,
- local_file => undef,
- tempfile => undef,
- error => undef,
- single_ext => undef,
- specific => 0,
- debug => 0,
-);
-
-
-=head1 NAME
-
-OpenILS::Utils::RemoteAccount - Encapsulate FTP, SFTP and SSH file transactions for Evergreen
-
-=head1 DESCRIPTION
-
-The Remote Account module attempts to transfer a file to/from a remote server.
-Either Net::FTP or Net::SSH2 is used.
-
-=head1 PARAMETERS
-
-All information is expected to be supplied by the caller via parameters:
- ~ remote_host (required)
- ~ remote_user
- ~ remote_password
- ~ remote_account
- ~ ssh_privatekey
- ~ ssh_publickey
- ~ type (FTP, SFTP or SCP -- default FTP)
- ~ port
- ~ debug
-
-Note: none of the parameters are actually required, except remote_host.
-That is because remote_user, remote_password and remote_account can all be
-extrapolated from other sources, as the Net::FTP docs describe:
-
- If no arguments are given then Net::FTP uses the Net::Netrc package
- to lookup the login information for the connected host.
-
- If no information is found then a login of anonymous is used.
-
- If no password is given and the login is anonymous then anonymous@
- will be used for password.
-
-Note that specifying a password will require you to specify a user.
-Similarly, specifying an account requires both user and password.
-That is, there are no assumed defaults when the latter arguments are used.
-
-=head2 SSH KEYS:
-
-The use of ssh keys is preferred. Explicit specification of connection type will prevent
-multiple attempts to the same server. Therefore, using the type parameter is also recommended.
-
-If the type is not explicit, we attempt to use SSH keys where they are specified or otherwise found
-in the runtime environment. If only one key is specified, we attempt to derive
-the corresponding filename based on the ssh-keygen defaults. If either key is
-specified, but both are not found (and readable) then the result is failure. If
-no key or type is specified, but keys are found, the key-based connections will be attempted,
-but failure will be non-fatal.
-
-=cut
-
-sub plausible_dirs {
- # returns plausible locations of a .ssh subdir where SSH keys might be stashed
- # NOTE: these would need to be properly genericized w/ Makefile vars
- # in order to support Debian packaging and multiple EG's on one box.
- # Until that happens, we just rely on $HOME
-
- my @bases = (
- # '/openils/conf', # __EG_CONFIG_DIR__
- );
- ($ENV{HOME}) and unshift @bases, $ENV{HOME};
-
- return grep {-d $_} map {"$_/.ssh"} @bases;
-}
-
-sub local_keyfiles {
- # populates %keyfiles hash
- # %keyfiles maps SSH_PRIVATEKEY => SSH_PUBLICKEY
- my $self = shift;
- my $force = (@_ ? shift : 0);
- return %keyfiles if (%keyfiles and not $force); # caching
- $logger->info("Checking for SSH keyfiles" . ($force ? ' (ignoring cache)' : ''));
- %keyfiles = (); # reset to empty
- my @dirs = plausible_dirs();
- $logger->debug(scalar(@dirs) . " plausible dirs: " . join(', ', @dirs));
- foreach my $dir (@dirs) {
- foreach my $key (qw/rsa dsa/) {
- my $private = "$dir/id_$key";
- my $public = "$dir/id_$key.pub";
- unless (-r $private) {
- $logger->debug("Key '$private' cannot be read: $!");
- next;
- }
- unless (-r $public) {
- $logger->debug("Key '$public' cannot be read: $!");
- next;
- }
- $keyfiles{$private} = $public;
- }
- }
- return %keyfiles;
-}
-
-sub param_keys {
- my $self = shift;
- my %keys = ();
- if ($self->ssh_publickey and not $self->ssh_privatekey) {
- my $private = $self->ssh_publickey;
- unless ($private and $private =~ s/\.pub$// and -r $self->ssh_privatekey) { # try to guess missing private key name
- $logger->error("No ssh_privatekey specified or found to pair with " . $self->ssh_publickey);
- return;
- }
- $self->ssh_privatekey($private);
- }
- if ($self->ssh_privatekey and not $self->ssh_publickey) {
- my $pub = $self->ssh_privatekey . '.pub'; # guess missing public key name
- unless (-r $pub) {
- $logger->error("No ssh_publickey specified or found to pair with " . $self->ssh_privatekey);
- return;
- }
- $self->ssh_publickey($pub);
- }
-
- # so now, we have either both ssh_p*keys params or neither
- foreach (qw/ssh_publickey ssh_privatekey/) {
- unless (-r $self->{$_}) {
- $logger->error("$_ '" . $self->{$_} . "' cannot be read: $!");
- return; # quit w/ error if we fail on any user-specified key
- }
- }
- $keys{$self->ssh_privatekey} = $self->ssh_publickey;
- return %keys;
-}
-
-sub new_tempfile {
- my $self = shift;
- my $text = shift || $self->content || '';
- my $tmp = File::Temp->new(); # magical self-destructing tempfile
- # print $tmp "THIS IS TEXT\n";
- print $tmp $text or $logger->error($self->_error("could not write to tempfile '$tmp'"));
- close $tmp;
- $self->tempfile($tmp); # save the object
- $self->local_file($tmp->filename); # save the filename
- $logger->info(_pkg("using tempfile $tmp"));
- return $self->local_file; # return the filename
-}
-
-sub outbound_file {
- my $self = shift;
- my $params = shift;
-
- unless (defined $self->content or $self->local_file) { # content can be emptystring
- $logger->error($self->_error("No content or local_file specified -- nothing to send"));
- return;
- }
-
- # tricky subtlety: we want to use the most recently specified options
- # with priority order: filename, content, old filename, old content.
- #
- # The $params->{x} will already match $self->x after the secondary init,
- # so the checks using $params below are for whether the value was specified NOW (e.g. via put()) or not.
- #
- # if we got a new local_file value, we use it
- # else if the content is new to this call, build a new tempfile w/ it,
- # else use existing local_file,
- # else build new tempfile w/ content already specified via new()
-
- return $params->{local_file} || (
- (defined $params->{content}) ?
- $self->new_tempfile($self->content) : # $self->content is same value as $params->{content}
- ($self->local_file || $self->new_tempfile($self->content))
- );
-}
-
-sub key_check {
- my $self = shift;
- my $params = shift;
-
- return if ($params->{type} and $params->{type} eq 'FTP'); # Forget it, user specified regular FTP
- return if ( $self->type and $self->type eq 'FTP'); # Forget it, user specified regular FTP
-
- if ($self->ssh_publickey || $self->ssh_privatekey) {
- $self->specific(1);
- return $self->param_keys(); # we got one or both params, but they didn't pan out
- }
- return local_keyfiles(); # optional "force" arg could be used here to empty cache
-}
-
-
-# TOP LEVEL methods
-# TODO: delete for both FTP and SSH2
-
-sub get {
- my $self = shift;
- my $params = shift;
- if (! ref $params) {
- $params = {remote_file => $params} ;
- }
-
- $self->init($params); # secondary init
-
- $self->{get_args} = [$self->remote_file]; # same for scp_put and FTP put
- push @{$self->{get_args}}, $self->local_file if defined $self->local_file;
-
- # $self->content($content);
-
- if ($self->type eq "FTP") {
- return $self->get_ftp(@{$self->{get_args}});
- } else {
- my %keys = $self->key_check($params);
- return $self->get_ssh2(\%keys, @{$self->{get_args}});
- }
-}
-
-sub put {
- my $self = shift;
- my $params = shift;
- if (! ref $params) {
- $params = {local_file => $params} ;
- }
-
- $self->init($params); # secondary init
-
- my $local_file = $self->outbound_file($params) or return;
-
- $self->{put_args} = [$local_file]; # same for scp_put and FTP put
- if (defined $self->remote_path and not defined $self->remote_file) {
- my $rpath = $self->remote_path;
- my $fname = basename($local_file);
- if ($rpath =~ /^(.*)\*+(.*)$/) { # if the path has an asterisk in it, like './incoming/*.tst'
- my $head = $1;
- my $tail = $2;
- if ($tail =~ /\//) {
- $logger->warn($self->_error("remote path '$rpath' has dir slashes AFTER an asterisk. Cannot determine target dir"));
- return;
- }
- if ($self->single_ext) {
- $tail =~ /\./ and $fname =~ s/\./_/g; # if dot in tail, replace dots in fname (w/ _)
- }
- $self->remote_file($head . $fname . $tail);
- } else {
- $self->remote_file($rpath . '/' . $fname); # if we know just the dir
- }
- }
-
- if (defined $self->remote_file) {
- push @{$self->{put_args}}, $self->remote_file; # user can specify remote_file name, optionally
- }
-
- if ($self->type eq "FTP") {
- return $self->put_ftp(@{$self->{put_args}});
- } else {
- my %keys = $self->key_check($params);
- $self->put_ssh2(\%keys, @{$self->{put_args}}) and return $self->remote_file;
- }
-}
-
-sub ls {
- my $self = shift;
- my $params = shift;
- my @targets = @_;
- if (! ref $params) {
- unshift @targets, ($params || '.'); # If it was just a string, it's the first target, else default pwd
- delete $self->{remote_file}; # overriding any target in the object previously.
- $params = {}; # make params a normal hashref again
- } else {
- if ($params->{remote_file} and @_) {
- $logger->warn($self->_error("Ignoring ls parameter remote_file for subsequent args"));
- delete $params->{remote_file};
- }
- $self->init($params); # secondary init
- $self->remote_file and (! @targets) and push @targets, $self->remote_file; # if remote_file is there, and there's nothing else, use it
- delete $self->{remote_file};
- }
-
- $self->{ls_args} = \@targets;
-
- if ($self->type eq "FTP") {
- return $self->ls_ftp(@targets);
- } else {
- my %keys = $self->key_check($params);
- # $logger->info("*** calling ls_ssh2(keys, '" . join("', '", (scalar(@targets) ? map {defined $_ ? $_ : '' } @targets : ())) . "') with ssh keys");
- return $self->ls_ssh2(\%keys, @targets);
- }
-}
-
-# Checks if the filename part of a pathname has one or more glob characters
-# We split out the filename portion of the path
-# Detect glob or no glob.
-# returns: directory, regex for matching filenames
-sub glob_parse {
- my $self = shift;
- my $path = shift or return;
- my ($vol, $dir, $file) = File::Spec->splitpath($path); # we don't care about attempted globs in mid-filepath
- my $front = $vol ? File::Spec->catdir($vol, $dir) : $dir;
- $file =~ /\*/ and return ($front, glob_to_regex($file));
- $file =~ /\?/ and return ($front, glob_to_regex($file));
- $logger->debug("No glob detected in '$path'");
- return;
-}
-
-
-# Internal Mechanics
-
-sub _ssh2 {
- my $self = shift;
- $self->{ssh2} and return $self->{ssh2}; # caching
- my $keys = shift;
-
- my $ssh2 = Net::SSH2->new();
- unless($ssh2->connect($self->remote_host)) {
- $logger->warn($self->error("SSH2 connect FAILED: $! " . join(" ", $ssh2->error)));
- return; # we cannot connect
- }
-
- my $success = 0;
- my @privates = keys %$keys;
- my $count = scalar @privates;
-
- if ($count) {
- foreach (@privates) {
- if ($self->auth_ssh2($ssh2,$self->auth_ssh2_args($_,$keys->{$_}))) {
- $success++;
- last;
- }
- }
- unless ($success) {
- $logger->error(
- $self->error(
- "All ($count) keypair(s) FAILED for " . $self->remote_host
- )
- );
- return;
- }
- } else {
- $logger->error(
- $self->error("Login FAILED for " . $self->remote_host)
- ) unless $self->auth_ssh2($ssh2, $self->auth_ssh2_args);
- }
- return $self->{ssh2} = $ssh2;
-}
-
-sub auth_ssh2 {
- my $self = shift;
- my $ssh2 = shift;
- my %auth_args = @_;
- $ssh2 or return;
-
- my $host = $auth_args{hostname} || 'UNKNOWN';
- my $key = $auth_args{privatekey} || 'UNKNOWN';
- my $msg = "ssh2->auth by keypair for $host using $key";
- if ($ssh2->auth(%auth_args)) {
- $logger->info("Successful $msg");
- return 1;
- }
-
- if ($self->specific) {
- $logger->error($self->error("Aborting. FAILED $msg: " . ($ssh2->error || '')));
- } else {
- $logger->warn($self->error("Unsuccessful keypair: FAILED $msg: " . ($ssh2->error || '')));
- }
- return;
-}
-
-sub auth_ssh2_args {
- my $self = shift;
- my %auth_args = (
- privatekey => shift,
- publickey => shift,
- rank => [qw/ publickey hostbased password /],
- );
- $self->remote_user and $auth_args{username} = $self->remote_user ;
- $self->remote_password and $auth_args{password} = $self->remote_password;
- $self->remote_host and $auth_args{hostname} = $self->remote_host ;
- return %auth_args;
-}
-
-sub put_ssh2 {
- my $self = shift;
- my $keys = shift; # could have many keypairs here
- unless (@_) {
- $logger->error($self->_error("put_ssh2 called without target: nothing to put!"));
- return;
- }
-
- $logger->info("*** attempting put (" . join(", ", @_) . ") with ssh keys");
- my $ssh2 = $self->_ssh2($keys) or return;
- my $res;
- if ($res = $ssh2->scp_put( @_ )) {
- $logger->info(_pkg("successfully sent", $self->remote_host, join(' --> ', @_ )));
- return $res;
- }
- $logger->error($self->_error(sprintf "put with keys to %s failed with error: $!", $self->remote_host));
- return;
-}
-
-sub get_ssh2 {
- my $self = shift;
- my $keys = shift; # could have many keypairs here
- unless (@_) {
- $logger->error($self->_error("get_ssh2 called without target: nothing to get!"));
- return;
- }
-
- $logger->info("*** get args: " . Dumper(\@_));
- $logger->info("*** attempting get (" . join(", ", map {$_ =~ /\S/ ? $_ : '*Object'} map {defined($_) ? $_ : '*Object'} @_) . ") with ssh keys");
- my $ssh2 = $self->_ssh2($keys) or return;
- my $res;
- if ($res = $ssh2->scp_get( @_ )) {
- $logger->info(_pkg("successfully got", $self->remote_host, join(' --> ', @_ )));
- return $res;
- }
- $logger->error($self->_error(sprintf "get with keys from %s failed with error: $!", $self->remote_host));
- return;
-}
-
-sub ls_ssh2 {
- my $self = shift;
- my @list = $self->ls_ssh2_full(@_);
- @list and return sort map {$_->{slash_path}} @list;
-# @list and return sort grep {$_->{name} !~ /./ and {$_->{name} !~ /./ } map {$_->{slash_path}} @list;
-}
-
-sub ls_ssh2_full {
- my $self = shift;
- my $keys = shift; # could have many keypairs here
- my @targets = grep {defined} @_;
-
- $logger->info("*** attempting ls ('" . join("', '", @targets) . "') with ssh keys");
- my $ssh2 = $self->_ssh2($keys) or return;
- my $sftp = $ssh2->sftp or return;
-
- my @list = ();
- foreach my $target (@targets) {
- my ($dir, $file);
- my ($dirpath, $regex) = $self->glob_parse($target);
- $dir = $sftp->opendir($dirpath || $target); # Try to open it like a directory
- unless ($dir) {
- $file = $sftp->stat($target); # Otherwise, check it like a file
- if ($file) {
- $file->{slash_path} = $self->_slash_path($target, $file->{name}); # it was a file, not a dir. That's OK.
- push @list, $file;
- } else {
- $logger->warn($self->_error("sftp->opendir($target) failed: " . $sftp->error));
- }
- next;
- }
- my @pool = ();
- while ($file = $dir->read()) {
- $file->{slash_path} = $self->_slash_path($target, $file->{name});
- push @pool, $file;
- }
- if ($regex) {
- my $count = scalar(@pool);
- @pool = grep {$_->{name} =~ /$regex/} @pool;
- $logger->info("SSH ls: Glob regex($regex) matches " . scalar(@pool) . " of $count files");
- } # else { $logger->info("SSH ls: No Glob regex in '$target'. Just a regular ls"); }
- push @list, @pool;
- }
- return @list;
-
-}
-
-sub _slash_path {
- my $self = shift;
- my $dir = shift || '.';
- my $file = shift || '';
- my ($dirpath, $regex) = $self->glob_parse($dir);
- $dir = $dirpath if $dirpath;
- return $dir . ($dir =~ /\/$/ ? '' : '/') . $file;
-}
-
-sub _ftp {
- my $self = shift;
- my %options = ();
- $self->{ftp} and return $self->{ftp}; # caching
- foreach (qw/debug port/) {
- $options{ucfirst($_)} = $self->{$_} if $self->{$_};
- }
-
- my $ftp = new Net::FTP($self->remote_host, %options);
- unless ($ftp) {
- $logger->error(
- $self->_error(
- "new Net::FTP('" . $self->remote_host . ", ...) FAILED: $@"
- )
- );
- return;
- }
-
- my @login_args = ();
- foreach (qw/remote_user remote_password remote_account/) {
- $self->{$_} or last;
- push @login_args, $self->{$_};
- }
- my $login_ok = 0;
- eval { $login_ok = $ftp->login(@login_args) };
- if ($@ or !$login_ok) {
- $logger->error(
- $self->_error(
- "failed login to", $self->remote_host, "w/ args(" .
- join(',', @login_args) . ") : $@"
- )
- ); # XXX later, maybe keep passwords out of the logs?
- return;
- }
- return $self->{ftp} = $ftp;
-}
-
-sub put_ftp {
- my $self = shift;
- my $filename;
-
- eval { $filename = $self->_ftp->put(@{$self->{put_args}}) };
- if ($@ or not $filename) {
- $logger->error(
- $self->_error(
- "put to", $self->remote_host, "failed with error: $@"
- )
- );
- return;
- }
-
- $self->remote_file($filename);
- $logger->info(
- _pkg(
- "successfully sent", $self->remote_host, $self->local_file, '-->',
- $filename
- )
- );
- return $filename;
-}
-
-sub get_ftp {
- my $self = shift;
- my $filename;
-
- eval { $filename = $self->_ftp->get(@{$self->{get_args}}) };
- if ($@ or not $filename) {
- $logger->error(
- $self->_error(
- "get from", $self->remote_host, "failed with error: $@"
- )
- );
- return;
- }
-
- $self->local_file($filename);
- $logger->info(
- _pkg(
- "successfully retrieved $filename <--", $self->remote_host . '/' .
- $self->remote_file
- )
- );
- return $self->local_file;
-}
-
-sub ls_ftp { # returns full path like: dir/path/file.ext
- my $self = shift;
- my @list;
-
- foreach (@_) {
- my @part;
- my ($dirpath, $regex) = $self->glob_parse($_);
- my $dirtarget = $dirpath || $_;
- $dirtarget =~ s/\/+$//;
- eval { @part = $self->_ftp->ls($dirtarget) }; # this ls returns relative/path/filenames. defer filename glob filtering for below.
- if ($@) {
- $logger->error(
- $self->_error(
- "ls from", $self->remote_host, "failed with error: $@"
- )
- );
- next;
- }
- if ($dirtarget and $dirtarget ne '.' and $dirtarget ne './' and
- $self->_ftp->is_dir($dirtarget)) {
- foreach my $file (@part) { # we ensure full(er) path
- $file =~ /^$dirtarget\// and next;
- $logger->debug("ls_ftp: prepending $dirtarget/ to $file");
- $file = File::Spec->catdir($dirtarget, $file);
- }
- }
- if ($regex) {
- my $count = scalar(@part);
- # @part = grep {my @a = split('/',$_); scalar(@a) ? /$regex/ : ($a[-1] =~ /$regex/)} @part;
- my @bulk = @part;
- @part = grep {
- my ($vol, $dir, $file) = File::Spec->splitpath($_);
- $file =~ /$regex/
- } @part;
- $logger->info("FTP ls: Glob regex($regex) matches " . scalar(@part) . " of $count files");
- } # else {$logger->info("FTP ls: No Glob regex in '$_'. Just a regular ls");}
- push @list, @part;
- }
- return @list;
-}
-
-sub delete_ftp { # XXX not yet used
- $_[0]->_ftp->delete($_[1]);
-}
-
-sub _pkg { # Not OO
- return __PACKAGE__ . ' : ' unless @_;
- return __PACKAGE__ . ' : ' . join(' ', @_);
-}
-
-sub _error {
- my $self = shift;
- return _pkg($self->error(join(' ',@_)));
-}
-
-sub init {
- my $self = shift;
- my $params = shift;
- my @required = @_; # qw(remote_host) ; # nothing required now
-
- if ($params->{account_object}) { # if we got passed an object, we initialize off that first
- $self->{remote_host } = $params->{account_object}->host;
- $self->{remote_user } = $params->{account_object}->username;
- $self->{remote_password} = $params->{account_object}->password;
- $self->{remote_account } = $params->{account_object}->account;
- $self->{remote_path } = $params->{account_object}->path; # not really the same as remote_file, maybe expand on this later
- }
-
- foreach (keys %{$self->{_permitted}}) {
- $self->{$_} = $params->{$_} if defined $params->{$_}; # possibly override settings from object
- }
-
- foreach (@required) {
- unless ($self->{$_}) {
- $logger->error("Required parameter $_ not specified");
- return;
- }
- }
- return $self;
-}
-
-sub new {
- my ($class, %args) = @_;
- my $self = { _permitted => \%fields, %fields };
-
- bless $self, $class;
-
- $self->init(\%args); # or croak "Initialization error caused by bad args";
- return $self;
-}
-
-sub DESTROY {
- # in order to create, we must first ...
- my $self = shift;
- $self->{ssh2} and $self->{ssh2}->disconnect(); # let the other end know we're done.
- $self->{ftp} and $self->{ftp}->quit(); # let the other end know we're done.
-}
-
-sub AUTOLOAD {
- my $self = shift;
- my $class = ref($self) or croak "AUTOLOAD error: $self is not an object";
- my $name = $AUTOLOAD;
-
- $name =~ s/.*://; # strip leading package stuff
-
- unless (exists $self->{_permitted}->{$name}) {
- croak "AUTOLOAD error: Cannot access '$name' field of class '$class'";
- }
-
- if (@_) {
- return $self->{$name} = shift;
- } else {
- return $self->{$name};
- }
-}
-
-1;
-
+++ /dev/null
-package OpenILS::Utils::ScriptRunner;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::JSON;
-use JavaScript::SpiderMonkey;
-use LWP::UserAgent;
-use XML::LibXML;
-use Time::HiRes qw/time/;
-use vars qw/%_paths/;
-
-sub DESTROY {
- my $self = shift;
- $logger->info("script_runner: destroying self: $self");
-}
-
-sub cleanup {
- my $runner = shift;
- $logger->info("script_runner: destroying context...");
- $runner->context->destroy;
- delete($$runner{$_}) for (keys %$runner);
-}
-
-sub new {
- my $class = shift;
- my %params = @_;
- $class = ref($class) || $class;
- $params{paths} ||= [];
- $params{reset_count} ||= 0;
-
- my $self = bless { file => $params{file},
- libs => $params{libs},
- reset_count => $params{reset_count},
- _runs => 0,
- _path => {%_paths} } => $class;
-
- $self->add_path($_) for @{$params{paths}};
- return $self->init;
-}
-
-sub context {
- my( $self, $context ) = @_;
- $self->{ctx} = $context if $context;
- return $self->{ctx};
-}
-
-sub init {
- my $self = shift;
- $self->context( new JavaScript::SpiderMonkey );
- $self->context->init();
-
- $self->{_runs} = 0;
-
- # eating our own dog food with insert
- $self->insert(log_stdout => sub { print "@_\n"; } );
- $self->insert(log_stderr => sub { warn "@_\n"; } );
- $self->insert(log_activity => sub { $logger->activity("script_runner: @_"); return 1;} );
- $self->insert(log_error => sub { $logger->error("script_runner: @_"); return 1;} );
- $self->insert(log_warn => sub { $logger->warn("script_runner: @_"); return 1;} );
- $self->insert(log_info => sub { $logger->info("script_runner: @_"); return 1;} );
- $self->insert(log_debug => sub { $logger->debug("script_runner: @_"); return 1;} );
- $self->insert(log_internal => sub { $logger->internal("script_runner: @_"); return 1;} );
- $self->insert(debug => sub { $logger->debug("script_runner: @_"); return 1;} );
- $self->insert(alert => sub { $logger->warn("script_runner: @_"); return 1;} );
- $self->insert(load_lib => sub { $self->load_lib(@_); return 1;});
-
- # OpenSRF support functions
- $self->insert(
- _OILS_FUNC_jsonopensrfrequest_send =>
- sub { $self->_jsonopensrfrequest_send(@_); }
- );
- $self->insert(
- _OILS_FUNC_jsonopensrfrequest_connect =>
- sub { $self->_jsonopensrfrequest_connect(@_); }
- );
- $self->insert(
- _OILS_FUNC_jsonopensrfrequest_disconnect =>
- sub { $self->_jsonopensrfrequest_disconnect(@_); }
- );
- $self->insert(
- _OILS_FUNC_jsonopensrfrequest_finish =>
- sub { $self->_jsonopensrfrequest_finish(@_); }
- );
-
- # XML support functions
- $self->insert(
- _OILS_FUNC_xmlhttprequest_send =>
- sub { $self->_xmlhttprequest_send(@_); }
- );
- $self->insert(
- _OILS_FUNC_xml_parse_string =>
- sub { $self->_parse_xml_string(@_); }
- );
-
- while ( my $e = shift @{$self->{_env}} ) {
- $self->insert( @$e{ qw/key value readonly/ } => 1 );
- }
-
- while ( my $e = shift @{$self->{_methods}} ) {
- $self->insert_method( @$e{ qw/key name meth/ } => 1 );
- }
-
- $self->load_lib($_) for @{$self->{libs}};
-
- return $self;
-}
-
-sub refresh_context {
- my $self = shift;
- $logger->debug("Refreshing JavaScript Context...");
- $self->context->destroy;
- $logger->debug("Context destroyed");
- $self->{_loaded} = {};
- $logger->debug("Loaded scripts removed");
- $self->init;
- $logger->debug("New Context initialized");
- return $self;
-}
-
-sub load {
- my( $self, $filename ) = @_;
- $self->{file} = $filename;
-}
-
-sub runs { shift()->{_runs} }
-
-sub reset_count {
- my $self = shift;
- my $count = shift;
-
- $self->{reset_count} = $count if ($count);
- return $self->{reset_count};
-}
-
-sub run {
- my $self = shift;
- my $file = shift();
-
- my $_real = 0;
- if(!$file) {
- $_real = 1;
- $file = $self->{file};
- }
-
- $self->refresh_context
- if ($self->reset_count && $self->runs > $self->reset_count);
-
- $self->{_runs}++ if ($_real);
-
- $file = $self->_find_file($file);
- $logger->debug("full script file path: $file");
-
- if( ! open(F, $file) ) {
- $logger->error("Error opening script file: $file");
- return 0;
- }
-
- my $js = $self->context;
-
- my $res = '';
- { local $/ = undef;
-
- $self->insert('environment.result' => {});
-
- my $content = <F>;
- #print ( "full script is [$content]" );
-
- my $s = time();
- if( !$js || !$content || !$js->eval($content) ) {
- $logger->error("$file Eval failed: $@");
- return 0;
- }
- $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
-
- if ($_real) {
- $self->insert('__' => {'OILS_RESULT' => ''});
- $js->eval("__.OILS_RESULT = js2JSON(environment.result);");
- $res = $self->retrieve('__.OILS_RESULT');
- }
- }
-
- close(F);
- $logger->debug( "script result is [$res]" );
- return OpenSRF::Utils::JSON->JSON2perl( $res );
-}
-
-sub remove_path {
- my( $self, $path ) = @_;
- if (ref($self)) {
- if ($self->{_path}{$path}) {
- $self->{_path}{$path} = 0;
- }
- return $self->{_path}{$path};
- } else {
- if ($_paths{$path}) {
- $_paths{$path} = 0;
- }
- return $_paths{$path};
- }
-}
-
-sub add_path {
- my( $self, $path ) = @_;
- if (ref($self)) {
- if (!$self->{_path}{$path}) {
- $self->{_path}{$path} = 1;
- }
- } else {
- if (!$_paths{$path}) {
- $_paths{$path} = 1;
- }
- }
- return $self;
-}
-
-sub _find_file {
- my $self = shift;
- my $file = shift;
- for my $p ( keys %{ $self->{_path} } ) {
- next unless ($self->{_path}{$p});
- my $full = join('/',$p,$file);
- return $full if (-e $full);
- }
-}
-
-sub load_lib {
- my( $self, $file ) = @_;
-
- my @paths = keys %{$self->{_path}};
- $logger->debug("script_runner: Loading lib file $file : paths=[@paths]");
-
- push @{ $self->{libs} }, $file
- if (! grep {$_ eq $file} @{ $self->{libs} });
-
- if (!$self->{_loaded}{$file}) {
- $self->run( $file );
- $self->{_loaded}{$file} = 1;
- }
- return $self->{_loaded}{$file};
-}
-
-sub _js_prop_name {
- my $name = shift;
- $name =~ s/^.*\.//o;
- return $name;
-}
-
-sub retrieve {
- my( $self, $key ) = @_;
- return $self->context->property_get($key);
-}
-
-sub insert_method {
- my( $self, $obj_key, $meth_name, $sub, $stop) = @_;
-
- push @{$self->{_methods}}, { key => $obj_key => name => $meth_name, meth => $sub } unless ($stop);
-
- my $obj = $self->context->object_by_path( $obj_key );
- $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
-}
-
-
-sub insert {
- my( $self, $key, $val, $RO, $stop ) = @_;
- return unless defined($key);
-
- push @{$self->{_env}}, { key => $key => value => $val, readonly => $RO } unless ($stop);
-
- if (ref($val) =~ /^Fieldmapper/o) {
- $self->insert_fm($key, $val, $RO);
- } elsif (ref($val) and $val =~ /ARRAY/o) {
- $self->insert_array($key, $val, $RO);
- } elsif (ref($val) and $val =~ /HASH/o) {
- $self->insert_hash($key, $val, $RO);
- } elsif (ref($val) and $val =~ /CODE/o) {
- $self->context->function_set( $key, $val );
- } elsif (!ref($val)) {
- if( defined($val) ) {
- $self->context->property_by_path(
- $key, $val,
- ( !$RO ? (sub { $val }, sub { my( $k, $v ) = @_; $val = $v; }) : () )
- );
- } else {
- $self->context->property_by_path($key, "");
- }
-
- } else {
- return 0;
- }
-
- return 1;
-}
-
-sub insert_fm {
-
- my( $self, $key, $fm, $RO ) = @_;
- my $ctx = $self->context;
- return undef unless ($ctx and $key and $fm);
- my $o = $ctx->object_by_path($key);
-
- for my $f ( $fm->properties ) {
- my $val = $fm->$f();
- if (ref $val) {
- $self->insert("$key.$f", $val);
- } else {
- $ctx->property_by_path(
- "$key.$f",
- $val,
- ( !$RO ?
- (sub {
- my $k = _js_prop_name(shift());
- $fm->$k();
- },
- sub {
- my $k = _js_prop_name(shift());
- $fm->ischanged(1);
- $fm->$k(@_);
- }) :
- ()
- )
- );
- }
- }
-}
-
-sub insert_hash {
-
- my( $self, $key, $hash, $RO ) = @_;
- my $ctx = $self->context;
- return undef unless ($ctx and $key and $hash);
- $ctx->object_by_path($key);
-
- for my $k ( keys %$hash ) {
- my $v = $hash->{$k};
- if (ref $v) {
- $self->insert("$key.$k", $v);
- } else {
- $ctx->property_by_path(
- "$key.$k", $v,
- ( !$RO ?
- (sub { $hash->{_js_prop_name(shift())} },
- sub {
- my( $hashkey, $val ) = @_;
- $hash->{_js_prop_name($hashkey)} = $val;
- }) :
- ()
- )
- );
- }
- }
-}
-
-my $__array_id = 0;
-sub insert_array {
-
- my( $self, $key, $array ) = @_;
- my $ctx = $self->context;
- return undef unless ($ctx and $key and $array);
-
- my $a = $ctx->array_by_path($key);
-
- my $ind = 0;
- for my $v ( @$array ) {
- if (ref $v) {
- my $tmp_index = $__array_id++;
- my $elobj = $ctx->object_by_path('__tmp_arr_el'.$tmp_index);
- $self->insert('__tmp_arr_el'.$tmp_index, $v);
- $ctx->array_set_element_as_object( $a, $ind, $elobj );
- } else {
- $ctx->array_set_element( $a, $ind, $v ) if defined($v);
- }
- $ind++;
- }
-}
-
-sub _xmlhttprequest_send {
- my $self = shift;
- my $id = shift;
- my $method = shift;
- my $url = shift;
- my $blocking = shift;
- my $headerlist = shift;
- my $data = shift;
-
- my $ctx = $self->context;
-
- # just so perl has access to it...
- $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
-
- my $headers = new HTTP::Headers;
- my @lines = split(/\n/so, $headerlist);
- for my $line (@lines) {
- if ($line =~ /^(.+?)|(.+)$/o) {
- $headers->header($1 => $2);
- }
- }
-
- my $ua = LWP::UserAgent->new;
- $ua->agent("OpenILS/0.1");
-
- my $req = HTTP::Request->new($method => $url => $headers => $data);
- my $res = $ua->request($req);
-
- if ($res->is_success) {
-
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
-
- }
-
-}
-
-our %_jsonopensrfrequest_cache = ();
-
-sub _jsonopensrfrequest_connect {
- my $self = shift;
- my $id = shift;
- my $service = shift;
-
- my $ctx = $self->context;
- $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
-
- my $ses = $_jsonopensrfrequest_cache{$id} ||
- do { $_jsonopensrfrequest_cache{$id} = OpenSRF::AppSession->create($service) };
-
- if($ses->connect) {
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.connected', 1);
- } else {
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.connected', 0);
- }
-}
-
-sub _jsonopensrfrequest_disconnect {
- my $self = shift;
- my $id = shift;
-
- my $ctx = $self->context;
- $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
-
- my $ses = $_jsonopensrfrequest_cache{$id};
- return unless $ses;
-
- $ses->disconnect;
-}
-
-sub _jsonopensrfrequest_finish {
- my $self = shift;
- my $id = shift;
-
- my $ctx = $self->context;
- $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
-
- my $ses = $_jsonopensrfrequest_cache{$id};
- return unless $ses;
-
- $ses->finish;
- delete $_jsonopensrfrequest_cache{$id};
-}
-
-sub _jsonopensrfrequest_send {
- my $self = shift;
- my $id = shift;
- my $service = shift;
- my $method = shift;
- my $blocking = shift;
- my $params = shift;
-
- my @p = @{ OpenSRF::Utils::JSON->JSON2perl($params) };
-
- my $ctx = $self->context;
-
- # just so perl has access to it...
- $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
-
- my $ses = $_jsonopensrfrequest_cache{$id} ||
- do { $_jsonopensrfrequest_cache{$id} = OpenSRF::AppSession->create($service) };
- my $req = $ses->request($method,@p);
-
- $req->wait_complete;
- if (!$req->failed) {
- my $res = $req->recv->content;
-
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.responseText', OpenSRF::Utils::JSON->perl2JSON($res));
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.readyState', 4);
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.statusText', 'OK');
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.status', '200');
-
- } else {
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.responseText', '');
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.readyState', 4);
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.statusText', $req->failed->status );
- $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.status', $req->failed->statusCode );
- }
-
- $req->finish;
-
-}
-
-sub _parse_xml_string {
- my $self = shift;
- my $string = shift;
- my $key = shift;
-
-
- my $doc;
- my $s = 0;
- try {
- $doc = XML::LibXML->new->parse_string( $string );
- $s = 1;
- } catch Error with {
- my $e = shift;
- warn "Could not parse document: $e\n";
- };
- return unless ($s);
-
- _JS_DOM($self->context, $key, $doc);
-}
-
-sub _JS_DOM {
- my $ctx = shift;
- my $key = shift;
- my $node = shift;
-
- if ($node->nodeType == 9) {
- $node = $node->documentElement;
-
- my $n = $node->nodeName;
- my $ns = $node->namespaceURI;
- $ns =~ s/'/\'/gso if ($ns);
- $ns = "'$ns'" if ($ns);
- $ns = 'null' unless ($ns);
- $n =~ s/'/\'/gso;
-
- #warn("$key = DOMImplementation().createDocument($ns,'$n');");
- $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
-
- $key = $key.'.documentElement';
- }
-
- for my $a ($node->attributes) {
- my $n = $a->nodeName;
- my $v = $a->value;
- $n =~ s/'/\'/gso;
- $v =~ s/'/\'/gso;
- #warn("$key.setAttribute('$n','$v');");
- $ctx->eval("$key.setAttribute('$n','$v');");
-
- }
-
- my $k = 0;
- for my $c ($node->childNodes) {
- if ($c->nodeType == 1) {
- my $n = $c->nodeName;
- my $ns = $node->namespaceURI;
-
- $n =~ s/'/\'/gso;
- $ns =~ s/'/\'/gso if ($ns);
- $ns = "'$ns'" if ($ns);
- $ns = 'null' unless ($ns);
-
- #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
- $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
- _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
-
- } elsif ($c->nodeType == 3) {
- my $n = $c->data;
- $n =~ s/'/\'/gso;
- #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
- #warn("path is $key.item($k);");
- $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
-
- } elsif ($c->nodeType == 4) {
- my $n = $c->data;
- $n =~ s/'/\'/gso;
- #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
- $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
-
- } elsif ($c->nodeType == 8) {
- my $n = $c->data;
- $n =~ s/'/\'/gso;
- #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
- $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
-
- } else {
- warn "ACK! I don't know how to handle node type ".$c->nodeType;
- }
-
-
- $k++;
- }
-
- return 1;
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::Utils::SpiderMonkey;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw(:logger);
-use OpenSRF::EX qw(:try);
-use OpenILS::Utils::ScriptRunner;
-use base 'OpenILS::Utils::ScriptRunner';
-use JavaScript::SpiderMonkey;
-use LWP::UserAgent;
-use XML::LibXML;
-use Time::HiRes qw/time/;
-use vars qw/%_paths/;
-
-sub new {
- my ( $class, %params ) = @_;
- $class = ref($class) || $class;
- $params{paths} ||= [];
-
- my $self = { file => $params{file}, libs => $params{libs}, _path => {%_paths} };
- bless( $self, $class );
-
- $self->add_path($_) for @{$params{paths}};
- return $self;
-}
-
-sub context {
- my( $self, $context ) = @_;
- $self->{ctx} = $context if $context;
- return $self->{ctx};
-}
-
-sub init {
- my $self = shift;
- my $js = JavaScript::SpiderMonkey->new();
- $js->init();
-
- $js->function_set(perl_print => sub { print "@_\n"; } );
- $js->function_set(perl_warn => sub { warn @_; } );
- $js->function_set(log_activity => sub { $logger->activity(@_); return 1;} );
- $js->function_set(log_error => sub { $logger->error(@_); return 1;} );
- $js->function_set(log_warn => sub { $logger->warn(@_); return 1;} );
- $js->function_set(log_info => sub { $logger->info(@_); return 1;} );
- $js->function_set(log_debug => sub { $logger->debug(@_); return 1;} );
- $js->function_set(log_internal => sub { $logger->internal(@_); return 1;} );
- $js->function_set(debug => sub { $logger->debug(@_); return 1;} );
- $js->function_set(alert => sub { $logger->warn(@_); return 1;} );
-
- $js->function_set(load_lib => sub { $self->load_lib(@_); });
-
- # XML support functions
- $js->function_set(
- _OILS_FUNC_xmlhttprequest_send => sub { $self->_xmlhttprequest_send(@_); });
- $js->function_set(
- _OILS_FUNC_xml_parse_string => sub { $self->_parse_xml_string(@_); });
-
- $self->context($js);
- $self->load_lib($_) for @{$self->{libs}};
-
- return $self;
-}
-
-
-sub load {
- my( $self, $filename ) = @_;
- $self->{file} = $filename;
-}
-
-sub run {
- my $self = shift;
- my $file = shift() || $self->{file};
- my $js = $self->context;
-
- $file = $self->_find_file($file);
-
- if( ! open(F, $file) ) {
- $logger->error("Error opening script file: $file");
- return 0;
- }
-
- { local $/ = undef;
- my $content = <F>;
- my $s = time();
- if( !$js || !$content || !$js->eval($content) ) {
- $logger->error("$file Eval failed: $@");
- return 0;
- }
- $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
- }
-
- close(F);
- return 1;
-}
-
-sub remove_path {
- my( $self, $path ) = @_;
- if (ref($self)) {
- if ($self->{_path}{$path}) {
- $self->{_path}{$path} = 0;
- }
- return $self->{_path}{$path};
- } else {
- if ($_paths{$path}) {
- $_paths{$path} = 0;
- }
- return $_paths{$path};
- }
-}
-
-sub add_path {
- my( $self, $path ) = @_;
- if (ref($self)) {
- if (!$self->{_path}{$path}) {
- $self->{_path}{$path} = 1;
- }
- } else {
- if (!$_paths{$path}) {
- $_paths{$path} = 1;
- }
- }
- return $self;
-}
-
-sub _find_file {
- my $self = shift;
- my $file = shift;
- for my $p ( keys %{ $self->{_path} } ) {
- next unless ($self->{_path}{$p});
- my $full = join('/',$p,$file);
- return $full if (-e $full);
- }
-}
-
-sub load_lib {
- my( $self, $file ) = @_;
- if (!$self->{_loaded}{$file} && $self->run( $file )) {
- $self->{_loaded}{$file} = 1;
- }
- return $self->{_loaded}{$file};
-}
-
-sub _js_prop_name {
- my $name = shift;
- $name =~ s/^.*\.//o;
- return $name;
-}
-
-sub retrieve {
- my( $self, $key ) = @_;
- return $self->context->property_get($key);
-}
-
-sub insert_method {
- my( $self, $obj_key, $meth_name, $sub ) = @_;
- my $obj = $self->context->object_by_path( $obj_key );
- $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
-}
-
-
-sub insert {
- my( $self, $key, $val ) = @_;
- return unless defined($key);
-
- if (ref($val) =~ /^Fieldmapper/o) {
- $self->insert_fm($key, $val);
- } elsif (ref($val) and $val =~ /ARRAY/o) {
- $self->insert_array($key, $val);
- } elsif (ref($val) and $val =~ /HASH/o) {
- $self->insert_hash($key, $val);
- } elsif (ref($val) and $val =~ /CODE/o) {
- $self->context->function_set( $key, $val );
- } elsif (!ref($val)) {
- if( defined($val) ) {
- $self->context->property_by_path(
- $key, $val,
- sub { $val },
- sub { my( $k, $v ) = @_; $val = $v; }
- );
- } else {
- $self->context->property_by_path($key);
- }
-
- } else {
- return 0;
- }
-
- return 1;
-}
-
-sub insert_fm {
-
- my( $self, $key, $fm ) = @_;
- my $ctx = $self->context;
- return undef unless ($ctx and $key and $fm);
- my $o = $ctx->object_by_path($key);
-
- for my $f ( $fm->properties ) {
- my $val = $fm->$f();
- if (ref $val) {
- $self->insert("$key.$f", $val);
- } else {
- $ctx->property_by_path(
- "$key.$f",
- $val,
- sub {
- my $k = _js_prop_name(shift());
- $fm->$k();
- },
-
- sub {
- my $k = _js_prop_name(shift());
- $fm->ischanged(1);
- $fm->$k(@_);
- }
- );
- }
- }
-}
-
-sub insert_hash {
-
- my( $self, $key, $hash ) = @_;
- my $ctx = $self->context;
- return undef unless ($ctx and $key and $hash);
- $ctx->object_by_path($key);
-
- for my $k ( keys %$hash ) {
- my $v = $hash->{$k};
- if (ref $v) {
- $self->insert("$key.$k", $v);
- } else {
- $ctx->property_by_path(
- "$key.$k", $v,
- sub { $hash->{_js_prop_name(shift())} },
- sub {
- my( $key, $val ) = @_;
- $hash->{_js_prop_name($key)} = $val; }
- );
- }
- }
-}
-
-my $__array_id = 0;
-sub insert_array {
-
- my( $self, $key, $array ) = @_;
- my $ctx = $self->context;
- return undef unless ($ctx and $key and $array);
-
- my $a = $ctx->array_by_path($key);
-
- my $ind = 0;
- for my $v ( @$array ) {
- if (ref $v) {
- my $elobj = $ctx->object_by_path('__tmp_arr_el'.$__array_id);
- $self->insert('__tmp_arr_el'.$__array_id, $v);
- $ctx->array_set_element_as_object( $a, $ind, $elobj );
- $__array_id++;
- } else {
- $ctx->array_set_element( $a, $ind, $v ) if defined($v);
- }
- $ind++;
- }
-}
-
-sub _xmlhttprequest_send {
- my $self = shift;
- my $id = shift;
- my $method = shift;
- my $url = shift;
- my $blocking = shift;
- my $headerlist = shift;
- my $data = shift;
-
- my $ctx = $self->context;
-
- # just so perl has access to it...
- $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
-
- my $headers = new HTTP::Headers;
- my @lines = split(/\n/so, $headerlist);
- for my $line (@lines) {
- if ($line =~ /^(.+?)|(.+)$/o) {
- $headers->header($1 => $2);
- }
- }
-
- my $ua = LWP::UserAgent->new;
- $ua->agent("OpenILS/0.1");
-
- my $req = HTTP::Request->new($method => $url => $headers => $data);
- my $res = $ua->request($req);
-
- if ($res->is_success) {
-
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
- $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
-
- }
-
-}
-
-sub _parse_xml_string {
- my $self = shift;
- my $string = shift;
- my $key = shift;
-
-
- my $doc;
- my $s = 0;
- try {
- $doc = XML::LibXML->new->parse_string( $string );
- $s = 1;
- } catch Error with {
- my $e = shift;
- warn "Could not parse document: $e\n";
- };
- return unless ($s);
-
- _JS_DOM($self->context, $key, $doc);
-}
-
-sub _JS_DOM {
- my $ctx = shift;
- my $key = shift;
- my $node = shift;
-
- if ($node->nodeType == 9) {
- $node = $node->documentElement;
-
- my $n = $node->nodeName;
- my $ns = $node->namespaceURI;
- $ns =~ s/'/\'/gso if ($ns);
- $ns = "'$ns'" if ($ns);
- $ns = 'null' unless ($ns);
- $n =~ s/'/\'/gso;
-
- #warn("$key = DOMImplementation().createDocument($ns,'$n');");
- $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
-
- $key = $key.'.documentElement';
- }
-
- for my $a ($node->attributes) {
- my $n = $a->nodeName;
- my $v = $a->value;
- $n =~ s/'/\'/gso;
- $v =~ s/'/\'/gso;
- #warn("$key.setAttribute('$n','$v');");
- $ctx->eval("$key.setAttribute('$n','$v');");
-
- }
-
- my $k = 0;
- for my $c ($node->childNodes) {
- if ($c->nodeType == 1) {
- my $n = $c->nodeName;
- my $ns = $node->namespaceURI;
-
- $n =~ s/'/\'/gso;
- $ns =~ s/'/\'/gso if ($ns);
- $ns = "'$ns'" if ($ns);
- $ns = 'null' unless ($ns);
-
- #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
- $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
- _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
-
- } elsif ($c->nodeType == 3) {
- my $n = $c->data;
- $n =~ s/'/\'/gso;
- #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
- #warn("path is $key.item($k);");
- $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
-
- } elsif ($c->nodeType == 4) {
- my $n = $c->data;
- $n =~ s/'/\'/gso;
- #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
- $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
-
- } elsif ($c->nodeType == 8) {
- my $n = $c->data;
- $n =~ s/'/\'/gso;
- #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
- $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
-
- } else {
- warn "ACK! I don't know how to handle node type ".$c->nodeType;
- }
-
-
- $k++;
- }
-
- return 1;
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::Utils::ZClient;
-use UNIVERSAL::require;
-
-sub DESTROY {};
-
-use overload 'bool' => sub { return $_[0]->{connection} ? 1 : 0 };
-
-sub EVENT_NONE { 0 }
-sub EVENT_CONNECT { 1 }
-sub EVENT_SEND_DATA { 2 }
-sub EVENT_RECV_DATA { 3 }
-sub EVENT_TIMEOUT { 4 }
-sub EVENT_UNKNOWN { 5 }
-sub EVENT_SEND_APDU { 6 }
-sub EVENT_RECV_APDU { 7 }
-sub EVENT_RECV_RECORD { 8 }
-sub EVENT_RECV_SEARCH { 9 }
-sub EVENT_END { 10 }
-
-our $conn_class = 'ZOOM::Connection';
-our $imp_class = 'ZOOM';
-our $AUTOLOAD;
-
-# Detect the installed z client, prefering ZOOM.
-if (!$imp_class->use()) {
-
- $imp_class = 'Net::Z3950'; # Try Net::Z3950
- if ($imp_class->use()) {
-
- # Tell 'new' how to build the connection
- $conn_class = 'Net::Z3950::Connection';
-
- } else {
- die "Cannot load a z39.50 client implementation! Please install either ZOOM or Net::Z3950.\n";
- }
-}
-
-# 'new' is called thusly:
-# my $conn = OpenILS::Utils::ZClient->new( $host, $port, databaseName => $db, user => $username )
-
-sub new {
- my $class = shift();
- my @args = @_;
-
- if ($class ne __PACKAGE__) { # NOT called OO-ishly
- # put the first param back if called like OpenILS::Utils::ZClient::new()
- unshift @args, $class;
- }
-
- return bless { connection => $conn_class->new(@_) } => __PACKAGE__;
-}
-
-sub search {
- my $self = shift;
- my $r = $imp_class eq 'Net::Z3950' ?
- $self->{connection}->search( @_ ) :
- $self->{connection}->search_pqf( @_ );
-
- return OpenILS::Utils::ZClient::ResultSet->new( $r );
-}
-
-sub event {
- my $list = shift;
- if ($imp_class eq 'Net::Z3950') {
- if (defined $$list[0]{_async_index}) {
- return 0 if ($$list[0]{_async_index} == @$list);
- return ++$$list[0]{_async_index};
- } else {
- return $$list[0]{_async_index} = 1;
- }
- }
-
- return ZOOM::event([map { ($_->{connection}) } @$list]);
-}
-
-*{__PACKAGE__ . '::search_pqf'} = \&search;
-
-sub AUTOLOAD {
- my $self = shift;
-
- my $method = $AUTOLOAD;
- $method =~ s/.*://; # strip fully-qualified portion
-
- return $self->{connection}->$method( @_ );
-}
-
-#-------------------------------------------------------------------------------
-package OpenILS::Utils::ZClient::ResultSet;
-
-sub DESTROY {};
-our $AUTOLOAD;
-
-sub new {
- my $class = shift;
- my @args = @_;
-
- if ($class ne __PACKAGE__) { # NOT called OO-ishly
- # put the first param back if called like OpenILS::Utils::ZClient::ResultSet::new()
- unshift @args, $class;
- }
-
-
- return bless { result => $args[0] } => __PACKAGE__;
-}
-
-sub record {
- my $self = shift;
- my $offset = shift;
- my $r = $imp_class eq 'Net::Z3950' ?
- $self->{result}->record( ++$offset ) :
- $self->{result}->record( $offset );
-
- return OpenILS::Utils::ZClient::Record->new( $r );
-}
-
-sub last_event {
- my $self = shift;
- return OpenILS::Utils::ZClient::EVENT_END() if ($imp_class eq 'Net::Z3950');
- $self->{result}->last_event();
-}
-
-sub AUTOLOAD {
- my $self = shift;
-
- my $method = $AUTOLOAD;
- $method =~ s/.*://; # strip fully-qualified portion
-
- return $self->{result}->$method( @_ );
-}
-
-#-------------------------------------------------------------------------------
-package OpenILS::Utils::ZClient::Record;
-
-sub DESTROY {};
-our $AUTOLOAD;
-
-sub new {
- my $class = shift;
- my @args = @_;
-
- if ($class ne __PACKAGE__) { # NOT called OO-ishly
- # put the first param back if called like OpenILS::Utils::ZClient::ResultSet::new()
- unshift @args, $class;
- }
-
-
- return bless { record => shift() } => __PACKAGE__;
-}
-
-sub rawdata {
- my $self = shift;
- return $OpenILS::Utils::ZClient::imp_class eq 'Net::Z3950' ?
- $self->{record}->rawdata( @_ ) :
- $self->{record}->raw( @_ );
-}
-
-*{__PACKAGE__ . '::raw'} = \&rawdata;
-
-sub AUTOLOAD {
- my $self = shift;
-
- my $method = $AUTOLOAD;
- $method =~ s/.*://; # strip fully-qualified portion
-
- return $self->{record}->$method( @_ );
-}
-
-1;
-
+++ /dev/null
-package OpenILS::WWW::AddedContent;
-use strict; use warnings;
-
-use lib qw(/usr/lib/perl5/Bundle/);
-
-use CGI;
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use Data::Dumper;
-use UNIVERSAL::require;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Cache;
-use OpenSRF::System;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use LWP::UserAgent;
-use MIME::Base64;
-
-my $AC = __PACKAGE__;
-
-
-# set the bootstrap config when this module is loaded
-my $bs_config;
-
-sub import {
- my $self = shift;
- $bs_config = shift;
-}
-
-
-my $handler; # added content handler class handle
-my $cache; # memcache handle
-my $net_timeout; # max seconds to wait for a response from the added content vendor
-my $max_errors; # max consecutive lookup failures before added content is temporarily disabled
-my $error_countdown; # current consecutive errors countdown
-
-# number of seconds to wait before next lookup
-# is attempted after lookups have been disabled
-my $error_retry_timeout;
-
-
-sub child_init {
-
- OpenSRF::System->bootstrap_client( config_file => $bs_config );
- $cache = OpenSRF::Utils::Cache->new;
-
- my $sclient = OpenSRF::Utils::SettingsClient->new();
- my $ac_data = $sclient->config_value("added_content");
-
- return unless $ac_data;
- my $ac_handler = $ac_data->{module};
- return unless $ac_handler;
-
- $net_timeout = $ac_data->{timeout} || 1;
- $error_countdown = $max_errors = $ac_data->{max_errors} || 10;
- $error_retry_timeout = $ac_data->{retry_timeout} || 600;
-
- $logger->debug("Attempting to load Added Content handler: $ac_handler");
-
- $ac_handler->use;
-
- if($@) {
- $logger->error("Unable to load Added Content handler [$ac_handler]: $@");
- return;
- }
-
- $handler = $ac_handler->new($ac_data);
- $logger->debug("added content loaded handler: $handler");
-}
-
-
-sub handler {
-
- my $r = shift;
- return Apache2::Const::DECLINED if (-e $r->filename);
-
- my $cgi = CGI->new;
- my $path = $r->path_info;
- my $res;
-
- my( undef, $type, $format, $key ) = split(/\//, $r->path_info);
-
- child_init() unless $handler;
-
- return Apache2::Const::NOT_FOUND unless $handler and $type and $format and $key;
-
- my $err;
- my $data;
- my $method = "${type}_${format}";
-
- return Apache2::Const::NOT_FOUND unless $handler->can($method);
- return $res if defined($res = $AC->serve_from_cache($type, $format, $key));
- return Apache2::Const::NOT_FOUND unless $AC->lookups_enabled;
-
- try {
- $data = $handler->$method($key);
- } catch Error with {
- $err = shift;
- decr_error_countdown();
- $logger->debug("added content handler failed: $method($key) => $err");
- };
-
- return Apache2::Const::NOT_FOUND if $err;
-
- if(!$data) {
- # if the AC lookup found no corresponding data, cache that information
- $logger->debug("added content handler returned no results $method($key)") unless $data;
- $AC->cache_result($type, $format, $key, {nocontent=>1});
- return Apache2::Const::NOT_FOUND;
- }
-
- $AC->print_content($data);
- $AC->cache_result($type, $format, $key, $data);
-
- reset_error_countdown();
- return Apache2::Const::OK;
-}
-
-sub print_content {
- my($class, $data, $from_cache) = @_;
- return Apache2::Const::NOT_FOUND if $data->{nocontent};
-
- my $ct = $data->{content_type};
- my $content = $data->{content};
- print "Content-type: $ct\n\n";
-
- if($data->{binary}) {
- binmode STDOUT;
- # if it hasn't been cached yet, it's still in binary form
- print( ($from_cache) ? decode_base64($content) : $content );
- } else {
- print $content;
- }
-
-
- return Apache2::Const::OK;
-}
-
-
-
-
-# returns an HTPP::Response object
-sub get_url {
- my( $self, $url ) = @_;
-
- $logger->info("added content getting [timeout=$net_timeout, errors_remaining=$error_countdown] URL = $url");
- my $agent = LWP::UserAgent->new(timeout => $net_timeout);
-
- my $res = $agent->get($url);
- $logger->info("added content request returned with code " . $res->code);
- die "added content request failed: " . $res->status_line ."\n" unless $res->is_success;
-
- return $res;
-}
-
-sub lookups_enabled {
- if( $cache->get_cache('ac.no_lookup') ) {
- $logger->info("added content lookup disabled");
- return undef;
- }
- return 1;
-}
-
-sub disable_lookups {
- $cache->put_cache('ac.no_lookup', 1, $error_retry_timeout);
-}
-
-sub decr_error_countdown {
- $error_countdown--;
- if($error_countdown < 1) {
- $logger->warn("added content error count exhausted. Disabling lookups for $error_retry_timeout seconds");
- $AC->disable_lookups;
- }
-}
-
-sub reset_error_countdown {
- $error_countdown = $max_errors;
-}
-
-sub cache_result {
- my($class, $type, $format, $key, $data) = @_;
- $logger->debug("caching $type/$format/$key");
- $data->{content} = encode_base64($data->{content}) if $data->{binary};
- return $cache->put_cache("ac.$type.$format.$key", $data);
-}
-
-sub serve_from_cache {
- my($class, $type, $format, $key) = @_;
- my $data = $cache->get_cache("ac.$type.$format.$key");
- return undef unless $data;
- $logger->debug("serving $type/$format/$key from cache");
- return $class->print_content($data, 1);
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::AddedContent::Amazon;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils::SettingsParser;
-use OpenILS::WWW::AddedContent;
-use OpenSRF::Utils::JSON;
-use OpenSRF::EX qw/:try/;
-use XML::LibXML;
-
-my $AC = 'OpenILS::WWW::AddedContent';
-
-sub new {
- my( $class, $args ) = @_;
- $class = ref $class || $class;
- return bless($args, $class);
-}
-
-sub base_url {
- my $self = shift;
- return $self->{base_url};
-}
-
-sub userid {
- my $self = shift;
- return $self->{userid};
-}
-
-
-# --------------------------------------------------------------------------
-sub jacket_small {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_response('_SCMZZZZZZZ_.jpg', $key));
-}
-
-sub jacket_medium {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_response('_SCMZZZZZZZ_.jpg', $key));
-
-}
-sub jacket_large {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_response('_SCZZZZZZZ_.jpg', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub send_img {
- my($self, $response) = @_;
- return {
- content_type => $response->header('Content-type'),
- content => $response->content,
- binary => 1
- };
-}
-
-# returns the raw content returned from the URL fetch
-sub fetch_content {
- my( $self, $page, $key ) = @_;
- return $self->fetch_response($page, $key)->content;
-}
-
-# returns the HTTP response object from the URL fetch
-sub fetch_response {
- my( $self, $page, $key ) = @_;
- my $uname = $self->userid;
- my $url = $self->base_url . "$key.01.$page";
- return $AC->get_url($url);
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::AddedContent::ContentCafe;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils::SettingsParser;
-use OpenSRF::Utils::JSON;
-use OpenSRF::EX qw/:try/;
-use OpenILS::WWW::AddedContent;
-use XML::LibXML;
-use MIME::Base64;
-
-my $AC = 'OpenILS::WWW::AddedContent';
-
-my $base_url = 'http://contentcafe2.btol.com/ContentCafe/ContentCafe.asmx/Single';
-my $cover_base_url = 'http://contentcafe2.btol.com/ContentCafe/Jacket.aspx';
-
-sub new {
- my( $class, $args ) = @_;
- $class = ref $class || $class;
- return bless($args, $class);
-}
-
-sub userid {
- my $self = shift;
- return $self->{ContentCafe}->{userid};
-}
-
-sub password {
- my $self = shift;
- return $self->{ContentCafe}->{password};
-}
-
-sub return_behavior_on_no_jacket_image {
- my $self = shift;
- return $self->{ContentCafe}->{return_behavior_on_no_jacket_image};
-}
-
-# --------------------------------------------------------------------------
-sub jacket_small {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_cover_response('S', $key));
-}
-
-sub jacket_medium {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_cover_response('M', $key));
-
-}
-sub jacket_large {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_cover_response('L', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub toc_html {
- my( $self, $key ) = @_;
- my $xml = $self->fetch_content('TocDetail', $key);
- my $doc = XML::LibXML->new->parse_string($xml);
- $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
- my $html = '';
- my @nodes = $doc->findnodes('//cc:Toc');
- return 0 if (scalar(@nodes) < 1);
- foreach my $node ( @nodes ) {
- $html .= $node->textContent . '</P></P>';
- }
- return $self->send_html($html);
-}
-
-sub toc_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('TocDetail', $key));
-}
-
-sub toc_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('TocDetail', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub anotes_html {
- my( $self, $key ) = @_;
- my $xml = $self->fetch_content('BiographyDetail', $key);
- my $doc = XML::LibXML->new->parse_string($xml);
- $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
- my $html = '';
- my @nodes = $doc->findnodes('//cc:Biography');
- return 0 if (scalar(@nodes) < 1);
- foreach my $node ( @nodes ) {
- $html .= '<P class="biography">' . $node->textContent . '</P>';
- }
- return $self->send_html($html);
-}
-
-sub anotes_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('BiographyDetail', $key));
-}
-
-sub anotes_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('BiographyDetail', $key));
-}
-
-
-# --------------------------------------------------------------------------
-
-sub excerpt_html {
- my( $self, $key ) = @_;
- my $xml = $self->fetch_content('ExcerptDetail', $key);
- my $doc = XML::LibXML->new->parse_string($xml);
- $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
- my $html = '';
- my @nodes = $doc->findnodes('//cc:Excerpt');
- return 0 if (scalar(@nodes) < 1);
- foreach my $node ( @nodes ) {
- $html .= $node->textContent;
- }
- return $self->send_html($html);
-}
-
-sub excerpt_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('ExcerptDetail', $key));
-}
-
-sub excerpt_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('ExcerptDetail', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub reviews_html {
- my( $self, $key ) = @_;
- my $xml = $self->fetch_content('ReviewDetail', $key);
- my $doc = XML::LibXML->new->parse_string($xml);
- $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
- my $html = '<ul>';
- my @nodes = $doc->findnodes('//cc:ReviewItem');
- return 0 if (scalar(@nodes) < 1);
- foreach my $node ( @nodes ) {
- my @s_nodes = $node->findnodes('./cc:Supplier');
- my @p_nodes = $node->findnodes('./cc:Publication');
- my @i_nodes = $node->findnodes('./cc:Issue');
- my @r_nodes = $node->findnodes('./cc:Review');
- $html .= '<li><b>' . (scalar(@p_nodes) ? $p_nodes[0]->textContent : '') . '</b>';
- if (scalar(@i_nodes) && scalar(@p_nodes)) { $html .= ' : '; }
- $html .= (scalar(@i_nodes) ? $i_nodes[0]->textContent : '') . '<br/>';
- $html .= (scalar(@r_nodes) ? $r_nodes[0]->textContent : '') . '</li>';
- }
- $html .= '</ul>';
- return $self->send_html($html);
-}
-
-sub reviews_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('ReviewDetail', $key));
-}
-
-sub reviews_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('ReviewDetail', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub summary_html {
- my( $self, $key ) = @_;
- my $xml = $self->fetch_content('AnnotationDetail', $key);
- my $doc = XML::LibXML->new->parse_string($xml);
- $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
- my $html = '<ul>';
- my @nodes = $doc->findnodes('//cc:AnnotationItem');
- return 0 if (scalar(@nodes) < 1);
- foreach my $node ( @nodes ) {
- my @s_nodes = $node->findnodes('./cc:Supplier');
- my @a_nodes = $node->findnodes('./cc:Annotation');
- $html .= '<li><b>' . (scalar(@s_nodes) ? $s_nodes[0]->textContent : '') . '</b><br/>';
- $html .= (scalar(@a_nodes) ? $a_nodes[0]->textContent : '') . '</li>';
- }
- $html .= '</ul>';
- return $self->send_html($html);
-}
-
-sub summary_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('AnnotationDetail', $key));
-}
-
-sub summary_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('AnnotationDetail', $key));
-}
-
-
-# --------------------------------------------------------------------------
-
-
-sub data_exists {
- my( $self, $data ) = @_;
- return 0 if $data =~ m/<title>error<\/title>/iog;
- return 1;
-}
-
-
-sub send_json {
- my( $self, $xml ) = @_;
- return 0 unless $self->data_exists($xml);
- my $doc;
-
- try {
- $doc = XML::LibXML->new->parse_string($xml);
- } catch Error with {
- my $err = shift;
- $logger->error("added content XML parser error: $err\n\n$xml");
- $doc = undef;
- };
-
- return 0 unless $doc;
- my $perl = OpenSRF::Utils::SettingsParser::XML2perl($doc->documentElement);
- my $json = OpenSRF::Utils::JSON->perl2JSON($perl);
- return { content_type => 'text/plain', content => $json };
-}
-
-sub send_xml {
- my( $self, $xml ) = @_;
- return 0 unless $self->data_exists($xml);
- return { content_type => 'application/xml', content => $xml };
-}
-
-sub send_html {
- my( $self, $content ) = @_;
- return 0 unless $self->data_exists($content);
-
- # Hide anything that might contain a link since it will be broken
- my $HTML = <<" HTML";
- <div>
- <style type='text/css'>
- div.ac input, div.ac a[href],div.ac img, div.ac button { display: none; visibility: hidden }
- </style>
- <div class='ac'>
- $content
- </div>
- </div>
- HTML
-
- return { content_type => 'text/html', content => $HTML };
-}
-
-sub send_img {
- my($self, $response) = @_;
- return {
- content_type => $response->header('Content-type'),
- content => $response->content,
- binary => 1
- };
-}
-
-# returns the raw content returned from the URL fetch
-sub fetch_content {
- my( $self, $contentType, $key ) = @_;
- return $self->fetch_response($contentType, $key)->content;
-}
-
-# returns the HTTP response object from the URL fetch
-sub fetch_response {
- my( $self, $contentType, $key ) = @_;
- my $userid = $self->userid;
- my $password = $self->password;
- my $url = $base_url . "?UserID=$userid&Password=$password&Key=$key&Content=$contentType";
- return $AC->get_url($url);
-}
-
-# returns the HTTP response object from the URL fetch
-sub fetch_cover_response {
- my( $self, $size, $key ) = @_;
- my $userid = $self->userid;
- my $password = $self->password;
- my $return = $self->return_behavior_on_no_jacket_image;
- my $url = $cover_base_url . "?UserID=$userid&Password=$password&Return=$return&Type=$size&Value=$key";
- return $AC->get_url($url);
-}
-
-
-1;
+++ /dev/null
-# ---------------------------------------------------------------
-# Copyright (C) 2009 David Christensen <david.a.christensen@gmail.com>
-# Copyright (C) 2009 Dan Scott <dscott@laurentian.ca>
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-# ---------------------------------------------------------------
-
-package OpenILS::WWW::AddedContent::OpenLibrary;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils::SettingsParser;
-use OpenILS::WWW::AddedContent;
-use OpenSRF::Utils::JSON;
-use OpenSRF::EX qw/:try/;
-use Data::Dumper;
-
-# Edit the <added_content> section of /openils/conf/opensrf.xml
-# Change <module> to:
-# <module>OpenILS::WWW::AddedContent::OpenLibrary</module>
-
-my $AC = 'OpenILS::WWW::AddedContent';
-
-# These URLs are always the same for OpenLibrary, so there's no advantage to
-# pulling from opensrf.xml; we hardcode them here
-my $base_url = 'http://openlibrary.org/api/books?details=true&bibkeys=ISBN:';
-my $cover_base_url = 'http://covers.openlibrary.org/b/isbn/';
-
-sub new {
- my( $class, $args ) = @_;
- $class = ref $class || $class;
- return bless($args, $class);
-}
-
-# --------------------------------------------------------------------------
-sub jacket_small {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_cover_response('-S.jpg', $key));
-}
-
-sub jacket_medium {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_cover_response('-M.jpg', $key));
-
-}
-sub jacket_large {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_cover_response('-L.jpg', $key));
-}
-
-# --------------------------------------------------------------------------
-
-=head1
-
-OpenLibrary returns a JSON hash of zero or more book responses matching our
-request. Each response may contain a table of contents within the details
-section of the response.
-
-For now, we check only the first response in the hash for a table of
-contents, and if we find a table of contents, we transform it to a simple
-HTML table.
-
-=cut
-
-sub toc_html {
- my( $self, $key ) = @_;
- my $book_details_json = $self->fetch_response($key)->content();
-
-
- # Trim the "var _OlBookInfo = " declaration that makes this
- # invalid JSON
- $book_details_json =~ s/^.+?({.*?});$/$1/s;
-
- $logger->debug("$key: " . $book_details_json);
-
- my $toc_html;
-
- my $book_details = OpenSRF::Utils::JSON->JSON2perl($book_details_json);
- my $book_key = (keys %$book_details)[0];
-
- # We didn't find a matching book; short-circuit our response
- if (!$book_key) {
- $logger->debug("$key: no found book");
- return 0;
- }
-
- my $toc_json = $book_details->{$book_key}->{details}->{table_of_contents};
-
- # No table of contents is available for this book; short-circuit
- if (!$toc_json or !scalar(@$toc_json)) {
- $logger->debug("$key: no TOC");
- return 0;
- }
-
- # Build a basic HTML table containing the section number, section title,
- # and page number. Some rows may not contain section numbers, we should
- # protect against empty page numbers too.
- foreach my $chapter (@$toc_json) {
- my $label = $chapter->{label};
- if ($label) {
- $label .= '. ';
- }
- my $title = $chapter->{title} || '';
- my $page_number = $chapter->{pagenum} || '';
-
- $toc_html .= '<tr>' .
- "<td style='text-align: right;'>$label</td>" .
- "<td style='text-align: left; padding-right: 2em;'>$title</td>" .
- "<td style='text-align: right;'>$page_number</td>" .
- "</tr>\n";
- }
-
- $logger->debug("$key: $toc_html");
- $self->send_html("<table>$toc_html</table>");
-}
-
-sub toc_json {
- my( $self, $key ) = @_;
- my $toc = $self->send_json(
- $self->fetch_response($key)
- );
-}
-
-sub send_img {
- my($self, $response) = @_;
- return {
- content_type => $response->header('Content-type'),
- content => $response->content,
- binary => 1
- };
-}
-
-sub send_json {
- my( $self, $content ) = @_;
- return 0 unless $content;
-
- return { content_type => 'text/plain', content => $content };
-}
-
-sub send_html {
- my( $self, $content ) = @_;
- return 0 unless $content;
-
- # Hide anything that might contain a link since it will be broken
- my $HTML = <<" HTML";
- <div>
- <style type='text/css'>
- div.ac input, div.ac a[href],div.ac img, div.ac button { display: none; visibility: hidden }
- </style>
- <div class='ac'>
- $content
- </div>
- </div>
- HTML
-
- return { content_type => 'text/html', content => $HTML };
-}
-
-# returns the HTTP response object from the URL fetch
-sub fetch_response {
- my( $self, $key ) = @_;
- my $url = $base_url . "$key";
- my $response = $AC->get_url($url);
- return $response;
-}
-
-# returns the HTTP response object from the URL fetch
-sub fetch_cover_response {
- my( $self, $size, $key ) = @_;
- my $url = $cover_base_url . "$key$size";
- return $AC->get_url($url);
-}
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::AddedContent::Syndetic;
-use strict; use warnings;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils::SettingsParser;
-use OpenSRF::Utils::JSON;
-use OpenSRF::EX qw/:try/;
-use OpenILS::WWW::AddedContent;
-use XML::LibXML;
-use MIME::Base64;
-
-my $AC = 'OpenILS::WWW::AddedContent';
-
-
-sub new {
- my( $class, $args ) = @_;
- $class = ref $class || $class;
- return bless($args, $class);
-}
-
-sub base_url {
- my $self = shift;
- return $self->{base_url};
-}
-
-sub userid {
- my $self = shift;
- return $self->{userid};
-}
-
-
-# --------------------------------------------------------------------------
-sub jacket_small {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_response('sc.gif', $key, 1));
-}
-
-sub jacket_medium {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_response('mc.gif', $key, 1));
-
-}
-sub jacket_large {
- my( $self, $key ) = @_;
- return $self->send_img(
- $self->fetch_response('lc.gif', $key, 1));
-}
-
-# --------------------------------------------------------------------------
-
-sub toc_html {
- my( $self, $key ) = @_;
- return $self->send_html(
- $self->fetch_content('toc.html', $key));
-}
-
-sub toc_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('toc.xml', $key));
-}
-
-sub toc_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('toc.xml', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub anotes_html {
- my( $self, $key ) = @_;
- return $self->send_html(
- $self->fetch_content('anotes.html', $key));
-}
-
-sub anotes_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('anotes.xml', $key));
-}
-
-sub anotes_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('anotes.xml', $key));
-}
-
-
-# --------------------------------------------------------------------------
-
-sub excerpt_html {
- my( $self, $key ) = @_;
- return $self->send_html(
- $self->fetch_content('dbchapter.html', $key));
-}
-
-sub excerpt_xml {
- my( $self, $key ) = @_;
- return $self->send_xml(
- $self->fetch_content('dbchapter.xml', $key));
-}
-
-sub excerpt_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('dbchapter.xml', $key));
-}
-
-# --------------------------------------------------------------------------
-
-sub reviews_html {
- my( $self, $key ) = @_;
-
- my %reviews;
-
- $reviews{ljreview} = $self->fetch_content('ljreview.html', $key);
- $reviews{pwreview} = $self->fetch_content('pwreview.html', $key);
- $reviews{slreview} = $self->fetch_content('slreview.html', $key);
- $reviews{chreview} = $self->fetch_content('chreview.html', $key);
- $reviews{blreview} = $self->fetch_content('blreview.html', $key);
- $reviews{hbreview} = $self->fetch_content('hbreview.html', $key);
- $reviews{kirkreview} = $self->fetch_content('kirkreview.html', $key);
-
- for(keys %reviews) {
- if( ! $self->data_exists($reviews{$_}) ) {
- delete $reviews{$_};
- next;
- }
- $reviews{$_} =~ s/<!.*?>//og; # Strip any doctype declarations
- }
-
- return 0 if scalar(keys %reviews) == 0;
-
- #my $html = "<div>";
- my $html;
- $html .= $reviews{$_} for keys %reviews;
- #$html .= "</div>";
-
- return $self->send_html($html);
-}
-
-# we have to aggregate the reviews
-sub reviews_xml {
- my( $self, $key ) = @_;
- my %reviews;
-
- $reviews{ljreview} = $self->fetch_content('ljreview.xml', $key);
- $reviews{pwreview} = $self->fetch_content('pwreview.xml', $key);
- $reviews{slreview} = $self->fetch_content('slreview.xml', $key);
- $reviews{chreview} = $self->fetch_content('chreview.xml', $key);
- $reviews{blreview} = $self->fetch_content('blreview.xml', $key);
- $reviews{hbreview} = $self->fetch_content('hbreview.xml', $key);
- $reviews{kirkreview} = $self->fetch_content('kirkreview.xml', $key);
-
- for(keys %reviews) {
- if( ! $self->data_exists($reviews{$_}) ) {
- delete $reviews{$_};
- next;
- }
- # Strip the xml and doctype declarations
- $reviews{$_} =~ s/<\?xml.*?>//og;
- $reviews{$_} =~ s/<!.*?>//og;
- }
-
- return 0 if scalar(keys %reviews) == 0;
-
- my $xml = "<reviews>";
- $xml .= $reviews{$_} for keys %reviews;
- $xml .= "</reviews>";
-
- return $self->send_xml($xml);
-}
-
-
-sub reviews_json {
- my( $self, $key ) = @_;
- return $self->send_json(
- $self->fetch_content('dbchapter.xml', $key));
-}
-
-# --------------------------------------------------------------------------
-
-
-sub data_exists {
- my( $self, $data ) = @_;
- return 0 if $data =~ m/<title>error<\/title>/iog;
- return 1;
-}
-
-
-sub send_json {
- my( $self, $xml ) = @_;
- return 0 unless $self->data_exists($xml);
- my $doc;
-
- try {
- $doc = XML::LibXML->new->parse_string($xml);
- } catch Error with {
- my $err = shift;
- $logger->error("added content XML parser error: $err\n\n$xml");
- $doc = undef;
- };
-
- return 0 unless $doc;
- my $perl = OpenSRF::Utils::SettingsParser::XML2perl($doc->documentElement);
- my $json = OpenSRF::Utils::JSON->perl2JSON($perl);
- return { content_type => 'text/plain', content => $json };
-}
-
-sub send_xml {
- my( $self, $xml ) = @_;
- return 0 unless $self->data_exists($xml);
- return { content_type => 'application/xml', content => $xml };
-}
-
-sub send_html {
- my( $self, $content ) = @_;
- return 0 unless $self->data_exists($content);
-
- # Hide anything that might contain a link since it will be broken
- my $HTML = <<" HTML";
- <div>
- <style type='text/css'>
- div.ac input, div.ac a[href],div.ac img, div.ac button { display: none; visibility: hidden }
- </style>
- <div class='ac'>
- $content
- </div>
- </div>
- HTML
-
- return { content_type => 'text/html', content => $HTML };
-}
-
-sub send_img {
- my($self, $response) = @_;
- return {
- content_type => $response->header('Content-type'),
- content => $response->content,
- binary => 1
- };
-}
-
-# returns the raw content returned from the URL fetch
-sub fetch_content {
- my( $self, $page, $key ) = @_;
- return $self->fetch_response($page, $key)->content;
-}
-
-# returns the HTTP response object from the URL fetch
-sub fetch_response {
- my( $self, $page, $key, $notype ) = @_;
- my $uname = $self->userid;
- my $url = $self->base_url . "?isbn=$key/$page&client=$uname" . (($notype) ? '' : "&type=rw12");
- return $AC->get_url($url);
-}
-
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::BadDebt;
-use strict;
-use warnings;
-use bytes;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use APR::Table;
-
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use XML::LibXML;
-use XML::LibXSLT;
-
-use Encode;
-use Unicode::Normalize;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use UNIVERSAL::require;
-
-# set the bootstrap config when this module is loaded
-my $bootstrap;
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-}
-
-sub handler {
- my $r = shift;
- my $cgi = new CGI;
- my $auth_ses = $cgi->cookie('ses') || $cgi->param('ses');
-
- # find some IDs ...
- my @xacts;
-
- my $user = verify_login($auth_ses);
- return 403 unless $user;
-
- my $mark_bad = $cgi->param('action') eq 'unmark' ? 'f' : 't';
- my $format = $cgi->param('format') || 'csv';
-
- my $file = $cgi->param('idfile');
- if ($file) {
- my $col = $cgi->param('idcolumn') || 0;
- my $csv = new Text::CSV;
-
- while (<$file>) {
- $csv->parse($_);
- my @data = $csv->fields;
- my $id = $data[$col];
- $id =~ s/\D+//o;
- next unless ($id);
- push @xacts, $id;
- }
- }
-
- if (!@xacts) { # try pathinfo
- my $path_rec = $cgi->path_info();
- if ($path_rec) {
- @xacts = map { $_ ? ($_) : () } split '/', $path_rec;
- }
- }
-
- return 404 unless @xacts;
-
- my @lines;
-
- my ($yr,$mon,$day) = (localtime())[5,4,3]; $yr += 1900;
- my $date = sprintf('%d-%02d-%02d',$yr,$mon,$day);
-
- my @header = ( '"Transaction ID"', '"Message"', '"Amount Owed"', '"Transaction Start Date"', '"User Barcode"' );
-
- my $cstore = OpenSRF::AppSession->create('open-ils.cstore');
- my $actor = OpenSRF::AppSession->create('open-ils.actor');
-
- $cstore->connect();
- $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
-
- for my $xact ( @xacts ) {
- try {
-
- my $x = $cstore->request('open-ils.cstore.direct.money.billable_xact.retrieve' => $xact)->gather(1);
- my $s = $cstore->request('open-ils.cstore.direct.money.billable_xact_summary.retrieve' => $xact)->gather(1);
- my $u = $cstore->request('open-ils.cstore.direct.actor.usr.retrieve' => $s->usr)->gather(1);
- my $c = $cstore->request('open-ils.cstore.direct.actor.card.retrieve' => $u->card)->gather(1);
- my $w;
-
- if ($s->xact_type eq 'circulation') {
- $w = $cstore->request('open-ils.cstore.direct.action.circulation.retrieve' => $xact)->gather(1)->circ_lib :
- } elsif ($s->xact_type eq 'grocery') {
- $w = $cstore->request('open-ils.cstore.direct.money.grocery.retrieve' => $xact)->gather(1)->billing_location;
- } elsif ($s->xact_type eq 'reservation') {
- $w = $cstore->request('open-ils.cstore.direct.booking.reservation.retrieve' => $xact)->gather(1)->pickup_lib;
- } else {
- die;
- }
-
- my $failures = $actor->request('open-ils.actor.user.perm.check', $auth_ses, $user->id, $w, ['MARK_BAD_DEBT'])->gather(1);
-
- if (@$failures) {
- push @lines, [ $xact, '"Permission Failure"', '""', '""', '""' ];
- } else {
- $x->unrecovered($mark_bad);
- my $result = $cstore->request('open-ils.cstore.direct.money.billable_xact.update' => $x)->gather(1);
- if ($result != $x->id) {
- push @lines, [ $xact, '"Update Failure"', '""', '""', '""' ];
- } else {
- my $amount = $s->balance_owed;
- my $start = $s->xact_start;
- my $barcode = $c->barcode;
-
- if ( $mark_bad eq 't' ) {
- push @lines, [ $xact, '"Marked Bad Debt"', $amount, "\"$start\"", "\"$barcode\"" ];
- } else {
- push @lines, [ $xact, '"Unmarked Bad Debt"', $amount, "\"$start\"", "\"$barcode\"" ];
- }
- }
- }
- } otherwise {
- push @lines, [ $xact, '"Update Failure"', '""', '""', '""' ];
- };
- }
-
- $cstore->request('open-ils.cstore.transaction.commit')->gather(1);
- $cstore->disconnect();
-
- if ($format eq 'csv') {
- $r->headers_out->set("Content-Disposition" => "inline; filename=bad_debt_$date.csv");
- $r->content_type('application/octet-stream');
-
- $r->print( join(',', @header) . "\n" );
- $r->print( join(',', @$_ ) . "\n" ) for (@lines);
-
- } elsif ($format eq 'json') {
-
- $r->content_type('application/json');
-
- $r->print( '[' );
-
- my $first = 1;
- for my $line ( @lines ) {
- $r->print( ',' ) if $first;
- $first = 0;
-
- $r->print( '{' );
- for my $field ( 0 .. 4 ) {
- $r->print( "$header[$field] : $$line[$field]" );
- $r->print( ',' ) if ($field < 4);
- }
- $r->print( '}' );
- }
-
- $r->print( ']' );
- }
-
- return Apache2::Const::OK;
-
-}
-
-sub verify_login {
- my $auth_token = shift;
- return undef unless $auth_token;
-
- my $user = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( "open-ils.auth.session.retrieve", $auth_token )
- ->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return undef;
- }
-
- return $user if ref($user);
- return undef;
-}
-
-sub show_template {
- my $r = shift;
-
- $r->content_type('text/html');
- $r->print(<<HTML);
-
-<html>
- <head>
- <title>Record Export</title>
- </head>
- <body>
- <form method="POST" enctype="multipart/form-data">
- Use field number <input type="text" size="2" maxlength="2" name="idcolumn" value="0"/> (starting from 0)
- from CSV file <input type="file" name="idfile"/>
- <input type="submit" value="Mark Transactions Unrecoverable"/>
- </form>
- </body>
-</html>
-
-HTML
-
- return Apache2::Const::OK;
-}
-
-1;
+++ /dev/null
-package OpenILS::WWW::EGWeb;
-use strict; use warnings;
-use Template;
-use XML::Simple;
-use XML::LibXML;
-use File::stat;
-use Apache2::Const -compile => qw(OK DECLINED HTTP_INTERNAL_SERVER_ERROR);
-use Apache2::Log;
-use OpenSRF::EX qw(:try);
-
-use constant OILS_HTTP_COOKIE_SKIN => 'oils:skin';
-use constant OILS_HTTP_COOKIE_THEME => 'oils:theme';
-use constant OILS_HTTP_COOKIE_LOCALE => 'oils:locale';
-
-my $web_config;
-my $web_config_file;
-my $web_config_edit_time;
-
-sub import {
- my $self = shift;
- $web_config_file = shift;
- unless(-r $web_config_file) {
- warn "Invalid web config $web_config_file";
- return;
- }
- check_web_config();
-}
-
-
-sub handler {
- my $r = shift;
- check_web_config($r); # option to disable this
- my $ctx = load_context($r);
- my $base = $ctx->{base_path};
- my($template, $page_args, $as_xml) = find_template($r, $base, $ctx);
- return Apache2::Const::DECLINED unless $template;
-
- $template = $ctx->{skin} . "/$template";
- $ctx->{page_args} = $page_args;
- $r->content_type('text/html; encoding=utf8');
-
- my $tt = Template->new({
- OUTPUT => ($as_xml) ? sub { parse_as_xml($r, $ctx, @_); } : $r,
- INCLUDE_PATH => $ctx->{template_paths},
- });
-
- unless($tt->process($template, {ctx => $ctx})) {
- $r->log->warn('Template error: ' . $tt->error);
- return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
- }
-
- return Apache2::Const::OK;
-}
-
-sub parse_as_xml {
- my $r = shift;
- my $ctx = shift;
- my $data = shift;
-
- my $success = 0;
-
- try {
- my $doc = XML::LibXML->new->parse_string($data);
- $data = $doc->documentElement->toStringC14N;
- $data = $ctx->{final_dtd} . "\n" . $data;
- $success = 1;
- } otherwise {
- my $e = shift;
- my $err = "Invalid XML: $e";
- $r->log->error($err);
- $r->content_type('text/plain; encoding=utf8');
- $r->print("\n$err\n\n$data");
- };
-
- $r->print($data) if ($success);
-}
-
-
-sub load_context {
- my $r = shift;
- my $cgi = CGI->new;
- my $ctx = $web_config->{ctx};
- $ctx->{hostname} = $r->hostname;
- $ctx->{base_url} = $cgi->url(-base => 1);
- $ctx->{skin} = $cgi->cookie(OILS_HTTP_COOKIE_SKIN) || 'default';
- $ctx->{theme} = $cgi->cookie(OILS_HTTP_COOKIE_THEME) || 'default';
- $ctx->{locale} =
- $cgi->cookie(OILS_HTTP_COOKIE_LOCALE) ||
- parse_accept_lang($r->headers_in->get('Accept-Language')) || 'en-US';
- $r->log->debug('skin = ' . $ctx->{skin} . ' : theme = ' .
- $ctx->{theme} . ' : locale = ' . $ctx->{locale});
- return $ctx;
-}
-
-# turn Accept-Language into sometihng EG can understand
-sub parse_accept_lang {
- my $al = shift;
- return undef unless $al;
- my ($locale) = split(/,/, $al);
- ($locale) = split(/;/, $locale);
- return undef unless $locale;
- $locale =~ s/-(.*)/eval '-'.uc("$1")/e;
- return $locale;
-}
-
-# Given a URI, finds the configured template and any extra page
-# arguments (trailing path info). Any extra data is returned
-# as page arguments, in the form of an array, one item per
-# /-separated URI component
-sub find_template {
- my $r = shift;
- my $base = shift;
- my $ctx = shift;
- my $skin = $ctx->{skin};
- my $path = $r->uri;
- $path =~ s/$base//og;
- my @parts = split('/', $path);
- my $template = '';
- my $page_args = [];
- my $as_xml = $ctx->{force_valid_xml};
- my $handler = $web_config->{handlers};
-
- while(@parts) {
- my $part = shift @parts;
- next unless $part;
- my $t = $handler->{$part};
- if(ref($t) eq 'PathConfig') {
- $template = $t->{template};
- $as_xml = ($t->{as_xml} and $t->{as_xml} =~ /true/io) || $as_xml;
- $page_args = [@parts];
- last;
- } else {
- $handler = $t;
- }
- }
-
- unless($template) { # no template configured
-
- # see if we can magically find the template based on the path and default extension
- my $ext = $ctx->{default_template_extension};
-
- my @parts = split('/', $path);
- my $localpath = $path;
- my @args;
- while(@parts) {
- last unless $localpath;
- for my $tpath (@{$ctx->{template_paths}}) {
- my $fpath = "$tpath/$skin/$localpath.$ext";
- $r->log->debug("looking at possible template $fpath");
- if(-r $fpath) {
- $template = "$localpath.$ext";
- last;
- }
- }
- last if $template;
- push(@args, pop @parts);
- $localpath = '/'.join('/', @parts);
- }
-
- $page_args = [@args];
-
- # no template configured or found
- unless($template) {
- $r->log->warn("No template configured for path $path");
- return ();
- }
- }
-
- $r->log->debug("template = $template : page args = @$page_args");
- return ($template, $page_args, $as_xml);
-}
-
-# if the web configuration file has never been loaded or has
-# changed since the last load, reload it
-sub check_web_config {
- my $r = shift;
- my $epoch = stat($web_config_file)->mtime;
- unless($web_config_edit_time and $web_config_edit_time == $epoch) {
- $r->log->debug("Reloading web config after edit...") if $r;
- $web_config_edit_time = $epoch;
- $web_config = parse_config($web_config_file);
- }
-}
-
-sub parse_config {
- my $cfg_file = shift;
- my $data = XML::Simple->new->XMLin($cfg_file);
- my $ctx = {};
- my $handlers = {};
-
- $ctx->{media_prefix} = (ref $data->{media_prefix}) ? '' : $data->{media_prefix};
- $ctx->{base_path} = (ref $data->{base_path}) ? '' : $data->{base_path};
- $ctx->{template_paths} = [];
- $ctx->{force_valid_xml} = ($data->{force_valid_xml} =~ /true/io) ? 1 : 0;
- $ctx->{default_template_extension} = $data->{default_template_extension} || 'tt2';
- $ctx->{web_dir} = $data->{web_dir};
-
- my $tpaths = $data->{template_paths}->{path};
- $tpaths = [$tpaths] unless ref $tpaths;
- push(@{$ctx->{template_paths}}, $_) for @$tpaths;
-
- for my $handler (@{$data->{handlers}->{handler}}) {
- my @parts = split('/', $handler->{path});
- my $h = $handlers;
- my $pcount = scalar(@parts);
- for(my $i = 0; $i < $pcount; $i++) {
- my $p = $parts[$i];
- unless(defined $h->{$p}) {
- if($i == $pcount - 1) {
- $h->{$p} = PathConfig->new(%$handler);
- last;
- } else {
- $h->{$p} = {};
- }
- }
- $h = $h->{$p};
- }
- }
-
- return {ctx => $ctx, handlers => $handlers};
-}
-
-package PathConfig;
-sub new {
- my($class, %args) = @_;
- return bless(\%args, $class);
-}
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::Exporter;
-use strict;
-use warnings;
-use bytes;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use APR::Table;
-
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-use Data::Dumper;
-use Text::CSV;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Cache;
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use XML::LibXML;
-use XML::LibXSLT;
-
-use Encode;
-use Unicode::Normalize;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use MARC::Record;
-use MARC::File::XML;
-
-use UNIVERSAL::require;
-
-our @formats = qw/USMARC UNIMARC XML BRE/;
-
-# set the bootstrap config and template include directory when
-# this module is loaded
-my $bootstrap;
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-}
-
-sub handler {
- my $r = shift;
- my $cgi = new CGI;
-
- # find some IDs ...
- my @records;
-
- @records = map { $_ ? ($_) : () } $cgi->param('id');
-
- if (!@records) { # try for a file
- my $file = $cgi->param('idfile');
- if ($file) {
- my $col = $cgi->param('idcolumn') || 0;
- my $csv = new Text::CSV;
-
- while (<$file>) {
- $csv->parse($_);
- my @data = $csv->fields;
- my $id = $data[$col];
- $id =~ s/\D+//o;
- next unless ($id);
- push @records, $id;
- }
- }
- }
-
- if (!@records) { # try pathinfo
- my $path_rec = $cgi->path_info();
- if ($path_rec) {
- @records = map { $_ ? ($_) : () } split '/', $path_rec;
- }
- }
-
- my $ses = OpenSRF::AppSession->create('open-ils.cstore');
-
- # still no records ...
- my $container = $cgi->param('containerid');
- if ($container) {
- my $bucket = $ses->request( 'open-ils.cstore.direct.container.biblio_record_entry_bucket.retrieve', $container )->gather(1);
- unless($bucket) {
- $r->log->error("No such bucket $container");
- $logger->error("No such bucket $container");
- return Apache2::Const::NOT_FOUND;
- }
- if ($bucket->pub !~ /t|1/oi) {
- my $authid = $cgi->cookie('ses') || $cgi->param('ses');
- my $auth = verify_login($authid);
- if (!$auth) {
- return 403;
- }
- }
- my $recs = $ses->request( 'open-ils.cstore.direct.container.biblio_record_entry_bucket_item.search.atomic', { bucket => $container } )->gather(1);
- @records = map { ($_->target_biblio_record_entry) } @$recs;
- }
-
- return show_template($r) unless (@records);
-
- my $type = $cgi->param('rectype') || 'biblio';
- if ($type ne 'biblio' && $type ne 'authority') {
- return 400;
- }
-
- my $tcn_v = 'tcn_value';
- my $tcn_s = 'tcn_source';
-
- my $holdings = $cgi->param('holdings') if ($type eq 'biblio');
- my $location = $cgi->param('location') || 'gaaagpl'; # just because...
-
- my $format = $cgi->param('format') || 'USMARC';
- $format = uc($format);
-
- my $encoding = $cgi->param('encoding') || 'UTF-8';
- $encoding = uc($encoding);
-
- my $filename = $cgi->param('filename') || "export.$type.$encoding.$format";
-
- binmode(STDOUT, ':raw') if ($encoding ne 'UTF-8');
- binmode(STDOUT, ':utf8') if ($encoding eq 'UTF-8');
-
- if (!grep { uc($format) eq $_ } @formats) {
- return 400;
- }
-
- if ($format ne 'XML') {
- my $ftype = 'MARC::File::' . $format;
- $ftype->require;
- }
-
-
- $r->headers_out->set("Content-Disposition" => "inline; filename=$filename");
-
- if (uc($format) eq 'XML') {
- $r->content_type('application/xml');
- } else {
- $r->content_type('application/octet-stream');
- }
-
- $r->print( <<" HEADER" ) if (uc($format) eq 'XML');
-<?xml version="1.0" encoding="$encoding"?>
-<collection xmlns='http://www.loc.gov/MARC21/slim'>
- HEADER
-
- my %orgs;
- my %shelves;
- my %statuses;
-
- my $flesh = {};
- if ($holdings) {
-
- my $req = $ses->request( 'open-ils.cstore.direct.actor.org_unit.search', { id => { '!=' => undef } } );
-
- while (my $o = $req->recv) {
- next if ($req->failed);
- $o = $o->content;
- last unless ($o);
- $orgs{$o->id} = $o;
- }
- $req->finish;
-
- $req = $ses->request( 'open-ils.cstore.direct.asset.copy_location.search', { id => { '!=' => undef } } );
-
- while (my $s = $req->recv) {
- next if ($req->failed);
- $s = $s->content;
- last unless ($s);
- $shelves{$s->id} = $s;
- }
- $req->finish;
-
- $req = $ses->request( 'open-ils.cstore.direct.config.copy_status.search', { id => { '!=' => undef } } );
-
- while (my $s = $req->recv) {
- next if ($req->failed);
- $s = $s->content;
- last unless ($s);
- $statuses{$s->id} = $s;
- }
- $req->finish;
-
- $flesh = { flesh => 2, flesh_fields => { bre => [ 'call_numbers' ], acn => [ 'copies' ] } };
- }
-
- for my $i ( @records ) {
- my $bib;
- try {
- local $SIG{ALRM} = sub { die "TIMEOUT\n" };
- alarm(1);
- $bib = $ses->request( "open-ils.cstore.direct.$type.record_entry.retrieve", $i, $flesh )->gather(1);
- alarm(0);
- } otherwise {
- warn "\n!!!!!! Timed out trying to read record $i\n";
- };
- alarm(0);
-
- next unless $bib;
-
- if (uc($format) eq 'BRE') {
- $r->print( OpenSRF::Utils::JSON->perl2JSON($bib) . "\n" );
- next;
- }
-
- try {
-
- my $req = MARC::Record->new_from_xml( $bib->marc, $encoding, $format );
- $req->encoding($encoding) if ($encoding eq 'UTF-8');
-
- if ($holdings) {
- $req->delete_field( $_ ) for ($req->field('852')); # remove any legacy 852s
- my $cn_list = $bib->call_numbers;
- if ($cn_list && @$cn_list) {
-
- my $cp_list = [ map { @{ $_->copies } } @$cn_list ];
- if ($cp_list && @$cp_list) {
-
- my %cn_map;
- push @{$cn_map{$_->call_number}}, $_ for (@$cp_list);
-
- for my $cn ( @$cn_list ) {
- my $cn_map_list = $cn_map{$cn->id};
-
- for my $cp ( @$cn_map_list ) {
-
- $req->append_fields(
- MARC::Field->new(
- 852, '4', '',
- a => $location,
- b => $orgs{$cn->owning_lib}->shortname,
- b => $orgs{$cp->circ_lib}->shortname,
- c => $shelves{$cp->location}->name,
- j => $cn->label,
- ($cp->circ_modifier ? ( g => $cp->circ_modifier ) : ()),
- p => $cp->barcode,
- ($cp->price ? ( y => $cp->price ) : ()),
- ($cp->copy_number ? ( t => $cp->copy_number ) : ()),
- ($cp->ref eq 't' ? ( x => 'reference' ) : ( x => 'nonreference' )),
- ($cp->holdable eq 'f' ? ( x => 'unholdable' ) : ( x => 'holdable' )),
- ($cp->circulate eq 'f' ? ( x => 'noncirculating' ) : ( x => 'circulating' )),
- ($cp->opac_visible eq 'f' ? ( x => 'hidden' ) : ( x => 'visible' )),
- z => $statuses{$cp->status}->name,
- )
- );
-
- }
- }
- }
- }
- }
-
- if (uc($format) eq 'XML') {
- my $x = $req->as_xml_record;
- $x =~ s/^<\?xml version="1.0" encoding="UTF-8"\?>//o;
- $r->print($x);
- } elsif (uc($format) eq 'UNIMARC') {
- $r->print($req->as_usmarc);
- } elsif (uc($format) eq 'USMARC') {
- $r->print($req->as_usmarc);
- }
-
- $r->rflush();
-
- } otherwise {
- my $e = shift;
- warn "\n$e\n";
- };
-
- }
-
- $r->print("</collection>\n") if ($format eq 'XML');
-
- return Apache2::Const::OK;
-
-}
-
-sub verify_login {
- my $auth_token = shift;
- return undef unless $auth_token;
-
- my $user = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( "open-ils.auth.session.retrieve", $auth_token )
- ->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return undef;
- }
-
- return $user if ref($user);
- return undef;
-}
-
-sub show_template {
- my $r = shift;
-
- $r->content_type('text/html');
- $r->print(<<HTML);
-
-<html>
- <head>
- <title>Record Export</title>
- </head>
- <body>
- <form method="POST" enctype="multipart/form-data">
- Use field number <input type="text" size="2" maxlength="2" name="idcolumn" value="0"/> (starting from 0)
- from CSV file <input type="file" name="idfile"/>
- <br/><br/> <b>or</b> <br/><br/>
- Record ID <input type="text" size="12" maxlength="12" name="id"/>
- <br/><br/> Record Type:
- <select name="rectype">
- <option value="biblio">Bibliographic Records</option>
- <option value="authority">Authority Records</option>
- </select>
- <br/> Record Format:
- <select name="format">
- <option value="USMARC">MARC21</option>
- <option value="UNIMARC">UNIMARC</option>
- <option value="XML">MARC XML</option>
- <option value="BRE">Evergreen BRE</option>
- </select>
- <br/> Record Encoding:
- <select name="encoding">
- <option value="UTF-8">UTF-8</option>
- <option value="MARC8">MARC8</option>
- </select>
- <br/> Include holdings in Bibliographic Records:
- <input type="checkbox" name="holdings" value="1">
- <br/><br/><input type="submit" value="Retrieve Records"/>
- </form>
- </body>
-</html>
-
-HTML
-
- return Apache2::Const::OK;
-}
-
-1;
+++ /dev/null
-package OpenILS::WWW::IDL2js;
-use strict; use warnings;
-use XML::LibXML;
-use XML::LibXSLT;
-use Apache2::Const -compile => qw(OK DECLINED HTTP_INTERNAL_SERVER_ERROR);
-use Error qw/:try/;
-use OpenSRF::System;
-use OpenSRF::Utils::SettingsClient;
-
-my $bs_config;
-my $stylesheet;
-my $idl_doc;
-
-
-# load and parse the stylesheet
-sub import {
- my $self = shift;
- $bs_config = shift;
-}
-
-# parse the IDL, loaded from the network
-my $__initted = 0;
-sub child_init {
- $__initted = 1;
-
- OpenSRF::System->bootstrap_client(config_file => $bs_config);
- my $sclient = OpenSRF::Utils::SettingsClient->new();
-
- my $xsl_file = $sclient->config_value('IDL2js');
-
- unless($xsl_file) {
- warn "XSL2js XSL file required for IDL2js Apache module\n";
- return;
- }
-
- $xsl_file = $sclient->config_value(dirs => 'xsl')."/$xsl_file";
- my $idl_file = $sclient->config_value("IDL");
-
- my $xslt = XML::LibXSLT->new();
-
- try {
-
- my $style_doc = XML::LibXML->load_xml(location => $xsl_file, no_cdata=>1);
- $stylesheet = $xslt->parse_stylesheet($style_doc);
-
- } catch Error with {
- my $e = shift;
- warn "Invalid XSL File: $xsl_file: $e\n";
- };
-
- $idl_doc = XML::LibXML->load_xml(location => $idl_file);
-}
-
-
-sub handler {
- my $r = shift;
- my $args = $r->args || '';
- child_init() unless $__initted;
-
- return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR unless $stylesheet and $idl_doc;
- return Apache2::Const::DECLINED if $args and $args !~ /^[a-zA-Z,]*$/;
-
- my $output;
- try {
- my $results = $stylesheet->transform($idl_doc, class_list => "'$args'");
- $output = $stylesheet->output_as_bytes($results);
- } catch Error with {
- my $e = shift;
- $r->log->error("IDL XSL Error: $e");
- };
-
- return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR unless $output;
-
- $r->content_type('application/x-javascript; encoding=utf8');
- $r->print($output);
- return Apache2::Const::OK;
-}
-
-1;
+++ /dev/null
-package OpenILS::WWW::Method;
-use strict; use warnings;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-
-use OpenSRF::Utils::JSON;
-
-use CGI ();
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-
-my %session_hash;
-
-use constant MAX_SESSION_REQUESTS => 20;
-
-sub handler {
-
- use Data::Dumper;
-
-
- my $apache = shift;
- my $cgi = CGI->new( $apache );
-
- print "Content-type: text/plain; charset=utf-8\n\n";
- #print $cgi->header;
-
- my @p = $cgi->param();
- warn "Params: " . Dumper(\@p);
-
- my $method = $cgi->param("method");
- my $service = $cgi->param("service");
-
- my $err = undef;
-
- if( ! $service || ! $method ) {
- $err = {
- is_err => 1,
- err_msg => "Service name and method name required to fulfill request",
- };
- }
-
- if($err) {
- print OpenSRF::Utils::JSON->perl2JSON($err);
- return Apache2::Const::OK;
- }
-
- my @param_array;
- my %param_hash;
-
- warn "here\n";
-
- if(defined($cgi->param("param"))) {
- for my $param ( $cgi->param("param")) {
- push( @param_array, OpenSRF::Utils::JSON->JSON2perl( $param ));
- }
- } else {
- for my $param ($cgi->param()) {
- $param_hash{$param} = OpenSRF::Utils::JSON->JSON2perl($cgi->param($param))
- unless( $param eq "method" or $param eq "service" );
- }
- }
-
-
- if( @param_array ) {
- perform_method($service, $method, @param_array);
- } else {
- perform_method($service, $method, %param_hash);
- }
-
- return Apache2::Const::OK;
-}
-
-sub child_init_handler {
- OpenSRF::System->bootstrap_client(
- config_file => "SYSCONFDIR/opensrf_core.xml" );
-}
-
-
-sub perform_method {
-
- my ($service, $method, @params) = @_;
-
- warn "performing method $method for service $service with params @params\n";
-
- my $session;
-
- if($session_hash{$service} ) {
-
- $session = $session_hash{$service};
- $session->{web_count} += 1;
-
- if( $session->{web_count} > MAX_SESSION_REQUESTS) {
- $session->disconnect();
- $session->{web_count} = 1;
- }
-
- } else {
-
- $session = OpenSRF::AppSession->create($service);
- $session_hash{$service} = $session;
- $session->{web_count} = 1;
-
- }
-
- my $request = $session->request( $method, @params );
-
- my @results;
- while( my $response = $request->recv(20) ) {
-
- if( UNIVERSAL::isa( $response, "Error" )) {
- warn "Received exception: " . $response->stringify . "\n";
- my $err = {
- is_err => 1,
- err_msg => "Error Completing Request:\n " .
- "Service: $service \nMethod: $method \nParams: @params \n" .
- $response->stringify() . "\n",
- };
- print OpenSRF::Utils::JSON->perl2JSON($err);
- $request->finish();
- return 0;
- }
-
- my $content = $response->content;
- push @results, $content;
- }
-
-
- if(!$request->complete) {
- warn "ERROR Completing Request";
- my $err = {
- is_err => 1,
- err_msg => "Error Completing Request:\n ".
- "Service: $service \nMethod: $method \nParams: @params \n" .
- "request->complete test failed in OpenILS::Web::Method\n"
- };
- print OpenSRF::Utils::JSON->perl2JSON($err);
- $request->finish();
- return 0;
- }
-
- $request->finish();
- $session->finish();
-
- warn "Results: \n";
- warn Dumper \@results;
-
- print OpenSRF::Utils::JSON->perl2JSON( \@results );
-
- return 1;
-}
-
-# This module appears unfinshed and/or obsolete with many unconditional warns/dumps.
-# File is not referenced elsewhere in the codebase. Candidate for deletion.
-
-1;
+++ /dev/null
-package OpenILS::WWW::PasswordReset;
-
-# Copyright (C) 2010 Laurentian University
-# Dan Scott <dscott@laurentian.ca>
-#
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-
-use strict; use warnings;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-use Template;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Cache;
-use OpenSRF::System;
-use OpenSRF::AppSession;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Application::AppUtils;
-use OpenILS::Utils::CStoreEditor qw/:funcs/;
-
-my $log = 'OpenSRF::Utils::Logger';
-my $U = 'OpenILS::Application::AppUtils';
-
-my ($bootstrap, $actor, $templates);
-my $i18n = {};
-my $init_done = 0; # has child_init been called?
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-
- my $conf = OpenSRF::Utils::SettingsClient->new();
- my $idl = $conf->config_value("IDL");
- Fieldmapper->import(IDL => $idl);
- $templates = $conf->config_value("dirs", "templates");
- $actor = OpenSRF::AppSession->create('open-ils.actor');
- load_i18n();
- $init_done = 1;
-}
-
-sub password_reset {
- my $apache = shift;
-
- child_init() unless $init_done;
-
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- $apache->content_type('text/html');
-
- my $cgi = new CGI;
- my $ctx = {};
-
- $ctx->{'uri'} = $apache->uri;
-
- # Get our locale from the URL
- (my $locale = $apache->path_info) =~ s{^.*?/([a-z]{2}-[A-Z]{2})/.*?$}{$1};
- if (!$locale) {
- $locale = 'en-US';
- }
-
- # If locale exists, use it; otherwise fall back to en-US
- if (exists $i18n->{$locale}) {
- $ctx->{'i18n'} = $i18n->{$locale};
- } else {
- $ctx->{'i18n'} = $i18n->{'en-US'};
- }
-
- my $tt = Template->new({
- INCLUDE_PATH => $templates
- }) || die "$Template::ERROR\n";
-
- # Get our UUID: if no UUID, then display barcode / username / email prompt
- (my $uuid = $apache->path_info) =~ s{^/$locale/([^/]*?)$}{$1};
- $logger->info("Password reset: UUID = $uuid");
-
- if (!$uuid) {
- request_password_reset($apache, $cgi, $tt, $ctx);
- } else {
- reset_password($apache, $cgi, $tt, $ctx, $uuid);
- }
-}
-
-sub reset_password {
- my ($apache, $cgi, $tt, $ctx, $uuid) = @_;
-
- my $password_1 = $cgi->param('pwd1');
- my $password_2 = $cgi->param('pwd2');
-
- $ctx->{'title'} = $ctx->{'i18n'}{'TITLE'};
- $ctx->{'password_prompt'} = $ctx->{'i18n'}{'PASSWORD_PROMPT'};
- $ctx->{'password_prompt2'} = $ctx->{'i18n'}{'PASSWORD_PROMPT2'};
-
- # In case non-matching passwords slip through our funky Web interface
- if ($password_1 and $password_2 and ($password_1 ne $password_2)) {
- $ctx->{'status'} = {
- style => 'error',
- msg => $ctx->{'i18n'}{'NO_MATCH'}
- };
- $tt->process('password-reset/reset-form.tt2', $ctx)
- || die $tt->error();
- return Apache2::Const::OK;
- }
-
- if ($password_1 and $password_2 and ($password_1 eq $password_2)) {
- my $response = $actor->request('open-ils.actor.patron.password_reset.commit', $uuid, $password_1)->gather();
- if (ref($response) && $response->{'textcode'}) {
-
- if ($response->{'textcode'} eq 'PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST') {
- $ctx->{'status'} = {
- style => 'error',
- msg => $ctx->{'i18n'}{'NOT_ACTIVE'}
-
- };
- }
- if ($response->{'textcode'} eq 'PATRON_PASSWORD_WAS_NOT_STRONG') {
- $ctx->{'status'} = {
- style => 'error',
- msg => $ctx->{'i18n'}{'NOT_STRONG'}
-
- };
- }
- $tt->process('password-reset/reset-form.tt2', $ctx)
- || die $tt->error();
- return Apache2::Const::OK;
- }
- $ctx->{'status'} = {
- style => 'success',
- msg => $ctx->{'i18n'}{'SUCCESS'}
- };
- }
-
- # Either the password change was successful, or this is their first time through
- $tt->process('password-reset/reset-form.tt2', $ctx)
- || die $tt->error();
-
- return Apache2::Const::OK;
-}
-
-# Load our localized strings - lame, need to convert to Locale::Maketext
-sub load_i18n {
- foreach my $string_bundle (glob("$templates/password-reset/strings.*")) {
- open(I18NFH, '<', $string_bundle);
- (my $locale = $string_bundle) =~ s/^.*\.([a-z]{2}-[A-Z]{2})$/$1/;
- $logger->debug("Loaded locale [$locale] from file: [$string_bundle]");
- while(<I18NFH>) {
- my ($string_id, $string) = ($_ =~ m/^(.+?)=(.*?)$/);
- $i18n->{$locale}{$string_id} = $string;
- }
- close(I18NFH);
- }
-}
-
-sub request_password_reset {
- my ($apache, $cgi, $tt, $ctx) = @_;
-
- my $barcode = $cgi->param('barcode');
- my $username = $cgi->param('username');
- my $email = $cgi->param('email');
-
- if (!($barcode or $username or $email)) {
- $ctx->{'status'} = {
- style => 'plain',
- msg => $ctx->{'i18n'}{'IDENTIFY_YOURSELF'}
- };
- $tt->process('password-reset/request-form.tt2', $ctx)
- || die $tt->error();
- return Apache2::Const::OK;
- } elsif ($barcode) {
- my $response = $actor->request('open-ils.actor.patron.password_reset.request', 'barcode', $barcode)->gather();
- $ctx->{'status'} = {
- style => 'plain',
- msg => $ctx->{'i18n'}{'REQUEST_SUCCESS'}
- };
- # Hide form
- $tt->process('password-reset/request-form.tt2', $ctx)
- || die $tt->error();
- return Apache2::Const::OK;
- } elsif ($username) {
- my $response = $actor->request('open-ils.actor.patron.password_reset.request', 'username', $username)->gather();
- $ctx->{'status'} = {
- style => 'plain',
- msg => $ctx->{'i18n'}{'REQUEST_SUCCESS'}
- };
- # Hide form
- $tt->process('password-reset/request-form.tt2', $ctx)
- || die $tt->error();
- return Apache2::Const::OK;
- }
-}
-
-1;
-
-# vim: et:ts=4:sw=4
+++ /dev/null
-package OpenILS::WWW::Proxy;
-use strict; use warnings;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(REDIRECT FORBIDDEN OK NOT_FOUND DECLINED :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use CGI;
-use Data::Dumper;
-use Digest::MD5 qw/md5_hex/;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-
-
-# set the bootstrap config and template include directory when
-# this module is loaded
-my $bootstrap;
-my $ssl_off;
-
-my $default_template = <<HTML;
-<html>
- <head>
- <title>TITLE</title>
- </head>
- <body>
- <br/><br/><br/>
- <center>
- <form method='POST'>
- <table style='border-collapse: collapse; border: 1px solid black;'>
- <tr>
- <th colspan='2' align='center'><u>DESCRIPTION</u></th>
- </tr>
- <tr>
- <th align="right">Username or barcode:</th>
- <td><input type="text" name="user"/></td>
- </tr>
- <tr>
- <th align="right">Password:</th>
- <td><input type="password" name="passwd"/></td>
- </tr>
- </table>
- <input type="submit" value="Log in"/>
- </form>
- </center>
- </body>
-</html>
-HTML
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
- $ssl_off = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-}
-
-sub handler {
- my $apache = shift;
-
- my $proxyhtml = $apache->dir_config('OILSProxyHTML');
- my $title = $apache->dir_config('OILSProxyTitle');
- my $desc = $apache->dir_config('OILSProxyDescription');
- my $ltype = $apache->dir_config('OILSProxyLoginType');
- my $perms = [ split ' ', $apache->dir_config('OILSProxyPermissions') ];
-
- return Apache2::Const::NOT_FOUND unless ($title || $proxyhtml);
- return Apache2::Const::NOT_FOUND unless (@$perms);
-
- my $cgi = new CGI;
- my $auth_ses = $cgi->cookie('ses') || $cgi->param('ses');
- my $ws_ou = $apache->dir_config('OILSProxyLoginOU') || $cgi->cookie('ws_ou') || $cgi->param('ws_ou');
-
- my $url = $cgi->url;
-
- # push everyone to the secure site
- if (!$ssl_off && $url =~ /^http:/o) {
- my $base = $cgi->url(-base=>1);
- $base =~ s/^http:/https:/o;
- print "Location: $base".$apache->unparsed_uri."\n\n";
- return Apache2::Const::REDIRECT;
- }
-
- if (!$auth_ses) {
- my $u = $cgi->param('user');
- my $p = $cgi->param('passwd');
-
- if (!$u) {
-
- print $cgi->header(-type=>'text/html', -expires=>'-1d');
- if (!$proxyhtml) {
- $proxyhtml = $default_template;
- $proxyhtml =~ s/TITLE/$title/gso;
- $proxyhtml =~ s/DESCRIPTION/$desc/gso;
- } else {
- # XXX template toolkit??
- }
-
- print $proxyhtml;
- return Apache2::Const::OK;
- }
-
- $auth_ses = oils_login($u, $p, $ltype);
- if ($auth_ses) {
- print $cgi->redirect(
- -uri=> $apache->unparsed_uri,
- -cookie=>$cgi->cookie(
- -name=>'ses',
- -value=>$auth_ses,
- -path=>'/'
- )
- );
- return Apache2::Const::REDIRECT;
- } else {
- return back_to_login($apache, $cgi);
- }
- }
-
- my $user = verify_login($auth_ses);
- return back_to_login($apache, $cgi) unless $user;
-
- $ws_ou ||= $user->home_ou;
-
- warn "Checking perms " . join(',', @$perms) . " for user " . $user->id . " at location $ws_ou\n";
-
- my $failures = OpenSRF::AppSession
- ->create('open-ils.actor')
- ->request('open-ils.actor.user.perm.check', $auth_ses, $user->id, $ws_ou, $perms)
- ->gather(1);
-
- return back_to_login($apache, $cgi) if (@$failures > 0);
-
- # they're good, let 'em through
- return Apache2::Const::DECLINED;
-}
-
-sub back_to_login {
- my $apache = shift;
- my $cgi = shift;
- print $cgi->redirect(
- -uri=>$apache->unparsed_uri,
- -cookie=>$cgi->cookie(
- -name=>'ses',
- -value=>'',
- -path=>'/',-expires=>'-1h'
- )
- );
- return Apache2::Const::REDIRECT;
-}
-
-# returns the user object if the session is valid, 0 otherwise
-sub verify_login {
- my $auth_token = shift;
- return undef unless $auth_token;
-
- my $user = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( "open-ils.auth.session.retrieve", $auth_token )
- ->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return undef;
- }
-
- return $user if ref($user);
- return undef;
-}
-
-sub oils_login {
- my( $username, $password, $type ) = @_;
-
- $type |= "staff";
- my $nametype = 'username';
- $nametype = 'barcode' if ($username =~ /^\d+$/o);
-
- my $seed = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( 'open-ils.auth.authenticate.init', $username )
- ->gather(1);
-
- return undef unless $seed;
-
- my $response = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( 'open-ils.auth.authenticate.complete',
- { $nametype => $username,
- password => md5_hex($seed . md5_hex($password)),
- type => $type })
- ->gather(1);
-
- return undef unless $response;
-
- return $response->{payload}->{authtoken};
-}
-
-1;
-
+++ /dev/null
-package OpenILS::WWW::Redirect;
-use strict; use warnings;
-
-use Socket;
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use CGI ();
-
-use OpenSRF::AppSession;
-use OpenSRF::System;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use vars '$lib_ips_hash';
-my $lib_ips_hash;
-
-my $bootstrap_config_file;
-sub import {
- my( $self, $config ) = @_;
- $bootstrap_config_file = $config;
-}
-
-sub init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap_config_file );
-}
-
-sub parse_ips_file {
- my $class = shift;
- my $ips_file = shift;
-
- if( open(F, $ips_file) ) {
-
- while( my $data = <F> ) {
- chomp($data);
-
- my( $shortname, $ip1, $ip2 ) = split(/\s+/, $data);
- next unless ($shortname and $ip1 and $ip2);
-
- $lib_ips_hash->{$shortname} = [] unless $lib_ips_hash->{$shortname};
- push( @{$lib_ips_hash->{$shortname}}, [ $ip1, $ip2 ] );
- }
-
- close(F);
-
- } else {
- $logger->error("Unable to open lib IP redirector file $ips_file");
- }
-}
-
-
-sub handler {
-
- my $user_ip = $ENV{REMOTE_ADDR};
- my $apache_obj = shift;
- my $cgi = CGI->new( $apache_obj );
-
-
- my $skin = $apache_obj->dir_config('OILSRedirectSkin') || 'default';
- my $depth = $apache_obj->dir_config('OILSRedirectDepth');
- my $locale = $apache_obj->dir_config('OILSRedirectLocale') || 'en-US';
-
- my $hostname = $cgi->server_name();
- my $port = $cgi->server_port();
-
- my $proto = "http";
- if($cgi->https) { $proto = "https"; }
-
- my $url = "$proto://$hostname:$port/opac/$locale/skin/$skin/xml/index.xml";
-
- my $path = $apache_obj->path_info();
-
- $logger->debug("Apache client connecting from $user_ip");
-
- if(my $shortname = redirect_libs($user_ip)) {
-
- $logger->info("Apache redirecting $user_ip to $shortname");
- my $session = OpenSRF::AppSession->create("open-ils.actor");
-
- my $org = $session->request(
- 'open-ils.actor.org_unit.retrieve_by_shortname',
- $shortname)->gather(1);
-
- if($org) {
- $url .= "?ol=" . $org->id;
- $url .= "&d=$depth" if defined $depth;
- }
- }
-
- print "Location: $url\n\n";
- return Apache2::Const::REDIRECT;
-
- return print_page($url);
-}
-
-sub redirect_libs {
- my $source_ip = shift;
- my $aton_binary = inet_aton( $source_ip );
-
- return 0 unless $aton_binary;
-
- # do this the linear way for now...
- for my $shortname (keys %$lib_ips_hash) {
-
- for my $block (@{$lib_ips_hash->{$shortname}}) {
-
- if(defined($block->[0]) && defined($block->[1]) ) {
- my $start_binary = inet_aton( $block->[0] );
- my $end_binary = inet_aton( $block->[1] );
- next unless( $start_binary and $end_binary );
- if( $start_binary le $aton_binary and
- $end_binary ge $aton_binary ) {
- return $shortname;
- }
- }
- }
- }
- return 0;
-}
-
-
-sub print_page {
-
- my $url = shift;
-
- print "Content-type: text/html; charset=utf-8\n\n";
- print <<" HTML";
- <html>
- <head>
- <meta HTTP-EQUIV='Refresh' CONTENT="0; URL=$url"/>
- <style TYPE="text/css">
- .loading_div {
- text-align:center;
- margin-top:30px;
- font-weight:bold;
- background: lightgrey;
- color:black;
- width:100%;
- }
- </style>
- </head>
- <body>
- <br/><br/>
- <div class="loading_div">
- <h4>Loading...</h4>
- </div>
- <br/><br/>
- <center><img src='/opac/images/main_logo.jpg'/></center>
- </body>
- </html>
- HTML
-
- return Apache2::Const::OK;
-}
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::Reporter;
-use strict; use warnings;
-
-use vars qw/$dtype_xform_map $dtype_xform/;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-use Data::Dumper;
-
-use Template;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-use XML::LibXML;
-
-use OpenSRF::Utils::SettingsParser;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::WWW::Reporter::transforms;
-
-
-# set the bootstrap config and template include directory when
-# this module is loaded
-my $bootstrap;
-my $includes = [];
-my $base_xml;
-#my $base_xml_doc;
-
-sub import {
- my( $self, $bs_config, $core_xml, @incs ) = @_;
- $bootstrap = $bs_config;
- $base_xml = $core_xml;
- $includes = [ @incs ];
-}
-
-
-# our templates plugins are here
-my $plugin_base = 'OpenILS::Template::Plugin';
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-
- #parse the base xml file
- #my $parser = XML::LibXML->new;
- #$parser->expand_xinclude(1);
-
- #$base_xml_doc = $parser->parse_file($base_xml);
-
-}
-
-sub handler {
-
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = CGI->new;
-
- my $path = $apache->path_info;
- (my $ttk = $path) =~ s{^/?([a-zA-Z0-9_]+).*?$}{$1}o;
-
- $ttk = $apache->filename unless $ttk;
- $ttk = "dashboard" unless $ttk;
-
- $ttk = (split '/', $ttk)[-1];
-
- my $user;
-
- # if the user is not logged in via cookie, route them to the login page
- if(! ($user = verify_login($cgi->cookie("ses"))) ) {
- $ttk = "login";
- }
-
-
- print "Content-type: text/html; charset=utf-8\n\n";
- #print "Content-type: text/html\n\n";
-
- _process_template(
- apache => $apache,
- template => "$ttk.ttk",
- params => {
- user => $user,
- stage_dir => $ttk,
- config_xml => $base_xml,
- },
- );
-
- return Apache2::Const::OK;
-}
-
-
-sub _process_template {
-
- my %params = @_;
- my $ttk = $params{template} || return undef;
- my $apache = $params{apache} || undef;
- my $param_hash = $params{params} || {};
- $$param_hash{dtype_xform_map} = $OpenILS::WWW::Reporter::dtype_xform_map;
- $$param_hash{dtype_xforms} = $OpenILS::WWW::Reporter::dtype_xforms;
-
- my $template;
-
- $template = Template->new( {
- OUTPUT => $apache,
- ABSOLUTE => 1,
- RELATIVE => 1,
- PLUGIN_BASE => $plugin_base,
- INCLUDE_PATH => $includes,
- PRE_CHOMP => 1,
- POST_CHOMP => 1,
- #LOAD_PERL => 1,
- }
- );
-
- try {
-
- if( ! $template->process( $ttk, $param_hash ) ) {
- warn "Error Processing Template: " . $template->error();
- my $err = $template->error();
- $err =~ s/\n/\<br\/\>/g;
- warn "Error processing template $ttk\n";
- my $string = "<br><b>Unable to process template:<br/><br/> " . $err . "</b>";
- print "ERROR: $string";
- #$template->process( $error_ttk , { error => $string } );
- }
-
- } catch Error with {
- my $e = shift;
- warn "Error processing template $ttk: $e - $@ \n";
- print "<center><br/><br/><b>Error<br/><br/> $e <br/><br/> $@ </b><br/></center>";
- return;
- };
-
-}
-
-# returns the user object if the session is valid, 0 otherwise
-sub verify_login {
- my $auth_token = shift;
- return 0 unless $auth_token;
-
- my $session = OpenSRF::AppSession->create("open-ils.auth");
- my $req = $session->request(
- "open-ils.auth.session.retrieve", $auth_token );
- my $user = $req->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return 0;
- }
-
- return $user if ref($user);
- return 0;
-}
-
-
-
-1;
+++ /dev/null
-#!/usr/bin/perl
-
-package OpenILS::WWW::Reporter;
-
-our $dtype_xform_map = {
- 'int' => [ 'avg','stddev','sum','count','count_dist','numformat'],
- 'numeric' => [ 'avg','stddev','sum','count','count_dist','numformat'],
- 'float' => [ 'avg','stddev','sum','count','count_dist','numformat'],
- 'time' => [ 'count', 'dateformat'],
- 'date' => [ 'count', 'age','dateformat'],
- 'timestamp' => [ 'count', 'age','dateformat'],
- 'timestamptz' => [ 'count', 'age','dateformat'],
- 'text' => [ 'count','count_dist','lower','upper','substr'],
- 'call_number' => [ 'count','count_dist','dewy','dewy_prefix','count_dist_dewey','count_dist_dewey_prefix','lower','upper','substr'],
-};
-
-
-
-our $dtype_xforms = {
- 'avg' => {
- 'name' => 'Average per group',
- 'select' => 'AVG(?COLNAME?)',
- 'group' => 0 },
- 'stddev' => {
- 'label' => 'Standard Deviation per group',
- 'select' => 'STDDEV(?COLNAME?)',
- 'group' => 0 },
- 'sum' => {
- 'label' => 'Sum per group',
- 'select' => 'SUM(?COLNAME?)',
- 'group' => 0 },
- 'count' => {
- 'label' => 'Count per group',
- 'select' => 'COUNT(?COLNAME?)',
- 'group' => 0 },
- 'count_dist' => {
- 'label' => 'Distinct Count per group',
- 'select' => 'COUNT(DISTINCT ?COLNAME?)',
- 'group' => 0 },
- 'count_dist_dewey' => {
- 'label' => 'Distinct Count of Dewey numbers per group',
- 'select' => 'COUNT(DISTINCT call_number_dewey(?COLNAME?))',
- 'group' => 1 },
- 'count_dist_dewey_prefix'=> {
- 'label' => 'Distinct Count of Dewey Number Prefixes per group',
- 'select' => 'COUNT(DISTINCT call_number_dewey(?COLNAME?,?PARAM?))',
- 'param' => 1,
- 'group' => 1 },
- 'dewy_prefix' => {
- 'label' => 'Extract Dewey number prefix from call number',
- 'select' => 'call_number_dewey(?COLNAME?,?PARAM?)',
- 'param' => 1,
- 'group' => 1 },
- 'dewy' => {
- 'label' => 'Extract Dewey number from call number',
- 'select' => 'call_number_dewey(?COLNAME?)',
- 'group' => 1 },
- 'lower' => {
- 'label' => 'Transform string to lower case',
- 'select' => 'LOWER(?COLNAME?)',
- 'group' => 1 },
- 'upper' => {
- 'label' => 'Transform string to upper case',
- 'select' => 'UPPER(?COLNAME?)',
- 'group' => 1 },
- 'substr' => {
- 'label' => 'Trim string length',
- 'select' => 'substr(?COLNAME?,1,?PARAM?)',
- 'param' => 1,
- 'group' => 1 },
- 'age' => {
- 'label' => 'Age as of runtime -- day granularity',
- 'select' => 'AGE(?COLNAME?::DATE)',
- 'group' => 1 },
- 'dateformat' => { # see http://www.postgresql.org/docs/8.0/interactive/functions-formatting.html
- 'label' => 'Format date and time',
- 'select' => "TO_CHAR(?COLNAME?,'?PARAM?')",
- 'param' => 1,
- 'group' => 1 },
- 'numformat' => { # see http://www.postgresql.org/docs/8.0/interactive/functions-formatting.html
- 'label' => 'Format Numeric data',
- 'select' => "TO_CHAR(?COLNAME?,'?PARAM?')",
- 'param' => 1,
- 'group' => 1 },
-};
-
-;
+++ /dev/null
-package OpenILS::WWW::SuperCat;
-use strict; use warnings;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-use Data::Dumper;
-use SRU::Request;
-use SRU::Response;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Cache;
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use XML::LibXML;
-use XML::LibXSLT;
-
-use Encode;
-use Unicode::Normalize;
-use OpenILS::Utils::Fieldmapper;
-use OpenILS::WWW::SuperCat::Feed;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenILS::Application::AppUtils;
-
-use MARC::Record;
-use MARC::File::XML;
-
-my $log = 'OpenSRF::Utils::Logger';
-my $U = 'OpenILS::Application::AppUtils';
-
-# set the bootstrap config when this module is loaded
-my ($bootstrap, $supercat, $actor, $parser, $search, $xslt, $cn_browse_xslt, %browse_types);
-
-$browse_types{call_number}{xml} = sub {
- my $tree = shift;
-
- my $year = (gmtime())[5] + 1900;
- my $content = '';
-
- $content .= "<volumes xmlns='http://open-ils.org/spec/holdings/v1'>\n";
-
- for my $cn (@$tree) {
- (my $cn_class = $cn->class_name) =~ s/::/-/gso;
- $cn_class =~ s/Fieldmapper-//gso;
-
- my $cn_tag = "tag:open-ils.org,$year:$cn_class/".$cn->id;
- my $cn_lib = $cn->owning_lib->shortname;
- my $cn_label = $cn->label;
-
- $cn_label =~ s/\n//gos;
- $cn_label =~ s/&/&/go;
- $cn_label =~ s/'/'/go;
- $cn_label =~ s/</</go;
- $cn_label =~ s/>/>/go;
-
- (my $ou_class = $cn->owning_lib->class_name) =~ s/::/-/gso;
- $ou_class =~ s/Fieldmapper-//gso;
-
- my $ou_tag = "tag:open-ils.org,$year:$ou_class/".$cn->owning_lib->id;
- my $ou_name = $cn->owning_lib->name;
-
- $ou_name =~ s/\n//gos;
- $ou_name =~ s/'/'/go;
-
- (my $rec_class = $cn->record->class_name) =~ s/::/-/gso;
- $rec_class =~ s/Fieldmapper-//gso;
-
- my $rec_tag = "tag:open-ils.org,$year:$rec_class/".$cn->record->id.'/'.$cn->owning_lib->shortname;
-
- $content .= "<volume id='$cn_tag' lib='$cn_lib' label='$cn_label'>\n";
- $content .= "<owning_lib xmlns='http://open-ils.org/spec/actors/v1' id='$ou_tag' name='$ou_name'/>\n";
-
- my $r_doc = $parser->parse_string($cn->record->marc);
- $r_doc->documentElement->setAttribute( id => $rec_tag );
- $content .= $U->entityize($r_doc->documentElement->toString);
-
- $content .= "</volume>\n";
- }
-
- $content .= "</volumes>\n";
- return ("Content-type: application/xml\n\n",$content);
-};
-
-
-$browse_types{call_number}{html} = sub {
- my $tree = shift;
- my $p = shift;
- my $n = shift;
-
- if (!$cn_browse_xslt) {
- $cn_browse_xslt = $parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/CNBrowse2HTML.xsl"
- );
- $cn_browse_xslt = $xslt->parse_stylesheet( $cn_browse_xslt );
- }
-
- my (undef,$xml) = $browse_types{call_number}{xml}->($tree);
-
- return (
- "Content-type: text/html\n\n",
- $U->entityize(
- $cn_browse_xslt->transform(
- $parser->parse_string( $xml ),
- 'prev' => "'$p'",
- 'next' => "'$n'"
- )->toString(1)
- )
- );
-};
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-
- my $idl = OpenSRF::Utils::SettingsClient->new->config_value("IDL");
- Fieldmapper->import(IDL => $idl);
-
- $supercat = OpenSRF::AppSession->create('open-ils.supercat');
- $actor = OpenSRF::AppSession->create('open-ils.actor');
- $search = OpenSRF::AppSession->create('open-ils.search');
- $parser = new XML::LibXML;
- $xslt = new XML::LibXSLT;
-
- $cn_browse_xslt = $parser->parse_file(
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/CNBrowse2HTML.xsl"
- );
-
- $cn_browse_xslt = $xslt->parse_stylesheet( $cn_browse_xslt );
-
- my $list = $supercat
- ->request("open-ils.supercat.record.formats")
- ->gather(1);
-
- $list = [ map { (keys %$_)[0] } @$list ];
- push @$list, 'htmlholdings','html', 'marctxt', 'ris';
-
- for my $browse_axis ( qw/title author subject topic series item-age/ ) {
- for my $record_browse_format ( @$list ) {
- {
- my $__f = $record_browse_format;
- my $__a = $browse_axis;
-
- $browse_types{$__a}{$__f} = sub {
- my $record_list = shift;
- my $prev = shift;
- my $next = shift;
- my $real_format = shift || $__f;
- my $unapi = shift;
- my $base = shift;
- my $site = shift;
-
- $log->info("Creating record feed with params [$real_format, $record_list, $unapi, $site]");
- my $feed = create_record_feed( 'record', $real_format, $record_list, $unapi, $site, undef, $real_format =~ /(-full|-uris)$/o ? 1 : 0 );
- $feed->root( "$base/../" );
- $feed->lib( $site );
- $feed->link( next => $next => $feed->type );
- $feed->link( previous => $prev => $feed->type );
-
- return (
- "Content-type: ". $feed->type ."; charset=utf-8\n\n",
- $feed->toString
- );
- };
- }
- }
- }
-
- for my $basic_axis ( qw/authority.title authority.author authority.subject authority.topic/ ) {
- for my $browse_axis ( ($basic_axis, $basic_axis . ".refs") ) {
- {
- my $__f = 'marcxml';
- my $__a = $browse_axis;
-
- $browse_types{$__a}{$__f} = sub {
- my $record_list = shift;
- my $prev = shift;
- my $next = shift;
- my $real_format = shift || $__f;
- my $unapi = shift;
- my $base = shift;
- my $site = shift;
-
- $log->info("Creating record feed with params [$real_format, $record_list, $unapi, $site]");
- my $feed = create_record_feed( 'authority', $real_format, $record_list, $unapi, $site, undef, $real_format =~ /-full$/o ? -1 : 0 );
- $feed->root( "$base/../" );
- $feed->link( next => $next => $feed->type );
- $feed->link( previous => $prev => $feed->type );
-
- return (
- "Content-type: ". $feed->type ."; charset=utf-8\n\n",
- $feed->toString
- );
- };
- }
- }
- }
-}
-
-=head2 parse_feed_type($type)
-
-Determines whether and how a given feed type needs to be "fleshed out"
-with holdings information.
-
-The feed type could end with the string "-full", in which case we want
-to return call numbers, copies, and URIS.
-
-Or the feed type could be "-uris", in which case we want to return
-call numbers and URIS.
-
-Otherwise, we won't return any holdings.
-
-=cut
-
-sub parse_feed_type {
- my $type = shift;
-
- if ($type =~ /-full$/o) {
- return 1;
- }
-
- if ($type =~ /-uris$/o) {
- return "uris";
- }
-
- # Otherwise, we'll return just the facts, ma'am
- return 0;
-}
-
-=head2 supercat_format($format_hashref, $format_type)
-
-Given a reference to a hash containing the namespace_uri,
-docs, and schema location attributes for a set of formats,
-generate the XML description required by the supercat service.
-
-We derive the base type from the format type so that we do not
-have to populate the hash with redundant information.
-
-=cut
-
-sub supercat_format {
- my $h = shift;
- my $type = shift;
-
- (my $base_type = $type) =~ s/(-full|-uris)$//o;
-
- my $format = "<format><name>$type</name><type>application/xml</type>";
-
- for my $part ( qw/namespace_uri docs schema_location/ ) {
- $format .= "<$part>$$h{$base_type}{$part}</$part>"
- if ($$h{$base_type}{$part});
- }
-
- $format .= '</format>';
-
- return $format;
-}
-
-=head2 unapi_format($format_hashref, $format_type)
-
-Given a reference to a hash containing the namespace_uri,
-docs, and schema location attributes for a set of formats,
-generate the XML description required by the supercat service.
-
-We derive the base type from the format type so that we do not
-have to populate the hash with redundant information.
-
-=cut
-
-sub unapi_format {
- my $h = shift;
- my $type = shift;
-
- (my $base_type = $type) =~ s/(-full|-uris)$//o;
-
- my $format = "<format name='$type' type='application/xml'";
-
- for my $part ( qw/namespace_uri docs schema_location/ ) {
- $format .= " $part='$$h{$base_type}{$part}'"
- if ($$h{$base_type}{$part});
- }
-
- $format .= "/>\n";
-
- return $format;
-}
-
-
-sub oisbn {
-
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- (my $isbn = $apache->path_info) =~ s{^.*?([^/]+)$}{$1}o;
-
- my $list = $supercat
- ->request("open-ils.supercat.oisbn", $isbn)
- ->gather(1);
-
- print "Content-type: application/xml; charset=utf-8\n\n";
- print "<?xml version='1.0' encoding='UTF-8' ?>\n";
-
- unless (exists $$list{metarecord}) {
- print '<idlist/>';
- return Apache2::Const::OK;
- }
-
- print "<idlist metarecord='$$list{metarecord}'>\n";
-
- for ( keys %{ $$list{record_list} } ) {
- (my $o = $$list{record_list}{$_}) =~s/^(\S+).*?$/$1/o;
- print " <isbn record='$_'>$o</isbn>\n"
- }
-
- print "</idlist>\n";
-
- return Apache2::Const::OK;
-}
-
-sub unapi {
-
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'unapi', $url)[0];
- my $base = (split 'unapi', $url)[0] . 'unapi';
-
-
- my $uri = $cgi->param('id') || '';
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $skin = $cgi->param('skin') || 'default';
- my $locale = $cgi->param('locale') || 'en-US';
-
- # Enable localized results of copy status, etc
- $supercat->session_locale($locale);
-
- my $format = $cgi->param('format');
- my $flesh_feed = parse_feed_type($format);
- (my $base_format = $format) =~ s/(-full|-uris)$//o;
- my ($id,$type,$command,$lib,$depth,$paging) = ('','','');
-
- if (!$format) {
- my $body = "Content-type: application/xml; charset=utf-8\n\n";
-
- if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
- $id = $2;
- $paging = $3;
- ($lib,$depth) = split('/', $4);
- $type = 'record';
- $type = 'metarecord' if ($1 =~ /^m/o);
- $type = 'authority' if ($1 =~ /^authority/o);
-
- my $list = $supercat
- ->request("open-ils.supercat.$type.formats")
- ->gather(1);
-
- if ($type eq 'record' or $type eq 'isbn') {
- $body .= <<" FORMATS";
-<formats id='$uri'>
- <format name='opac' type='text/html'/>
- <format name='html' type='text/html'/>
- <format name='htmlholdings' type='text/html'/>
- <format name='holdings_xml' type='application/xml'/>
- <format name='holdings_xml-full' type='application/xml'/>
- <format name='html-full' type='text/html'/>
- <format name='htmlholdings-full' type='text/html'/>
- <format name='marctxt' type='text/plain'/>
- <format name='ris' type='text/plain'/>
- FORMATS
- } elsif ($type eq 'metarecord') {
- $body .= <<" FORMATS";
- <formats id='$uri'>
- <format name='opac' type='text/html'/>
- FORMATS
- } else {
- $body .= <<" FORMATS";
- <formats id='$uri'>
- FORMATS
- }
-
- for my $h (@$list) {
- my ($type) = keys %$h;
- $body .= unapi_format($h, $type);
-
- if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
- $body .= unapi_format($h, "$type-full");
- $body .= unapi_format($h, "$type-uris");
- }
- }
-
- $body .= "</formats>\n";
-
- } else {
- my $list = $supercat
- ->request("open-ils.supercat.$type.formats")
- ->gather(1);
-
- push @$list,
- @{ $supercat
- ->request("open-ils.supercat.metarecord.formats")
- ->gather(1);
- };
-
- my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
- $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
-
- $body .= <<" FORMATS";
-<formats>
- <format name='opac' type='text/html'/>
- <format name='html' type='text/html'/>
- <format name='htmlholdings' type='text/html'/>
- <format name='holdings_xml' type='application/xml'/>
- <format name='holdings_xml-full' type='application/xml'/>
- <format name='html-full' type='text/html'/>
- <format name='htmlholdings-full' type='text/html'/>
- <format name='marctxt' type='text/plain'/>
- <format name='ris' type='text/plain'/>
- FORMATS
-
-
- for my $h (@$list) {
- my ($type) = keys %$h;
- $body .= "\t" . unapi_format($h, $type);
-
- if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
- $body .= "\t" . unapi_format($h, "$type-full");
- $body .= "\t" . unapi_format($h, "$type-uris");
- }
- }
-
- $body .= "</formats>\n";
-
- }
- print $body;
- return Apache2::Const::OK;
- }
-
- my $scheme;
- if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
- $scheme = $1;
- $id = $2;
- $paging = $3;
- ($lib,$depth) = split('/', $4);
- $type = 'record';
- $type = 'metarecord' if ($scheme =~ /^metabib/o);
- $type = 'isbn' if ($scheme =~ /^isbn/o);
- $type = 'acp' if ($scheme =~ /^asset-copy/o);
- $type = 'acn' if ($scheme =~ /^asset-call_number/o);
- $type = 'auri' if ($scheme =~ /^asset-uri/o);
- $type = 'authority' if ($scheme =~ /^authority/o);
- $command = 'retrieve';
- $command = 'browse' if (grep { $scheme eq $_ } qw/call_number title author subject topic authority.title authority.author authority.subject authority.topic series item-age/);
- }
-
- if ($paging) {
- $paging = [split ',', $paging];
- } else {
- $paging = [];
- }
-
- if (!$lib || $lib eq '-') {
- $lib = $actor->request(
- 'open-ils.actor.org_unit_list.search' => parent_ou => undef
- )->gather(1)->[0]->shortname;
- }
-
- my ($lib_object,$lib_id,$ou_types,$lib_depth);
- if ($type ne 'acn' && $type ne 'acp' && $type ne 'auri') {
- $lib_object = $actor->request(
- 'open-ils.actor.org_unit_list.search' => shortname => $lib
- )->gather(1)->[0];
- $lib_id = $lib_object->id;
-
- $ou_types = $actor->request( 'open-ils.actor.org_types.retrieve' )->gather(1);
- $lib_depth = $depth || (grep { $_->id == $lib_object->ou_type } @$ou_types)[0]->depth;
- }
-
- if ($command eq 'browse') {
- print "Location: $root/browse/$base_format/$scheme/$lib/$id\n\n";
- return 302;
- }
-
- if ($type eq 'isbn') {
- my $rec = $supercat->request('open-ils.supercat.isbn.object.retrieve',$id)->gather(1);
- if (!@$rec) {
- print "Content-type: text/html; charset=utf-8\n\n";
- $apache->custom_response( 404, <<" HTML");
- <html>
- <head>
- <title>Type [$type] with id [$id] not found!</title>
- </head>
- <body>
- <br/>
- <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
- </body>
- </html>
- HTML
- return 404;
- }
- $id = $rec->[0]->id;
- $type = 'record';
- }
-
- if ( !grep
- { (keys(%$_))[0] eq $base_format }
- @{ $supercat->request("open-ils.supercat.$type.formats")->gather(1) }
- and !grep
- { $_ eq $base_format }
- qw/opac html htmlholdings marctxt ris holdings_xml/
- ) {
- print "Content-type: text/html; charset=utf-8\n\n";
- $apache->custom_response( 406, <<" HTML");
- <html>
- <head>
- <title>Invalid format [$format] for type [$type]!</title>
- </head>
- <body>
- <br/>
- <center>Sorry, format $format is not valid for type $type.</center>
- </body>
- </html>
- HTML
- return 406;
- }
-
- if ($format eq 'opac') {
- print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?m=$id&l=$lib_id&d=$lib_depth\n\n"
- if ($type eq 'metarecord');
- print "Location: $root/../../$locale/skin/$skin/xml/rdetail.xml?r=$id&l=$lib_id&d=$lib_depth\n\n"
- if ($type eq 'record');
- return 302;
- } elsif (OpenILS::WWW::SuperCat::Feed->exists($base_format) && ($type ne 'acn' && $type ne 'acp' && $type ne 'auri')) {
- my $feed = create_record_feed(
- $type,
- $format => [ $id ],
- $base,
- $lib,
- $depth,
- $flesh_feed,
- $paging
- );
-
- if (!$feed->count) {
- print "Content-type: text/html; charset=utf-8\n\n";
- $apache->custom_response( 404, <<" HTML");
- <html>
- <head>
- <title>Type [$type] with id [$id] not found!</title>
- </head>
- <body>
- <br/>
- <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
- </body>
- </html>
- HTML
- return 404;
- }
-
- $feed->root($root);
- $feed->creator($host);
- $feed->update_ts();
- $feed->link( unapi => $base) if ($flesh_feed);
-
- print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
- print $U->entityize($feed->toString) . "\n";
-
- return Apache2::Const::OK;
- }
-
- my $method = "open-ils.supercat.$type.$base_format.$command";
- my @params = ($id);
- push @params, $lib, $lib_depth, $flesh_feed, $paging if ($base_format eq 'holdings_xml');
-
- # for acn, acp, etc, the "lib" pathinfo position isn't useful.
- # however, we can have it carry extra options like no_record! (comma separated)
- push @params, { map { ( $_ => 1 ) } split(',', $lib) } if ( grep { $type eq $_} qw/acn acp auri/);
-
- my $req = $supercat->request($method,@params);
- my $data = $req->gather();
-
- if ($req->failed || !$data) {
- print "Content-type: text/html; charset=utf-8\n\n";
- $apache->custom_response( 404, <<" HTML");
- <html>
- <head>
- <title>$type $id not found!</title>
- </head>
- <body>
- <br/>
- <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
- </body>
- </html>
- HTML
- return 404;
- }
-
- print "Content-type: application/xml; charset=utf-8\n\n$data";
-
- if ($base_format eq 'holdings_xml') {
- while (my $c = $req->recv) {
- print $c->content;
- }
- }
-
- return Apache2::Const::OK;
-}
-
-sub supercat {
-
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'supercat', $url)[0];
- my $base = (split 'supercat', $url)[0] . 'supercat';
- my $unapi = (split 'supercat', $url)[0] . 'unapi';
-
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $path = $cgi->path_info;
- my ($id,$type,$format,$command) = reverse split '/', $path;
- my $flesh_feed = parse_feed_type($format);
- (my $base_format = $format) =~ s/(-full|-uris)$//o;
-
- my $skin = $cgi->param('skin') || 'default';
- my $locale = $cgi->param('locale') || 'en-US';
-
- # Enable localized results of copy status, etc
- $supercat->session_locale($locale);
-
- if ( $path =~ m{^/formats(?:/([^\/]+))?$}o ) {
- print "Content-type: application/xml; charset=utf-8\n";
- if ($1) {
- my $list = $supercat
- ->request("open-ils.supercat.$1.formats")
- ->gather(1);
-
- print "\n";
-
- print "<formats>
- <format>
- <name>opac</name>
- <type>text/html</type>
- </format>";
-
- if ($1 eq 'record' or $1 eq 'isbn') {
- print "<format>
- <name>htmlholdings</name>
- <type>text/html</type>
- </format>
- <format>
- <name>html</name>
- <type>text/html</type>
- </format>
- <format>
- <name>htmlholdings-full</name>
- <type>text/html</type>
- </format>
- <format>
- <name>html-full</name>
- <type>text/html</type>
- </format>
- <format>
- <name>marctxt</name>
- <type>text/plain</type>
- </format>
- <format>
- <name>ris</name>
- <type>text/plain</type>
- </format>";
- }
-
- for my $h (@$list) {
- my ($type) = keys %$h;
- print supercat_format($h, $type);
-
- if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
- print supercat_format($h, "$type-full");
- print supercat_format($h, "$type-uris");
- }
-
- }
-
- print "</formats>\n";
-
- return Apache2::Const::OK;
- }
-
- my $list = $supercat
- ->request("open-ils.supercat.record.formats")
- ->gather(1);
-
- push @$list,
- @{ $supercat
- ->request("open-ils.supercat.metarecord.formats")
- ->gather(1);
- };
-
- my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
- $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
-
- print "\n<formats>
- <format>
- <name>opac</name>
- <type>text/html</type>
- </format>
- <format>
- <name>htmlholdings</name>
- <type>text/html</type>
- </format>
- <format>
- <name>html</name>
- <type>text/html</type>
- </format>
- <format>
- <name>htmlholdings-full</name>
- <type>text/html</type>
- </format>
- <format>
- <name>html-full</name>
- <type>text/html</type>
- </format>
- <format>
- <name>marctxt</name>
- <type>text/plain</type>
- </format>
- <format>
- <name>ris</name>
- <type>text/plain</type>
- </format>";
-
- for my $h (@$list) {
- my ($type) = keys %$h;
- print supercat_format($h, $type);
-
- if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
- print supercat_format($h, "$type-full");
- print supercat_format($h, "$type-uris");
- }
-
- }
-
- print "</formats>\n";
-
-
- return Apache2::Const::OK;
- }
-
- if ($format eq 'opac') {
- print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?m=$id\n\n"
- if ($type eq 'metarecord');
- print "Location: $root/../../$locale/skin/$skin/xml/rdetail.xml?r=$id\n\n"
- if ($type eq 'record');
- return 302;
-
- } elsif ($base_format eq 'marc21') {
-
- my $ret = 200;
- try {
- my $bib = $supercat->request( "open-ils.supercat.record.object.retrieve", $id )->gather(1)->[0];
-
- print "Content-type: application/octet-stream\n\n" . MARC::Record->new_from_xml( $bib->marc, 'UTF-8', 'USMARC' )->as_usmarc;
-
- } otherwise {
- warn shift();
-
- print "Content-type: text/html; charset=utf-8\n\n";
- $apache->custom_response( 404, <<" HTML");
- <html>
- <head>
- <title>ERROR</title>
- </head>
- <body>
- <br/>
- <center>Couldn't fetch $id as MARC21.</center>
- </body>
- </html>
- HTML
- $ret = 404;
- };
-
- return Apache2::Const::OK;
-
- } elsif (OpenILS::WWW::SuperCat::Feed->exists($base_format)) {
- my $feed = create_record_feed(
- $type,
- $format => [ $id ],
- undef, undef, undef,
- $flesh_feed
- );
-
- $feed->root($root);
- $feed->creator($host);
-
- $feed->update_ts();
-
- $feed->link( unapi => $base) if ($flesh_feed);
-
- print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
- print $U->entityize($feed->toString) . "\n";
-
- return Apache2::Const::OK;
- }
-
- my $req = $supercat->request("open-ils.supercat.$type.$format.$command",$id);
- $req->wait_complete;
-
- if ($req->failed) {
- print "Content-type: text/html; charset=utf-8\n\n";
- $apache->custom_response( 404, <<" HTML");
- <html>
- <head>
- <title>$type $id not found!</title>
- </head>
- <body>
- <br/>
- <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
- </body>
- </html>
- HTML
- return 404;
- }
-
- print "Content-type: application/xml; charset=utf-8\n\n";
- print $U->entityize( $parser->parse_string( $req->gather(1) )->documentElement->toString );
-
- return Apache2::Const::OK;
-}
-
-
-sub bookbag_feed {
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
-
- my $year = (gmtime())[5] + 1900;
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'feed', $url)[0] . '/';
- my $base = (split 'bookbag', $url)[0] . '/bookbag';
- my $unapi = (split 'feed', $url)[0] . '/unapi';
-
- my $skin = $cgi->param('skin') || 'default';
- my $locale = $cgi->param('locale') || 'en-US';
- my $org = $cgi->param('searchOrg');
-
- # Enable localized results of copy status, etc
- $supercat->session_locale($locale);
-
- my $org_unit = get_ou($org);
- my $scope = "l=" . $org_unit->[0]->id . "&";
-
- $root =~ s{(?<!http:)//}{/}go;
- $base =~ s{(?<!http:)//}{/}go;
- $unapi =~ s{(?<!http:)//}{/}go;
-
- my $path = $cgi->path_info;
- #warn "URL breakdown: $url -> $root -> $base -> $path -> $unapi";
-
- my ($id,$type) = reverse split '/', $path;
- my $flesh_feed = parse_feed_type($type);
-
- my $bucket = $actor->request("open-ils.actor.container.public.flesh", 'biblio', $id)->gather(1);
- return Apache2::Const::NOT_FOUND unless($bucket);
-
- my $bucket_tag = "tag:$host,$year:record_bucket/$id";
- if ($type eq 'opac') {
- print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?$scope" . "rt=list&" .
- join('&', map { "rl=" . $_->target_biblio_record_entry } @{ $bucket->items }) .
- "\n\n";
- return 302;
- }
-
- my $feed = create_record_feed(
- 'record',
- $type,
- [ map { $_->target_biblio_record_entry } @{ $bucket->items } ],
- $unapi,
- $org_unit->[0]->shortname,
- undef,
- $flesh_feed
- );
- $feed->root($root);
- $feed->id($bucket_tag);
-
- $feed->title("Items in Book Bag [".$bucket->name."]");
- $feed->creator($host);
- $feed->update_ts();
-
- $feed->link(alternate => $base . "/rss2-full/$id" => 'application/rss+xml');
- $feed->link(atom => $base . "/atom-full/$id" => 'application/atom+xml');
- $feed->link(html => $base . "/html-full/$id" => 'text/html');
- $feed->link(unapi => $unapi);
-
- $feed->link(
- OPAC =>
- "http://$host/opac/$locale/skin/$skin/xml/rresult.xml?$scope" . "rt=list&" .
- join('&', map { 'rl=' . $_->target_biblio_record_entry } @{$bucket->items} ),
- 'text/html'
- );
-
-
- print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
- print $U->entityize($feed->toString) . "\n";
-
- return Apache2::Const::OK;
-}
-
-sub changes_feed {
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
-
- my $year = (gmtime())[5] + 1900;
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'feed', $url)[0];
- my $base = (split 'freshmeat', $url)[0] . '/freshmeat';
- my $unapi = (split 'feed', $url)[0] . 'unapi';
-
- my $skin = $cgi->param('skin') || 'default';
- my $locale = $cgi->param('locale') || 'en-US';
- my $org = $cgi->param('searchOrg');
-
- # Enable localized results of copy status, etc
- $supercat->session_locale($locale);
-
- my $org_unit = get_ou($org);
- my $scope = "l=" . $org_unit->[0]->id . "&";
-
- my $path = $cgi->path_info;
- #warn "URL breakdown: $url ($rel_name) -> $root -> $base -> $path -> $unapi";
-
- $path =~ s/^\/(?:feed\/)?freshmeat\///og;
-
- my ($type,$rtype,$axis,$limit,$date) = split '/', $path;
- my $flesh_feed = parse_feed_type($type);
-
- $limit ||= 10;
- $limit = 10 if $limit !~ /^\d+$/;
-
- my $list = $supercat->request("open-ils.supercat.$rtype.record.$axis.recent", $date, $limit)->gather(1);
-
- #if ($type eq 'opac') {
- # print "Location: $root/../../en-US/skin/default/xml/rresult.xml?rt=list&" .
- # join('&', map { "rl=" . $_ } @$list) .
- # "\n\n";
- # return 302;
- #}
-
- my $search = 'record';
- if ($rtype eq 'authority') {
- $search = 'authority';
- }
- my $feed = create_record_feed( $search, $type, $list, $unapi, $org_unit->[0]->shortname, undef, $flesh_feed);
- $feed->root($root);
-
- if ($date) {
- $feed->title("Up to $limit recent $rtype ${axis}s from $date forward");
- } else {
- $feed->title("$limit most recent $rtype ${axis}s");
- }
-
- $feed->creator($host);
- $feed->update_ts();
-
- $feed->link(alternate => $base . "/rss2-full/$rtype/$axis/$limit/$date" => 'application/rss+xml');
- $feed->link(atom => $base . "/atom-full/$rtype/$axis/$limit/$date" => 'application/atom+xml');
- $feed->link(html => $base . "/html-full/$rtype/$axis/$limit/$date" => 'text/html');
- $feed->link(unapi => $unapi);
-
- $feed->link(
- OPAC =>
- "http://$host/opac/$locale/skin/$skin/xml/rresult.xml?$scope" . "rt=list&" .
- join('&', map { 'rl=' . $_} @$list ),
- 'text/html'
- );
-
-
- print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
- print $U->entityize($feed->toString) . "\n";
-
- return Apache2::Const::OK;
-}
-
-sub opensearch_osd {
- my $version = shift;
- my $lib = shift;
- my $class = shift;
- my $base = shift;
-
- if ($version eq '1.0') {
- print <<OSD;
-Content-type: application/opensearchdescription+xml; charset=utf-8
-
-<?xml version="1.0" encoding="UTF-8"?>
-<OpenSearchDescription xmlns="http://a9.com/-/spec/opensearchdescription/1.0/">
- <Url>$base/1.0/$lib/-/$class/?searchTerms={searchTerms}&startPage={startPage}&startIndex={startIndex}&count={count}</Url>
- <Format>http://a9.com/-/spec/opensearchrss/1.0/</Format>
- <ShortName>$lib</ShortName>
- <LongName>Search $lib</LongName>
- <Description>Search the $lib OPAC by $class.</Description>
- <Tags>$lib book library</Tags>
- <SampleSearch>harry+potter</SampleSearch>
- <Developer>Mike Rylander for GPLS/PINES</Developer>
- <Contact>feedback\@open-ils.org</Contact>
- <SyndicationRight>open</SyndicationRight>
- <AdultContent>false</AdultContent>
-</OpenSearchDescription>
-OSD
- } else {
- print <<OSD;
-Content-type: application/opensearchdescription+xml; charset=utf-8
-
-<?xml version="1.0" encoding="UTF-8"?>
-<OpenSearchDescription xmlns="http://a9.com/-/spec/opensearch/1.1/">
- <ShortName>$lib</ShortName>
- <Description>Search the $lib OPAC by $class.</Description>
- <Tags>$lib book library</Tags>
- <Url type="application/rss+xml"
- template="$base/1.1/$lib/rss2-full/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
- <Url type="application/atom+xml"
- template="$base/1.1/$lib/atom-full/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
- <Url type="application/x-mods3+xml"
- template="$base/1.1/$lib/mods3/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
- <Url type="application/x-mods+xml"
- template="$base/1.1/$lib/mods/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
- <Url type="application/x-marcxml+xml"
- template="$base/1.1/$lib/marcxml/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
- <Url type="text/html"
- template="$base/1.1/$lib/html-full/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
- <LongName>Search $lib</LongName>
- <Query role="example" searchTerms="harry+potter" />
- <Developer>Mike Rylander for GPLS/PINES</Developer>
- <Contact>feedback\@open-ils.org</Contact>
- <SyndicationRight>open</SyndicationRight>
- <AdultContent>false</AdultContent>
- <Language>en-US</Language>
- <OutputEncoding>UTF-8</OutputEncoding>
- <InputEncoding>UTF-8</InputEncoding>
-</OpenSearchDescription>
-OSD
- }
-
- return Apache2::Const::OK;
-}
-
-sub opensearch_feed {
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
- my $year = (gmtime())[5] + 1900;
-
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'opensearch', $url)[0];
- my $base = (split 'opensearch', $url)[0] . 'opensearch';
- my $unapi = (split 'opensearch', $url)[0] . 'unapi';
-
- my $path = $cgi->path_info;
- #warn "URL breakdown: $url ($rel_name) -> $root -> $base -> $path -> $unapi";
-
- if ($path =~ m{^/?(1\.\d{1})/(?:([^/]+)/)?([^/]+)/osd.xml}o) {
-
- my $version = $1;
- my $lib = uc($2);
- my $class = $3;
-
- if (!$lib || $lib eq '-') {
- $lib = $actor->request(
- 'open-ils.actor.org_unit_list.search' => parent_ou => undef
- )->gather(1)->[0]->shortname;
- }
-
- if ($class eq '-') {
- $class = 'keyword';
- }
-
- return opensearch_osd($version, $lib, $class, $base);
- }
-
-
- my $page = $cgi->param('startPage') || 1;
- my $offset = $cgi->param('startIndex') || 1;
- my $limit = $cgi->param('count') || 10;
-
- $page = 1 if ($page !~ /^\d+$/);
- $offset = 1 if ($offset !~ /^\d+$/);
- $limit = 10 if ($limit !~ /^\d+$/); $limit = 25 if ($limit > 25);
-
- if ($page > 1) {
- $offset = ($page - 1) * $limit;
- } else {
- $offset -= 1;
- }
-
- my ($version,$org,$type,$class,$terms,$sort,$sortdir,$lang) = ('','','','','','','','');
- (undef,$version,$org,$type,$class,$terms,$sort,$sortdir,$lang) = split '/', $path;
-
- $lang = $cgi->param('searchLang') if $cgi->param('searchLang');
- $lang = '' if ($lang eq '*');
-
- $sort = $cgi->param('searchSort') if $cgi->param('searchSort');
- $sort ||= '';
- $sortdir = $cgi->param('searchSortDir') if $cgi->param('searchSortDir');
- $sortdir ||= '';
-
- $terms .= " " if ($terms && $cgi->param('searchTerms'));
- $terms .= $cgi->param('searchTerms') if $cgi->param('searchTerms');
-
- $class = $cgi->param('searchClass') if $cgi->param('searchClass');
- $class ||= '-';
-
- $type = $cgi->param('responseType') if $cgi->param('responseType');
- $type ||= '-';
-
- $org = $cgi->param('searchOrg') if $cgi->param('searchOrg');
- $org ||= '-';
-
-
- my $kwt = $cgi->param('kw');
- my $tit = $cgi->param('ti');
- my $aut = $cgi->param('au');
- my $sut = $cgi->param('su');
- my $set = $cgi->param('se');
-
- $terms .= " " if ($terms && $kwt);
- $terms .= "keyword: $kwt" if ($kwt);
- $terms .= " " if ($terms && $tit);
- $terms .= "title: $tit" if ($tit);
- $terms .= " " if ($terms && $aut);
- $terms .= "author: $aut" if ($aut);
- $terms .= " " if ($terms && $sut);
- $terms .= "subject: $sut" if ($sut);
- $terms .= " " if ($terms && $set);
- $terms .= "series: $set" if ($set);
-
- if ($version eq '1.0') {
- $type = 'rss2';
- } elsif ($type eq '-') {
- $type = 'atom';
- }
- my $flesh_feed = parse_feed_type($type);
-
- $terms = decode_utf8($terms);
- $lang = 'eng' if ($lang eq 'en-US');
-
- $log->debug("OpenSearch terms: $terms");
-
- my $org_unit = get_ou($org);
-
- # Apostrophes break search and get indexed as spaces anyway
- my $safe_terms = $terms;
- $safe_terms =~ s{'}{ }go;
-
- my $recs = $search->request(
- 'open-ils.search.biblio.multiclass.query' => {
- org_unit => $org_unit->[0]->id,
- offset => $offset,
- limit => $limit,
- sort => $sort,
- sort_dir => $sortdir,
- default_class => $class,
- ($lang ? ( 'language' => $lang ) : ()),
- } => $safe_terms => 1
- )->gather(1);
-
- $log->debug("Hits for [$terms]: $recs->{count}");
-
- my $feed = create_record_feed(
- 'record',
- $type,
- [ map { $_->[0] } @{$recs->{ids}} ],
- $unapi,
- $org,
- undef,
- $flesh_feed
- );
-
- $log->debug("Feed created...");
-
- $feed->root($root);
- $feed->lib($org);
- $feed->search($safe_terms);
- $feed->class($class);
-
- $feed->title("Search results for [$terms] at ".$org_unit->[0]->name);
-
- $feed->creator($host);
- $feed->update_ts();
-
- $feed->_create_node(
- $feed->{item_xpath},
- 'http://a9.com/-/spec/opensearch/1.1/',
- 'totalResults',
- $recs->{count},
- );
-
- $feed->_create_node(
- $feed->{item_xpath},
- 'http://a9.com/-/spec/opensearch/1.1/',
- 'startIndex',
- $offset + 1,
- );
-
- $feed->_create_node(
- $feed->{item_xpath},
- 'http://a9.com/-/spec/opensearch/1.1/',
- 'itemsPerPage',
- $limit,
- );
-
- $log->debug("...basic feed data added...");
-
- $feed->link(
- next =>
- $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang&startIndex=" . int($offset + $limit + 1) . "&count=" . $limit =>
- 'application/opensearch+xml'
- ) if ($offset + $limit < $recs->{count});
-
- $feed->link(
- previous =>
- $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang&startIndex=" . int(($offset - $limit) + 1) . "&count=" . $limit =>
- 'application/opensearch+xml'
- ) if ($offset);
-
- $feed->link(
- self =>
- $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
- 'application/opensearch+xml'
- );
-
- $feed->link(
- alternate =>
- $base . "/$version/$org/rss2-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
- 'application/rss+xml'
- );
-
- $feed->link(
- atom =>
- $base . "/$version/$org/atom-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
- 'application/atom+xml'
- );
-
- $feed->link(
- 'html' =>
- $base . "/$version/$org/html/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
- 'text/html'
- );
-
- $feed->link(
- 'html-full' =>
- $base . "/$version/$org/html-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
- 'text/html'
- );
-
- $feed->link( 'unapi-server' => $unapi);
-
- $log->debug("...feed links added...");
-
-# $feed->link(
-# opac =>
-# $root . "../$lang/skin/default/xml/rresult.xml?rt=list&" .
-# join('&', map { 'rl=' . $_->[0] } grep { ref $_ && defined $_->[0] } @{$recs->{ids}} ),
-# 'text/html'
-# );
-
- #print $cgi->header( -type => $feed->type, -charset => 'UTF-8') . entityize($feed->toString) . "\n";
- print $cgi->header( -type => $feed->type, -charset => 'UTF-8') . $feed->toString . "\n";
-
- $log->debug("...and feed returned.");
-
- return Apache2::Const::OK;
-}
-
-sub create_record_feed {
- my $search = shift;
- my $type = shift;
- my $records = shift;
- my $unapi = shift;
-
- my $lib = uc(shift()) || '-';
- my $depth = shift;
- my $flesh = shift;
-
- my $paging = shift;
-
- my $cgi = new CGI;
- my $base = $cgi->url;
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
- $year += 1900;
- $month += 1;
-
- my $tag_prefix = sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d", $month, $day);
-
- my $flesh_feed = defined($flesh) ? $flesh : parse_feed_type($type);
-
- $type =~ s/(-full|-uris)$//o;
-
- my $feed = new OpenILS::WWW::SuperCat::Feed ($type);
- $feed->base($base) if ($flesh);
- $feed->unapi($unapi) if ($flesh);
-
- $type = 'atom' if ($type eq 'html');
- $type = 'marcxml' if (($type eq 'htmlholdings') || ($type eq 'marctxt') || ($type eq 'ris'));
-
- #$records = $supercat->request( "open-ils.supercat.record.object.retrieve", $records )->gather(1);
-
- my $count = 0;
- for my $record (@$records) {
- next unless($record);
-
- #my $rec = $record->id;
- my $rec = $record;
-
- my $item_tag = "$tag_prefix:biblio-record_entry/$rec/$lib";
- $item_tag = "$tag_prefix:metabib-metarecord/$rec/$lib" if ($search eq 'metarecord');
- $item_tag = "$tag_prefix:isbn/$rec/$lib" if ($search eq 'isbn');
- $item_tag .= "/$depth" if (defined($depth));
-
- $item_tag = "$tag_prefix:authority-record_entry/$rec" if ($search eq 'authority');
-
- my $xml = $supercat->request(
- "open-ils.supercat.$search.$type.retrieve",
- $rec
- )->gather(1);
- next unless $xml;
-
- my $node = $feed->add_item($xml);
- next unless $node;
-
- $xml = '';
- if ($lib && ($type eq 'marcxml' || $type eq 'atom') && $flesh > 0) {
- my $r = $supercat->request( "open-ils.supercat.$search.holdings_xml.retrieve", $rec, $lib, $depth, $flesh_feed, $paging );
- while ( !$r->complete ) {
- $xml .= join('', map {$_->content} $r->recv);
- }
- $xml .= join('', map {$_->content} $r->recv);
- $node->add_holdings($xml);
- }
-
- $node->id($item_tag);
- #$node->update_ts(cleanse_ISO8601($record->edit_date));
- $node->link(alternate => $feed->unapi . "?id=$item_tag&format=htmlholdings-full" => 'text/html') if ($flesh > 0);
- $node->link(opac => $feed->unapi . "?id=$item_tag&format=opac") if ($flesh > 0);
- $node->link(unapi => $feed->unapi . "?id=$item_tag") if ($flesh);
- $node->link('unapi-id' => $item_tag) if ($flesh);
- }
-
- return $feed;
-}
-
-sub string_browse {
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
- my $year = (gmtime())[5] + 1900;
-
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'browse', $url)[0];
- my $base = (split 'browse', $url)[0] . 'browse';
- my $unapi = (split 'browse', $url)[0] . 'unapi';
-
- my $path = $cgi->path_info;
- $path =~ s/^\///og;
-
- my ($format,$axis,$site,$string,$page,$page_size) = split '/', $path;
- #warn " >>> $format -> $axis -> $site -> $string -> $page -> $page_size ";
-
- return item_age_browse($apache) if ($axis eq 'item-age'); # short-circut to the item-age sub
-
- my $status = [$cgi->param('status')];
- my $cpLoc = [$cgi->param('copyLocation')];
- $site ||= $cgi->param('searchOrg');
- $page ||= $cgi->param('startPage') || 0;
- $page_size ||= $cgi->param('count') || 9;
-
- $page = 0 if ($page !~ /^-?\d+$/);
- $page_size = 9 if $page_size !~ /^\d+$/;
-
- my $prev = join('/', $base,$format,$axis,$site,$string,$page - 1,$page_size);
- my $next = join('/', $base,$format,$axis,$site,$string,$page + 1,$page_size);
-
- unless ($string and $axis and grep { $axis eq $_ } keys %browse_types) {
- warn "something's wrong...";
- warn " >>> format: $format -> axis: $axis -> site: $site -> string: $string -> page: $page -> page_size: $page_size ";
- return undef;
- }
-
- $string = decode_utf8($string);
- $string =~ s/\+/ /go;
- $string =~ s/'//go;
-
- my $tree = $supercat->request(
- "open-ils.supercat.$axis.browse",
- $string,
- (($axis =~ /^authority/) ? () : ($site)),
- $page_size,
- $page,
- $status,
- $cpLoc
- )->gather(1);
-
- (my $norm_format = $format) =~ s/(-full|-uris)$//o;
-
- my ($header,$content) = $browse_types{$axis}{$norm_format}->($tree,$prev,$next,$format,$unapi,$base,$site);
- print $header.$content;
- return Apache2::Const::OK;
-}
-
-sub string_startwith {
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
- my $year = (gmtime())[5] + 1900;
-
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'startwith', $url)[0];
- my $base = (split 'startwith', $url)[0] . 'startwith';
- my $unapi = (split 'startwith', $url)[0] . 'unapi';
-
- my $path = $cgi->path_info;
- $path =~ s/^\///og;
-
- my ($format,$axis,$site,$string,$page,$page_size) = split '/', $path;
- #warn " >>> $format -> $axis -> $site -> $string -> $page -> $page_size ";
-
- my $status = [$cgi->param('status')];
- my $cpLoc = [$cgi->param('copyLocation')];
- $site ||= $cgi->param('searchOrg');
- $page ||= $cgi->param('startPage') || 0;
- $page_size ||= $cgi->param('count') || 9;
-
- $page = 0 if ($page !~ /^-?\d+$/);
- $page_size = 9 if $page_size !~ /^\d+$/;
-
- my $prev = join('/', $base,$format,$axis,$site,$string,$page - 1,$page_size);
- my $next = join('/', $base,$format,$axis,$site,$string,$page + 1,$page_size);
-
- unless ($string and $axis and grep { $axis eq $_ } keys %browse_types) {
- warn "something's wrong...";
- warn " >>> format: $format -> axis: $axis -> site: $site -> string: $string -> page: $page -> page_size: $page_size ";
- return undef;
- }
-
- $string = decode_utf8($string);
- $string =~ s/\+/ /go;
- $string =~ s/'//go;
-
- my $tree = $supercat->request(
- "open-ils.supercat.$axis.startwith",
- $string,
- (($axis =~ /^authority/) ? () : ($site)),
- $page_size,
- $page,
- $status,
- $cpLoc
- )->gather(1);
-
- (my $norm_format = $format) =~ s/(-full|-uris)$//o;
-
- my ($header,$content) = $browse_types{$axis}{$norm_format}->($tree,$prev,$next,$format,$unapi,$base,$site);
- print $header.$content;
- return Apache2::Const::OK;
-}
-
-sub item_age_browse {
- my $apache = shift;
- return Apache2::Const::DECLINED if (-e $apache->filename);
-
- my $cgi = new CGI;
- my $year = (gmtime())[5] + 1900;
-
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
-
- my $url = $cgi->url(-path_info=>$add_path);
- my $root = (split 'browse', $url)[0];
- my $base = (split 'browse', $url)[0] . 'browse';
- my $unapi = (split 'browse', $url)[0] . 'unapi';
-
- my $path = $cgi->path_info;
- $path =~ s/^\///og;
-
- my ($format,$axis,$site,$page,$page_size) = split '/', $path;
- #warn " >>> $format -> $axis -> $site -> $page -> $page_size ";
-
- unless ($axis eq 'item-age') {
- warn "something's wrong...";
- warn " >>> $format -> $axis -> $site -> $page -> $page_size ";
- return undef;
- }
-
- my $status = [$cgi->param('status')];
- my $cpLoc = [$cgi->param('copyLocation')];
- $site ||= $cgi->param('searchOrg') || '-';
- $page ||= $cgi->param('startPage') || 1;
- $page_size ||= $cgi->param('count') || 10;
-
- $page = 1 if ($page !~ /^-?\d+$/ || $page < 1);
- $page_size = 10 if $page_size !~ /^\d+$/;
-
- my $prev = join('/', $base,$format,$axis,$site,$page - 1,$page_size);
- my $next = join('/', $base,$format,$axis,$site,$page + 1,$page_size);
-
- my $recs = $supercat->request(
- "open-ils.supercat.new_book_list",
- $site,
- $page_size,
- $page,
- $status,
- $cpLoc
- )->gather(1);
-
- (my $norm_format = $format) =~ s/(-full|-uris)$//o;
-
- my ($header,$content) = $browse_types{$axis}{$norm_format}->($recs,$prev,$next,$format,$unapi,$base,$site);
- print $header.$content;
- return Apache2::Const::OK;
-}
-
-our %qualifier_map = (
-
- # Some EG qualifiers
- 'eg.site' => 'site',
- 'eg.sort' => 'sort',
- 'eg.direction' => 'dir',
- 'eg.available' => 'available',
-
- # Title class:
- 'eg.title' => 'title',
- 'dc.title' => 'title',
- 'bib.titleabbreviated' => 'title|abbreviated',
- 'bib.titleuniform' => 'title|uniform',
- 'bib.titletranslated' => 'title|translated',
- 'bib.titlealternative' => 'title',
- 'bib.titleseries' => 'series',
- 'eg.series' => 'title',
-
- # Author/Name class:
- 'eg.author' => 'author',
- 'eg.name' => 'author',
- 'creator' => 'author',
- 'dc.creator' => 'author',
- 'dc.contributer' => 'author',
- 'dc.publisher' => 'keyword',
- 'bib.name' => 'author',
- 'bib.namepersonal' => 'author|personal',
- 'bib.namepersonalfamily'=> 'author|personal',
- 'bib.namepersonalgiven' => 'author|personal',
- 'bib.namecorporate' => 'author|corporate',
- 'bib.nameconference' => 'author|conference',
-
- # Subject class:
- 'eg.subject' => 'subject',
- 'dc.subject' => 'subject',
- 'bib.subjectplace' => 'subject|geographic',
- 'bib.subjecttitle' => 'keyword',
- 'bib.subjectname' => 'subject|name',
- 'bib.subjectoccupation' => 'keyword',
-
- # Keyword class:
- 'eg.keyword' => 'keyword',
- 'srw.serverchoice' => 'keyword',
-
- # Identifiers:
- 'dc.identifier' => 'keyword',
-
- # Dates:
- 'bib.dateissued' => undef,
- 'bib.datecreated' => undef,
- 'bib.datevalid' => undef,
- 'bib.datemodified' => undef,
- 'bib.datecopyright' => undef,
-
- # Resource Type:
- 'dc.type' => undef,
-
- # Format:
- 'dc.format' => undef,
-
- # Genre:
- 'bib.genre' => 'keyword',
-
- # Target Audience:
- 'bib.audience' => undef,
-
- # Place of Origin:
- 'bib.originplace' => undef,
-
- # Language
- 'dc.language' => 'lang',
-
- # Edition
- 'bib.edition' => 'keyword',
-
- # Part:
- 'bib.volume' => 'keyword',
- 'bib.issue' => 'keyword',
- 'bib.startpage' => 'keyword',
- 'bib.endpage' => 'keyword',
-
- # Issuance:
- 'bib.issuance' => 'keyword',
-);
-
-our %qualifier_ids = (
- eg => 'http://open-ils.org/spec/SRU/context-set/evergreen/v1',
- dc => 'info:srw/cql-context-set/1/dc-v1.1',
- bib => 'info:srw/cql-context-set/1/bib-v1.0',
- srw => ''
-);
-
-our %nested_qualifier_map = (
- eg => {
- site => ['site','Evergreen Site Code (shortname)'],
- sort => ['sort','Sort on relevance, title, author, pubdate, create_date or edit_date'],
- direction => ['dir','Sort direction (asc|desc)'],
- available => ['available','Filter to available (true|false)'],
- title => ['title'],
- author => ['author'],
- name => ['author'],
- subject => ['subject'],
- keyword => ['keyword'],
- series => ['series'],
- },
- dc => {
- title => ['title'],
- creator => ['author'],
- contributor => ['author'],
- publisher => ['keyword'],
- subject => ['subject'],
- identifier => ['keyword'],
- type => [undef],
- format => [undef],
- language => ['lang'],
- },
- bib => {
- # Title class:
- titleAbbreviated => ['title'],
- titleUniform => ['title'],
- titleTranslated => ['title'],
- titleAlternative => ['title'],
- titleSeries => ['series'],
-
- # Author/Name class:
- name => ['author'],
- namePersonal => ['author'],
- namePersonalFamily => ['author'],
- namePersonalGiven => ['author'],
- nameCorporate => ['author'],
- nameConference => ['author'],
-
- # Subject class:
- subjectPlace => ['subject'],
- subjectTitle => ['keyword'],
- subjectName => ['subject|name'],
- subjectOccupation => ['keyword'],
-
- # Keyword class:
-
- # Dates:
- dateIssued => [undef],
- dateCreated => [undef],
- dateValid => [undef],
- dateModified => [undef],
- dateCopyright => [undef],
-
- # Genre:
- genre => ['keyword'],
-
- # Target Audience:
- audience => [undef],
-
- # Place of Origin:
- originPlace => [undef],
-
- # Edition
- edition => ['keyword'],
-
- # Part:
- volume => ['keyword'],
- issue => ['keyword'],
- startPage => ['keyword'],
- endPage => ['keyword'],
-
- # Issuance:
- issuance => ['keyword'],
- },
- srw => {
- serverChoice => ['keyword'],
- },
-);
-
-
-my $base_explain = <<XML;
-<explain
- id="evergreen-sru-explain-full"
- authoritative="true"
- xmlns:z="http://explain.z3950.org/dtd/2.0/"
- xmlns="http://explain.z3950.org/dtd/2.0/">
- <serverInfo transport="http" protocol="SRU" version="1.1">
- <host/>
- <port/>
- <database/>
- </serverInfo>
-
- <databaseInfo>
- <title primary="true"/>
- <description primary="true"/>
- </databaseInfo>
-
- <indexInfo>
- <set identifier="info:srw/cql-context-set/1/cql-v1.2" name="cql"/>
- </indexInfo>
-
- <schemaInfo>
- <schema
- identifier="info:srw/schema/1/marcxml-v1.1"
- location="http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
- sort="true"
- retrieve="true"
- name="marcxml">
- <title>MARC21Slim (marcxml)</title>
- </schema>
- </schemaInfo>
-
- <configInfo>
- <default type="numberOfRecords">50</default>
- <default type="contextSet">eg</default>
- <default type="index">keyword</default>
- <default type="relation">all</default>
- <default type="sortSchema">marcxml</default>
- <default type="retrieveSchema">marcxml</default>
- <setting type="maximumRecords">50</setting>
- <supports type="relationModifier">relevant</supports>
- <supports type="relationModifier">stem</supports>
- <supports type="relationModifier">fuzzy</supports>
- <supports type="relationModifier">word</supports>
- </configInfo>
-
-</explain>
-XML
-
-
-my $ex_doc;
-sub sru_search {
- my $cgi = new CGI;
-
- my $req = SRU::Request->newFromCGI( $cgi );
- my $resp = SRU::Response->newFromRequest( $req );
-
- # Find the org_unit shortname, if passed as part of the URL
- # http://example.com/opac/extras/sru/SHORTNAME
- my $url = $cgi->path_info;
- my ($shortname, $holdings) = $url =~ m#/?([^/]*)(/holdings)?#;
-
- if ( $resp->type eq 'searchRetrieve' ) {
-
- # Older versions of Debian packages returned terms to us double-encoded,
- # so we had to forcefully double-decode them a second time with
- # an outer decode('utf8', $string) call; this seems to be resolved with
- # Debian Lenny packages sometime between 2009-07-27 and 2010-02-15
- my $cql_query = decode_utf8($req->query);
- my $search_string = decode_utf8($req->cql->toEvergreen);
-
- # Ensure the search string overrides the default site
- if ($shortname and $search_string !~ m#site:#) {
- $search_string .= " site:$shortname";
- }
-
- my $offset = $req->startRecord;
- $offset-- if ($offset);
- $offset ||= 0;
-
- my $limit = $req->maximumRecords;
- $limit ||= 10;
-
- $log->info("SRU search string [$cql_query] converted to [$search_string]\n");
-
- my $recs = $search->request(
- 'open-ils.search.biblio.multiclass.query' => {offset => $offset, limit => $limit} => $search_string => 1
- )->gather(1);
-
- my $bre = $supercat->request( 'open-ils.supercat.record.object.retrieve' => [ map { $_->[0] } @{$recs->{ids}} ] )->gather(1);
-
- foreach my $record (@$bre) {
- my $marcxml = $record->marc;
- # Make the beast conform to a VDX-supported format
- # See http://vdxipedia.oclc.org/index.php/Holdings_Parsing
- # Trying to implement LIBSOL_852_A format; so much for standards
- if ($holdings) {
- my $bib_holdings = $supercat->request('open-ils.supercat.record.basic_holdings.retrieve', $record->id, $shortname || '-')->gather(1);
- my $marc = MARC::Record->new_from_xml($marcxml, 'UTF8', 'XML');
-
- # Force record leader to 'a' as our data is always UTF8
- # Avoids marc8_to_utf8 from being invoked with horrible results
- # on the off-chance the record leader isn't correct
- my $ldr = $marc->leader;
- substr($ldr, 9, 1, 'a');
- $marc->leader($ldr);
-
- # Expects the record ID in the 001
- $marc->delete_field($_) for ($marc->field('001'));
- if (!$marc->field('001')) {
- $marc->insert_fields_ordered(
- MARC::Field->new( '001', $record->id )
- );
- }
- $marc->delete_field($_) for ($marc->field('852')); # remove any legacy 852s
- foreach my $cn (keys %$bib_holdings) {
- foreach my $cp (@{$bib_holdings->{$cn}->{'copies'}}) {
- $marc->insert_fields_ordered(
- MARC::Field->new(
- '852', '4', '',
- a => $cp->{'location'},
- b => $bib_holdings->{$cn}->{'owning_lib'},
- c => $cn,
- d => $cp->{'circlib'},
- g => $cp->{'barcode'},
- n => $cp->{'status'},
- )
- );
- }
- }
-
- # Ensure the data is encoded as UTF8 before we hand it off
- $marcxml = encode_utf8($marc->as_xml_record());
- $marcxml =~ s/^<\?xml version="1.0" encoding="UTF-8"\?>//o;
-
- }
- $resp->addRecord(
- SRU::Response::Record->new(
- recordSchema => 'info:srw/schema/1/marcxml-v1.1',
- recordData => $marcxml,
- recordPosition => ++$offset
- )
- );
- }
-
- $resp->numberOfRecords($recs->{count});
-
- } elsif ( $resp->type eq 'explain' ) {
- if (!$ex_doc) {
- my $host = $cgi->virtual_host || $cgi->server_name;
-
- my $add_path = 0;
- if ( $cgi->server_software !~ m|^Apache/2.2| ) {
- my $rel_name = $cgi->url(-relative=>1);
- $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
- }
- my $base = $cgi->url(-base=>1);
- my $url = $cgi->url(-path_info=>$add_path);
- $url =~ s/^$base\///o;
-
- my $doc = $parser->parse_string($base_explain);
- my $e = $doc->documentElement;
- $e->findnodes('/z:explain/z:serverInfo/z:host')->shift->appendText( $host );
- $e->findnodes('/z:explain/z:serverInfo/z:port')->shift->appendText( $cgi->server_port );
- $e->findnodes('/z:explain/z:serverInfo/z:database')->shift->appendText( $url );
-
- for my $name ( keys %OpenILS::WWW::SuperCat::nested_qualifier_map ) {
-
- my $identifier = $OpenILS::WWW::SuperCat::qualifier_ids{ $name };
-
- next unless $identifier;
-
- my $set_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'set' );
- $set_node->setAttribute( identifier => $identifier );
- $set_node->setAttribute( name => $name );
-
- $e->findnodes('/z:explain/z:indexInfo')->shift->appendChild( $set_node );
-
- for my $index ( keys %{ $OpenILS::WWW::SuperCat::nested_qualifier_map{$name} } ) {
- my $desc = $OpenILS::WWW::SuperCat::nested_qualifier_map{$name}{$index}[1] || $index;
-
- my $name_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'name' );
-
- my $map_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'map' );
- $map_node->appendChild( $name_node );
-
- my $title_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'title' );
-
- my $index_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'index' );
- $index_node->appendChild( $title_node );
- $index_node->appendChild( $map_node );
-
- $index_node->setAttribute( id => $name . '.' . $index );
- $title_node->appendText( $desc );
- $name_node->setAttribute( set => $name );
- $name_node->appendText($index );
-
- $e->findnodes('/z:explain/z:indexInfo')->shift->appendChild( $index_node );
- }
- }
-
- $ex_doc = $e->toString;
- }
-
- $resp->record(
- SRU::Response::Record->new(
- recordSchema => 'info:srw/cql-context-set/2/zeerex-1.1',
- recordData => $ex_doc
- )
- );
- }
-
- print $cgi->header( -type => 'application/xml' );
- print $U->entityize($resp->asXML) . "\n";
- return Apache2::Const::OK;
-}
-
-
-{
- package CQL::BooleanNode;
-
- sub toEvergreen {
- my $self = shift;
- my $left = $self->left();
- my $right = $self->right();
- my $leftStr = $left->toEvergreen;
- my $rightStr = $right->toEvergreen();
-
- my $op = '||' if uc $self->op() eq 'OR';
- $op ||= '&&';
-
- return "$leftStr $rightStr";
- }
-
- package CQL::TermNode;
-
- sub toEvergreen {
- my $self = shift;
- my $qualifier = $self->getQualifier();
- my $term = $self->getTerm();
- my $relation = $self->getRelation();
-
- my $query;
- if ( $qualifier ) {
- my ($qset, $qname) = split(/\./, $qualifier);
-
- $log->debug("SRU toEvergreen: $qset, $qname $OpenILS::WWW::SuperCat::nested_qualifier_map{$qset}{$qname}[0]\n");
-
- if ( exists($OpenILS::WWW::SuperCat::nested_qualifier_map{$qset}{$qname}) ) {
- $qualifier = $OpenILS::WWW::SuperCat::nested_qualifier_map{$qset}{$qname}[0] || 'kw';
- }
-
- my @modifiers = $relation->getModifiers();
-
- my $base = $relation->getBase();
- if ( grep { $base eq $_ } qw/= scr exact all/ ) {
-
- my $quote_it = 1;
- foreach my $m ( @modifiers ) {
- if( grep { $m->[ 1 ] eq $_ } qw/cql.fuzzy cql.stem cql.relevant cql.word/ ) {
- $quote_it = 0;
- last;
- }
- }
-
- $quote_it = 0 if ( $base eq 'all' );
- $term = maybeQuote($term) if $quote_it;
-
- } else {
- croak( "Evergreen doesn't support the $base relations" );
- }
-
-
- } else {
- $qualifier = "kw";
- }
-
- return "$qualifier:$term";
- }
-}
-
-=head2 get_ou($org_unit)
-
-Returns an aou object for a given actor.org_unit shortname or ID.
-
-=cut
-
-sub get_ou {
- my $org = shift || '-';
- my $org_unit;
-
- if ($org eq '-') {
- $org_unit = $actor->request(
- 'open-ils.actor.org_unit_list.search' => parent_ou => undef
- )->gather(1);
- } elsif ($org !~ /^\d+$/o) {
- $org_unit = $actor->request(
- 'open-ils.actor.org_unit_list.search' => shortname => uc($org)
- )->gather(1);
- } else {
- $org_unit = $actor->request(
- 'open-ils.actor.org_unit_list.search' => id => $org
- )->gather(1);
- }
-
- return $org_unit;
-}
-
-1;
-
-# vim: noet:ts=4:sw=4
+++ /dev/null
-package OpenILS::WWW::SuperCat::Feed;
-use strict; use warnings;
-use vars qw/$parser/;
-use OpenSRF::EX qw(:try);
-use XML::LibXML;
-use XML::LibXSLT;
-use OpenSRF::Utils::SettingsClient;
-use CGI;
-use DateTime;
-use DateTime::Format::Mail;
-
-
-sub exists {
- my $class = shift;
- my $type = shift;
-
- return 1 if UNIVERSAL::can("OpenILS::WWW::SuperCat::Feed::$type" => 'new');
- return 0;
-}
-
-sub new {
- my $class = shift;
- my $type = shift;
- if ($type) {
- $class .= '::'.$type;
- return $class->new;
- }
- throw OpenSRF::EX::ERROR ("I need a feed type!") ;
-}
-
-sub build {
- my $class = shift;
- my $xml = shift;
- return undef unless $xml;
-
- $parser = new XML::LibXML if (!$parser);
-
- my $self = { doc => $parser->parse_string($xml), items => [] };
-
- $self = bless $self => $class;
- $self->{count} = 0;
- return $self;
-}
-
-sub type {
- my $self = shift;
- my $type = shift;
- $self->{type} = $type if ($type);
- return $self->{type};
-}
-
-sub count {
- my $self = shift;
- return $self->{count};
-}
-
-sub search {
- my $self = shift;
- my $search = shift;
- $self->{search} = $search if ($search);
- return $self->{search};
-}
-
-sub class {
- my $self = shift;
- my $search = shift;
- $self->{class} = $search if ($search);
- return $self->{class};
-}
-
-sub Sort {
- my $self = shift;
- my $search = shift;
- $self->{sort} = $search if ($search);
- return $self->{sort};
-}
-
-sub SortDir {
- my $self = shift;
- my $search = shift;
- $self->{sort_dir} = $search if ($search);
- return $self->{sort_dir};
-}
-
-sub lang {
- my $self = shift;
- my $search = shift;
- $self->{lang} = $search if ($search);
- return $self->{lang};
-}
-
-sub lib {
- my $self = shift;
- my $lib = shift;
- $self->{lib} = $lib if ($lib);
- return $self->{lib};
-}
-
-sub base {
- my $self = shift;
- my $base = shift;
- $self->{base} = $base if ($base);
- return $self->{base};
-}
-
-sub root {
- my $self = shift;
- my $root = shift;
- $self->{root} = $root if ($root);
- return $self->{root};
-}
-
-sub unapi {
- my $self = shift;
- my $unapi = shift;
- $self->{unapi} = $unapi if ($unapi);
- return $self->{unapi};
-}
-
-sub push_item {
- my $self = shift;
- $self->{count} += scalar(@_);
- push @{ $self->{items} }, @_;
-}
-
-sub items {
- my $self = shift;
- return @{ $self->{items} } if (wantarray);
- return $self->{items};
-}
-
-sub _add_node {
- my $self = shift;
-
- my $xpath = shift;
- my $new = shift;
-
- for my $node ($self->{doc}->findnodes($xpath)) {
- $node->appendChild($new);
- last;
- }
-}
-
-sub _create_node {
- my $self = shift;
-
- my $xpath = shift;
- my $ns = shift;
- my $name = shift;
- my $text = shift;
- my $attrs = shift;
-
- for my $node ($self->{doc}->findnodes($xpath)) {
- my $new = $self->{doc}->createElement($name) if (!$ns);
- $new = $self->{doc}->createElementNS($ns,$name) if ($ns);
-
- $new->appendChild( $self->{doc}->createTextNode( $text ) )
- if (defined $text);
-
- if (ref($attrs)) {
- for my $key (keys %$attrs) {
- next unless $$attrs{$key};
- $new->setAttribute( $key => $$attrs{$key} );
- }
- }
-
- $node->appendChild( $new );
-
- return $new;
- }
-}
-
-sub add_item {
- my $self = shift;
- my $class = ref($self) || $self;
- $class .= '::item';
-
- my $item_xml = shift;
- my $entry = $class->new($item_xml);
- return undef unless $entry;
-
- $entry->base($self->base);
- $entry->unapi($self->unapi);
-
- $self->push_item($entry);
- return $entry;
-}
-
-sub add_holdings {
- my $self = shift;
- my $holdings_xml = shift;
-
- return $self unless ($holdings_xml);
-
- $parser = new XML::LibXML if (!$parser);
- my $new_doc = $parser->parse_string($holdings_xml);
-
- for my $root ( $self->{doc}->findnodes($self->{holdings_xpath}) ) {
- $root->appendChild($new_doc->documentElement);
- last;
- }
- return $self;
-}
-
-sub composeDoc {
- my $self = shift;
- for my $root ( $self->{doc}->findnodes($self->{item_xpath}) ) {
- for my $item ( $self->items ) {
- $root->appendChild( $item->{doc}->documentElement );
- }
- last;
- }
-}
-
-sub toString {
- my $self = shift;
- $self->composeDoc;
- return $self->{doc}->toString(1);
-}
-
-sub id {};
-sub link {};
-sub title {};
-sub update_ts {};
-sub creator {};
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::atom;
-use base 'OpenILS::WWW::SuperCat::Feed';
-use OpenSRF::Utils qw/:datetime/;
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<feed xmlns:atom="http://www.w3.org/2005/Atom"/>');
- $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', undef);
- $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', 'atom');
- $self->{type} = 'application/atom+xml';
- $self->{item_xpath} = '/atom:feed';
- return $self;
-}
-
-sub title {
- my $self = shift;
- my $text = shift;
- $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','title', $text);
-}
-
-sub update_ts {
- my $self = shift;
- # ATOM demands RFC-3339 compliant datetime formats
- my $text = shift || gmtime_ISO8601();
- $self->_create_node($self->{item_xpath},'http://www.w3.org/2005/Atom','updated', $text);
-}
-
-sub creator {
- my $self = shift;
- my $text = shift;
- $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','author');
- $self->_create_node('/atom:feed/atom:author', 'http://www.w3.org/2005/Atom','name', $text);
-}
-
-sub link {
- my $self = shift;
- my $type = shift;
- my $id = shift;
- my $mime = shift || "application/x-$type+xml";
- my $title = shift;
-
- $type = 'self' if ($type eq 'atom');
-
- $self->_create_node(
- $self->{item_xpath},
- 'http://www.w3.org/2005/Atom',
- 'link',
- undef,
- { rel => $type,
- href => $id,
- title => $title,
- type => $mime,
- }
- );
-}
-
-sub id {
- my $self = shift;
- my $id = shift;
-
- $self->_create_node( $self->{item_xpath}, 'http://www.w3.org/2005/Atom', 'id', $id );
-}
-
-package OpenILS::WWW::SuperCat::Feed::atom::item;
-use base 'OpenILS::WWW::SuperCat::Feed::atom';
-
-sub new {
- my $class = shift;
- my $xml = shift;
- my $self = $class->SUPER::build($xml);
- $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', undef);
- $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', 'atom');
- $self->{item_xpath} = '/atom:entry';
- $self->{holdings_xpath} = '/atom:entry';
- $self->{type} = 'application/atom+xml';
- return $self;
-}
-
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::rss2;
-use base 'OpenILS::WWW::SuperCat::Feed';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<rss version="2.0"><channel/></rss>');
- $self->{type} = 'application/rss+xml';
- $self->{item_xpath} = '/rss/channel';
- return $self;
-}
-
-sub title {
- my $self = shift;
- my $text = shift;
- $self->_create_node('/rss/channel',undef,'title', $text);
- # RSS2 demands a /channel/description element; just dupe title until we give
- # users the ability to provide a description for their bookbags
- $self->_create_node('/rss/channel',undef,'description', $text);
-}
-
-sub update_ts {
- my $self = shift;
- # RSS2 demands RFC-822 compliant datetime formats
- my $text = shift || DateTime::Format::Mail->format_datetime(DateTime->now());
- $self->_create_node($self->{item_xpath},undef,'lastBuildDate', $text);
-}
-
-sub creator {
- my $self = shift;
- my $text = shift;
- $self->_create_node('/rss/channel', undef,'generator', $text);
-}
-
-sub link {
- my $self = shift;
- my $type = shift;
- my $id = shift;
- my $mime = shift || "application/x-$type+xml";
-
- if ($type eq 'rss2' or $type eq 'alternate') {
- # Just link to ourself using standard RSS2 link element
- $self->_create_node(
- $self->{item_xpath},
- undef,
- 'link',
- $id,
- undef
- );
- } else {
- # Alternate link: use XHTML link element
- $self->_create_node(
- $self->{item_xpath},
- 'http://www.w3.org/1999/xhtml',
- 'xhtml:link',
- $id,
- { rel => $type,
- type => $mime,
- }
- );
- }
-}
-
-sub id {
- my $self = shift;
- my $id = shift;
-
- $self->_create_node($self->{item_xpath}, undef,'guid', $id);
-}
-
-package OpenILS::WWW::SuperCat::Feed::rss2::item;
-use base 'OpenILS::WWW::SuperCat::Feed::rss2';
-
-sub new {
- my $class = shift;
- my $xml = shift;
- my $self = $class->SUPER::build($xml);
- $self->{type} = 'application/rss+xml';
- $self->{item_xpath} = '/item';
- $self->{holdings_xpath} = '/item';
- return $self;
-}
-
-sub update_ts {
- my $self = shift;
- # RSS2 demands RFC-822 compliant datetime formats
- my $text = shift;
- if (!$text) {
- # No date passed in, default to now
- $text = DateTime::Format::Mail->format_datetime(DateTime->now());
- } elsif ($text =~ m/^\s*(\d{4})\.?\s*$/o) {
- # Publication date is just a year, convert accordingly
- my $year = DateTime->new(year=>$1);
- $text = DateTime::Format::Mail->format_datetime($year);
- }
- $self->_create_node($self->{item_xpath},undef,'pubDate', $text);
-}
-
-sub id {
- my $self = shift;
- my $id = shift;
-
- $self->_create_node(
- $self->{item_xpath},
- undef,
- 'guid',
- $id,
- {
- isPermaLink=>"false"
- }
- );
-}
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::mods;
-use base 'OpenILS::WWW::SuperCat::Feed';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<modsCollection version="3.0" xmlns="http://www.loc.gov/mods/" xmlns:mods="http://www.loc.gov/mods/"/>');
- $self->{type} = 'application/xml';
- $self->{item_xpath} = '/mods:modsCollection';
- return $self;
-}
-
-package OpenILS::WWW::SuperCat::Feed::mods::item;
-use base 'OpenILS::WWW::SuperCat::Feed::mods';
-
-sub new {
- my $class = shift;
- my $xml = shift;
- my $self = $class->SUPER::build($xml);
- $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/', 'mods');
- $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/', undef, 1);
- $self->{type} = 'application/xml';
- $self->{holdings_xpath} = '/mods:mods';
- return $self;
-}
-
-my $linkid = 1;
-
-sub link {
- my $self = shift;
- my $type = shift;
- my $id = shift;
-
- if ($type eq 'unapi' || $type eq 'opac') {
- $self->_create_node(
- 'mods:mods',
- undef,
- 'relatedItem',
- undef,
- { type => 'otherFormat', id => 'link-'.$linkid }
- );
- $self->_create_node(
- "mods:mods/relatedItem[\@id='link-$linkid']",
- undef,
- 'recordIdentifier',
- $id
- );
- $linkid++;
- }
-}
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::mods3;
-use base 'OpenILS::WWW::SuperCat::Feed::mods';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<modsCollection version="3.0" xmlns="http://www.loc.gov/mods/v3" xmlns:mods="http://www.loc.gov/mods/v3"/>');
- $self->{type} = 'application/xml';
- $self->{item_xpath} = '/mods:modsCollection';
- return $self;
-}
-
-package OpenILS::WWW::SuperCat::Feed::mods3::item;
-use base 'OpenILS::WWW::SuperCat::Feed::mods::item';
-
-sub new {
- my $class = shift;
- my $xml = shift;
- my $self = $class->SUPER::build($xml);
- $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/v3', 'mods');
- $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/v3', undef, 1);
- $self->{type} = 'application/xml';
- $self->{holdings_xpath} = '/mods:mods';
- return $self;
-}
-
-sub link {
- my $self = shift;
- my $type = shift;
- my $id = shift;
-
- if ($type eq 'unapi' || $type eq 'opac') {
- $self->_create_node(
- 'mods:mods',
- undef,
- 'relatedItem',
- undef,
- { type => 'otherFormat', id => 'link-'.$linkid }
- );
- $self->_create_node(
- "mods:mods/relatedItem[\@id='link-$linkid']",
- undef,
- 'recordIdentifier',
- $id
- );
- $linkid++;
- }
-}
-
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::mods32;
-use base 'OpenILS::WWW::SuperCat::Feed::mods3';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<modsCollection version="3.2" xmlns="http://www.loc.gov/mods/v3" xmlns:mods="http://www.loc.gov/mods/v3"/>');
- $self->{type} = 'application/xml';
- $self->{item_xpath} = '/mods:modsCollection';
- return $self;
-}
-
-package OpenILS::WWW::SuperCat::Feed::mods32::item;
-use base 'OpenILS::WWW::SuperCat::Feed::mods3::item';
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::mods33;
-use base 'OpenILS::WWW::SuperCat::Feed::mods3';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<modsCollection version="3.3" xmlns="http://www.loc.gov/mods/v3" xmlns:mods="http://www.loc.gov/mods/v3"/>');
- $self->{type} = 'application/xml';
- $self->{item_xpath} = '/mods:modsCollection';
- return $self;
-}
-
-package OpenILS::WWW::SuperCat::Feed::mods33::item;
-use base 'OpenILS::WWW::SuperCat::Feed::mods3::item';
-
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::marcxml;
-use base 'OpenILS::WWW::SuperCat::Feed';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::build('<collection xmlns="http://www.loc.gov/MARC21/slim" xmlns:marc="http://www.loc.gov/MARC21/slim"/>');
- $self->{type} = 'application/xml';
- $self->{item_xpath} = '/marc:collection';
- return $self;
-}
-sub link {
- my $self = shift;
- my $type = shift;
- my $id = shift;
-
- if ($type eq 'unapi') {
- $self->_create_node(
- 'marc:collection',
- 'http://www.w3.org/1999/xhtml',
- 'xhtml:link',
- undef,
- { rel => 'unapi-server', href => $id, title => "unapi" }
- );
- $linkid++;
- }
-}
-
-
-package OpenILS::WWW::SuperCat::Feed::marcxml::item;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
-
-sub new {
- my $class = shift;
- my $xml = shift;
- my $self = $class->SUPER::build($xml);
- return undef unless $self;
- $self->{doc}->documentElement->setNamespace('http://www.loc.gov/MARC21/slim', undef);
- $self->{type} = 'application/xml';
- $self->{holdings_xpath} = '/*[local-name()="record"]';
- return $self;
-}
-
-sub link {
- my $self = shift;
- my $type = shift;
- my $id = shift;
-
- if ($type eq 'opac') {
- $self->_create_node(
- '*[local-name()="record"]',
- 'http://www.w3.org/1999/xhtml',
- 'xhtml:link',
- undef,
- { rel => 'otherFormat', href => $id, title => "Dynamic Details" }
- );
- $linkid++;
- } elsif ($type eq 'unapi-id') {
- $self->_create_node(
- '*[local-name()="record"]',
- 'http://www.w3.org/1999/xhtml',
- 'xhtml:abbr',
- undef,
- { title => $id, class => "unapi-id" }
- );
- $linkid++;
- }
-}
-
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::html;
-use base 'OpenILS::WWW::SuperCat::Feed::atom';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
- $self->type('text/html');
- return $self;
-}
-
-our ($_parser, $_xslt, $xslt_file);
-
-sub toString {
- my $self = shift;
- my $base = $self->base || '';
- my $root = $self->root || '';
- my $search = $self->search || '';
- my $class = $self->class || '';
- my $lib = $self->lib || '-';
-
- $self->composeDoc;
-
- $_parser ||= new XML::LibXML;
- $_xslt ||= new XML::LibXSLT;
-
- $xslt_file ||=
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- "/ATOM2XHTML.xsl";
-
- # parse the MODS xslt ...
- my $atom2html_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
-
- my $new_doc = $atom2html_xslt->transform(
- $self->{doc},
- base_dir => "'$root'",
- lib => "'$lib'",
- searchTerms => "'$search'",
- searchClass => "'$class'",
- );
-
- return $new_doc->toString(1);
-}
-
-
-package OpenILS::WWW::SuperCat::Feed::html::item;
-use base 'OpenILS::WWW::SuperCat::Feed::atom::item';
-
-#----------------------------------------------------------
-
-package OpenILS::WWW::SuperCat::Feed::htmlcard;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
- $self->type('text/html');
- $self->{xsl} = "/MARC21slim2HTMLCard.xsl";
- return $self;
-}
-
-our ($_parser, $_xslt, $xslt_file);
-
-sub toString {
- my $self = shift;
- my $base = $self->base || '';
- my $root = $self->root || '';
- my $search = $self->search || '';
- my $sort = $self->Sort || '';
- my $sort_dir = $self->SortDir || '';
- my $lang = $self->lang || '';
- my $lib = $self->lib || '-';
-
- $self->composeDoc;
-
- $_parser ||= new XML::LibXML;
- $_xslt ||= new XML::LibXSLT;
-
- $xslt_file =
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).$self->{xsl};
-
- # parse the MODS xslt ...
- my $atom2html_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
-
- my $new_doc = $atom2html_xslt->transform(
- $self->{doc},
- base_dir => "'$root'",
- lib => "'$lib'",
- searchTerms => "'$search'",
- searchSort => "'$sort'",
- searchSortDir => "'$sort_dir'",
- searchLang => "'$lang'",
- );
-
- return $new_doc->toString(1);
-}
-
-package OpenILS::WWW::SuperCat::Feed::htmlcard::item;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml::item';
-
-package OpenILS::WWW::SuperCat::Feed::htmlholdings;
-use base 'OpenILS::WWW::SuperCat::Feed::htmlcard';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
- $self->{xsl} = "/MARC21slim2HTMLCard-holdings.xsl";
- return $self;
-}
-
-package OpenILS::WWW::SuperCat::Feed::htmlholdings::item;
-use base 'OpenILS::WWW::SuperCat::Feed::htmlcard::item';
-
-
-package OpenILS::WWW::SuperCat::Feed::marctxt;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
- $self->{type} = 'text/plain';
- $self->{xsl} = "/MARC21slim2MARCtxt.xsl";
- return $self;
-}
-
-
-our ($_parser, $_xslt, $xslt_file);
-
-sub toString {
- my $self = shift;
- my $base = $self->base || '';
- my $root = $self->root || '';
- my $search = $self->search || '';
- my $class = $self->class || '';
- my $lib = $self->lib || '-';
-
- $self->composeDoc;
-
- $_parser ||= new XML::LibXML;
- $_xslt ||= new XML::LibXSLT;
-
- $xslt_file ||=
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- $self->{xsl};
-
- # parse the MARC text xslt ...
- my $marctxt_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
-
- my $new_doc = $marctxt_xslt->transform(
- $self->{doc},
- base_dir => "'$root'",
- lib => "'$lib'",
- searchTerms => "'$search'",
- searchClass => "'$class'",
- );
-
- return $marctxt_xslt->output_string($new_doc);
-}
-
-
-package OpenILS::WWW::SuperCat::Feed::marctxt::item;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml::item';
-
-
-package OpenILS::WWW::SuperCat::Feed::ris;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
-
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
- $self->{type} = 'text/plain';
- $self->{xsl} = "/MARC21slim2RIS.xsl";
- return $self;
-}
-
-
-our ($_parser, $_xslt, $xslt_file);
-
-sub toString {
- my $self = shift;
- my $base = $self->base || '';
- my $root = $self->root || '';
- my $search = $self->search || '';
- my $class = $self->class || '';
- my $lib = $self->lib || '-';
-
- $self->composeDoc;
-
- $_parser ||= new XML::LibXML;
- $_xslt ||= new XML::LibXSLT;
-
- $xslt_file ||=
- OpenSRF::Utils::SettingsClient
- ->new
- ->config_value( dirs => 'xsl' ).
- $self->{xsl};
-
- # parse the MARC text xslt ...
- my $ris_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
-
- my $new_doc = $ris_xslt->transform(
- $self->{doc},
- base_dir => "'$root'",
- lib => "'$lib'",
- searchTerms => "'$search'",
- searchClass => "'$class'",
- );
-
- return $ris_xslt->output_string($new_doc);
-}
-
-
-package OpenILS::WWW::SuperCat::Feed::ris::item;
-use base 'OpenILS::WWW::SuperCat::Feed::marcxml::item';
-
-
-1;
+++ /dev/null
-package OpenILS::WWW::TemplateBatchBibUpdate;
-use strict;
-use warnings;
-use bytes;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use APR::Table;
-
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-use Data::Dumper;
-use Text::CSV;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils qw/:datetime/;
-use OpenSRF::Utils::Cache;
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use XML::LibXML;
-use XML::LibXSLT;
-
-use Encode;
-use Unicode::Normalize;
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use MARC::Record;
-use MARC::File::XML;
-
-use UNIVERSAL::require;
-
-our @formats = qw/USMARC UNIMARC XML BRE/;
-
-# set the bootstrap config and template include directory when
-# this module is loaded
-my $bootstrap;
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
- Fieldmapper->import(IDL => OpenSRF::Utils::SettingsClient->new->config_value("IDL"));
-}
-
-sub handler {
- my $r = shift;
- my $cgi = new CGI;
-
- my $authid = $cgi->cookie('ses') || $cgi->param('ses');
- my $usr = verify_login($authid);
- return show_template($r) unless ($usr);
-
- my $template = $cgi->param('template');
- return show_template($r) unless ($template);
-
-
- my $rsource = $cgi->param('recordSource');
- # find some IDs ...
- my @records;
-
- if ($rsource eq 'r') {
- @records = map { $_ ? ($_) : () } $cgi->param('recid');
- }
-
- if ($rsource eq 'c') { # try for a file
- my $file = $cgi->param('idfile');
- if ($file) {
- my $col = $cgi->param('idcolumn') || 0;
- my $csv = new Text::CSV;
-
- while (<$file>) {
- $csv->parse($_);
- my @data = $csv->fields;
- my $id = $data[$col];
- $id =~ s/\D+//o;
- next unless ($id);
- push @records, $id;
- }
- }
- }
-
- my $e = OpenSRF::AppSession->connect('open-ils.cstore');
- $e->request('open-ils.cstore.transaction.begin')->gather(1);
-
- # still no records ...
- my $container = $cgi->param('containerid');
- if ($rsource eq 'b') {
- if ($container) {
- my $bucket = $e->request(
- 'open-ils.cstore.direct.container.biblio_record_entry_bucket.retrieve',
- $container
- )->gather(1);
- unless($bucket) {
- $e->request('open-ils.cstore.transaction.rollback')->gather(1);
- $e->disconnect;
- $r->log->error("No such bucket $container");
- $logger->error("No such bucket $container");
- return Apache2::Const::NOT_FOUND;
- }
- my $recs = $e->request(
- 'open-ils.cstore.direct.container.biblio_record_entry_bucket_item.search.atomic',
- { bucket => $container }
- )->gather(1);
- @records = map { ($_->target_biblio_record_entry) } @$recs;
- }
- }
-
- unless (@records) {
- $e->request('open-ils.cstore.transaction.rollback')->gather(1);
- $e->disconnect;
- return show_template($r);
- }
-
- # we have a template and some record ids, so...
-
- # insert the template record
- my $min_id = $e->request(
- 'open-ils.cstore.json_query',
- { select => { bre => [{ column => 'id', transform => 'min', aggregate => 1}] }, from => 'bre' }
- )->gather(1)->{id} - 1;
-
- warn "new template bib id = $min_id\n";
-
- my $tmpl_rec = Fieldmapper::biblio::record_entry->new;
- $tmpl_rec->id($min_id);
- $tmpl_rec->deleted('t');
- $tmpl_rec->active('f');
- $tmpl_rec->marc($template);
- $tmpl_rec->creator($usr->id);
- $tmpl_rec->editor($usr->id);
-
- warn "about to create bib $min_id\n";
- $e->request('open-ils.cstore.direct.biblio.record_entry.create', $tmpl_rec )->gather(1);
-
- # create the new container for the records and the template
- my $bucket = Fieldmapper::container::biblio_record_entry_bucket->new;
- $bucket->owner($usr->id);
- $bucket->btype('template_merge');
-
- my $bname = $cgi->param('bname') || 'Temporary Merge Bucket '. localtime() . ' ' . $usr->id;
- $bucket->name($bname);
-
- $bucket = $e->request('open-ils.cstore.direct.container.biblio_record_entry_bucket.create', $bucket )->gather(1);
-
- # create items in the bucket
- my $item = Fieldmapper::container::biblio_record_entry_bucket_item->new;
- $item->bucket($bucket->id);
- $item->target_biblio_record_entry($min_id);
-
- $e->request('open-ils.cstore.direct.container.biblio_record_entry_bucket_item.create', $item )->gather(1);
-
- my %seen;
- for my $r (@records) {
- next if ($seen{$r});
- $item->target_biblio_record_entry($r);
- $e->request('open-ils.cstore.direct.container.biblio_record_entry_bucket_item.create', $item )->gather(1);
- $seen{$r}++;
- }
-
- $e->request('open-ils.cstore.transaction.commit')->gather(1);
- $e->disconnect;
-
- # fire the background bucket processor
- my $cache_key = OpenSRF::AppSession
- ->create('open-ils.cat')
- ->request('open-ils.cat.container.template_overlay.background', $authid, $bucket->id)
- ->gather(1);
-
- return show_processing_template($r, $bucket->id, \@records, $cache_key);
-}
-
-sub verify_login {
- my $auth_token = shift;
- return undef unless $auth_token;
-
- my $user = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( "open-ils.auth.session.retrieve", $auth_token )
- ->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return undef;
- }
-
- return $user if ref($user);
- return undef;
-}
-
-sub show_processing_template {
- my $r = shift;
- my $bid = shift;
- my $recs = shift;
- my $cache_key = shift;
-
- my $rec_string = @$recs;
-
- $r->content_type('text/html');
- $r->print(<<HTML);
-<html xmlns="http://www.w3.org/1999/xhtml">
-
- <head>
- <title>Merging records...</title>
- <style type="text/css">
- \@import '/js/dojo/dojo/resources/dojo.css';
- \@import '/js/dojo/dijit/themes/tundra/tundra.css';
- .hide_me { display: none; visibility: hidden; }
- th { font-weight: bold; }
- </style>
-
- <script type="text/javascript">
- var djConfig= {
- isDebug: false,
- parseOnLoad: true,
- AutoIDL: ['aou','aout','pgt','au','cbreb']
- }
- </script>
-
- <script src='/js/dojo/dojo/dojo.js'></script>
- <!-- <script src="/js/dojo/dojo/openils_dojo.js"></script> -->
-
- <script type="text/javascript">
-
- dojo.require('fieldmapper.AutoIDL');
- dojo.require('fieldmapper.dojoData');
- dojo.require('openils.User');
- dojo.require('openils.CGI');
- dojo.require('openils.widget.ProgressDialog');
-
- var cgi = new openils.CGI();
- var u = new openils.User({ authcookie : 'ses' });
-
- dojo.addOnLoad(function () {
- progress_dialog.show(true);
- progress_dialog.update({maximum:$rec_string});
-
- var interval;
- interval = setInterval( function() {
- fieldmapper.standardRequest(
- ['open-ils.actor','open-ils.actor.anon_cache.get_value'],
- { async : false,
- params: [ u.authtoken, 'res_list' ],
- onerror : function (r) { progress_dialog.hide(); },
- onresponse : function (r) {
- var counter = { success : 0, fail : 0, total : 0 };
- dojo.forEach( openils.Util.readResponse(r), function(x) {
- if (x.complete) {
- clearInterval(interval);
- progress_dialog.hide();
- if (x.success == 't') dojo.byId('complete_msg').innerHTML = 'Overlay completed successfully';
- else dojo.byId('complete_msg').innerHTML = 'Overlay did not complet successfully';
- } else {
- counter.total++;
- switch (x.success) {
- case 't':
- counter.success++;
- break;
- default:
- counter.fail++;
- break;
- }
- }
- });
-
- // update the progress dialog
- progress_dialog.update({progress:counter.total});
- dojo.byId('success_count').innerHTML = counter.success;
- dojo.byId('fail_count').innerHTML = counter.fail;
- dojo.byId('total_count').innerHTML = counter.total;
- }
- }
- );
- }, 1000);
-
- });
- </script>
- </head>
-
- <body style="margin:10px;" class='tundra'>
- <div class="hide_me"><div dojoType="openils.widget.ProgressDialog" jsId="progress_dialog"></div></div>
-
- <table style="width:100%; margin-top:100px;">
- <th>
- <td>Status</td>
- <td>Record Count</td>
- </th>
- <tr>
- <td>Success</td>
- <td id='success_count'></td>
- </tr>
- <tr>
- <td>Failure</td>
- <td id='fail_count'></td>
- </tr>
- <tr>
- <td></td>
- <td id='total_count'></td>
- </tr>
- </table>
-
- <div id='complete_msg'></div>
-
- </body>
-</html>
-HTML
-
- return Apache2::Const::OK;
-}
-
-
-sub show_template {
- my $r = shift;
-
- $r->content_type('text/html');
- $r->print(<<'HTML');
-<html xmlns="http://www.w3.org/1999/xhtml">
-
- <head>
- <title>Merge Template Builder</title>
- <style type="text/css">
- @import '/js/dojo/dojo/resources/dojo.css';
- @import '/js/dojo/dijit/themes/tundra/tundra.css';
- .hide_me { display: none; visibility: hidden; }
- table.ruleTable th { padding: 5px; border-collapse: collapse; border-bottom: solid 1px gray; font-weight: bold; }
- table.ruleTable td { padding: 5px; border-collapse: collapse; border-bottom: solid 1px gray; }
- </style>
-
- <script type="text/javascript">
- var djConfig= {
- isDebug: false,
- parseOnLoad: true,
- AutoIDL: ['aou','aout','pgt','au','cbreb']
- }
- </script>
-
- <script src='/js/dojo/dojo/dojo.js'></script>
- <!-- <script src="/js/dojo/dojo/openils_dojo.js"></script> -->
-
- <script type="text/javascript">
-
- dojo.require('dojo.data.ItemFileReadStore');
- dojo.require('dijit.form.Form');
- dojo.require('dijit.form.NumberSpinner');
- dojo.require('dijit.form.FilteringSelect');
- dojo.require('dijit.form.TextBox');
- dojo.require('dijit.form.Textarea');
- dojo.require('dijit.form.Button');
- dojo.require('MARC.Batch');
- dojo.require('fieldmapper.AutoIDL');
- dojo.require('fieldmapper.dojoData');
- dojo.require('openils.User');
- dojo.require('openils.CGI');
-
- var cgi = new openils.CGI();
- var u = new openils.User({ authcookie : 'ses' });
-
- var bucketStore = new dojo.data.ItemFileReadStore(
- { data : cbreb.toStoreData(
- fieldmapper.standardRequest(
- ['open-ils.actor','open-ils.actor.container.retrieve_by_class'],
- [u.authtoken, u.user.id(), 'biblio', 'staff_client']
- )
- )
- }
- );
-
- function render_preview () {
- var rec = ruleset_to_record();
- dojo.byId('marcPreview').innerHTML = rec.toBreaker();
- }
-
- function render_from_template () {
- var kid_number = dojo.byId('ruleList').childNodes.length;
- var clone = dojo.query('*[name=ruleTable]', dojo.byId('ruleTemplate'))[0].cloneNode(true);
-
- var typeSelect = dojo.query('*[name=typeSelect]',clone).instantiate(dijit.form.FilteringSelect, {
- onChange : function (val) {
- switch (val) {
- case 'a':
- case 'r':
- dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]).attr('disabled',false);
- break;
- default :
- dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]).attr('disabled',true);
- };
- render_preview();
- }
- })[0];
-
- var marcData = dojo.query('*[name=marcData]',clone).instantiate(dijit.form.TextBox, {
- onChange : render_preview
- })[0];
-
-
- var tag = dojo.query('*[name=tag]',clone).instantiate(dijit.form.TextBox, {
- onChange : function (newtag) {
- var md = dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]);
- var current_marc = md.attr('value');
-
- if (newtag.length == 3) {
- if (current_marc.length == 0) newtag += ' \\\\';
- if (current_marc.substr(0,3) != newtag) current_marc = newtag + current_marc.substr(3);
- }
- md.attr('value', current_marc);
- render_preview();
- }
- })[0];
-
- var sf = dojo.query('*[name=sf]',clone).instantiate(dijit.form.TextBox, {
- onChange : function (newsf) {
- var md = dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]);
- var current_marc = md.attr('value');
- var sf_list = newsf.split('');
-
- for (var i in sf_list) {
- var re = '\\$' + sf_list[i];
- if (current_marc.match(re)) continue;
- current_marc += '$' + sf_list[i];
- }
-
- md.attr('value', current_marc);
- render_preview();
- }
- })[0];
-
- var matchSF = dojo.query('*[name=matchSF]',clone).instantiate(dijit.form.TextBox, {
- onChange : render_preview
- })[0];
-
- var matchRE = dojo.query('*[name=matchRE]',clone).instantiate(dijit.form.TextBox, {
- onChange : render_preview
- })[0];
-
- var removeButton = dojo.query('*[name=removeButton]',clone).instantiate(dijit.form.Button, {
- onClick : function() {
- dojo.addClass(
- dojo.byId('ruleList').childNodes[kid_number],
- 'hide_me'
- );
- render_preview();
- }
- })[0];
-
- dojo.place(clone,'ruleList');
- }
-
- function ruleset_to_record () {
- var rec = new MARC.Record ({ delimiter : '$' });
-
- dojo.forEach(
- dojo.query('#ruleList *[name=ruleTable]').filter( function (node) {
- if (node.className.match(/hide_me/)) return false;
- return true;
- }),
- function (tbl) {
- var rule_tag = new MARC.Field ({
- tag : '905',
- ind1 : ' ',
- ind2 : ' '
- });
- var rule_txt = dijit.byNode(dojo.query('*[name=tagContainer] .dijit',tbl)[0]).attr('value');
- rule_txt += dijit.byNode(dojo.query('*[name=sfContainer] .dijit',tbl)[0]).attr('value');
-
- var reSF = dijit.byNode(dojo.query('*[name=matchSFContainer] .dijit',tbl)[0]).attr('value');
- if (reSF) {
- var reRE = dijit.byNode(dojo.query('*[name=matchREContainer] .dijit',tbl)[0]).attr('value');
- rule_txt += '[' + reSF + '~' + reRE + ']';
- }
-
- var rtype = dijit.byNode(dojo.query('*[name=typeSelectContainer] .dijit',tbl)[0]).attr('value');
- rule_tag.addSubfields( rtype, rule_txt )
- rec.appendFields( rule_tag );
-
- if (rtype == 'a' || rtype == 'r') {
- rec.appendFields(
- new MARC.Record ({
- delimiter : '$',
- marcbreaker : dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',tbl)[0]).attr('value')
- }).fields[0]
- );
- }
- }
- );
-
- return rec;
- }
- </script>
- </head>
-
- <body style="margin:10px;" class='tundra'>
-
- <div dojoType="dijit.form.Form" id="myForm" jsId="myForm" encType="multipart/form-data" action="" method="POST">
- <script type='dojo/method' event='onSubmit'>
- var rec = ruleset_to_record();
-
- if (rec.subfield('905','r') == '') { // no-op to force replace mode
- rec.appendFields(
- new MARC.Field ({
- tag : '905',
- ind1 : ' ',
- ind2 : ' ',
- subfields : [['r','901c']]
- })
- );
- }
-
- dojo.byId('template_value').value = rec.toXmlString();
- return true;
- </script>
-
- <input type='hidden' id='template_value' name='template'/>
-
- <label for='inputTypeSelect'>Record source:</label>
- <select name='recordSource' dojoType='dijit.form.FilteringSelect'>
- <script type='dojo/method' event='onChange' args="val">
- switch (val) {
- case 'b':
- dojo.removeClass('bucketListContainer','hide_me');
- dojo.addClass('csvContainer','hide_me');
- dojo.addClass('recordContainer','hide_me');
- break;
- case 'c':
- dojo.addClass('bucketListContainer','hide_me');
- dojo.removeClass('csvContainer','hide_me');
- dojo.addClass('recordContainer','hide_me');
- break;
- case 'r':
- dojo.addClass('bucketListContainer','hide_me');
- dojo.addClass('csvContainer','hide_me');
- dojo.removeClass('recordContainer','hide_me');
- break;
- };
- </script>
- <script type='dojo/method' event='postCreate'>
- if (cgi.param('recordSource')) {
- this.attr('value',cgi.param('recordSource'));
- this.onChange(cgi.param('recordSource'));
- }
- </script>
- <option value='b'>a Bucket</option>
- <option value='c'>a CSV File</option>
- <option value='r'>a specific record ID</option>
- </select>
-
- <table style='margin:10px; margin-bottom:20px;'>
-<!--
- <tr>
- <th>Merge template name (optional):</th>
- <td><input id='bucketName' jsId='bucketName' type='text' dojoType='dijit.form.TextBox' name='bname' value=''/></td>
- </tr>
--->
- <tr class='' id='bucketListContainer'>
- <td>Bucket named:
- <div name='containerid' jsId='bucketList' dojoType='dijit.form.FilteringSelect' store='bucketStore' searchAttr='name' id='bucketList'>
- <script type='dojo/method' event='postCreate'>
- if (cgi.param('containerid')) this.attr('value',cgi.param('containerid'));
- </script>
- </div>
- </td>
- </tr>
- <tr class='hide_me' id='csvContainer'>
- <td>
- Column <input style='width:75px;' type='text' dojoType='dijit.form.NumberSpinner' name='idcolumn' value='0' constraints='{min:0,max:100,places:0}' /> of:
- <input id='idfile' type="file" name="idfile"/>
- <br/>
- <br/>
- Columns are numbered starting at 0. For instance, when looking at a CSV file in Excel, the column labeled A is the same as column 0, and the column labeled B is the same as column 1.
- </td>
- </tr>
- <tr class='hide_me' id='recordContainer'>
- <td>Record ID: <input dojoType='dijit.form.TextBox' name='recid' style='width:75px;' type='text' value=''/></td>
- </tr>
- </table>
-
- <button type="submit" dojoType='dijit.form.Button'>GO!</button> (After setting up your template below.)
-
- <br/>
- <br/>
-
- </div> <!-- end of the form -->
-
- <hr/>
- <table style='width: 100%'>
- <tr>
- <td style='width: 50%'><div id='ruleList'></div></td>
- <td valign='top'>Update Template Preview:<br/><pre id='marcPreview'></pre></td>
- </tr>
- </table>
-
- <button dojoType='dijit.form.Button'>Add Merge Rule
- <script type='dojo/connect' event='onClick'>render_from_template()</script>
- <script type='dojo/method' event='postCreate'>render_from_template()</script>
- </button>
-
- <div class='hide_me' id='ruleTemplate'>
- <div name='ruleTable'>
- <table class='ruleTable'>
- <tbody>
- <tr>
- <th style="text-align:center;">Rule Setup</th>
- <th style="text-align:center;">Data</th>
- <th style="text-align:center;">Help</th>
- </tr>
- <tr>
- <th>Action (Rule Type)</th>
- <td name='typeSelectContainer'>
- <select name='typeSelect'>
- <option value='r'>Replace</option>
- <option value='a'>Add</option>
- <option value='d'>Delete</option>
- </select>
- </td>
- <td>How to change the existing records</td>
- </tr>
- <tr>
- <th>MARC Tag</th>
- <td name='tagContainer'><input style='with: 2em;' name='tag' type='text'></input</td>
- <td>Three characters, no spaces, no indicators, etc. eg: 245</td>
- </td>
- <tr>
- <th>Subfields (optional)</th>
- <td name='sfContainer'><input name='sf' type='text'/></td>
- <td>No spaces, no delimiters, eg: abcnp</td>
- </tr>
- <tr>
- <th>MARC Data</th>
- <td name='marcDataContainer'><input name='marcData' type='text'/></td>
- <td>MARC-Breaker formatted data with indicators and subfield delimiters, eg:<br/>245 04$aThe End</td>
- </tr>
- <tr>
- <th colspan='3' style='padding-top: 20px; text-align: center;'>Advanced Matching Restriction (Optional)</th>
- </tr>
- <tr>
- <th>Subfield</th>
- <td name='matchSFContainer'><input style='with: 2em;' name='matchSF' type='text'></input</td>
- <td>A single subfield code, no delimiters, eg: a</td>
- <tr>
- <th>Regular Expression</th>
- <td name='matchREContainer'><input name='matchRE' type='text'/></td>
- <td>See <a href="http://perldoc.perl.org/perlre.html#Regular-Expressions" target="_blank">the Perl documentation</a>
- for an explanation of Regular Expressions.
- </td>
- </tr>
- <tr>
- <td colspan='3' style='padding-top: 20px; text-align: center;'>
- <button name='removeButton'>Remove this Template Rule</button>
- </td>
- </tr>
- </tbody>
- </table>
- <hr/>
- </div>
- </div>
-
- </body>
-</html>
-HTML
-
- return Apache2::Const::OK;
-}
-
-1;
-
-
+++ /dev/null
-package OpenILS::WWW::Vandelay;
-use strict;
-use warnings;
-use bytes;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND FORBIDDEN :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use APR::Table;
-
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use CGI;
-use Data::Dumper;
-use Text::CSV;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::Utils::Cache;
-use OpenSRF::System;
-use OpenSRF::AppSession;
-use XML::LibXML;
-
-use OpenILS::Utils::Fieldmapper;
-use OpenSRF::Utils::Logger qw/$logger/;
-
-use MARC::Record;
-use MARC::File::XML;
-
-use MIME::Base64;
-use Digest::MD5 qw/md5_hex/;
-use OpenSRF::Utils::SettingsClient;
-
-use UNIVERSAL::require;
-
-our @formats = qw/USMARC UNIMARC XML BRE/;
-my $MAX_FILE_SIZE = 10737418240; #10G
-my $FILE_READ_SIZE = 4096;
-
-# set the bootstrap config and template include directory when
-# this module is loaded
-my $bootstrap;
-
-sub import {
- my $self = shift;
- $bootstrap = shift;
-}
-
-
-sub child_init {
- OpenSRF::System->bootstrap_client( config_file => $bootstrap );
-}
-
-sub spool_marc {
- my $r = shift;
- my $cgi = new CGI;
-
- my $auth = $cgi->param('ses') || $cgi->cookie('ses');
-
- unless(verify_login($auth)) {
- $logger->error("authentication failed on vandelay record import: $auth");
- return Apache2::Const::FORBIDDEN;
- }
-
- my $data_fingerprint = '';
- my $purpose = $cgi->param('purpose') || '';
- my $infile = $cgi->param('marc_upload') || '';
- my $bib_source = $cgi->param('bib_source') || '';
- my $provider = $cgi->param('provider') || '';
- my $picklist = $cgi->param('picklist') || '';
- my $create_po = $cgi->param('create_po') || '';
- my $activate_po = $cgi->param('activate_po') || '';
- my $ordering_agency = $cgi->param('ordering_agency') || '';
- my $create_assets = $cgi->param('create_assets') || '';
-
- $logger->debug("purpose = $purpose, infile = $infile, bib_source = $bib_source ".
- "provider = $provider, picklist = $picklist, create_po = $create_po, ordering_agency = $ordering_agency");
-
- my $conf = OpenSRF::Utils::SettingsClient->new;
- my $dir = $conf->config_value(
- apps => 'open-ils.vandelay' => app_settings => databases => 'importer');
-
- unless(-w $dir) {
- $logger->error("We need some place to store our MARC files");
- return Apache2::Const::FORBIDDEN;
- }
-
- if($infile and -e $infile) {
- my ($total_bytes, $buf, $bytes) = (0);
- $data_fingerprint = md5_hex(time."$$".rand());
- my $outfile = "$dir/$data_fingerprint.mrc";
-
- unless(open(OUTFILE, ">$outfile")) {
- $logger->error("unable to open MARC file [$outfile] for writing: $@");
- return Apache2::Const::FORBIDDEN;
- }
-
- while($bytes = sysread($infile, $buf, $FILE_READ_SIZE)) {
- $total_bytes += $bytes;
- if($total_bytes >= $MAX_FILE_SIZE) {
- close(OUTFILE);
- unlink $outfile;
- $logger->error("import exceeded upload size: $MAX_FILE_SIZE");
- return Apache2::Const::FORBIDDEN;
- }
- print OUTFILE $buf;
- }
-
- close(OUTFILE);
-
- OpenSRF::Utils::Cache->new->put_cache(
- 'vandelay_import_spool_' . $data_fingerprint,
- { purpose => $purpose,
- path => $outfile,
- bib_source => $bib_source,
- provider => $provider,
- picklist => $picklist,
- create_po => $create_po,
- create_assets => $create_assets,
- ordering_agency => $ordering_agency
- }
- );
- }
-
- $logger->info("uploaded MARC batch with key $data_fingerprint");
- $r->content_type('text/plain; charset=utf-8');
- print "$data_fingerprint";
- return Apache2::Const::OK;
-}
-
-sub verify_login {
- my $auth_token = shift;
- return undef unless $auth_token;
-
- my $user = OpenSRF::AppSession
- ->create("open-ils.auth")
- ->request( "open-ils.auth.session.retrieve", $auth_token )
- ->gather(1);
-
- if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
- return undef;
- }
-
- return $user if ref($user);
- return undef;
-}
-
-1;
+++ /dev/null
-package OpenILS::WWW::Web;
-use strict;
-use warnings;
-
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-
-#use CGI ();
-use Template;
-
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-
-my $main_ttk = "opac/logic/page_router.ttk";
-my $error_ttk = "opac/pages/error.ttk";
-my $init_ttk = "opac/logic/page_init.ttk";
-my $bootstrap = "SYSCONFDIR/opensrf_core.xml";
-my $child_init_ttk = "opac/logic/child_init.ttk";
-
-my $includes = []; # [ '/pines/cvs/ILS/Open-ILS/src/templates' ];
-
-sub import {
- my ( $self, $tdir ) = @_;
- $includes = [$tdir];
-}
-
-my $plugin_base = 'OpenILS::Template::Plugin';
-
-sub handler {
-
- my $apache = shift;
- print "Content-type: text/html; charset=utf-8\n\n";
-
- _process_template(
- apache => $apache,
- template => $main_ttk,
- pre_process => $init_ttk
- );
-
- return Apache2::Const::OK;
-}
-
-sub child_init_handler {
- _process_template( template => $child_init_ttk );
-}
-
-sub _process_template {
-
- my %params = @_;
- my $ttk = $params{template} || return undef;
- my $apache = $params{apache} || undef;
- my $pre_process = $params{pre_process} || undef;
- my $param_hash = $params{params} || {};
-
- my $template;
-
- $template = Template->new(
- {
- OUTPUT => $apache,
- ABSOLUTE => 1,
- RELATIVE => 1,
- PLUGIN_BASE => $plugin_base,
- PRE_PROCESS => $pre_process,
- INCLUDE_PATH => $includes,
- PRE_CHOMP => 1,
- POST_CHOMP => 1,
- }
- );
-
- try {
-
- if ( !$template->process( $ttk, $param_hash ) ) {
- warn "Error Occured: " . $template->error();
- my $err = $template->error();
- $err =~ s/\n/\<br\/\>/g;
- warn "Error processing template $ttk\n";
- my $string =
- "<br><b>Unable to process template:<br/><br/> "
- . $err
- . "!!!</b>";
- $template->process( $error_ttk, { error => $string } );
- }
-
- }
- catch Error with {
- my $e = shift;
- warn "Error processing template $ttk: $e - $@ \n";
- print "<center><br/><br/><b>Error<br/><br/> $e <br/><br/> $@ </b><br/></center>";
- return;
- };
-
-}
-
-# This module appears obsolete (probably superceded by EGWeb.pm
-# The template files it references do not exist in the codebase.
-# File is not referenced elsewhere in the codebase. Candidate for deletion.
-
-1;
+++ /dev/null
-package OpenILS::WWW::XMLRPCGateway;
-use strict; use warnings;
-
-use CGI;
-use Apache2::Log;
-use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
-use APR::Const -compile => qw(:error SUCCESS);
-use Apache2::RequestRec ();
-use Apache2::RequestIO ();
-use Apache2::RequestUtil;
-use Data::Dumper;
-use UNIVERSAL::require;
-
-use XML::LibXML;
-use OpenSRF::EX qw(:try);
-use OpenSRF::System;
-use OpenSRF::Utils::Cache;
-use OpenSRF::Utils::Logger qw/$logger/;
-use OpenSRF::Utils::SettingsClient;
-
-use RPC::XML qw/smart_encode/;
-use RPC::XML::Parser;
-use RPC::XML::Function;
-use RPC::XML::Method;
-use RPC::XML::Procedure;
-
-$RPC::XML::ENCODING = 'utf-8';
-
-my $services; # allowed services
-my $CLASS_KEY = '__class__'; # object wrapper class key
-my $PAYLOAD_KEY = '__data__'; # object wrapper payload key
-my $bs_config; # bootstrap config
-my $__inited = 0; # has child_init run?
-
-
-# set the bootstrap config when this module is loaded
-sub import { $bs_config = $_[1]; }
-
-
-# Bootstrap and load config settings
-sub child_init {
- $__inited = 1;
- OpenSRF::System->bootstrap_client( config_file => $bs_config );
- my $sclient = OpenSRF::Utils::SettingsClient->new();
- my $idl = $sclient->config_value("IDL");
- $services = $sclient->config_value("xml-rpc", "allowed_services", "service");
- $services = ref $services ? $services : [ $services ];
- $logger->debug("XML-RPC: allowed services @$services");
- OpenILS::Utils::Fieldmapper->require;
- Fieldmapper->import(IDL => $idl);
-}
-
-
-sub handler {
-
- my $r = shift;
- my $cgi = CGI->new;
- my $service = $r->path_info;
- $service =~ s#^/##;
-
- child_init() unless $__inited; # ?
-
- return Apache2::Const::NOT_FOUND unless grep { $_ eq $service } @$services;
-
- my $request = RPC::XML::Parser->new->parse($cgi->param('POSTDATA'));
-
- my @args;
- push( @args, unwrap_perl($_->value) ) for @{$request->args};
- my $method = $request->name;
-
- warn "XML-RPC: service=$service, method=$method, args=@args\n";
- $logger->debug("XML-RPC: service=$service, method=$method, args=@args");
-
- my $perl = run_request( $service, $method, @args );
- my $resp = RPC::XML::response->new(smart_encode($perl));
-
- print "Content-type: application/xml; charset=utf-8\n\n";
- print $resp->as_string;
- return Apache2::Const::OK;
-}
-
-
-sub run_request {
- my( $service, $method, @args ) = @_;
- my $ses = OpenSRF::AppSession->create( $service );
- #my $data = $ses->request($method, @args)->gather(1);
-
- my $data = [];
- my $req = $ses->request($method, @args);
- while( my $resp = $req->recv( timeout => 600 ) ) {
- if( $req->failed ) {
- push( @$data, $req->failed );
- last;
- }
- push( @$data, $resp->content );
- }
-
- return [] if scalar(@$data) == 0;
- return wrap_perl($$data[0])
- if scalar(@$data) == 1 and $method !~ /.atomic$/og;
- return wrap_perl($data);
-}
-
-# These should probably be moved out to a library somewhere
-
-sub wrap_perl {
- my $obj = shift;
- my $ref = ref($obj);
-
- if ($ref =~ /^Fieldmapper/o) {
- $ref = $obj->json_hint;
- $obj = $obj->to_bare_hash;
- }
-
- if( $ref eq 'HASH' ) {
- $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
- } elsif( $ref eq 'ARRAY' ) {
- $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1 );
- } elsif( $ref ) {
- if(UNIVERSAL::isa($obj, 'HASH')) {
- $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
- bless($obj, 'HASH'); # so our parser won't add the hints
- } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
- $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1);
- bless($obj, 'ARRAY'); # so our parser won't add the hints
- }
- $obj = { $CLASS_KEY => $ref, $PAYLOAD_KEY => $obj };
- }
- return $obj;
-}
-
-
-
-sub unwrap_perl {
- my $obj = shift;
- my $ref = ref($obj);
- if( $ref eq 'HASH' ) {
- if( defined($obj->{$CLASS_KEY})) {
- my $class = $obj->{$CLASS_KEY};
- if( $obj = unwrap_perl($obj->{$PAYLOAD_KEY}) ) {
- return bless(\$obj, $class) unless ref($obj);
- return bless( $obj, $class );
- }
- return undef;
- }
- $obj->{$_} = unwrap_perl( $obj->{$_} ) for (keys %$obj);
- } elsif( $ref eq 'ARRAY' ) {
- $obj->[$_] = unwrap_perl($obj->[$_]) for(0..scalar(@$obj) - 1);
- }
- return $obj;
-}
-
-
-
-
-1;
--- /dev/null
+#!/usr/bin/perl
+
+package OpenILS;
+
+our $VERSION = '2.00';
+
+1;
--- /dev/null
+package OpenILS::Application;
+use OpenSRF::Application;
+use UNIVERSAL::require;
+use base qw/OpenSRF::Application/;
+
+sub ils_version {
+ # version format is "x-y-z", for example "2-0-0" for Evergreen 2.0.0
+ # For branches, format is "x-y"
+ return "HEAD";
+}
+
+__PACKAGE__->register_method(
+ api_name => 'opensrf.open-ils.system.ils_version',
+ api_level => 1,
+ method => 'ils_version',
+);
+
+__PACKAGE__->register_method(
+ api_name => 'opensrf.open-ils.fetch_idl.file',
+ api_level => 1,
+ method => 'get_idl_file',
+);
+sub get_idl_file {
+ use OpenSRF::Utils::SettingsClient;
+ return OpenSRF::Utils::SettingsClient->new->config_value('IDL');
+}
+
+sub register_method {
+ my $class = shift;
+ my %args = @_;
+ my %dup_args = %args;
+
+ $class = ref($class) || $class;
+
+ $args{package} ||= $class;
+ __PACKAGE__->SUPER::register_method( %args );
+
+ if (exists($dup_args{authoritative}) and $dup_args{authoritative}) {
+ (my $name = $dup_args{api_name}) =~ s/$/.authoritative/o;
+ if ($name ne $dup_args{api_name}) {
+ $dup_args{real_api_name} = $dup_args{api_name};
+ $dup_args{method} = 'authoritative_wrapper';
+ $dup_args{api_name} = $name;
+ $dup_args{package} = __PACKAGE__;
+ __PACKAGE__->SUPER::register_method( %dup_args );
+ }
+ }
+}
+
+sub authoritative_wrapper {
+
+ if (!$OpenILS::Utils::CStoreEditor::_loaded) {
+ die "Couldn't load OpenILS::Utils::CStoreEditor!" unless 'OpenILS::Utils::CStoreEditor'->use;
+ }
+
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my $method = $self->method_lookup($self->{real_api_name});
+ die unless $method;
+
+ local $OpenILS::Utils::CStoreEditor::always_xact = 1;
+
+ $client->respond( $_ ) for ( $method->run(@args) );
+
+ OpenILS::Utils::CStoreEditor->flush_forced_xacts();
+
+ return undef;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Acq;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenILS::Application::Acq::Picklist;
+use OpenILS::Application::Acq::Financials;
+use OpenILS::Application::Acq::Provider;
+use OpenILS::Application::Acq::Lineitem;
+use OpenILS::Application::Acq::Order;
+use OpenILS::Application::Acq::EDI;
+use OpenILS::Application::Acq::Search;
+use OpenILS::Application::Acq::Claims;
+use OpenILS::Application::Acq::Invoice;
+
+1;
--- /dev/null
+package OpenILS::Application::Acq::Claims;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Event;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+__PACKAGE__->register_method(
+ method => 'claim_ready_items',
+ api_name => 'open-ils.acq.claim.eligible.lineitem_detail',
+ stream => 1,
+ signature => {
+ desc => q/Locates lineitem_details that are eligible for claiming/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ { desc => q/
+ Filter object. Filter keys include
+ purchase_order
+ lineitem
+ lineitem_detail
+ claim_policy_action
+ ordering_agency
+ /,
+ type => 'object'
+ },
+ { desc => q/
+ Flesh fields. Which fields to flesh on the response object.
+ For valid options, see the filter object
+ q/,
+ type => 'array'
+ }
+ ],
+ return => {desc => 'Claim ready data', type => 'object', class => 'acrlid'}
+ }
+);
+
+sub claim_ready_items {
+ my($self, $conn, $auth, $filters, $flesh_fields, $limit, $offset) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ $filters ||= {};
+ $flesh_fields ||= [];
+ $limit ||= 50;
+ $offset ||= 0;
+
+ if(defined $filters->{ordering_agency}) {
+ return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $filters->{ordering_agency});
+ } else {
+ $filters->{ordering_agency} = $U->user_has_work_perm_at($e, 'VIEW_PURCHASE_ORDER', {descendants => 1});
+ }
+
+ my $items = $e->search_acq_claim_ready_lineitem_detail([$filters, {limit => $limit, offset => $offset}]);
+
+ my %cache;
+ for my $item (@$items) {
+
+ # flesh from the flesh fields, using the cache when we can
+ foreach (@$flesh_fields) {
+ my $retrieve = "retrieve_acq_${_}";
+ $cache{$_} = {} unless $cache{$_};
+ $item->$_(
+ $cache{$_}{$item->$_} ||
+ ($cache{$_}{$item->$_} = $e->$retrieve($item->$_))
+ );
+ }
+
+ $conn->respond($item);
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "claim_item",
+ api_name => "open-ils.acq.claim.lineitem",
+ stream => 1,
+ signature => {
+ desc => q/Initiates a claim for a lineitem/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Lineitem ID", type => "number"},
+ {desc => q/Claim (acqcl) ID. If defined, attach new claim
+ events to this existing claim object/, type => "number"},
+ {desc => q/Claim Type (acqclt) ID. If defined (and no claim is
+ defined), create a new claim with this type/, type => "number"},
+ {desc => "Note for the claim event", type => "string"},
+ {desc => q/Optional: Claim Policy Actions. If not present,
+ claim events for all eligible claim policy actions will be
+ created. This is an array of acqclpa IDs./,
+ type => "array"},
+ ],
+ return => {
+ desc => "The claim voucher events on success, Event on error",
+ type => "object", class => "acrlid"
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'claim_item',
+ api_name => 'open-ils.acq.claim.lineitem_detail',
+ stream => 1,
+ signature => {
+ desc => q/Initiates a claim for an individual lineitem_detail/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Lineitem Detail ID', type => 'number'},
+ {desc => 'Claim (acqcl) ID. If defined, attach new claim events to this existing claim object', type => 'number'},
+ {desc => 'Claim Type (acqclt) ID. If defined (and no claim is defined), create a new claim with this type', type => 'number'},
+ {desc => "Note for the claim event", type => "string"},
+ { desc => q/
+
+ Optional: Claim Policy Actions. If not present, claim events
+ for all eligible claim policy actions will be created. This is
+ an array of acqclpa ID's.
+ /,
+ type => 'array'
+ },
+ { desc => q/
+ Optional: Claim Event Types. If present, we bypass any policy configuration
+ and use the specified event types. This is useful for manual claiming against
+ items that have no claim policy.
+ /,
+ type => 'array'
+ }
+ ],
+ return => {
+ desc => "The claim voucher events on success, Event on error",
+ type => "object", class => "acrlid"
+ }
+ }
+);
+
+sub claim_item {
+ my $self = shift;
+ my $conn = shift;
+ my $auth = shift;
+ my $object_id = shift;
+ my $claim_id = shift;
+ my $claim_type_id = shift;
+ my $note = shift;
+ my $policy_actions = shift;
+
+ # if this claim occurs outside of a policy, allow the caller to specificy the event type
+ my $claim_event_types = shift;
+
+ my $e = new_editor(xact => 1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $evt;
+ my $claim;
+ my $claim_type;
+ my $claim_events = {
+ events => [],
+ trigger_stuff => []
+ };
+
+ my $lid_flesh = {
+ "flesh" => 2,
+ "flesh_fields" => {
+ "acqlid" => ["lineitem"], "jub" => ["purchase_order"],
+ }
+ };
+
+ if($claim_id) {
+ $claim = $e->retrieve_acq_claim($claim_id) or return $e->die_event;
+ } elsif($claim_type_id) {
+ $claim_type = $e->retrieve_acq_claim_type($claim_type_id) or return $e->die_event;
+ } else {
+ $e->rollback;
+ return OpenILS::Event->new('BAD_PARAMS');
+ }
+
+
+ my $lids;
+ if($self->api_name =~ /claim.lineitem_detail/) {
+
+ $lids = $e->search_acq_lineitem_detail([
+ {"id" => $object_id, "cancel_reason" => undef},
+ $lid_flesh
+ ]) or return $e->die_event;
+
+ } elsif($self->api_name =~ /claim.lineitem/) {
+ $lids = $e->search_acq_lineitem_detail([
+ {"lineitem" => $object_id, "cancel_reason" => undef},
+ $lid_flesh
+ ]) or return $e->die_event;
+ }
+
+ foreach my $lid (@$lids) {
+ return $evt if
+ $evt = claim_lineitem_detail(
+ $e, $lid, $claim, $claim_type, $policy_actions,
+ $note, $claim_events, $claim_event_types
+ );
+ }
+
+ $e->commit;
+
+ # create related A/T events
+ $U->create_events_for_hook('claim_event.created', $_->[0], $_->[1]) for @{$claim_events->{trigger_stuff}};
+
+ # do voucher rendering and return result
+ $conn->respond($U->fire_object_event(
+ undef, "format.acqcle.html", $_->[0], $_->[1], "print-on-demand"
+ )) foreach @{$claim_events->{trigger_stuff}};
+ return undef;
+}
+
+sub claim_lineitem_detail {
+ my($e, $lid, $claim, $claim_type, $policy_actions, $note, $claim_events, $claim_event_types) = @_;
+
+ # Create the claim object
+ unless($claim) {
+ $claim = Fieldmapper::acq::claim->new;
+ $claim->lineitem_detail($lid->id);
+ $claim->type($claim_type->id);
+ $e->create_acq_claim($claim) or return $e->die_event;
+ }
+
+ unless($claim_event_types) {
+ # user did not specify explicit event types
+
+ unless($policy_actions) {
+ # user did not specifcy policy actions. find all eligible.
+
+ my $list = $e->json_query({
+ select => {acrlid => ['claim_policy_action']},
+ from => 'acrlid',
+ where => {lineitem_detail => $lid->id}
+ });
+
+ $policy_actions = [map { $_->{claim_policy_action} } @$list];
+ }
+
+ # from the set of policy_action's, locate the related event types
+ # IOW, the policy action's action
+ $claim_event_types = [];
+ for my $act_id (@$policy_actions) {
+ my $action = $e->retrieve_acq_claim_policy_action($act_id) or return $e->die_event;
+ push(@$claim_event_types, $action->action);
+ }
+ }
+
+ # for each eligible (or chosen) policy actions, create a claim_event
+ for my $event_type (@$claim_event_types) {
+ my $event = Fieldmapper::acq::claim_event->new;
+ $event->claim($claim->id);
+ $event->type($event_type);
+ $event->creator($e->requestor->id);
+ $event->note($note);
+ $e->create_acq_claim_event($event) or return $e->die_event;
+ push(@{$claim_events->{events}}, $event);
+ push(@{$claim_events->{trigger_stuff}}, [$event, $lid->lineitem->purchase_order->ordering_agency]);
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_claim_voucher_by_lid",
+ api_name => "open-ils.acq.claim.voucher.by_lineitem_detail",
+ stream => 1,
+ signature => {
+ desc => q/Retrieve existing claim vouchers by lineitem detail ID/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Lineitem detail ID", type => "number"}
+ ],
+ return => {
+ desc => "Claim ready data", type => "object", class => "atev"
+ }
+ }
+);
+
+sub get_claim_voucher_by_lid {
+ my ($self, $conn, $auth, $lid_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $lid = $e->retrieve_acq_lineitem_detail([
+ $lid_id, {
+ "flesh" => 2,
+ "flesh_fields" => {
+ "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
+ }
+ }
+ ]);
+
+ return $e->die_event unless $e->allowed(
+ "VIEW_PURCHASE_ORDER", $lid->lineitem->purchase_order->ordering_agency
+ );
+
+ my $id_list = $e->json_query({
+ "select" => {"atev" => ["id"]},
+ "from" => {
+ "atev" => {
+ "atevdef" => {"field" => "id", "fkey" => "event_def"},
+ "acqcle" => {
+ "field" => "id", "fkey" => "target",
+ "join" => {
+ "acqcl" => {
+ "field" => "id", "fkey" => "claim",
+ "join" => {
+ "acqlid" => {
+ "fkey" => "lineitem_detail",
+ "field" => "id"
+ }
+ }
+ }
+ }
+ }
+ }
+ },
+ "where" => {
+ "-and" => {
+ "+atevdef" => {"hook" => "format.acqcle.html"},
+ "+acqlid" => {"id" => $lid_id}
+ }
+ }
+ }) or return $e->die_event;
+
+ if ($id_list && @$id_list) {
+ foreach (@$id_list) {
+ $conn->respond(
+ $e->retrieve_action_trigger_event([
+ $_->{"id"}, {
+ "flesh" => 1,
+ "flesh_fields" => {"atev" => ["template_output"]}
+ }
+ ])
+ );
+ }
+ }
+
+ $e->disconnect;
+ undef;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Acq::EDI;
+use base qw/OpenILS::Application/;
+
+use strict; use warnings;
+
+use IO::Scalar;
+
+use OpenSRF::AppSession;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenSRF::Utils::JSON;
+
+use OpenILS::Application::Acq::Lineitem;
+use OpenILS::Utils::RemoteAccount;
+use OpenILS::Utils::CStoreEditor q/new_editor/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Application::Acq::EDI::Translator;
+
+use Business::EDI;
+
+use Data::Dumper;
+our $verbose = 0;
+
+sub new {
+ my($class, %args) = @_;
+ my $self = bless(\%args, $class);
+ # $self->{args} = {};
+ return $self;
+}
+
+# our $reasons = {}; # cache for acq.cancel_reason rows ?
+
+our $translator;
+
+sub translator {
+ return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
+}
+
+my %map = (
+ host => 'remote_host',
+ username => 'remote_user',
+ password => 'remote_password',
+ account => 'remote_account',
+ # in_dir => 'remote_path', # field_map overrides path with in_dir
+ path => 'remote_path',
+);
+
+
+## Just for debugging stuff:
+sub add_a_msg {
+ my ($self, $conn) = @_;
+ my $e = new_editor(xact=>1);
+ my $incoming = Fieldmapper::acq::edi_message->new;
+ $incoming->edi("This is content");
+ $incoming->account(1);
+ $incoming->remote_file('in/some_file.edi');
+ $e->create_acq_edi_message($incoming);;
+ $e->commit;
+}
+# __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg'); # debugging
+
+__PACKAGE__->register_method(
+ method => 'retrieve',
+ api_name => 'open-ils.acq.edi.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Fetch incoming message(s) from EDI accounts. ' .
+ 'Optional arguments to restrict to one vendor and/or a max number of messages. ' .
+ 'Note that messages are not parsed or processed here, just fetched and translated.',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Vendor ID (undef for "all")', type => 'number'},
+ {desc => 'Date Inactive Since', type => 'string'},
+ {desc => 'Max Messages Retrieved', type => 'number'}
+ ],
+ return => {
+ desc => 'List of new message IDs (empty if none)',
+ type => 'array'
+ }
+ }
+);
+
+sub retrieve_core {
+ my ($self, $set, $max, $e, $test) = @_; # $e is a working editor
+
+ $e ||= new_editor();
+ $set ||= __PACKAGE__->retrieve_vendors($e);
+
+ my @return = ();
+ my $vcount = 0;
+ foreach my $account (@$set) {
+ my $count = 0;
+ my $server;
+ $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host);
+ unless ($server = __PACKAGE__->remote_account($account)) { # assignment, not comparison
+ $logger->err(sprintf "Failed remote account mapping for %s (%s)", $account->host, $account->id);
+ next;
+ };
+# my $rf_starter = './'; # default to current dir
+ if ($account->in_dir) {
+ if ($account->in_dir =~ /\*+.*\//) {
+ $logger->err("EDI in_dir has a slash after an asterisk in value: '" . $account->in_dir . "'. Skipping account with indeterminate target dir!");
+ next;
+ }
+# $rf_starter = $account->in_dir;
+# $rf_starter =~ s/((\/)?[^\/]*)\*+[^\/]*$//; # kill up to the first (possible) slash before the asterisk: keep the preceeding static dir
+# $rf_starter .= '/' if $rf_starter or $2; # recap the dir, or replace leading "/" if there was one (but don't add if empty)
+ }
+ my @files = ($server->ls({remote_file => ($account->in_dir || './')}));
+ my @ok_files = grep {$_ !~ /\/\.?\.$/ and $_ ne '0'} @files;
+ $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, $account->in_dir);
+ # $server->remote_path(undef);
+ foreach my $remote_file (@ok_files) {
+ # my $remote_file = $rf_starter . $_;
+ my $description = sprintf "%s/%s", $account->host, $remote_file;
+
+ # deduplicate vs. acct/filenames already in DB
+ my $hits = $e->search_acq_edi_message([
+ {
+ account => $account->id,
+ remote_file => $remote_file,
+ status => {'in' => [qw/ processed /]}, # if it never got processed, go ahead and get the new one (try again)
+ # create_time => 'NOW() - 60 DAYS', # if we wanted to allow filenames to be reused after a certain time
+ # ideally we would also use the date from FTP, but that info isn't available via RemoteAccount
+ }
+ # { flesh => 1, flesh_fields => {...}, }
+ ]);
+ if (scalar(@$hits)) {
+ $logger->debug("EDI: $remote_file already retrieved. Skipping");
+ warn "EDI: $remote_file already retrieved. Skipping";
+ next;
+ }
+
+ ++$count;
+ $max and $count > $max and last;
+ $logger->info(sprintf "%s of %s targets: %s", $count, scalar(@ok_files), $description);
+ print sprintf "%s of %s targets: %s\n", $count, scalar(@ok_files), $description;
+ if ($test) {
+ push @return, "test_$count";
+ next;
+ }
+ my $content;
+ my $io = IO::Scalar->new(\$content);
+ unless ( $server->get({remote_file => $remote_file, local_file => $io}) ) {
+ $logger->error("(S)FTP get($description) failed");
+ next;
+ }
+ my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id, $e);
+# $server->delete(remote_file => $_); # delete remote copies of saved message
+ push @return, $incoming->id;
+ }
+ }
+ return \@return;
+}
+
+# my $in = OpenILS::Application::Acq::EDI->process_retrieval($file_content, $remote_filename, $server, $account_id, $editor);
+
+sub process_retrieval {
+ my $incoming = Fieldmapper::acq::edi_message->new;
+ my ($class, $content, $remote, $server, $account_or_id, $e) = @_;
+ $content or return;
+ $e ||= new_editor;
+
+ my $account = __PACKAGE__->record_activity( $account_or_id, $e );
+
+ my $z; # must predeclare
+ $z = ( $content =~ s/('UNH\+\d+\+ORDRSP:)0(:96A:UN')/$1D$2/g )
+ and $logger->warn("Patching bogus spec reference ORDRSP:0:96A:UN => ORDRSP:D:96A:UN ($z times)"); # Hack/fix some faulty "0" in (B&T) data
+
+ $incoming->remote_file($remote);
+ $incoming->account($account->id);
+ $incoming->edi($content);
+ $incoming->message_type(($content =~ /'UNH\+\d+\+(\S{6}):/) ? $1 : 'ORDRSP'); # cheap sniffing, ORDRSP fallback
+ __PACKAGE__->attempt_translation($incoming);
+ $e->xact_begin;
+ $e->create_acq_edi_message($incoming);
+ $e->xact_commit;
+ # refresh: send process_jedi the updated row
+ $e->xact_begin;
+ my $outgoing = $e->retrieve_acq_edi_message($incoming->id); # refresh again!
+ $e->xact_rollback;
+ my $res = __PACKAGE__->process_jedi($outgoing, $server, $account, $e);
+ $e->xact_begin;
+ $outgoing = $e->retrieve_acq_edi_message($incoming->id); # refresh again!
+ $e->xact_rollback;
+ $outgoing->status($res ? 'processed' : 'proc_error');
+ if ($res) {
+ $e->xact_begin;
+ $e->update_acq_edi_message($outgoing);
+ $e->xact_commit;
+ }
+ return $outgoing;
+}
+
+# ->send_core
+# $account is a Fieldmapper object for acq.edi_account row
+# $messageset is an arrayref with acq.edi_message.id values
+# $e is optional editor object
+sub send_core {
+ my ($class, $account, $message_ids, $e) = @_; # $e is a working editor
+
+ ($account and scalar @$message_ids) or return;
+ $e ||= new_editor();
+
+ $e->xact_begin;
+ my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids;
+ $e->xact_rollback;
+ my $m_count = scalar(@messageset);
+ (scalar(@$message_ids) == $m_count) or
+ $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)");
+
+ my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host;
+ $logger->info("$log_str: $m_count message(s)");
+ $m_count or return;
+
+ my $server;
+ my $server_error;
+ unless ($server = __PACKAGE__->remote_account($account, 1)) { # assignment, not comparison
+ $logger->error("Failed remote account connection for $log_str");
+ $server_error = 1;
+ };
+ foreach (@messageset) {
+ $_ or next; # we already warned about bum ids
+ my ($res, $error);
+ if ($server_error) {
+ $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below
+ } elsif (! $_->edi) {
+ $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content");
+ $error = "EDI empty!";
+ } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi, single_ext => 1})) {
+ # This is the successful case!
+ $_->remote_file($res);
+ $_->status('complete');
+ $_->process_time('NOW'); # For outbound files, sending is the end of processing on the EG side.
+ $logger->info("Sent message (id " . $_->id. ") via $log_str");
+ } else {
+ $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
+ $error = "put FAILED: " . ($server->error || 'UNKOWNN');
+ }
+ if ($error) {
+ $_->error($error);
+ $_->error_time('NOW');
+ }
+ $logger->info("Calling update_acq_edi_message");
+ $e->xact_begin;
+ unless ($e->update_acq_edi_message($_)) {
+ $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_));
+ OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_ ), '/tmp/update_acq_edi_message.FAIL');
+ OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash');
+ }
+ # There's always an update, even if we failed.
+ $e->xact_commit;
+ __PACKAGE__->record_activity($account, $e); # There's always an update, even if we failed.
+ }
+ return \@messageset;
+}
+
+# attempt_translation does not touch the DB, just the object.
+sub attempt_translation {
+ my ($class, $edi_message, $to_edi) = @_;
+ my $tran = translator();
+ my $ret = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi);
+# $logger->error("json: " . Dumper($json)); # debugging
+ if (not $ret or (! ref($ret)) or $ret->is_fault) { # RPC::XML::fault on failure
+ $edi_message->status('trans_error');
+ $edi_message->error_time('NOW');
+ my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed";
+ my $message = ref($ret) ?
+ ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) :
+ ("$pre: " . __PACKAGE__->nice_string($ret) ) ;
+ $edi_message->error($message);
+ $logger->error( $message);
+ return;
+ }
+ $edi_message->status('translated');
+ $edi_message->translate_time('NOW');
+ if ($to_edi) {
+ $edi_message->edi($ret->value); # translator returns an object
+ } else {
+ $edi_message->jedi($ret->value); # translator returns an object
+ }
+ return $edi_message;
+}
+
+sub retrieve_vendors {
+ my ($self, $e, $vendor_id, $last_activity) = @_; # $e is a working editor
+
+ $e ||= new_editor();
+
+ my $criteria = {'+acqpro' => {active => 't'}};
+ $criteria->{'+acqpro'}->{id} = $vendor_id if $vendor_id;
+ return $e->search_acq_edi_account([
+ $criteria, {
+ 'join' => 'acqpro',
+ flesh => 1,
+ flesh_fields => {
+ acqedi => ['provider']
+ }
+ }
+ ]);
+# {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
+}
+
+# This is the SRF-exposed call, so it does checkauth
+
+sub retrieve {
+ my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ unless ($e and $e->checkauth()) {
+ $logger->warn("checkauth failed for authtoken '$auth'");
+ return ();
+ }
+ # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency); # add permission here ?
+
+ my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
+ return __PACKAGE__->retrieve_core($e, $set, $max);
+}
+
+
+# field_map takes the hashref of vendor data with fields from acq.edi_account and
+# maps them to the argument style needed for RemoteAccount. It also extrapolates
+# data from the remote_host string for type and port, when available.
+
+sub field_map {
+ my $self = shift;
+ my $vendor = shift or return;
+ my $no_override = @_ ? shift : 0;
+ my %args = ();
+ $verbose and $logger->warn("vendor: " . Dumper($vendor));
+ foreach (keys %map) {
+ $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
+ }
+ unless ($no_override) {
+ $args{remote_path} = $vendor->in_dir; # override "path" with "in_dir"
+ }
+ my $host = $args{remote_host} || '';
+ ($host =~ s/^(S?FTP)://i and $args{type} = uc($1)) or
+ ($host =~ s/^(SSH|SCP)://i and $args{type} = 'SCP' ) ;
+ $host =~ s/:(\d+)$// and $args{port} = $1;
+ ($args{remote_host} = $host) =~ s#/+##;
+ $verbose and $logger->warn("field_map: " . Dumper(\%args));
+ return %args;
+}
+
+
+# The point of remote_account is to get the RemoteAccount object with args from the DB
+
+sub remote_account {
+ my ($self, $vendor, $outbound, $e) = @_;
+
+ unless (ref($vendor)) { # It's not a hashref/object.
+ $vendor or return; # If in fact it's nothing: abort!
+ # else it's a vendor_id string, so get the full vendor data
+ $e ||= new_editor();
+ my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
+ $vendor = shift @$set_of_one;
+ }
+
+ return OpenILS::Utils::RemoteAccount->new(
+ $self->field_map($vendor, $outbound)
+ );
+}
+
+# takes account ID or account Fieldmapper object
+
+sub record_activity {
+ my ($class, $account_or_id, $e) = @_;
+ $account_or_id or return;
+ $e ||= new_editor();
+ my $account = ref($account_or_id) ? $account_or_id : $e->retrieve_acq_edi_account($account_or_id);
+ $logger->info("EDI record_activity calling update_acq_edi_account");
+ $account->last_activity('NOW') or return;
+ $e->xact_begin;
+ $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
+ $e->xact_commit;
+ return $account;
+}
+
+sub nice_string {
+ my $class = shift;
+ my $string = shift or return '';
+ chomp($string);
+ my $head = @_ ? shift : 100;
+ my $tail = @_ ? shift : 25;
+ (length($string) < $head + $tail) and return $string;
+ my $h = substr($string,0,$head);
+ my $t = substr($string, -1*$tail);
+ $h =~s/\s*$//o;
+ $t =~s/\s*$//o;
+ return "$h ... $t";
+ # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
+}
+
+sub jedi2perl {
+ my ($class, $jedi) = @_;
+ $jedi or return;
+ my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi );
+ open (FOO, ">>/tmp/JSON2perl_dump.txt");
+ print FOO Dumper($msg), "\n\n";
+ close FOO;
+ $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt");
+ return $msg;
+}
+
+our @datecodes = (35, 359, 17, 191, 69, 76, 75, 79, 85, 74, 84, 223);
+our @noop_6063 = (21);
+
+# ->process_jedi($message, $server, $remote, $e)
+# $message is an edi_message object
+#
+sub process_jedi {
+ my ($class, $message, $server, $remote, $e) = @_;
+ $message or return;
+ $server ||= {}; # context
+ $remote ||= {}; # context
+ $e ||= new_editor;
+ my $jedi;
+ unless (ref($message) and $jedi = $message->jedi) { # assignment, not comparison
+ $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi)!");
+ return;
+ }
+ my $perl = __PACKAGE__->jedi2perl($jedi);
+ my $error = '';
+ if (ref($message) and not $perl) {
+ $error = ($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi";
+ }
+ elsif (! $perl->{body}) {
+ $error = "EDI interchange body not found!";
+ }
+ elsif (! $perl->{body}->[0]) {
+ $error = "EDI interchange body not a populated arrayref!";
+ }
+ if ($error) {
+ $logger->warn($error);
+ $message->error($error);
+ $message->error_time('NOW');
+ $e->xact_begin;
+ $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!");
+ $e->xact_commit;
+ return;
+ }
+
+# Crazy data structure. Most of the arrays will be 1 element... we think.
+# JEDI looks like:
+# {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ...
+#
+# So you might access it like:
+# $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH'
+
+ $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " message(s)");
+ my @ok_msg_codes = qw/ORDRSP OSTRPT/;
+ my @messages;
+ my $i = 0;
+ foreach my $part (@{$perl->{body}}) {
+ $i++;
+ unless (ref $part and scalar keys %$part) {
+ $logger->warn("EDI interchange message $i lacks structure. Skipping it.");
+ next;
+ }
+ foreach my $key (keys %$part) {
+ if (! grep {$_ eq $key} @ok_msg_codes) { # We only do one type for now. TODO: other types here
+ $logger->warn("EDI interchange $i contains unhandled '$key' message. Ignoring it.");
+ next;
+ }
+ my $msg = __PACKAGE__->message_object($part->{$key}) or next;
+ push @messages, $msg;
+
+ my $bgm = $msg->xpath('BGM') or $logger->warn("EDI No BGM segment found?!");
+ my $tag4343 = $msg->xpath('BGM/4343');
+ my $tag1225 = $msg->xpath('BGM/1225');
+ if (ref $tag4343) {
+ $logger->info(sprintf "EDI $key BGM/4343 Response Type: %s - %s", $tag4343->value, $tag4343->label)
+ } else {
+ $logger->warn("EDI $key BGM/4343 Response Type Code unrecognized"); # next; #?
+ }
+ if (ref $tag1225) {
+ $logger->info(sprintf "EDI $key BGM/1225 Message Function: %s - %s", $tag1225->value, $tag1225->label);
+ } else {
+ $logger->warn("EDI $key BGM/1225 Message Function Code unrecognized"); # next; #?
+ }
+
+ # TODO: currency check, just to be paranoid
+ # *should* be unnecessary (vendor should reply in currency we send in ORDERS)
+ # That begs a policy question: how to handle mismatch? convert (bad accuracy), reject, or ignore? I say ignore.
+
+ # ALL those codes below are basically some form of (lastest) delivery date/time
+ # see, e.g.: http://www.stylusstudio.com/edifact/D04B/2005.htm
+ # The order is the order of definitiveness (first match wins)
+ # Note: if/when we do serials via EDI, dates (and ranges/periods) will need massive special handling
+ my @dates;
+ my $ddate;
+
+ foreach my $date ($msg->xpath('delivery_schedule')) {
+ my $val_2005 = $date->xpath_value('DTM/2005') or next;
+ (grep {$val_2005 eq $_} @datecodes) or next; # no match means some other kind of date we don't care about
+ push @dates, $date;
+ }
+ if (@dates) {
+ DATECODE: foreach my $dcode (@datecodes) { # now cycle back through hits in order of dcode definitiveness
+ foreach my $date (@dates) {
+ $date->xpath_value('DTM/2005') == $dcode or next;
+ $ddate = $date->xpath_value('DTM/2380') and last DATECODE;
+ # TODO: conversion based on format specified in DTM/2379 (best encapsulated in Business::EDI)
+ }
+ }
+ }
+ foreach my $detail ($msg->part('line_detail')) {
+ my $eg_line = __PACKAGE__->eg_li($detail, $remote, $server->{remote_host}, $e) or next;
+ my $li_date = $detail->xpath_value('DTM/2380') || $ddate;
+ my $price = $detail->xpath_value('line_price/PRI/5118') || '';
+ $eg_line->expected_recv_time($li_date) if $li_date;
+ $eg_line->estimated_unit_price($price) if $price;
+ if (not $message->purchase_order) { # first good lineitem sets the message PO link
+ $message->purchase_order($eg_line->purchase_order); # EG $message object NOT Business::EDI $msg object
+ $e->xact_begin;
+ $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message (for PO number) failed! $!");
+ $e->xact_commit;
+ }
+ # $e->search_acq_edi_account([]);
+ my $touches = 0;
+ my $eg_lids = $e->search_acq_lineitem_detail({lineitem => $eg_line->id}); # should be the same as $eg_line->lineitem_details
+ my $lidcount = scalar(@$eg_lids);
+ $lidcount == $eg_line->item_count or $logger->warn(
+ sprintf "EDI: LI %s itemcount (%d) mismatch, %d LIDs found", $eg_line->id, $eg_line->item_count, $lidcount
+ );
+ foreach my $qty ($detail->part('all_QTY')) {
+ my $ubound = $qty->xpath_value('6060') or next; # nothing to do if qty is 0
+ my $val_6063 = $qty->xpath_value('6063');
+ $ubound > 0 or next; # don't be crazy!
+ if (! $val_6063) {
+ $logger->warn("EDI: Response for LI " . $eg_line->id . " specifies quantity $ubound with no 6063 code! Contact vendor to resolve.");
+ next;
+ }
+
+ my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $val_6063); # DB populated w/ 6063 keys in 1200's
+ if (! $eg_reason) {
+ $logger->warn("EDI: Unhandled quantity code '$val_6063' (LI " . $eg_line->id . ") $ubound items unprocessed");
+ next;
+ } elsif (grep {$val_6063 == $_} @noop_6063) { # an FYI like "ordered quantity"
+ $ubound eq $lidcount
+ or $logger->warn("EDI: LI " . $eg_line->id . " -- Vendor says we ordered $ubound, but we have $lidcount LIDs!)");
+ next;
+ }
+ # elsif ($val_6063 == 83) { # backorder
+ #} elsif ($val_6063 == 85) { # cancel
+ #} elsif ($val_6063 == 12 or $val_6063 == 57 or $val_6063 == 84 or $val_6063 == 118) {
+ # despatched, in transit, urgent delivery, or quantity manifested
+ #}
+ if ($touches >= $lidcount) {
+ $logger->warn("EDI: LI " . $eg_line->id . ", We already updated $touches of $lidcount LIDS, " .
+ "but message wants QTY $ubound more set to " . $eg_reason->label . ". Ignoring!");
+ next;
+ }
+ $e->xact_begin;
+ foreach (1 .. $ubound) {
+ my $eg_lid = shift @$eg_lids or $logger->warn("EDI: Used up all $lidcount LIDs! Ignoring extra status " . $eg_reason->label);
+ $eg_lid or next;
+ $logger->debug(sprintf "Updating LID %s to %s", $eg_lid->id, $eg_reason->label);
+ $eg_lid->cancel_reason($eg_reason->id);
+ $e->update_acq_lineitem_detail($eg_lid);
+ $touches++;
+ }
+ $e->xact_commit;
+ if ($ubound == $eg_line->item_count) {
+ $eg_line->cancel_reason($eg_reason->id); # if ALL the items have the same cancel_reason, the PO gets it too
+ }
+ }
+ $eg_line->edit_time('NOW'); # TODO: have this field automatically updated via ON UPDATE trigger.
+ $e->xact_begin;
+ $e->update_acq_lineitem($eg_line) or $logger->warn("EDI: update_acq_lineitem FAILED");
+ $e->xact_commit;
+ # print STDERR "Lineitem update: ", Dumper($eg_line);
+ }
+ }
+ }
+ return \@messages;
+}
+
+# returns message object if processing should continue
+# returns false/undef value if processing should abort
+
+sub message_object {
+ my $class = shift;
+ my $body = shift or return;
+ my $key = shift if @_;
+ my $keystring = $key || 'UNSPECIFIED';
+
+ my $msg = Business::EDI::Message->new($body);
+ unless ($msg) {
+ $logger->error("EDI interchange message: $keystring body failed Business::EDI constructor. Skipping it.");
+ return;
+ }
+ $key = $msg->code if ! $key; # Now we set the key for reference if it wasn't specified
+ my $val_0065 = $msg->xpath_value('UNH/S009/0065') || '';
+ unless ($val_0065 eq $key) {
+ $logger->error("EDI $key UNH/S009/0065 ('$val_0065') conflicts w/ message type $key. Aborting");
+ return;
+ }
+ my $val_0051 = $msg->xpath_value('UNH/S009/0051') || '';
+ unless ($val_0051 eq 'UN') {
+ $logger->warn("EDI $key UNH/S009/0051 designates '$val_0051', not 'UN' as controlling agency. Attempting to process anyway");
+ }
+ my $val_0054 = $msg->xpath_value('UNH/S009/0054') || '';
+ if ($val_0054) {
+ $logger->info("EDI $key UNH/S009/0054 uses Spec revision version '$val_0054'");
+ # Possible Spec Version limitation
+ # my $yy = $tag_0054 ? substr($val_0054,0,2) : '';
+ # unless ($yy eq '00' or $yy > 94 ...) {
+ # $logger->warn("EDI $key UNH/S009/0051 Spec revision version '$val_0054' not supported");
+ # }
+ } else {
+ $logger->warn("EDI $key UNH/S009/0054 does not reference a known Spec revision version");
+ }
+ return $msg;
+}
+
+=head2 ->eg_li($lineitem_object, [$remote, $server_log_string, $editor])
+
+my $line_item = OpenILS::Application::Acq::EDI->eg_li($edi_line, $remote, "test_server_01", $e);
+
+ $remote is a acq.edi_account Fieldmapper object.
+ $server_log_string is an arbitrary string use to identify the remote host in potential log messages.
+
+Updates:
+ acq.lineitem.estimated_unit_price,
+ acq.lineitem.state (dependent on mapping codes),
+ acq.lineitem.expected_recv_time,
+ acq.lineitem.edit_time (consequently)
+
+=cut
+
+sub eg_li {
+ my ($class, $line, $server, $server_log_string, $e) = @_;
+ $line or return;
+ $e ||= new_editor();
+
+ my $id;
+ # my $rff = $line->part('line_reference/RFF') or $logger->warn("EDI ORDRSP line_detail/RFF missing!");
+ my $val_1153 = $line->xpath_value('line_reference/RFF/1153') || '';
+ my $val_1154 = $line->xpath_value('line_reference/RFF/1154') || '';
+ my $val_1082 = $line->xpath_value('LIN/1082') || '';
+
+ my @po_nums;
+
+ $val_1154 =~ s#^(.*)\/##; # Many sources send the ID as 'order_ID/LI_ID'
+ $1 and push @po_nums, $1;
+ $val_1082 =~ s#^(.*)\/##; # Many sources send the ID as 'order_ID/LI_ID'
+ $1 and push @po_nums, $1;
+
+ # TODO: possible check of po_nums
+ # now do a lot of checking
+
+ if ($val_1153 eq 'LI') {
+ $id = $val_1154 or $logger->warn("EDI ORDRSP RFF/1154 reference to LI empty. Attempting failover to LIN/1082");
+ } else {
+ $logger->warn("EDI ORDRSP RFF/1153 unexpected value ('$val_1153', not 'LI'). Attempting failover to LIN/1082");
+ }
+
+ # FIXME - the line item ID in LIN/1082 ought to match RFF/1154, but
+ # not all materials vendors obey this. Commenting out check for now
+ # as being too strict.
+ #if ($id and $val_1082 and $val_1082 ne $id) {
+ # $logger->warn("EDI ORDRSP LIN/1082 Line Item ID mismatch ($id vs. $val_1082): cannot target update");
+ # return;
+ #}
+
+ $id ||= $val_1082 || '';
+ if ($id eq '') {
+ $logger->warn('Cannot identify line item from EDI message');
+ return;
+ }
+
+ $logger->info("EDI retrieve/update lineitem $id");
+
+ my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id, {
+ flesh_li_details => 1,
+ }, 1); # Could send more {options}. The 1 is for no_auth.
+
+ if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') {
+ $logger->error("EDI failed to retrieve lineitem by id '$id' for server $server_log_string");
+ return;
+ }
+ unless ((! $server) or (! $server->provider)) { # but here we want $server to be acq.edi_account instead of RemoteAccount
+ if ($server->provider != $li->provider) {
+ # links go both ways: acq.provider.edi_default and acq.edi_account.provider
+ $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider("
+ . $li->provider . "). Checking acq.provider.edi_default...");
+ my $provider = $e->retrieve_acq_provider($li->provider);
+ if ($provider->edi_default != $server->id) {
+ $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s",
+ $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default);
+ return;
+ }
+ }
+ }
+
+ my @lin_1229 = $line->xpath('LIN/1229') or $logger->warn("EDI LIN/1229 Action Code missing!");
+ my $key = $lin_1229[0] or return;
+
+ my $eg_reason = $e->retrieve_acq_cancel_reason(1000 + $key->value); # DB populated w/ spec keys in 1000's
+ $eg_reason or $logger->warn(sprintf "EDI LIN/1229 Action Code '%s' (%s) not recognized in acq.cancel_reason", $key->value, $key->label);
+ $eg_reason or return;
+
+ $li->cancel_reason($eg_reason->id);
+ unless ($eg_reason->keep_debits) {
+ $logger->warn("EDI LIN/1229 Action Code '%s' (%s) has keep_debits=0", $key->value, $key->label);
+ }
+
+ my @prices = $line->xpath_value("line_price/PRI/5118");
+ $li->estimated_unit_price($prices[0]) if @prices;
+
+ return $li;
+}
+
+# caching not needed for now (edi_fetcher is asynchronous)
+# sub get_reason {
+# my ($class, $key, $e) = @_;
+# $reasons->{$key} and return $reasons->{$key};
+# $e ||= new_editor();
+# $reasons->{$key} = $e->retrieve_acq_cancel_reason($key);
+# return $reasons->{$key};
+# }
+
+1;
+
+__END__
+
+Example JSON data.
+
+Note the pseudo-hash 2-element arrays.
+
+[
+ 'SG26',
+ [
+ [
+ 'LIN',
+ {
+ '1229' => '5',
+ '1082' => 1,
+ 'C212' => {
+ '7140' => '9780446360272',
+ '7143' => 'EN'
+ }
+ }
+ ],
+ [
+ 'IMD',
+ {
+ '7081' => 'BST',
+ '7077' => 'F',
+ 'C273' => {
+ '7008' => [
+ 'NOT APPLIC WEBSTERS NEW WORLD THESA'
+ ]
+ }
+ }
+ ],
+ [
+ 'QTY',
+ {
+ 'C186' => {
+ '6063' => '21',
+ '6060' => 10
+ }
+ }
+ ],
+ [
+ 'QTY',
+ {
+ 'C186' => {
+ '6063' => '12',
+ '6060' => 10
+ }
+ }
+ ],
+ [
+ 'QTY',
+ {
+ 'C186' => {
+ '6063' => '85',
+ '6060' => 0
+ }
+ }
+ ],
+ [
+ 'FTX',
+ {
+ '4451' => 'LIN',
+ 'C107' => {
+ '4441' => '01',
+ '3055' => '28',
+ '1131' => '8B'
+ }
+ }
+ ],
+ [
+ 'SG30',
+ [
+ [
+ 'PRI',
+ {
+ 'C509' => {
+ '5118' => '4.5',
+ '5387' => 'SRP',
+ '5125' => 'AAB'
+ }
+ }
+ ]
+ ]
+ ],
+ [
+ 'SG31',
+ [
+ [
+ 'RFF',
+ {
+ 'C506' => {
+ '1154' => '8/1',
+ '1153' => 'LI'
+ }
+ }
+ ]
+ ]
+ ]
+ ]
+],
+
--- /dev/null
+package OpenILS::Application::Acq::EDI::Translator;
+
+use warnings;
+use strict;
+
+use RPC::XML::Client;
+use Data::Dumper;
+
+# DEFAULTS
+my $proto = 'http://';
+my $host = $proto . 'localhost';
+my $path = '/EDI';
+my $port = 9191;
+my $verbose = 0;
+
+sub new {
+ my ($class, %args) = @_;
+ my $self = bless(\%args, $class);
+ $self->init;
+ return $self;
+}
+
+sub init {
+ my $self = shift;
+ $self->host_cleanup;
+}
+
+sub host_cleanup {
+ my $self = shift;
+ my $target = $self->{host} || $host;
+ $target =~ /^\S+:\/\// or $target = ($self->{proto} || $proto) . $target;
+ $target =~ /:\d+$/ or $target .= ':' . ($self->{port} || $port);
+ $target .= ($self->{path} || $path);
+ $self->{verbose} and print "Cleanup: $self->{host} ==> $target\n";
+ $self->{host} = $target;
+ return $target;
+}
+
+sub client {
+ my $self = shift;
+ return $self->{client} ||= RPC::XML::Client->new($self->{host}); # TODO: auth
+}
+
+sub debug_file {
+ my $self = shift;
+ my $text = shift;
+ my $filename = @_ ? shift : ('/tmp/' . __PACKAGE__ . '_unknown.tmp');
+ unless (open (TMP_EDI, ">$filename")) {
+ warn "Cannot write $filename: $!";
+ return;
+ }
+ print TMP_EDI $text, "\n";
+ close TMP_EDI;
+ return 1;
+}
+
+sub json2edi {
+ my $self = shift;
+ my $text = shift;
+ $self->debug_file($text, '/tmp/perl_json2edi.tmp');
+ my $client = $self->client();
+ $self->{verbose} and print "Trying json2edi on host: $self->{host}\n";
+ $client->request->header('Content-Type' => 'text/xml;charset=utf-8');
+ my $resp = $client->send_request('json2edi', $text);
+ $self->{verbose} and print Dumper($resp);
+ return $resp;
+}
+
+sub edi2json {
+ my $self = shift;
+ my $text = shift;
+ $self->debug_file($text, '/tmp/perl_edi2json.tmp');
+ my $client = $self->client();
+ $self->{verbose} and print "Trying edi2json on host: $self->{host}\n";
+ $client->request->header('Content-Type' => 'text/xml;charset=utf-8');
+ my $resp = $client->send_request('edi2json', $text);
+ $self->{verbose} and print Dumper($resp);
+ return $resp;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Acq::Financials;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Const qw/:const/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Event;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Acq::Lineitem;
+my $U = 'OpenILS::Application::AppUtils';
+
+# ----------------------------------------------------------------------------
+# Funding Sources
+# ----------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'create_funding_source',
+ api_name => 'open-ils.acq.funding_source.create',
+ signature => {
+ desc => 'Creates a new funding_source',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'funding source object to create', type => 'object'}
+ ],
+ return => {desc => 'The ID of the new funding_source'}
+ }
+);
+
+sub create_funding_source {
+ my($self, $conn, $auth, $funding_source) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('ADMIN_FUNDING_SOURCE', $funding_source->owner);
+ $e->create_acq_funding_source($funding_source) or return $e->die_event;
+ $e->commit;
+ return $funding_source->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_funding_source',
+ api_name => 'open-ils.acq.funding_source.delete',
+ signature => {
+ desc => 'Deletes a funding_source',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'funding source ID', type => 'number'}
+ ],
+ return => {desc => '1 on success, Event on failure'}
+ }
+);
+
+sub delete_funding_source {
+ my($self, $conn, $auth, $funding_source_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $funding_source = $e->retrieve_acq_funding_source($funding_source_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('ADMIN_FUNDING_SOURCE', $funding_source->owner, $funding_source);
+ $e->delete_acq_funding_source($funding_source) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_funding_source',
+ api_name => 'open-ils.acq.funding_source.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a new funding_source',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'funding source ID', type => 'number'}
+ ],
+ return => {desc => 'The funding_source object on success, Event on failure'}
+ }
+);
+
+sub retrieve_funding_source {
+ my($self, $conn, $auth, $funding_source_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $options ||= {};
+
+ my $flesh = {flesh => 1, flesh_fields => {acqfs => []}};
+ push(@{$flesh->{flesh_fields}->{acqfs}}, 'credits') if $$options{flesh_credits};
+ push(@{$flesh->{flesh_fields}->{acqfs}}, 'allocations') if $$options{flesh_allocations};
+
+ my $funding_source = $e->retrieve_acq_funding_source([$funding_source_id, $flesh]) or return $e->event;
+
+ return $e->event unless $e->allowed(
+ ['ADMIN_FUNDING_SOURCE','MANAGE_FUNDING_SOURCE', 'VIEW_FUNDING_SOURCE'],
+ $funding_source->owner, $funding_source);
+
+ $funding_source->summary(retrieve_funding_source_summary_impl($e, $funding_source))
+ if $$options{flesh_summary};
+ return $funding_source;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_org_funding_sources',
+ api_name => 'open-ils.acq.funding_source.org.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves all the funding_sources associated with an org unit that the requestor has access to see',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'List of org Unit IDs. If no IDs are provided, this method returns the
+ full set of funding sources this user has permission to view', type => 'number'},
+ {desc => q/Limiting permission. this permission is used find the work-org tree from which
+ the list of orgs is generated if no org ids are provided.
+ The default is ADMIN_FUNDING_SOURCE/, type => 'string'},
+ ],
+ return => {desc => 'The funding_source objects on success, empty array otherwise'}
+ }
+);
+
+sub retrieve_org_funding_sources {
+ my($self, $conn, $auth, $org_id_list, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $options ||= {};
+
+ my $limit_perm = ($$options{limit_perm}) ? $$options{limit_perm} : 'ADMIN_FUNDING_SOURCE';
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $limit_perm =~ /(ADMIN|MANAGE|VIEW)_FUNDING_SOURCE/;
+
+ my $org_ids = ($org_id_list and @$org_id_list) ? $org_id_list :
+ $U->user_has_work_perm_at($e, $limit_perm, {descendants =>1});
+
+ return [] unless @$org_ids;
+ my $sources = $e->search_acq_funding_source({owner => $org_ids});
+
+ for my $source (@$sources) {
+ $source->summary(retrieve_funding_source_summary_impl($e, $source))
+ if $$options{flesh_summary};
+ $conn->respond($source);
+ }
+
+ return undef;
+}
+
+sub retrieve_funding_source_summary_impl {
+ my($e, $source) = @_;
+ my $at = $e->search_acq_funding_source_allocation_total({funding_source => $source->id})->[0];
+ my $b = $e->search_acq_funding_source_balance({funding_source => $source->id})->[0];
+ my $ct = $e->search_acq_funding_source_credit_total({funding_source => $source->id})->[0];
+ return {
+ allocation_total => ($at) ? $at->amount : 0,
+ balance => ($b) ? $b->amount : 0,
+ credit_total => ($ct) ? $ct->amount : 0,
+ };
+}
+
+
+__PACKAGE__->register_method(
+ method => 'create_funding_source_credit',
+ api_name => 'open-ils.acq.funding_source_credit.create',
+ signature => {
+ desc => 'Create a new funding source credit',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'funding source credit object', type => 'object'}
+ ],
+ return => {desc => 'The ID of the new funding source credit on success, Event on failure'}
+ }
+);
+
+sub create_funding_source_credit {
+ my($self, $conn, $auth, $fs_credit) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->event unless $e->checkauth;
+
+ my $fs = $e->retrieve_acq_funding_source($fs_credit->funding_source)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed(['MANAGE_FUNDING_SOURCE'], $fs->owner, $fs);
+
+ $e->create_acq_funding_source_credit($fs_credit) or return $e->die_event;
+ $e->commit;
+ return $fs_credit->id;
+}
+
+
+# ---------------------------------------------------------------
+# funds
+# ---------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'create_fund',
+ api_name => 'open-ils.acq.fund.create',
+ signature => {
+ desc => 'Creates a new fund',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund object to create', type => 'object'}
+ ],
+ return => {desc => 'The ID of the newly created fund object'}
+ }
+);
+
+sub create_fund {
+ my($self, $conn, $auth, $fund) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('ADMIN_FUND', $fund->org);
+ $e->create_acq_fund($fund) or return $e->die_event;
+ $e->commit;
+ return $fund->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_fund',
+ api_name => 'open-ils.acq.fund.delete',
+ signature => {
+ desc => 'Deletes a fund',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund ID', type => 'number'}
+ ],
+ return => {desc => '1 on success, Event on failure'}
+ }
+);
+
+sub delete_fund {
+ my($self, $conn, $auth, $fund_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $fund = $e->retrieve_acq_fund($fund_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('ADMIN_FUND', $fund->org, $fund);
+ $e->delete_acq_fund($fund) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_fund',
+ api_name => 'open-ils.acq.fund.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a new fund',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund ID', type => 'number'}
+ ],
+ return => {desc => 'The fund object on success, Event on failure'}
+ }
+);
+
+sub retrieve_fund {
+ my($self, $conn, $auth, $fund_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $options ||= {};
+
+ my $flesh = {flesh => 2, flesh_fields => {acqf => []}};
+ if ($options->{"flesh_tags"}) {
+ push @{$flesh->{"flesh_fields"}->{"acqf"}}, "tags";
+ $flesh->{"flesh_fields"}->{"acqftm"} = ["tag"];
+ }
+ push(@{$flesh->{flesh_fields}->{acqf}}, 'debits') if $$options{flesh_debits};
+ push(@{$flesh->{flesh_fields}->{acqf}}, 'allocations') if $$options{flesh_allocations};
+ push(@{$flesh->{flesh_fields}->{acqfa}}, 'funding_source') if $$options{flesh_allocation_sources};
+
+ my $fund = $e->retrieve_acq_fund([$fund_id, $flesh]) or return $e->event;
+ return $e->event unless $e->allowed(['ADMIN_FUND','MANAGE_FUND', 'VIEW_FUND'], $fund->org, $fund);
+ $fund->summary(retrieve_fund_summary_impl($e, $fund))
+ if $$options{flesh_summary};
+ return $fund;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_org_funds',
+ api_name => 'open-ils.acq.fund.org.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves all the funds associated with an org unit',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'List of org Unit IDs. If no IDs are provided, this method returns the
+ full set of funding sources this user has permission to view', type => 'number'},
+ {desc => q/Options hash.
+ "limit_perm" -- this permission is used find the work-org tree from which
+ the list of orgs is generated if no org ids are provided. The default is ADMIN_FUND.
+ "flesh_summary" -- if true, the summary field on each fund is fleshed
+ The default is ADMIN_FUND/, type => 'string'},
+ ],
+ return => {desc => 'The fund objects on success, Event on failure'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'retrieve_org_funds',
+ api_name => 'open-ils.acq.fund.org.years.retrieve');
+
+
+sub retrieve_org_funds {
+ my($self, $conn, $auth, $filter, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $filter ||= {};
+ $options ||= {};
+
+ my $limit_perm = ($$options{limit_perm}) ? $$options{limit_perm} : 'ADMIN_FUND';
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $limit_perm =~ /(ADMIN|MANAGE|VIEW)_FUND/;
+
+ $filter->{org} = $filter->{org} ||
+ $U->user_has_work_perm_at($e, $limit_perm, {descendants =>1});
+ return undef unless @{$filter->{org}};
+
+ my $query = [
+ $filter,
+ {
+ limit => $$options{limit} || 50,
+ offset => $$options{offset} || 0,
+ order_by => $$options{order_by} || {acqf => 'name'}
+ }
+ ];
+
+ if($self->api_name =~ /years/) {
+ # return the distinct set of fund years covered by the selected funds
+ my $data = $e->json_query({
+ select => {
+ acqf => [{column => 'year', transform => 'distinct'}]
+ },
+ from => 'acqf',
+ where => $filter}
+ );
+
+ return [map { $_->{year} } @$data];
+ }
+
+ my $funds = $e->search_acq_fund($query);
+
+ for my $fund (@$funds) {
+ $fund->summary(retrieve_fund_summary_impl($e, $fund))
+ if $$options{flesh_summary};
+ $conn->respond($fund);
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_fund_summary',
+ api_name => 'open-ils.acq.fund.summary.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Returns a summary of credits/debits/encumbrances for a fund',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund id', type => 'number' }
+ ],
+ return => {desc => 'A hash of summary information, Event on failure'}
+ }
+);
+
+sub retrieve_fund_summary {
+ my($self, $conn, $auth, $fund_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $fund = $e->retrieve_acq_fund($fund_id) or return $e->event;
+ return $e->event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
+ return retrieve_fund_summary_impl($e, $fund);
+}
+
+
+sub retrieve_fund_summary_impl {
+ my($e, $fund) = @_;
+
+ my $at = $e->search_acq_fund_allocation_total({fund => $fund->id})->[0];
+ my $dt = $e->search_acq_fund_debit_total({fund => $fund->id})->[0];
+ my $et = $e->search_acq_fund_encumbrance_total({fund => $fund->id})->[0];
+ my $st = $e->search_acq_fund_spent_total({fund => $fund->id})->[0];
+ my $cb = $e->search_acq_fund_combined_balance({fund => $fund->id})->[0];
+ my $sb = $e->search_acq_fund_spent_balance({fund => $fund->id})->[0];
+
+ return {
+ allocation_total => ($at) ? $at->amount : 0,
+ debit_total => ($dt) ? $dt->amount : 0,
+ encumbrance_total => ($et) ? $et->amount : 0,
+ spent_total => ($st) ? $st->amount : 0,
+ combined_balance => ($cb) ? $cb->amount : 0,
+ spent_balance => ($sb) ? $sb->amount : 0,
+ };
+}
+
+__PACKAGE__->register_method(
+ method => 'transfer_money_between_funds',
+ api_name => 'open-ils.acq.funds.transfer_money',
+ signature => {
+ desc => 'Method for transfering money between funds',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Originating fund ID', type => 'number'},
+ {desc => 'Amount of money to transfer away from the originating fund, in the same currency as said fund', type => 'number'},
+ {desc => 'Destination fund ID', type => 'number'},
+ {desc => 'Amount of money to transfer to the destination fund, in the same currency as said fund. If null, uses the same amount specified with the Originating Fund, and attempts a currency conversion if appropriate.', type => 'number'},
+ {desc => 'Transfer Note', type => 'string'}
+ ],
+ return => {desc => '1 on success, Event on failure'}
+ }
+);
+
+sub transfer_money_between_funds {
+ my($self, $conn, $auth, $ofund_id, $ofund_amount, $dfund_id, $dfund_amount, $note) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $ofund = $e->retrieve_acq_fund($ofund_id) or return $e->event;
+ return $e->die_event unless $e->allowed(['ADMIN_FUND','MANAGE_FUND'], $ofund->org, $ofund);
+ my $dfund = $e->retrieve_acq_fund($dfund_id) or return $e->event;
+ return $e->die_event unless $e->allowed(['ADMIN_FUND','MANAGE_FUND'], $dfund->org, $dfund);
+
+ if (!defined $dfund_amount) {
+ my $ratio = 1;
+ if ($ofund->currency_type ne $dfund->currency_type) {
+ my $exchange_rate = $e->json_query({
+ "select"=>{"acqexr"=>["ratio"]},
+ "from"=>"acqexr",
+ "where"=>{
+ "from_currency"=>$ofund->currency_type,
+ "to_currency"=>$dfund->currency_type
+ }
+ });
+ if (scalar(@$exchange_rate)<1) {
+ $logger->error('Unable to find exchange rate for ' . $ofund->currency_type . ' to ' . $dfund->currency_type);
+ return $e->die_event;
+ }
+ $ratio = @{$exchange_rate}[0]->{ratio};
+ }
+ $dfund_amount = $ofund_amount * $ratio;
+ } else {
+ return $e->die_event unless $e->allowed("ACQ_XFER_MANUAL_DFUND_AMOUNT");
+ }
+
+ $e->json_query({
+ from => [
+ 'acq.transfer_fund',
+ $ofund_id, $ofund_amount, $dfund_id, $dfund_amount, $e->requestor->id, $note
+ ]
+ });
+
+ $e->commit;
+
+ return 1;
+}
+
+
+
+# ---------------------------------------------------------------
+# fund Allocations
+# ---------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'create_fund_alloc',
+ api_name => 'open-ils.acq.fund_allocation.create',
+ signature => {
+ desc => 'Creates a new fund_allocation',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund allocation object to create', type => 'object'}
+ ],
+ return => {desc => 'The ID of the new fund_allocation'}
+ }
+);
+
+sub create_fund_alloc {
+ my($self, $conn, $auth, $fund_alloc) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ # this action is equivalent to both debiting a funding source and crediting a fund
+
+ my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner);
+
+ my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
+
+ $fund_alloc->allocator($e->requestor->id);
+ $e->create_acq_fund_allocation($fund_alloc) or return $e->die_event;
+ $e->commit;
+ return $fund_alloc->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_fund_alloc',
+ api_name => 'open-ils.acq.fund_allocation.delete',
+ signature => {
+ desc => 'Deletes a fund_allocation',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund Alocation ID', type => 'number'}
+ ],
+ return => {desc => '1 on success, Event on failure'}
+ }
+);
+
+sub delete_fund_alloc {
+ my($self, $conn, $auth, $fund_alloc_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $fund_alloc = $e->retrieve_acq_fund_allocation($fund_alloc_id) or return $e->die_event;
+
+ my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner, $source);
+
+ my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
+
+ $e->delete_acq_fund_allocation($fund_alloc) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_fund_alloc',
+ api_name => 'open-ils.acq.fund_allocation.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a new fund_allocation',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund Allocation ID', type => 'number'}
+ ],
+ return => {desc => 'The fund allocation object on success, Event on failure'}
+ }
+);
+
+sub retrieve_fund_alloc {
+ my($self, $conn, $auth, $fund_alloc_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $fund_alloc = $e->retrieve_acq_fund_allocation($fund_alloc_id) or return $e->event;
+
+ my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner, $source);
+
+ my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
+
+ return $fund_alloc;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_funding_source_allocations',
+ api_name => 'open-ils.acq.funding_source.allocations.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a new fund_allocation',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'fund Allocation ID', type => 'number'}
+ ],
+ return => {desc => 'The fund allocation object on success, Event on failure'}
+ }
+);
+
+sub retrieve_funding_source_allocations {
+ my($self, $conn, $auth, $fund_alloc_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $fund_alloc = $e->retrieve_acq_fund_allocation($fund_alloc_id) or return $e->event;
+
+ my $source = $e->retrieve_acq_funding_source($fund_alloc->funding_source)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUNDING_SOURCE', $source->owner, $source);
+
+ my $fund = $e->retrieve_acq_fund($fund_alloc->fund) or return $e->die_event;
+ return $e->die_event unless $e->allowed('MANAGE_FUND', $fund->org, $fund);
+
+ return $fund_alloc;
+}
+
+# ----------------------------------------------------------------------------
+# Currency
+# ----------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'retrieve_all_currency_type',
+ api_name => 'open-ils.acq.currency_type.all.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves all currency_type objects',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ ],
+ return => {desc => 'List of currency_type objects', type => 'list'}
+ }
+);
+
+sub retrieve_all_currency_type {
+ my($self, $conn, $auth, $fund_alloc_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('GENERAL_ACQ');
+ $conn->respond($_) for @{$e->retrieve_all_acq_currency_type()};
+}
+
+__PACKAGE__->register_method(
+ method => 'create_lineitem_assets',
+ api_name => 'open-ils.acq.lineitem.assets.create',
+ signature => {
+ desc => q/Creates the bibliographic data, volume, and copies associated with a lineitem./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'The lineitem id', type => 'number'},
+ {desc => q/Options hash./}
+ ],
+ return => {desc => 'ID of newly created bib record, Event on error'}
+ }
+);
+
+sub create_lineitem_assets {
+ my($self, $conn, $auth, $li_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my ($count, $resp) = create_lineitem_assets_impl($e, $li_id, $options);
+ return $resp if $resp;
+ $e->commit;
+ return $count;
+}
+
+sub create_lineitem_assets_impl {
+ my($e, $li_id, $options) = @_;
+ $options ||= {};
+ my $evt;
+
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id,
+ { flesh => 1,
+ flesh_fields => {jub => ['purchase_order', 'attributes']}
+ }
+ ]) or return (undef, $e->die_event);
+
+ # -----------------------------------------------------------------
+ # first, create the bib record if necessary
+ # -----------------------------------------------------------------
+ unless($li->eg_bib_id) {
+
+ my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
+ $e, $li->marc); #$rec->bib_source
+
+ if($U->event_code($record)) {
+ $e->rollback;
+ return (undef, $record);
+ }
+
+ $li->editor($e->requestor->id);
+ $li->edit_time('now');
+ $li->eg_bib_id($record->id);
+ $e->update_acq_lineitem($li) or return (undef, $e->die_event);
+ }
+
+ my $li_details = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
+
+ # -----------------------------------------------------------------
+ # for each lineitem_detail, create the volume if necessary, create
+ # a copy, and link them all together.
+ # -----------------------------------------------------------------
+ my %volcache;
+ for my $li_detail_id (@{$li_details}) {
+
+ my $li_detail = $e->retrieve_acq_lineitem_detail($li_detail_id)
+ or return (undef, $e->die_event);
+
+ # Create the volume object if necessary
+ my $volume = $volcache{$li_detail->cn_label};
+ unless($volume and $volume->owning_lib == $li_detail->owning_lib) {
+ ($volume, $evt) =
+ OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
+ $e, $li_detail->cn_label, $li->eg_bib_id, $li_detail->owning_lib);
+ return (undef, $evt) if $evt;
+ $volcache{$volume->id} = $volume;
+ }
+
+ my $copy = Fieldmapper::asset::copy->new;
+ $copy->isnew(1);
+ $copy->loan_duration(2);
+ $copy->fine_level(2);
+ $copy->status(OILS_COPY_STATUS_ON_ORDER);
+ $copy->barcode($li_detail->barcode);
+ $copy->location($li_detail->location);
+ $copy->call_number($volume->id);
+ $copy->circ_lib($volume->owning_lib);
+ $copy->circ_modifier($$options{circ_modifier} || 'book');
+
+ $evt = OpenILS::Application::Cat::AssetCommon->create_copy($e, $volume, $copy);
+ return (undef, $evt) if $evt;
+
+ $li_detail->eg_copy_id($copy->id);
+ $e->update_acq_lineitem_detail($li_detail) or return (undef, $e->die_event);
+ }
+
+ return (scalar @{$li_details});
+}
+
+
+
+
+sub create_purchase_order_impl {
+ my($e, $p_order) = @_;
+
+ $p_order->creator($e->requestor->id);
+ $p_order->editor($e->requestor->id);
+ $p_order->owner($e->requestor->id);
+ $p_order->edit_time('now');
+
+ return $e->die_event unless
+ $e->allowed('CREATE_PURCHASE_ORDER', $p_order->ordering_agency);
+
+ my $provider = $e->retrieve_acq_provider($p_order->provider)
+ or return $e->die_event;
+ return $e->die_event unless
+ $e->allowed('MANAGE_PROVIDER', $provider->owner, $provider);
+
+ $e->create_acq_purchase_order($p_order) or return $e->die_event;
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_all_user_purchase_order',
+ api_name => 'open-ils.acq.purchase_order.user.all.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves a purchase order',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'purchase_order to retrieve', type => 'number'},
+ {desc => q/Options hash. flesh_lineitems: to get the lineitems and lineitem_attrs;
+ clear_marc: to clear the MARC data from the lineitem (for reduced bandwidth);
+ limit: number of items to return ,defaults to 50;
+ offset: offset in the list of items to return
+ order_by: sort the result, provide one or more colunm names, separated by commas,
+ optionally followed by ASC or DESC as a single string
+ li_limit : number of lineitems to return if fleshing line items;
+ li_offset : lineitem offset if fleshing line items
+ li_order_by : lineitem sort definition if fleshing line items
+ flesh_lineitem_detail_count : flesh lineitem_detail_count field
+ /,
+ type => 'hash'}
+ ],
+ return => {desc => 'The purchase order, Event on failure'}
+ }
+);
+
+sub retrieve_all_user_purchase_order {
+ my($self, $conn, $auth, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $options ||= {};
+
+ # grab purchase orders I have
+ my $perm_orgs = $U->user_has_work_perm_at($e, 'MANAGE_PROVIDER', {descendants =>1});
+ return OpenILS::Event->new('PERM_FAILURE', ilsperm => 'MANAGE_PROVIDER')
+ unless @$perm_orgs;
+ my $provider_ids = $e->search_acq_provider({owner => $perm_orgs}, {idlist=>1});
+ my $po_ids = $e->search_acq_purchase_order({provider => $provider_ids}, {idlist=>1});
+
+ # grab my purchase orders
+ push(@$po_ids, @{$e->search_acq_purchase_order({owner => $e->requestor->id}, {idlist=>1})});
+
+ return undef unless @$po_ids;
+
+ # now get the db to limit/sort for us
+ $po_ids = $e->search_acq_purchase_order(
+ [ {id => $po_ids}, {
+ limit => $$options{limit} || 50,
+ offset => $$options{offset} || 0,
+ order_by => {acqpo => $$options{order_by} || 'create_time'}
+ }
+ ],
+ {idlist => 1}
+ );
+
+ $conn->respond(retrieve_purchase_order_impl($e, $_, $options)) for @$po_ids;
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'search_purchase_order',
+ api_name => 'open-ils.acq.purchase_order.search',
+ stream => 1,
+ signature => {
+ desc => 'Search for a purchase order',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => q/Search hash. Search fields include id, provider/, type => 'hash'}
+ ],
+ return => {desc => 'A stream of POs'}
+ }
+);
+
+sub search_purchase_order {
+ my($self, $conn, $auth, $search, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $po_ids = $e->search_acq_purchase_order($search, {idlist=>1});
+ for my $po_id (@$po_ids) {
+ $conn->respond($e->retrieve_acq_purchase_order($po_id))
+ unless po_perm_failure($e, $po_id);
+ }
+
+ return undef;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_purchase_order',
+ api_name => 'open-ils.acq.purchase_order.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves a purchase order',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'purchase_order to retrieve', type => 'number'},
+ {desc => q/Options hash. flesh_lineitems, to get the lineitems and lineitem_attrs;
+ clear_marc, to clear the MARC data from the lineitem (for reduced bandwidth)
+ li_limit : number of lineitems to return if fleshing line items;
+ li_offset : lineitem offset if fleshing line items
+ li_order_by : lineitem sort definition if fleshing line items,
+ flesh_po_items : po_item objects
+ /,
+ type => 'hash'}
+ ],
+ return => {desc => 'The purchase order, Event on failure'}
+ }
+);
+
+sub retrieve_purchase_order {
+ my($self, $conn, $auth, $po_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ $po_id = [ $po_id ] unless ref $po_id;
+ for ( @{$po_id} ) {
+ my $rv;
+ if ( po_perm_failure($e, $_) )
+ { $rv = $e->event }
+ else
+ { $rv = retrieve_purchase_order_impl($e, $_, $options) }
+
+ $conn->respond($rv);
+ }
+
+ return undef;
+}
+
+
+# if the user does not have permission to perform actions on this PO, return the perm failure event
+sub po_perm_failure {
+ my($e, $po_id, $fund_id) = @_;
+ my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency, $po);
+ return undef;
+}
+
+sub build_price_summary {
+ my ($e, $po_id) = @_;
+
+ # TODO: Add summary value for estimated amount (pre-encumber)
+
+ # fetch the fund debits for this purchase order
+ my $debits = $e->json_query({
+ "select" => {"acqfdeb" => [qw/encumbrance amount/]},
+ "from" => {
+ "acqlid" => {
+ "jub" => {
+ "fkey" => "lineitem",
+ "field" => "id",
+ "join" => {
+ "acqpo" => {
+ "fkey" => "purchase_order", "field" => "id"
+ }
+ }
+ },
+ "acqfdeb" => {"fkey" => "fund_debit", "field" => "id"}
+ }
+ },
+ "where" => {"+acqpo" => {"id" => $po_id}}
+ });
+
+ # add any debits for non-bib po_items
+ push(@$debits, @{
+ $e->json_query({
+ "select" => {"acqfdeb" => [qw/encumbrance amount/]},
+ "from" => {acqpoi => 'acqfdeb'},
+ "where" => {"+acqpoi" => {"purchase_order" => $po_id}}
+ })
+ });
+
+ my ($enc, $spent) = (0, 0);
+ for my $deb (@$debits) {
+ if($U->is_true($deb->{encumbrance})) {
+ $enc += $deb->{amount};
+ } else {
+ $spent += $deb->{amount};
+ }
+ }
+ ($enc, $spent);
+}
+
+
+sub retrieve_purchase_order_impl {
+ my($e, $po_id, $options) = @_;
+
+ my $flesh = {"flesh" => 1, "flesh_fields" => {"acqpo" => []}};
+
+ $options ||= {};
+ unless ($options->{"no_flesh_cancel_reason"}) {
+ push @{$flesh->{"flesh_fields"}->{"acqpo"}}, "cancel_reason";
+ }
+ if ($options->{"flesh_notes"}) {
+ push @{$flesh->{"flesh_fields"}->{"acqpo"}}, "notes";
+ }
+ if ($options->{"flesh_provider"}) {
+ push @{$flesh->{"flesh_fields"}->{"acqpo"}}, "provider";
+ }
+
+ push (@{$flesh->{flesh_fields}->{acqpo}}, 'po_items') if $options->{flesh_po_items};
+
+ my $args = (@{$flesh->{"flesh_fields"}->{"acqpo"}}) ?
+ [$po_id, $flesh] : $po_id;
+
+ my $po = $e->retrieve_acq_purchase_order($args)
+ or return $e->event;
+
+ if($$options{flesh_lineitems}) {
+
+ my $flesh_fields = { jub => ['attributes'] };
+ $flesh_fields->{jub}->[1] = 'lineitem_details' if $$options{flesh_lineitem_details};
+ $flesh_fields->{acqlid} = ['fund_debit'] if $$options{flesh_fund_debit};
+
+ my $items = $e->search_acq_lineitem([
+ {purchase_order => $po_id},
+ {
+ flesh => 3,
+ flesh_fields => $flesh_fields,
+ limit => $$options{li_limit} || 50,
+ offset => $$options{li_offset} || 0,
+ order_by => {jub => $$options{li_order_by} || 'create_time'}
+ }
+ ]);
+
+ if($$options{clear_marc}) {
+ $_->clear_marc for @$items;
+ }
+
+ $po->lineitems($items);
+ $po->lineitem_count(scalar(@$items));
+
+ } elsif( $$options{flesh_lineitem_ids} ) {
+ $po->lineitems($e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1}));
+
+ } elsif( $$options{flesh_lineitem_count} ) {
+
+ my $items = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist=>1});
+ $po->lineitem_count(scalar(@$items));
+ }
+
+ if($$options{flesh_price_summary}) {
+ my ($enc, $spent) = build_price_summary($e, $po_id);
+ $po->amount_encumbered($enc);
+ $po->amount_spent($spent);
+ }
+
+ return $po;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'format_po',
+ api_name => 'open-ils.acq.purchase_order.format'
+);
+
+sub format_po {
+ my($self, $conn, $auth, $po_id, $format) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency);
+
+ my $hook = "format.po.$format";
+ return $U->fire_object_event(undef, $hook, $po, $po->ordering_agency);
+}
+
+__PACKAGE__->register_method(
+ method => 'format_lineitem',
+ api_name => 'open-ils.acq.lineitem.format'
+);
+
+sub format_lineitem {
+ my($self, $conn, $auth, $li_id, $format, $user_data) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $li = $e->retrieve_acq_lineitem($li_id) or return $e->event;
+
+ my $context_org;
+ if (defined $li->purchase_order) {
+ my $po = $e->retrieve_acq_purchase_order($li->purchase_order) or return $e->die_event;
+ return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency);
+ $context_org = $po->ordering_agency;
+ } else {
+ my $pl = $e->retrieve_acq_picklist($li->picklist) or return $e->die_event;
+ if($e->requestor->id != $pl->owner) {
+ return $e->event unless
+ $e->allowed('VIEW_PICKLIST', $pl->org_unit, $pl);
+ }
+ $context_org = $pl->org_unit;
+ }
+
+ my $hook = "format.acqli.$format";
+ return $U->fire_object_event(undef, $hook, $li, $context_org, 'print-on-demand', $user_data);
+}
+
+__PACKAGE__->register_method (
+ method => 'po_events',
+ api_name => 'open-ils.acq.purchase_order.events.owner',
+ stream => 1,
+ signature => q/
+ Retrieve EDI-related purchase order events (format.po.jedi), by default those which are pending.
+ @param authtoken Login session key
+ @param owner Id or array of id's for the purchase order Owner field. Filters the events to just those pertaining to PO's meeting this criteria.
+ @param options Object for tweaking the selection criteria and fleshing options.
+ /
+);
+
+__PACKAGE__->register_method (
+ method => 'po_events',
+ api_name => 'open-ils.acq.purchase_order.events.ordering_agency',
+ stream => 1,
+ signature => q/
+ Retrieve EDI-related purchase order events (format.po.jedi), by default those which are pending.
+ @param authtoken Login session key
+ @param owner Id or array of id's for the purchase order Ordering Agency field. Filters the events to just those pertaining to PO's meeting this criteria.
+ @param options Object for tweaking the selection criteria and fleshing options.
+ /
+);
+
+__PACKAGE__->register_method (
+ method => 'po_events',
+ api_name => 'open-ils.acq.purchase_order.events.id',
+ stream => 1,
+ signature => q/
+ Retrieve EDI-related purchase order events (format.po.jedi), by default those which are pending.
+ @param authtoken Login session key
+ @param owner Id or array of id's for the purchase order Id field. Filters the events to just those pertaining to PO's meeting this criteria.
+ @param options Object for tweaking the selection criteria and fleshing options.
+ /
+);
+
+sub po_events {
+ my($self, $conn, $auth, $search_value, $options) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ (my $search_field = $self->api_name) =~ s/.*\.([_a-z]+)$/$1/;
+ my $obj_type = 'acqpo';
+
+ if ($search_field eq 'ordering_agency') {
+ $search_value = $U->get_org_descendants($search_value);
+ }
+
+ my $query = {
+ "select"=>{"atev"=>["id"]},
+ "from"=>"atev",
+ "where"=>{
+ "target"=>{
+ "in"=>{
+ "select"=>{$obj_type=>["id"]},
+ "from"=>$obj_type,
+ "where"=>{$search_field=>$search_value}
+ }
+ },
+ "event_def"=>{
+ "in"=>{
+ "select"=>{atevdef=>["id"]},
+ "from"=>"atevdef",
+ "where"=>{
+ "hook"=>"format.po.jedi"
+ }
+ }
+ },
+ "state"=>"pending"
+ },
+ "order_by"=>[{"class"=>"atev", "field"=>"run_time", "direction"=>"desc"}]
+ };
+
+ if ($options && defined $options->{state}) {
+ $query->{'where'}{'state'} = $options->{state}
+ }
+
+ if ($options && defined $options->{start_time}) {
+ $query->{'where'}{'start_time'} = $options->{start_time};
+ }
+
+ if ($options && defined $options->{order_by}) {
+ $query->{'order_by'} = $options->{order_by};
+ }
+ my $po_events = $e->json_query($query);
+
+ my $flesh_fields = { 'atev' => [ 'event_def' ] };
+ my $flesh_depth = 1;
+
+ for my $id (@$po_events) {
+ my $event = $e->retrieve_action_trigger_event([
+ $id->{id},
+ {flesh => $flesh_depth, flesh_fields => $flesh_fields}
+ ]);
+ if (! $event) { next; }
+
+ my $po = retrieve_purchase_order_impl(
+ $e,
+ $event->target(),
+ {flesh_lineitem_count=>1,flesh_price_summary=>1}
+ );
+
+ if ($e->allowed( ['CREATE_PURCHASE_ORDER','VIEW_PURCHASE_ORDER'], $po->ordering_agency() )) {
+ $event->target( $po );
+ $conn->respond($event);
+ }
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method (
+ method => 'update_po_events',
+ api_name => 'open-ils.acq.purchase_order.event.cancel.batch',
+ stream => 1,
+);
+__PACKAGE__->register_method (
+ method => 'update_po_events',
+ api_name => 'open-ils.acq.purchase_order.event.reset.batch',
+ stream => 1,
+);
+
+sub update_po_events {
+ my($self, $conn, $auth, $event_ids) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $x = 1;
+ for my $id (@$event_ids) {
+
+ # do a little dance to determine what libraries we are ultimately affecting
+ my $event = $e->retrieve_action_trigger_event([
+ $id,
+ { flesh => 2,
+ flesh_fields => {atev => ['event_def'], atevdef => ['hook']}
+ }
+ ]) or return $e->die_event;
+
+ my $po = retrieve_purchase_order_impl(
+ $e,
+ $event->target(),
+ {}
+ );
+
+ return $e->die_event unless $e->allowed( ['CREATE_PURCHASE_ORDER','VIEW_PURCHASE_ORDER'], $po->ordering_agency() );
+
+ if($self->api_name =~ /cancel/) {
+ $event->state('invalid');
+ } elsif($self->api_name =~ /reset/) {
+ $event->clear_start_time;
+ $event->clear_update_time;
+ $event->state('pending');
+ }
+
+ $e->update_action_trigger_event($event) or return $e->die_event;
+ $conn->respond({maximum => scalar(@$event_ids), progress => $x++});
+ }
+
+ $e->commit;
+ return {complete => 1};
+}
+
+
+__PACKAGE__->register_method (
+ method => 'process_fiscal_rollover',
+ api_name => 'open-ils.acq.fiscal_rollover.combined',
+ stream => 1,
+ signature => {
+ desc => q/
+ Performs a combined fiscal fund rollover process.
+
+ Creates a new series of funds for the following year, copying the old years
+ funds that are marked as propagable. They apply to the funds belonging to
+ either an org unit or to an org unit and all of its dependent org units.
+ The procedures may be run repeatedly; if any fund has already been propagated,
+ both the old and the new funds will be left alone.
+
+ Closes out any applicable funds (by org unit or by org unit and dependents)
+ that are marked as propagable. If such a fund has not already been propagated
+ to the new year, it will be propagated at closing time.
+
+ If a fund is marked as subject to rollover, any unspent balance in the old year's
+ fund (including money encumbered but not spent) is transferred to the new year's
+ fund. Otherwise it is deallocated back to the funding source(s).
+
+ In either case, any encumbrance debits are transferred to the new fund, along
+ with the corresponding lineitem details. The old year's fund is marked as inactive
+ so that new debits may not be charged to it.
+ /,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Fund Year to roll over', type => 'integer'},
+ {desc => 'Org unit ID', type => 'integer'},
+ {desc => 'Include Descendant Orgs (boolean)', type => 'integer'},
+ ],
+ return => {desc => 'Returns a stream of all related funds for the next year including fund summary for each'}
+ }
+
+);
+
+__PACKAGE__->register_method (
+ method => 'process_fiscal_rollover',
+ api_name => 'open-ils.acq.fiscal_rollover.combined.dry_run',
+ stream => 1,
+ signature => {
+ desc => q/
+ @see open-ils.acq.fiscal_rollover.combined
+ This is the dry-run version. The action is performed,
+ new fund information is returned, then all changes are rolled back.
+ /
+ }
+
+);
+
+__PACKAGE__->register_method (
+ method => 'process_fiscal_rollover',
+ api_name => 'open-ils.acq.fiscal_rollover.propagate',
+ stream => 1,
+ signature => {
+ desc => q/
+ @see open-ils.acq.fiscal_rollover.combined
+ This version performs fund propagation only. I.e, creation of
+ the following year's funds. It does not rollover over balances, encumbrances,
+ or mark the previous year's funds as complete.
+ /
+ }
+);
+
+__PACKAGE__->register_method (
+ method => 'process_fiscal_rollover',
+ api_name => 'open-ils.acq.fiscal_rollover.propagate.dry_run',
+ stream => 1,
+ signature => { desc => q/
+ @see open-ils.acq.fiscal_rollover.propagate
+ This is the dry-run version. The action is performed,
+ new fund information is returned, then all changes are rolled back.
+ / }
+);
+
+
+
+sub process_fiscal_rollover {
+ my( $self, $conn, $auth, $year, $org_id, $descendants, $options ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('ADMIN_FUND', $org_id);
+ $options ||= {};
+
+ my $combined = ($self->api_name =~ /combined/);
+
+ my $org_ids = ($descendants) ?
+ [
+ map
+ { $_->{id} } # fetch my descendants
+ @{$e->json_query({from => ['actor.org_unit_descendants', $org_id]})}
+ ]
+ : [$org_id];
+
+ # Create next year's funds
+ # Note, it's safe to run this more than once.
+ # IOW, it will not create duplicate new funds.
+ $e->json_query({
+ from => [
+ ($descendants) ?
+ 'acq.propagate_funds_by_org_tree' :
+ 'acq.propagate_funds_by_org_unit',
+ $year, $e->requestor->id, $org_id
+ ]
+ });
+
+ if($combined) {
+
+ # Roll the uncumbrances over to next year's funds
+ # Mark the funds for $year as inactive
+
+ $e->json_query({
+ from => [
+ ($descendants) ?
+ 'acq.rollover_funds_by_org_tree' :
+ 'acq.rollover_funds_by_org_unit',
+ $year, $e->requestor->id, $org_id
+ ]
+ });
+ }
+
+ # Fetch all funds for the specified org units for the subsequent year
+ my $fund_ids = $e->search_acq_fund([
+ {
+ year => int($year) + 1,
+ org => $org_ids,
+ propagate => 't'
+ }, {
+ limit => $$options{limit} || 20,
+ offset => $$options{offset} || 0,
+ }
+ ],
+ {idlist => 1}
+ );
+
+ foreach (@$fund_ids) {
+ my $fund = $e->retrieve_acq_fund($_) or return $e->die_event;
+ $fund->summary(retrieve_fund_summary_impl($e, $fund));
+
+ my $amount = 0;
+ if($combined and $U->is_true($fund->rollover)) {
+ # see how much money was rolled over
+
+ my $sum = $e->json_query({
+ select => {acqftr => [{column => 'dest_amount', transform => 'sum'}]},
+ from => 'acqftr',
+ where => {dest_fund => $fund->id, note => 'Rollover'}
+ })->[0];
+
+ $amount = $sum->{dest_amount} if $sum;
+ }
+
+ $conn->respond({fund => $fund, rollover_amount => $amount});
+ }
+
+ $self->api_name =~ /dry_run/ and $e->rollback or $e->commit;
+ return undef;
+}
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Acq::Invoice;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Event;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+__PACKAGE__->register_method(
+ method => 'build_invoice_api',
+ api_name => 'open-ils.acq.invoice.update',
+ signature => {
+ desc => q/Creates, updates, and deletes invoices, and related invoice entries, and invoice items/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => q/Invoice/, type => 'number'},
+ {desc => q/Entries. Array of 'acqie' objects/, type => 'array'},
+ {desc => q/Items. Array of 'acqii' objects/, type => 'array'},
+ ],
+ return => {desc => 'The invoice w/ entries and items attached', type => 'object', class => 'acqinv'}
+ }
+);
+
+sub build_invoice_api {
+ my($self, $conn, $auth, $invoice, $entries, $items) = @_;
+
+ my $e = new_editor(xact => 1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $evt;
+
+ if(ref $invoice) {
+ if($invoice->isnew) {
+ $invoice->receiver($e->requestor->ws_ou) unless $invoice->receiver;
+ $invoice->recv_method('PPR') unless $invoice->recv_method;
+ $invoice->recv_date('now') unless $invoice->recv_date;
+ $e->create_acq_invoice($invoice) or return $e->die_event;
+ } elsif($invoice->isdeleted) {
+ i$e->delete_acq_invoice($invoice) or return $e->die_event;
+ } else {
+ $e->update_acq_invoice($invoice) or return $e->die_event;
+ }
+ } else {
+ # caller only provided the ID
+ $invoice = $e->retrieve_acq_invoice($invoice) or return $e->die_event;
+ }
+
+ return $e->die_event unless $e->allowed('CREATE_INVOICE', $invoice->receiver);
+
+ if($entries) {
+ for my $entry (@$entries) {
+ $entry->invoice($invoice->id);
+
+ if($entry->isnew) {
+
+ $e->create_acq_invoice_entry($entry) or return $e->die_event;
+ return $evt if $evt = update_entry_debits($e, $entry);
+
+ } elsif($entry->isdeleted) {
+
+ return $evt if $evt = rollback_entry_debits($e, $entry);
+ $e->delete_acq_invoice_entry($entry) or return $e->die_event;
+
+ } elsif($entry->ischanged) {
+
+ my $orig_entry = $e->retrieve_acq_invoice_entry($entry->id) or return $e->die_event;
+
+ if($orig_entry->amount_paid != $entry->amount_paid or
+ $entry->phys_item_count != $orig_entry->phys_item_count) {
+
+ return $evt if $evt = rollback_entry_debits($e, $orig_entry);
+ return $evt if $evt = update_entry_debits($e, $entry);
+
+ }
+
+ $e->update_acq_invoice_entry($entry) or return $e->die_event;
+ }
+ }
+ }
+
+ if($items) {
+ for my $item (@$items) {
+ $item->invoice($invoice->id);
+
+ if($item->isnew) {
+
+ $e->create_acq_invoice_item($item) or return $e->die_event;
+
+ # future: cache item types
+ my $item_type = $e->retrieve_acq_invoice_item_type(
+ $item->inv_item_type) or return $e->die_event;
+
+ # prorated items are handled separately
+ unless($U->is_true($item_type->prorate)) {
+ my $debit;
+ if($item->po_item) {
+ my $po_item = $e->retrieve_acq_po_item($item->po_item) or return $e->die_event;
+ $debit = $e->retrieve_acq_fund_debit($po_item->fund_debit) or return $e->die_event;
+ } else {
+ $debit = Fieldmapper::acq::fund_debit->new;
+ $debit->isnew(1);
+ }
+ $debit->fund($item->fund);
+ $debit->amount($item->amount_paid);
+ $debit->origin_amount($item->amount_paid);
+ $debit->origin_currency_type($e->retrieve_acq_fund($item->fund)->currency_type); # future: cache funds locally
+ $debit->encumbrance('f');
+ $debit->debit_type('direct_charge');
+
+ if($debit->isnew) {
+ $e->create_acq_fund_debit($debit) or return $e->die_event;
+ } else {
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+ }
+
+ $item->fund_debit($debit->id);
+ $e->update_acq_invoice_item($item) or return $e->die_event;
+ }
+
+ } elsif($item->isdeleted) {
+
+ $e->delete_acq_invoice_item($item) or return $e->die_event;
+
+ if($item->po_item and $e->retrieve_acq_po_item($item->po_item)->fund_debit == $item->fund_debit) {
+ # the debit is attached to the po_item. instead of deleting it, roll it back
+ # to being an encumbrance. Note: a prorated invoice_item that points to a po_item
+ # could point to a different fund_debit. We can't go back in time to collect all the
+ # prorated invoice_items (nor is the caller asking us too), so when that happens,
+ # just delete the extraneous debit (in the else block).
+ my $debit = $e->retrieve_acq_fund_debit($item->fund_debit);
+ $debit->encumbrance('t');
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+ } else {
+ $e->delete_acq_fund_debit($e->retrieve_acq_fund_debit($item->fund_debit))
+ or return $e->die_event;
+ }
+
+
+ } elsif($item->ischanged) {
+
+ my $debit = $e->retrieve_acq_fund_debit($item->fund_debit) or return $e->die_event;
+ $debit->amount($item->amount_paid);
+ $debit->fund($item->fund);
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+ $e->update_acq_invoice_item($item) or return $e->die_event;
+ }
+ }
+ }
+
+ $invoice = fetch_invoice_impl($e, $invoice->id);
+ $e->commit;
+
+ return $invoice;
+}
+
+
+sub rollback_entry_debits {
+ my($e, $entry) = @_;
+ my $debits = find_entry_debits($e, $entry, 'f', entry_amount_per_item($entry));
+ my $lineitem = $e->retrieve_acq_lineitem($entry->lineitem) or return $e->die_event;
+
+ for my $debit (@$debits) {
+ # revert to the original estimated amount re-encumber
+ $debit->encumbrance('t');
+ $debit->amount($lineitem->estimated_unit_price());
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+ update_copy_cost($e, $debit) or return $e->die_event; # clear the cost
+ }
+
+ return undef;
+}
+
+sub update_entry_debits {
+ my($e, $entry) = @_;
+
+ my $debits = find_entry_debits($e, $entry, 't');
+ return undef unless @$debits;
+
+ if($entry->phys_item_count > @$debits) {
+ $e->rollback;
+ # We can't invoice for more items than we have debits for
+ return OpenILS::Event->new(
+ 'ACQ_INVOICE_ENTRY_COUNT_EXCEEDS_DEBITS',
+ payload => {entry => $entry->id});
+ }
+
+ for my $debit (@$debits) {
+ my $amount = entry_amount_per_item($entry);
+ $debit->amount($amount);
+ $debit->encumbrance('f');
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+
+ # TODO: this does not reflect ancillary charges, like taxes, etc.
+ # We may need a way to indicate whether the amount attached to an
+ # invoice_item should be prorated and included in the copy cost.
+ # Note that acq.invoice_item_type.prorate does not necessarily
+ # mean a charge should be included in the copy price, only that
+ # it should spread accross funds.
+ update_copy_cost($e, $debit, $amount) or return $e->die_event;
+ }
+
+ return undef;
+}
+
+# update the linked copy to reflect the amount paid for the item
+# returns true on success, false on error
+sub update_copy_cost {
+ my ($e, $debit, $amount) = @_;
+
+ my $lid = $e->search_acq_lineitem_detail([
+ {fund_debit => $debit->id},
+ {flesh => 1, flesh_fields => {acqlid => ['eg_copy_id']}}
+ ])->[0];
+
+ if($lid and my $copy = $lid->eg_copy_id) {
+ defined $amount and $copy->cost($amount) or $copy->clear_cost;
+ $copy->editor($e->requestor->id);
+ $copy->edit_date('now');
+ $e->update_asset_copy($copy) or return 0;
+ }
+
+ return 1;
+}
+
+
+sub entry_amount_per_item {
+ my $entry = shift;
+ return $entry->amount_paid if $U->is_true($entry->billed_per_item);
+ return 0 if $entry->phys_item_count == 0;
+ return $entry->amount_paid / $entry->phys_item_count;
+}
+
+sub easy_money { # TODO XXX replace with something from a library
+ my ($val) = @_;
+
+ my $rounded = int($val * 100) / 100.0;
+ if ($rounded == $val) {
+ return sprintf("%.02f", $val);
+ } else {
+ return sprintf("%g", $val);
+ }
+}
+
+# 0 on failure (caller should call $e->die_event), array on success
+sub amounts_spent_per_fund {
+ my ($e, $inv_id) = @_;
+
+ my $entries = $e->search_acq_invoice_entry({"invoice" => $inv_id}) or
+ return 0;
+
+ my $items = $e->search_acq_invoice_item({"invoice" => $inv_id}) or
+ return 0;
+
+ my %totals_by_fund;
+ foreach my $entry (@$entries) {
+ my $debits = find_entry_debits($e, $entry, "f") or return 0;
+ foreach (@$debits) {
+ $totals_by_fund{$_->fund} ||= 0.0;
+ $totals_by_fund{$_->fund} += $_->amount;
+ }
+ }
+
+ foreach my $item (@$items) {
+ next unless $item->fund and $item->amount_paid;
+ $totals_by_fund{$item->fund} ||= 0.0;
+ $totals_by_fund{$item->fund} += $item->amount_paid;
+ }
+
+ my @totals;
+ foreach my $fund_id (keys %totals_by_fund) {
+ my $fund = $e->retrieve_acq_fund($fund_id) or return 0;
+ push @totals, {
+ "fund" => $fund->to_bare_hash,
+ "total" => easy_money($totals_by_fund{$fund_id})
+ };
+ }
+
+ return \@totals;
+}
+
+# there is no direct link between invoice_entry and fund debits.
+# when we need to retrieve the related debits, we have to do some searching
+sub find_entry_debits {
+ my($e, $entry, $encumbrance, $amount) = @_;
+
+ my $query = {
+ select => {acqfdeb => ['id']},
+ from => {
+ acqfdeb => {
+ acqlid => {
+ join => {
+ jub => {
+ join => {
+ acqie => {
+ filter => {id => $entry->id}
+ }
+ }
+ }
+ }
+ }
+ }
+ },
+ where => {'+acqfdeb' => {encumbrance => $encumbrance}},
+ order_by => {'acqlid' => ['recv_time']}, # un-received items will sort to the end
+ limit => $entry->phys_item_count
+ };
+
+ $query->{where}->{'+acqfdeb'}->{amount} = $amount if $amount;
+
+ my $debits = $e->json_query($query);
+ my $debit_ids = [map { $_->{id} } @$debits];
+ return (@$debit_ids) ? $e->search_acq_fund_debit({id => $debit_ids}) : [];
+}
+
+
+__PACKAGE__->register_method(
+ method => 'build_invoice_api',
+ api_name => 'open-ils.acq.invoice.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => q/Creates a new stub invoice/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => q/Invoice Id/, type => 'number'},
+ ],
+ return => {desc => 'The new invoice w/ entries and items attached', type => 'object', class => 'acqinv'}
+ }
+);
+
+
+sub fetch_invoice_api {
+ my($self, $conn, $auth, $invoice_id, $options) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $invoice = fetch_invoice_impl($e, $invoice_id, $options) or
+ return $e->event;
+ return $e->event unless $e->allowed(['VIEW_INVOICE', 'CREATE_INVOICE'], $invoice->receiver);
+
+ return $invoice;
+}
+
+sub fetch_invoice_impl {
+ my ($e, $invoice_id, $options) = @_;
+
+ $options ||= {};
+
+ my $args = $options->{"no_flesh_misc"} ? $invoice_id : [
+ $invoice_id,
+ {
+ "flesh" => 6,
+ "flesh_fields" => {
+ "acqinv" => ["entries", "items"],
+ "acqii" => ["fund_debit", "purchase_order", "po_item"]
+ }
+ }
+ ];
+
+ return $e->retrieve_acq_invoice($args);
+}
+
+__PACKAGE__->register_method(
+ method => 'prorate_invoice',
+ api_name => 'open-ils.acq.invoice.apply_prorate',
+ signature => {
+ desc => q/
+ For all invoice items that have the prorate flag set to true, this will create the necessary
+ additional invoice_item's to prorate the cost across all affected funds by percent spent for each fund.
+ /,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => q/Invoice Id/, type => 'number'},
+ ],
+ return => {desc => 'The updated invoice w/ entries and items attached', type => 'object', class => 'acqinv'}
+ }
+);
+
+
+sub prorate_invoice {
+ my($self, $conn, $auth, $invoice_id) = @_;
+
+ my $e = new_editor(xact => 1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $invoice = fetch_invoice_impl($e, $invoice_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('CREATE_INVOICE', $invoice->receiver);
+
+ my @lid_debits;
+ push(@lid_debits, @{find_entry_debits($e, $_, 'f', entry_amount_per_item($_))}) for @{$invoice->entries};
+
+ my $inv_items = $e->search_acq_invoice_item([
+ {"invoice" => $invoice_id, "fund_debit" => {"!=" => undef}},
+ {"flesh" => 1, "flesh_fields" => {"acqii" => ["fund_debit"]}}
+ ]) or return $e->die_event;
+
+ my @item_debits = map { $_->fund_debit } @$inv_items;
+
+ my %fund_totals;
+ my $total_entry_paid = 0;
+ for my $debit (@lid_debits, @item_debits) {
+ $fund_totals{$debit->fund} = 0 unless $fund_totals{$debit->fund};
+ $fund_totals{$debit->fund} += $debit->amount;
+ $total_entry_paid += $debit->amount;
+ }
+
+ $logger->info("invoice: prorating against invoice amount $total_entry_paid");
+
+ for my $item (@{$invoice->items}) {
+
+ next if $item->fund_debit; # item has already been processed
+
+ # future: cache item types locally
+ my $item_type = $e->retrieve_acq_invoice_item_type($item->inv_item_type) or return $e->die_event;
+ next unless $U->is_true($item_type->prorate);
+
+ # Prorate charges across applicable funds
+ my $full_item_paid = $item->amount_paid; # total amount paid for this item before splitting
+ my $full_item_cost = $item->cost_billed; # total amount invoiced for this item before splitting
+ my $first_round = 1;
+ my $largest_debit;
+ my $largest_item;
+ my $total_debited = 0;
+ my $total_costed = 0;
+
+ for my $fund_id (keys %fund_totals) {
+
+ my $spent_for_fund = $fund_totals{$fund_id};
+ next unless $spent_for_fund > 0;
+
+ my $prorated_amount = ($spent_for_fund / $total_entry_paid) * $full_item_paid;
+ my $prorated_cost = ($spent_for_fund / $total_entry_paid) * $full_item_cost;
+ $logger->info("invoice: attaching prorated amount $prorated_amount to fund $fund_id for invoice $invoice_id");
+
+ my $debit;
+ if($first_round and $item->po_item) {
+ # if this item is the result of a PO item, repurpose the original debit
+ # for the first chunk of the prorated amount
+ $debit = $e->retrieve_acq_fund_debit($item->po_item->fund_debit);
+ } else {
+ $debit = Fieldmapper::acq::fund_debit->new;
+ $debit->isnew(1);
+ }
+
+ $debit->fund($fund_id);
+ $debit->amount($prorated_amount);
+ $debit->origin_amount($prorated_amount);
+ $debit->origin_currency_type($e->retrieve_acq_fund($fund_id)->currency_type); # future: cache funds locally
+ $debit->encumbrance('f');
+ $debit->debit_type('prorated_charge');
+
+ if($debit->isnew) {
+ $e->create_acq_fund_debit($debit) or return $e->die_event;
+ } else {
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+ }
+
+ $total_debited += $prorated_amount;
+ $total_costed += $prorated_cost;
+ $largest_debit = $debit if !$largest_debit or $prorated_amount > $largest_debit->amount;
+
+ if($first_round) {
+
+ # re-purpose the original invoice_item for the first prorated amount
+ $item->fund($fund_id);
+ $item->fund_debit($debit->id);
+ $item->amount_paid($prorated_amount);
+ $item->cost_billed($prorated_cost);
+ $e->update_acq_invoice_item($item) or return $e->die_event;
+ $largest_item = $item if !$largest_item or $prorated_amount > $largest_item->amount_paid;
+
+ } else {
+
+ # for subsequent prorated amounts, create a new invoice_item
+ my $new_item = $item->clone;
+ $new_item->clear_id;
+ $new_item->fund($fund_id);
+ $new_item->fund_debit($debit->id);
+ $new_item->amount_paid($prorated_amount);
+ $new_item->cost_billed($prorated_cost);
+ $e->create_acq_invoice_item($new_item) or return $e->die_event;
+ $largest_item = $new_item if !$largest_item or $prorated_amount > $largest_item->amount_paid;
+ }
+
+ $first_round = 0;
+ }
+
+ # make sure the percentages didn't leave a small sliver of money over/under-debited
+ # if so, tweak the largest debit to smooth out the difference
+ if($total_debited != $full_item_paid or $total_costed != $full_item_cost) {
+
+ my $paid_diff = $full_item_paid - $total_debited;
+ my $cost_diff = $full_item_cost - $total_debited;
+ $logger->info("invoice: repairing prorate descrepency of paid:$paid_diff and cost:$cost_diff");
+ my $new_paid = $largest_item->amount_paid + $paid_diff;
+ my $new_cost = $largest_item->cost_billed + $cost_diff;
+
+ $largest_debit = $e->retrieve_acq_fund_debit($largest_debit->id); # get latest copy
+ $largest_debit->amount($new_paid);
+ $e->update_acq_fund_debit($largest_debit) or return $e->die_event;
+
+ $largest_item = $e->retrieve_acq_invoice_item($largest_item->id); # get latest copy
+ $largest_item->amount_paid($new_paid);
+ $largest_item->cost_billed($new_cost);
+
+ $e->update_acq_invoice_item($largest_item) or return $e->die_event;
+ }
+ }
+
+ $invoice = fetch_invoice_impl($e, $invoice_id);
+ $e->commit;
+
+ return $invoice;
+}
+
+
+__PACKAGE__->register_method(
+ method => "print_html_invoice",
+ api_name => "open-ils.acq.invoice.print.html",
+ stream => 1,
+ signature => {
+ desc => "Retrieve printable HTML vouchers for each given invoice",
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Invoice ID or a list of them", type => "mixed"},
+ ],
+ return => {
+ desc => q{One A/T event containing a printable HTML voucher for
+ each given invoice},
+ type => "object", class => "atev"}
+ }
+);
+
+
+sub print_html_invoice {
+ my ($self, $conn, $auth, $id_list) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ $id_list = [$id_list] unless ref $id_list;
+
+ my $invoices = $e->search_acq_invoice({"id" => $id_list}) or
+ return $e->die_event;
+
+ foreach my $invoice (@$invoices) {
+ return $e->die_event unless
+ $e->allowed("VIEW_INVOICE", $invoice->receiver);
+
+ my $amounts = amounts_spent_per_fund($e, $invoice->id) or
+ return $e->die_event;
+
+ $conn->respond(
+ $U->fire_object_event(
+ undef, "format.acqinv.html", $invoice, $invoice->receiver,
+ "print-on-demand", $amounts
+ )
+ );
+ }
+
+ $e->disconnect;
+ undef;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Acq::Lineitem;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenILS::Event;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Const qw/:const/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Acq::Financials;
+use OpenILS::Application::Cat::BibCommon;
+use OpenILS::Application::Cat::AssetCommon;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+__PACKAGE__->register_method(
+ method => 'create_lineitem',
+ api_name => 'open-ils.acq.lineitem.create',
+ signature => {
+ desc => 'Creates a lineitem',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'The lineitem object to create', type => 'object'},
+ ],
+ return => {desc => 'ID of newly created lineitem on success, Event on error'}
+ }
+);
+
+sub create_lineitem {
+ my($self, $conn, $auth, $li) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+
+ if($li->picklist) {
+ my $picklist = $e->retrieve_acq_picklist($li->picklist)
+ or return $e->die_event;
+
+ if($picklist->owner != $e->requestor->id) {
+ return $e->die_event unless
+ $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
+ }
+
+ # indicate the picklist was updated
+ $picklist->edit_time('now');
+ $picklist->editor($e->requestor->id);
+ $e->update_acq_picklist($picklist) or return $e->die_event;
+ }
+
+ if($li->purchase_order) {
+ my $po = $e->retrieve_acq_purchase_order($li->purchase_order)
+ or return $e->die_event;
+ return $e->die_event unless
+ $e->allowed('MANAGE_PROVIDER', $po->ordering_agency, $po);
+
+ $li->provider($po->provider) unless defined $li->provider;
+ }
+
+ $li->selector($e->requestor->id);
+ $e->create_acq_lineitem($li) or return $e->die_event;
+
+ $e->commit;
+ return $li->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_lineitem',
+ api_name => 'open-ils.acq.lineitem.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a lineitem',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID to retrieve', type => 'number'},
+ {options => q/Hash of options, including:
+flesh_attrs : for attributes,
+flesh_notes : for notes,
+flesh_cancel_reason : for cancel reason,
+flesh_li_details : for order details objects,
+clear_marc : to clear marcxml from lineitem/, type => 'hash'},
+ ],
+ return => {desc => 'lineitem object on success, Event on error'}
+ }
+);
+
+
+sub retrieve_lineitem {
+ my($self, $conn, $auth, $li_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return retrieve_lineitem_impl($e, $li_id, $options);
+}
+
+sub retrieve_lineitem_impl {
+ my ($e, $li_id, $options, $no_auth) = @_; # no_auth needed for EDI scripts
+ $options ||= {};
+
+ my $flesh = {
+ flesh => 3,
+ flesh_fields => {
+ jub => ['purchase_order', 'picklist'], # needed for permission check
+ acqlid => [],
+ acqlin => []
+ }
+ };
+
+ my $fields = $flesh->{flesh_fields};
+
+ push(@{$fields->{jub} }, 'attributes') if $$options{flesh_attrs};
+ push(@{$fields->{jub} },'lineitem_notes') if $$options{flesh_notes};
+ push(@{$fields->{acqlin}}, 'alert_text') if $$options{flesh_notes};
+ push(@{$fields->{jub} }, 'order_summary') if $$options{flesh_order_summary};
+ push(@{$fields->{acqlin}}, 'cancel_reason') if $$options{flesh_cancel_reason};
+
+ if($$options{flesh_li_details}) {
+ push(@{$fields->{jub} }, 'lineitem_details');
+ push(@{$fields->{acqlid}}, 'fund' ) if $$options{flesh_fund};
+ push(@{$fields->{acqlid}}, 'fund_debit' ) if $$options{flesh_fund_debit};
+ push(@{$fields->{acqlid}}, 'cancel_reason') if $$options{flesh_cancel_reason};
+ }
+
+ if($$options{clear_marc}) { # avoid fetching marc blob
+ my @fields = grep { $_ ne 'marc' } Fieldmapper::acq::lineitem->new->real_fields;
+ $flesh->{select} = {jub => [@fields]};
+ }
+
+ my $li = $e->retrieve_acq_lineitem([$li_id, $flesh]) or return $e->event;
+
+ # collect the # of lids
+ if($$options{flesh_li_details}) {
+ $li->item_count(scalar(@{$li->lineitem_details}));
+ } else {
+ my $details = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
+ $li->item_count(scalar(@$details));
+ }
+
+ # attach claims to LIDs
+ if($$options{flesh_li_details}) {
+ foreach (@{$li->lineitem_details}) {
+ $_->claims(
+ $e->search_acq_claim([
+ {"lineitem_detail", $_->id}, {
+ "flesh" => 1, "flesh_fields" => {"acqcl" => ["type"]}
+ }
+ ])
+ );
+ }
+ }
+
+ return $e->event unless ((
+ $li->purchase_order and
+ ($no_auth or $e->allowed(['VIEW_PURCHASE_ORDER', 'CREATE_PURCHASE_ORDER'],
+ $li->purchase_order->ordering_agency, $li->purchase_order))
+ ) or (
+ $li->picklist and !$li->purchase_order and # user doesn't have view_po perms
+ ($no_auth or $e->allowed(['VIEW_PICKLIST', 'CREATE_PICKLIST'],
+ $li->picklist->org_unit, $li->picklist))
+ ));
+
+ unless ($$options{flesh_po}) {
+ $li->purchase_order(
+ $li->purchase_order ? $li->purchase_order->id : undef
+ );
+ }
+ unless ($$options{flesh_pl}) {
+ $li->picklist($li->picklist ? $li->picklist->id : undef);
+ }
+ return $li;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'delete_lineitem',
+ api_name => 'open-ils.acq.lineitem.delete',
+ signature => {
+ desc => 'Deletes a lineitem',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID to delete', type => 'number'},
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'delete_lineitem',
+ api_name => 'open-ils.acq.purchase_order.lineitem.delete',
+ signature => {
+ desc => 'Deletes a lineitem from a purchase order',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID to delete', type => 'number'},
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'delete_lineitem',
+ api_name => 'open-ils.acq.picklist.lineitem.delete',
+ signature => {
+ desc => 'Deletes a lineitem from a picklist',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID to delete', type => 'number'},
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub delete_lineitem {
+ my($self, $conn, $auth, $li_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $li = $e->retrieve_acq_lineitem($li_id)
+ or return $e->die_event;
+
+ # XXX check state
+
+ if($li->picklist) {
+ my $picklist = $e->retrieve_acq_picklist($li->picklist)
+ or return $e->die_event;
+ return OpenILS::Event->new('BAD_PARAMS')
+ if $picklist->owner != $e->requestor->id;
+ } else {
+ # check PO perms
+ }
+
+ # once a LI is attached to a PO, deleting it
+ # from a picklist means *detaching* it from the picklist
+ if ($self->api_name =~ /picklist/ && $li->purchase_order) {
+ $li->clear_picklist;
+ my $evt = update_lineitem_impl($e, $li);
+ return $evt if $evt;
+ $e->commit;
+ return 1;
+ }
+
+ # delete the attached lineitem_details
+ my $lid_ids = $e->search_acq_lineitem_detail(
+ {lineitem => $li_id}, {idlist=>1});
+
+ for my $lid_id (@$lid_ids) {
+ $e->delete_acq_lineitem_detail(
+ $e->retrieve_acq_lineitem_detail($lid_id))
+ or return $e->die_event;
+ }
+
+ $e->delete_acq_lineitem($li) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'update_lineitem',
+ api_name => 'open-ils.acq.lineitem.update',
+ signature => {
+ desc => 'Update one or many lineitems',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem object update', type => 'object'}
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub update_lineitem {
+ my($self, $conn, $auth, $li) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ $li = [$li] unless ref $li eq "ARRAY";
+ foreach (@$li) {
+ my $evt = update_lineitem_impl($e, $_);
+ return $evt if $evt;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+sub update_lineitem_impl {
+ my($e, $li) = @_;
+
+ my $orig_li = $e->retrieve_acq_lineitem([
+ $li->id,
+ { flesh => 1, # grab the lineitem with picklist attached
+ flesh_fields => {jub => ['picklist', 'purchase_order']}
+ }
+ ]) or return $e->die_event;
+
+ # the marc may have been cleared on retrieval...
+ $li->marc($orig_li->marc) unless $li->marc;
+
+ $li->editor($e->requestor->id);
+ $li->edit_time('now');
+ $e->update_acq_lineitem($li) or return $e->die_event;
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'lineitem_search',
+ api_name => 'open-ils.acq.lineitem.search',
+ stream => 1,
+ signature => {
+ desc => 'Searches lineitems',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Search definition', type => 'object'},
+ {desc => 'Options hash. idlist=true', type => 'object'},
+ {desc => 'List of lineitems', type => 'object/number'},
+ ]
+ }
+);
+
+sub lineitem_search {
+ my($self, $conn, $auth, $search, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('CREATE_PICKLIST');
+ # XXX needs permissions consideration
+ my $lis = $e->search_acq_lineitem($search, {idlist=>1});
+ for my $li_id (@$lis) {
+ if($$options{idlist}) {
+ $conn->respond($li_id);
+ } else {
+ my $res = retrieve_lineitem($self, $conn, $auth, $li_id, $options);
+ $conn->respond($res) unless $U->event_code($res);
+ }
+ }
+ return undef;
+}
+
+__PACKAGE__->register_method (
+ method => 'lineitems_related_by_bib',
+ api_name => 'open-ils.acq.lineitems_for_bib.by_bib_id',
+ stream => 1,
+ signature => q/
+ Retrieves lineitems attached to same bib record, subject to the PO ordering agency. This variant takes the bib id.
+ @param authtoken Login session key
+ @param bib_id Id for the pertinent bib record.
+ @param options Object for tweaking the selection criteria and fleshing options.
+ /
+);
+
+__PACKAGE__->register_method (
+ method => 'lineitems_related_by_bib',
+ api_name => 'open-ils.acq.lineitems_for_bib.by_lineitem_id',
+ stream => 1,
+ signature => q/
+ Retrieves lineitems attached to same bib record, subject to the PO ordering agency. This variant takes the id for any of the pertinent lineitems.
+ @param authtoken Login session key
+ @param bib_id Id for a pertinent lineitem.
+ @param options Object for tweaking the selection criteria and fleshing options.
+ /
+);
+
+__PACKAGE__->register_method (
+ method => 'lineitems_related_by_bib',
+ api_name => 'open-ils.acq.lineitems_for_bib.by_lineitem_id.count',
+ stream => 1,
+ signature => q/See open-ils.acq.lineitems_for_bib.by_lineitem_id. This version returns numbers of lineitems only (XXX may count lineitems we don't actually have permission to retrieve)/
+);
+
+sub lineitems_related_by_bib {
+ my($self, $conn, $auth, $test_value, $options) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $perm_orgs = $U->user_has_work_perm_at($e, 'VIEW_PURCHASE_ORDER', {descendants =>1}, $e->requestor->id);
+
+ my $query = {
+ "select"=>{"jub"=>["id"]},
+ "from"=>{"jub" => {"acqpo" => {type => 'left'}, "acqpl" => {type => 'left'}}},
+ "where"=>{
+ '-or' => [
+ { "+acqpo"=>{ "ordering_agency" => $perm_orgs } },
+ { '+acqpl' => { org_unit => $perm_orgs } }
+ ]
+ },
+ "order_by"=>[{"class"=>"jub", "field"=>"create_time", "direction"=>"desc"}]
+ };
+
+ # Be sure we just return the original LI if no related bibs
+ if ($self->api_name =~ /by_lineitem_id/) {
+ my $orig = retrieve_lineitem($self, $conn, $auth, $test_value) or
+ return $e->die_event;
+ if ($test_value = $orig->eg_bib_id) {
+ $query->{"where"}->{"eg_bib_id"} = $test_value;
+ } else {
+ $query->{"where"}->{"id"} = $orig->id;
+ }
+ } elsif ($test_value) {
+ $query->{"where"}->{"eg_bib_id"} = $test_value;
+ } else {
+ $e->disconnect;
+ return new OpenILS::Event("BAD_PARAMS", "Null bib id");
+ }
+
+ if ($options && defined $options->{lineitem_state}) {
+ $query->{'where'}{'jub'}{'state'} = $options->{lineitem_state};
+ }
+
+ if ($options && defined $options->{po_state}) {
+ $query->{'where'}{'+acqpo'}{'state'} = $options->{po_state};
+ }
+
+ if ($options && defined $options->{order_by}) {
+ $query->{'order_by'} = $options->{order_by};
+ }
+
+ my $results = $e->json_query($query);
+ if ($self->api_name =~ /count$/) {
+ return scalar(@$results);
+ } else {
+ for my $result (@$results) {
+ # retrieve_lineitem takes care of POs and PLs and also handles
+ # options like flesh_notes and permissions checking.
+ $conn->respond(
+ retrieve_lineitem($self, $conn, $auth, $result->{"id"}, $options)
+ );
+ }
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "lineitem_search_by_attributes",
+ api_name => "open-ils.acq.lineitem.search.by_attributes",
+ stream => 1,
+ signature => {
+ desc => "Performs a search against lineitem_attrs",
+ params => [
+ {desc => "Authentication token", type => "string"},
+ { desc => q/
+Search definition:
+ attr_value_pairs : list of pairs of (attr definition ID, attr value) where value can be scalar (fuzzy match) or array (exact match)
+ li_states : list of lineitem states
+ po_agencies : list of purchase order ordering agencies (org) ids
+
+At least one of these search terms is required.
+ /,
+ type => "object"},
+ { desc => q/
+Options hash:
+ idlist : if set, only return lineitem IDs
+ clear_marc : if set, strip the MARC xml from the lineitem before delivery
+ flesh_attrs : flesh lineitem attributes;
+ /,
+ type => "object"}
+ ]
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "lineitem_search_by_attributes",
+ api_name => "open-ils.acq.lineitem.search.by_attributes.ident",
+ stream => 1,
+ signature => {
+ desc => "Performs a search against lineitem_attrs where ident is true. ".
+ "See open-ils.acq.lineitem.search.by_attributes for params."
+ }
+);
+
+sub lineitem_search_by_attributes {
+ my ($self, $conn, $auth, $search, $options) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ # XXX needs permissions consideration
+
+ return [] unless $search;
+ my $attr_value_pairs = $search->{attr_value_pairs};
+ my $li_states = $search->{li_states};
+ my $po_agencies = $search->{po_agencies}; # XXX if none, base it on perms
+
+ my $query = {
+ "select" => {"acqlia" =>
+ [{"column" => "lineitem", "transform" => "distinct"}]
+ },
+ "from" => {
+ "acqlia" => {
+ "acqliad" => {"field" => "id", "fkey" => "definition"},
+ "jub" => {
+ "field" => "id",
+ "fkey" => "lineitem",
+ "join" => {
+ "acqpo" => {
+ "type" => "left",
+ "field" => "id",
+ "fkey" => "purchase_order"
+ }
+ }
+ }
+ }
+ }
+ };
+
+ my $where = {};
+ $where->{"+acqliad"} = {"ident" => "t"}
+ if $self->api_name =~ /\.ident/;
+
+ my $searched_for_something = 0;
+
+ if (ref $attr_value_pairs eq "ARRAY") {
+ $where->{"-or"} = [];
+ foreach (@$attr_value_pairs) {
+ next if @$_ != 2;
+ my ($def, $value) = @$_;
+ push @{$where->{"-or"}}, {
+ "-and" => {
+ "attr_value" => (ref $value) ?
+ $value : {"ilike" => "%" . $value . "%"},
+ "definition" => $def
+ }
+ };
+ }
+ $searched_for_something = 1;
+ }
+
+ if ($li_states and @$li_states) {
+ $where->{"+jub"} = {"state" => $li_states};
+ $searched_for_something = 1;
+ }
+
+ if ($po_agencies and @$po_agencies) {
+ $where->{"+acqpo"} = {"ordering_agency" => $po_agencies};
+ $searched_for_something = 1;
+ }
+
+ if (not $searched_for_something) {
+ $e->rollback;
+ return new OpenILS::Event(
+ "BAD_PARAMS", note => "You have provided no search terms."
+ );
+ }
+
+ $query->{"where"} = $where;
+ my $lis = $e->json_query($query);
+
+ for my $li_id_obj (@$lis) {
+ my $li_id = $li_id_obj->{"lineitem"};
+ if($options->{"idlist"}) {
+ $conn->respond($li_id);
+ } else {
+ $conn->respond(
+ retrieve_lineitem($self, $conn, $auth, $li_id, $options)
+ );
+ }
+ }
+ undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'lineitem_search_ident',
+ api_name => 'open-ils.acq.lineitem.search.ident',
+ stream => 1,
+ signature => {
+ desc => 'Performs a search against lineitem_attrs where ident is true',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ { desc => q/Search definition. Options are:
+ attr_values : list of attribute values (required)
+ li_states : list of lineitem states
+ po_agencies : list of purchase order ordering agencies (org) ids
+ /,
+ type => 'object',
+ },
+ { desc => q/
+ Options hash. Options are:
+ idlist : if set, only return lineitem IDs
+ clear_marc : if set, strip the MARC xml from the lineitem before delivery
+ flesh_attrs : flesh lineitem attributes;
+ /,
+ type => 'object',
+ }
+ ]
+ }
+);
+
+my $LI_ATTR_SEARCH = {
+ select => { acqlia => ['lineitem'] },
+ from => {
+ acqlia => {
+ acqliad => {
+ field => 'id',
+ fkey => 'definition'
+ },
+ jub => {
+ field => 'id',
+ fkey => 'lineitem',
+ join => {
+ acqpo => {
+ field => 'id',
+ fkey => 'purchase_order'
+ }
+ }
+ }
+ }
+ }
+};
+
+sub lineitem_search_ident {
+ my($self, $conn, $auth, $search, $options) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->event unless $e->checkauth;
+ # XXX needs permissions consideration
+
+ return [] unless $search;
+ my $attr_values = $search->{attr_values};
+ my $li_states = $search->{li_states};
+ my $po_agencies = $search->{po_agencies}; # XXX if none, base it on perms
+
+ my $where_clause = {
+ '-or' => [],
+ '+acqlia' => {
+ '+acqliad' => {ident => 't'},
+ }
+ };
+
+ push(@{$where_clause->{'-or'}}, {attr_value => {ilike => "%$_%"}}) for @$attr_values;
+
+ $where_clause->{'+jub'} = {state => {in => $li_states}}
+ if $li_states and @$li_states;
+
+ $where_clause->{'+acqpo'} = {ordering_agency => $po_agencies}
+ if $po_agencies and @$po_agencies;
+
+ $LI_ATTR_SEARCH->{where} = $where_clause;
+
+ my $lis = $e->json_query($LI_ATTR_SEARCH);
+
+ for my $li_id_obj (@$lis) {
+ my $li_id = $li_id_obj->{lineitem};
+ if($$options{idlist}) {
+ $conn->respond($li_id);
+ } else {
+ my $li;
+ if($$options{flesh_attrs}) {
+ $li = $e->retrieve_acq_lineitem([
+ $li_id, {flesh => 1, flesh_fields => {jub => ['attributes']}}])
+ } else {
+ $li = $e->retrieve_acq_lineitem($li_id);
+ }
+ $li->clear_marc if $$options{clear_marc};
+ $conn->respond($li);
+ }
+ }
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_lineitem_detail',
+ api_name => 'open-ils.acq.lineitem_detail.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => q/Updates a lineitem detail/,
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'id of lineitem_detail to retrieve', type => 'number' },
+ ],
+ return => { desc => 'object on success, Event on failure' }
+ }
+);
+sub retrieve_lineitem_detail {
+ my($self, $conn, $auth, $li_detail_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $li_detail = $e->retrieve_acq_lineitem_detail($li_detail_id)
+ or return $e->event;
+
+ if($li_detail->fund) {
+ my $fund = $e->retrieve_acq_fund($li_detail->fund) or return $e->event;
+ return $e->event unless
+ $e->allowed('MANAGE_FUND', $fund->org, $fund);
+ }
+
+ # XXX check lineitem perms
+ return $li_detail;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'approve_lineitem',
+ api_name => 'open-ils.acq.lineitem.approve',
+ signature => {
+ desc => 'Mark a lineitem as approved',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'lineitem ID', type => 'number' }
+ ],
+ return => { desc => '1 on success, Event on error' }
+ }
+);
+sub approve_lineitem {
+ my($self, $conn, $auth, $li_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ # XXX perm checks for each lineitem detail
+
+ my $li = $e->retrieve_acq_lineitem($li_id)
+ or return $e->die_event;
+
+ return OpenILS::Event->new('ACQ_LINEITEM_APPROVED', payload => $li_id)
+ if $li->state eq 'approved';
+
+ my $details = $e->search_acq_lineitem_detail({lineitem => $li_id});
+ return OpenILS::Event->new('ACQ_LINEITEM_NO_COPIES', payload => $li_id)
+ unless scalar(@$details) > 0;
+
+ for my $detail (@$details) {
+ return OpenILS::Event->new('ACQ_LINEITEM_DETAIL_NO_FUND', payload => $detail->id)
+ unless $detail->fund;
+
+ return OpenILS::Event->new('ACQ_LINEITEM_DETAIL_NO_ORG', payload => $detail->id)
+ unless $detail->owning_lib;
+ }
+
+ $li->state('approved');
+ $li->edit_time('now');
+ $e->update_acq_lineitem($li) or return $e->die_event;
+
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'set_lineitem_attr',
+ api_name => 'open-ils.acq.lineitem_usr_attr.set',
+ signature => {
+ desc => 'Sets a lineitem_usr_attr value',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Lineitem ID', type => 'number' },
+ { desc => 'Attr name', type => 'string' },
+ { desc => 'Attr value', type => 'string' }
+ ],
+ return => { desc => '1 on success, Event on error' }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'set_lineitem_attr',
+ api_name => 'open-ils.acq.lineitem_local_attr.set',
+ signature => {
+ desc => 'Sets a lineitem_local_attr value',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Lineitem ID', type => 'number' },
+ { desc => 'Attr name', type => 'string' },
+ { desc => 'Attr value', type => 'string' }
+ ],
+ return => { desc => 'ID of the attr object on success, Event on error' }
+ }
+);
+
+
+sub set_lineitem_attr {
+ my($self, $conn, $auth, $li_id, $attr_name, $attr_value) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ # XXX perm
+
+ my $attr_type = $self->api_name =~ /local_attr/ ?
+ 'lineitem_local_attr_definition' : 'lineitem_usr_attr_definition';
+
+ my $attr = $e->search_acq_lineitem_attr({
+ lineitem => $li_id,
+ attr_type => $attr_type,
+ attr_name => $attr_name})->[0];
+
+ my $find = "search_acq_$attr_type";
+
+ if($attr) {
+ $attr->attr_value($attr_value);
+ $e->update_acq_lineitem_attr($attr) or return $e->die_event;
+ } else {
+ $attr = Fieldmapper::acq::lineitem_attr->new;
+ $attr->lineitem($li_id);
+ $attr->attr_type($attr_type);
+ $attr->attr_name($attr_name);
+ $attr->attr_value($attr_value);
+
+ my $attr_def_id = $e->$find({code => $attr_name}, {idlist=>1})->[0]
+ or return $e->die_event;
+ $attr->definition($attr_def_id);
+ $e->create_acq_lineitem_attr($attr) or return $e->die_event;
+ }
+
+ $e->commit;
+ return $attr->id;
+}
+
+__PACKAGE__->register_method(
+ method => 'get_lineitem_attr_defs',
+ api_name => 'open-ils.acq.lineitem_attr_definition.retrieve.all',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieve lineitem attr definitions',
+ params => [ { desc => 'Authentication token', type => 'string' }, ],
+ return => { desc => 'List of attr definitions' }
+ }
+);
+
+sub get_lineitem_attr_defs {
+ my($self, $conn, $auth) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my %results;
+ for my $type (qw/generated marc local usr provider/) {
+ my $call = "retrieve_all_acq_lineitem_${type}_attr_definition";
+ $results{$type} = $e->$call;
+ }
+ return \%results;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'lineitem_note_CUD_batch',
+ api_name => 'open-ils.acq.lineitem_note.cud.batch',
+ stream => 1,
+ signature => {
+ desc => q/Manage lineitem notes/,
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'List of lineitem_notes to manage', type => 'array' },
+ ],
+ return =>
+ { desc => 'Streaming response of current position in the array' }
+ }
+);
+
+sub lineitem_note_CUD_batch {
+ my($self, $conn, $auth, $li_notes) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ # XXX perms
+
+ my $total = @$li_notes;
+ my $count = 0;
+
+ for my $note (@$li_notes) {
+
+ $note->editor($e->requestor->id);
+ $note->edit_time('now');
+
+ if($note->isnew) {
+ $note->creator($e->requestor->id);
+ $note = $e->create_acq_lineitem_note($note) or return $e->die_event;
+
+ } elsif($note->isdeleted) {
+ $e->delete_acq_lineitem_note($note) or return $e->die_event;
+
+ } elsif($note->ischanged) {
+ $e->update_acq_lineitem_note($note) or return $e->die_event;
+ }
+
+ if(!$note->isdeleted) {
+ $note = $e->retrieve_acq_lineitem_note([
+ $note->id, {
+ "flesh" => 1, "flesh_fields" => {"acqlin" => ["alert_text"]}
+ }
+ ]);
+ }
+
+ $conn->respond({maximum => $total, progress => ++$count, note => $note});
+ }
+
+ $e->commit;
+ return {complete => 1};
+}
+
+__PACKAGE__->register_method(
+ method => 'ranged_line_item_alert_text',
+ api_name => 'open-ils.acq.line_item_alert_text.ranged.retrieve.all'); # TODO: signature
+
+sub ranged_line_item_alert_text {
+ my($self, $conn, $auth, $org_id, $depth) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('ADMIN_ACQ_LINEITEM_ALERT_TEXT', $org_id);
+ return $e->search_acq_lineitem_alert_text(
+ {owning_lib => $U->get_org_full_path($org_id, $depth)});
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_lineitem_by_copy_id",
+ api_name => "open-ils.acq.lineitem.retrieve.by_copy_id",
+ authoritative => 1,
+ signature => {
+ desc => q/Manage lineitem notes/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Evergreen internal copy ID", type => "number"},
+ {desc => "Hash of options (see open-ils.acq.lineitem.retrieve",
+ type => "object"}
+ ],
+ return => {
+ desc => "Lineitem associated with given copy",
+ type => "object", class => "jub"
+ }
+ }
+);
+
+sub retrieve_lineitem_by_copy_id {
+ my ($self, $conn, $auth, $object_id, $options) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $result = $e->json_query({
+ "select" => {"acqlid" => ["lineitem"]},
+ "from" => "acqlid",
+ "where" => {"eg_copy_id" => $object_id}
+ })->[0] or do {
+ $e->disconnect;
+ return new OpenILS::Event("ACQ_LINEITEM_NOT_FOUND");
+ };
+
+ my $li = retrieve_lineitem_impl($e, $result->{"lineitem"}, $options) or
+ return $e->die_event;
+
+ $e->disconnect;
+ return $li;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Acq::BatchManager;
+use OpenILS::Application::Acq::Financials;
+use OpenSRF::AppSession;
+use OpenSRF::EX qw/:try/;
+use strict; use warnings;
+
+sub new {
+ my($class, %args) = @_;
+ my $self = bless(\%args, $class);
+ $self->{args} = {
+ lid => 0,
+ li => 0,
+ copies => 0,
+ bibs => 0,
+ progress => 0,
+ debits_accrued => 0,
+ purchase_order => undef,
+ picklist => undef,
+ complete => 0,
+ indexed => 0,
+ total => 0
+ };
+ $self->{ingest_queue} = [];
+ $self->{cache} = {};
+ $self->throttle(5) unless $self->throttle;
+ $self->{post_proc_queue} = [];
+ $self->{last_respond_progress} = 0;
+ return $self;
+}
+
+sub conn {
+ my($self, $val) = @_;
+ $self->{conn} = $val if $val;
+ return $self->{conn};
+}
+sub throttle {
+ my($self, $val) = @_;
+ $self->{throttle} = $val if $val;
+ return $self->{throttle};
+}
+sub respond {
+ my($self, %other_args) = @_;
+ if($self->throttle and not %other_args) {
+ return unless (
+ ($self->{args}->{progress} - $self->{last_respond_progress}) >= $self->throttle
+ );
+ }
+ $self->conn->respond({ %{$self->{args}}, %other_args });
+ $self->{last_respond_progress} = $self->{args}->{progress};
+}
+sub respond_complete {
+ my($self, %other_args) = @_;
+ $self->complete;
+ $self->conn->respond_complete({ %{$self->{args}}, %other_args });
+ $self->run_post_response_hooks;
+ return undef;
+}
+
+# run the post response hook subs, shifting them off as we go
+sub run_post_response_hooks {
+ my($self) = @_;
+ (shift @{$self->{post_proc_queue}})->() while @{$self->{post_proc_queue}};
+}
+
+# any subs passed to this method will be run after the call to respond_complete
+sub post_process {
+ my($self, $sub) = @_;
+ push(@{$self->{post_proc_queue}}, $sub);
+}
+
+sub total {
+ my($self, $val) = @_;
+ $self->{args}->{total} = $val if defined $val;
+ $self->{args}->{maximum} = $self->{args}->{total};
+ return $self->{args}->{total};
+}
+sub purchase_order {
+ my($self, $val) = @_;
+ $self->{args}->{purchase_order} = $val if $val;
+ return $self;
+}
+sub picklist {
+ my($self, $val) = @_;
+ $self->{args}->{picklist} = $val if $val;
+ return $self;
+}
+sub add_lid {
+ my $self = shift;
+ $self->{args}->{lid} += 1;
+ $self->{args}->{progress} += 1;
+ return $self;
+}
+sub add_li {
+ my $self = shift;
+ $self->{args}->{li} += 1;
+ $self->{args}->{progress} += 1;
+ return $self;
+}
+sub add_copy {
+ my $self = shift;
+ $self->{args}->{copies} += 1;
+ $self->{args}->{progress} += 1;
+ return $self;
+}
+sub add_bib {
+ my $self = shift;
+ $self->{args}->{bibs} += 1;
+ $self->{args}->{progress} += 1;
+ return $self;
+}
+sub add_debit {
+ my($self, $amount) = @_;
+ $self->{args}->{debits_accrued} += $amount;
+ $self->{args}->{progress} += 1;
+ return $self;
+}
+sub editor {
+ my($self, $editor) = @_;
+ $self->{editor} = $editor if defined $editor;
+ return $self->{editor};
+}
+sub complete {
+ my $self = shift;
+ $self->{args}->{complete} = 1;
+ return $self;
+}
+
+sub ingest_ses {
+ my($self, $val) = @_;
+ $self->{ingest_ses} = $val if $val;
+ return $self->{ingest_ses};
+}
+
+sub push_ingest_queue {
+ my($self, $rec_id) = @_;
+
+ $self->ingest_ses(OpenSRF::AppSession->connect('open-ils.ingest'))
+ unless $self->ingest_ses;
+
+ my $req = $self->ingest_ses->request('open-ils.ingest.full.biblio.record', $rec_id);
+
+ push(@{$self->{ingest_queue}}, $req);
+}
+
+sub process_ingest_records {
+ my $self = shift;
+ return unless @{$self->{ingest_queue}};
+
+ for my $req (@{$self->{ingest_queue}}) {
+
+ try {
+ $req->gather(1);
+ $self->{args}->{indexed} += 1;
+ $self->{args}->{progress} += 1;
+ } otherwise {};
+
+ $self->respond;
+ }
+ $self->ingest_ses->disconnect;
+}
+
+
+sub cache {
+ my($self, $org, $key, $val) = @_;
+ $self->{cache}->{$org} = {} unless $self->{cache}->{org};
+ $self->{cache}->{$org}->{$key} = $val if defined $val;
+ return $self->{cache}->{$org}->{$key};
+}
+
+
+package OpenILS::Application::Acq::Order;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+# ----------------------------------------------------------------------------
+# Break up each component of the order process and pieces into managable
+# actions that can be shared across different workflows
+# ----------------------------------------------------------------------------
+use OpenILS::Event;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenSRF::Utils::JSON;
+use OpenSRF::AppSession;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Const qw/:const/;
+use OpenSRF::EX q/:try/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Cat::BibCommon;
+use OpenILS::Application::Cat::AssetCommon;
+use MARC::Record;
+use MARC::Batch;
+use MARC::File::XML;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+# ----------------------------------------------------------------------------
+# Lineitem
+# ----------------------------------------------------------------------------
+sub create_lineitem {
+ my($mgr, %args) = @_;
+ my $li = Fieldmapper::acq::lineitem->new;
+ $li->creator($mgr->editor->requestor->id);
+ $li->selector($li->creator);
+ $li->editor($li->creator);
+ $li->create_time('now');
+ $li->edit_time('now');
+ $li->state('new');
+ $li->$_($args{$_}) for keys %args;
+ $li->clear_id;
+ $mgr->add_li;
+ $mgr->editor->create_acq_lineitem($li) or return 0;
+
+ unless($li->estimated_unit_price) {
+ # extract the price from the MARC data
+ my $price = get_li_price_from_attr($mgr->editor, $li) or return $li;
+ $li->estimated_unit_price($price);
+ return update_lineitem($mgr, $li);
+ }
+
+ return $li;
+}
+
+sub get_li_price_from_attr {
+ my($e, $li) = @_;
+ my $attrs = $li->attributes || $e->search_acq_lineitem_attr({lineitem => $li->id});
+
+ for my $attr_type (qw/
+ lineitem_local_attr_definition
+ lineitem_prov_attr_definition
+ lineitem_marc_attr_definition/) {
+
+ my ($attr) = grep {
+ $_->attr_name eq 'estimated_price' and
+ $_->attr_type eq $attr_type } @$attrs;
+
+ return $attr->attr_value if $attr;
+ }
+
+ return undef;
+}
+
+
+sub update_lineitem {
+ my($mgr, $li) = @_;
+ $li->edit_time('now');
+ $li->editor($mgr->editor->requestor->id);
+ $mgr->add_li;
+ return $mgr->editor->retrieve_acq_lineitem($mgr->editor->data) if
+ $mgr->editor->update_acq_lineitem($li);
+ return undef;
+}
+
+
+# ----------------------------------------------------------------------------
+# Create real holds from patron requests for a given lineitem
+# ----------------------------------------------------------------------------
+sub promote_lineitem_holds {
+ my($mgr, $li) = @_;
+
+ my $requests = $mgr->editor->search_acq_user_request(
+ { lineitem => $li->id,
+ '-or' =>
+ [ { need_before => {'>' => 'now'} },
+ { need_before => undef }
+ ]
+ }
+ );
+
+ for my $request ( @$requests ) {
+
+ $request->eg_bib( $li->eg_bib_id );
+ $mgr->editor->update_acq_user_request( $request ) or return 0;
+
+ next unless ($U->is_true( $request->hold ));
+
+ my $hold = Fieldmapper::action::hold_request->new;
+ $hold->usr( $request->usr );
+ $hold->requestor( $request->usr );
+ $hold->request_time( $request->request_date );
+ $hold->pickup_lib( $request->pickup_lib );
+ $hold->request_lib( $request->pickup_lib );
+ $hold->selection_ou( $request->pickup_lib );
+ $hold->phone_notify( $request->phone_notify );
+ $hold->email_notify( $request->email_notify );
+ $hold->expire_time( $request->need_before );
+
+ if ($request->holdable_formats) {
+ my $mrm = $mgr->editor->search_metabib_metarecord_source_map( { source => $li->eg_bib_id } )->[0];
+ if ($mrm) {
+ $hold->hold_type( 'M' );
+ $hold->holdable_formats( $request->holdable_formats );
+ $hold->target( $mrm->metarecord );
+ }
+ }
+
+ if (!$hold->target) {
+ $hold->hold_type( 'T' );
+ $hold->target( $li->eg_bib_id );
+ }
+
+ $mgr->editor->create_actor_hold_request( $hold ) or return 0;
+ }
+
+ return $li;
+}
+
+sub delete_lineitem {
+ my($mgr, $li) = @_;
+ $li = $mgr->editor->retrieve_acq_lineitem($li) unless ref $li;
+
+ # delete the attached lineitem_details
+ my $lid_ids = $mgr->editor->search_acq_lineitem_detail({lineitem => $li->id}, {idlist=>1});
+ for my $lid_id (@$lid_ids) {
+ return 0 unless delete_lineitem_detail($mgr, $lid_id);
+ }
+
+ $mgr->add_li;
+ return $mgr->editor->delete_acq_lineitem($li);
+}
+
+# begins and commit transactions as it goes
+sub create_lineitem_list_assets {
+ my($mgr, $li_ids) = @_;
+ return undef if check_import_li_marc_perms($mgr, $li_ids);
+
+ # create the bibs/volumes/copies and ingest the records
+ for my $li_id (@$li_ids) {
+ $mgr->editor->xact_begin;
+ my $data = create_lineitem_assets($mgr, $li_id) or return undef;
+ $mgr->editor->xact_commit;
+ # XXX ingest is in-db now
+ #$mgr->push_ingest_queue($data->{li}->eg_bib_id) if $data->{new_bib};
+ $mgr->respond;
+ }
+ $mgr->process_ingest_records;
+ return 1;
+}
+
+# returns event on error, undef on success
+sub check_import_li_marc_perms {
+ my($mgr, $li_ids) = @_;
+
+ # if there are any order records that are not linked to
+ # in-db bib records, verify staff has perms to import order records
+ my $order_li = $mgr->editor->search_acq_lineitem(
+ [{id => $li_ids, eg_bib_id => undef}, {limit => 1}], {idlist => 1})->[0];
+
+ if($order_li) {
+ return $mgr->editor->die_event unless
+ $mgr->editor->allowed('IMPORT_ACQ_LINEITEM_BIB_RECORD');
+ }
+
+ return undef;
+}
+
+
+# ----------------------------------------------------------------------------
+# if all of the lineitem details for this lineitem have
+# been received, mark the lineitem as received
+# returns 1 on non-received, li on received, 0 on error
+# ----------------------------------------------------------------------------
+
+sub describe_affected_po {
+ my ($e, $po) = @_;
+
+ my ($enc, $spent) =
+ OpenILS::Application::Acq::Financials::build_price_summary(
+ $e, $po->id
+ );
+
+ +{$po->id => {
+ "state" => $po->state,
+ "amount_encumbered" => $enc,
+ "amount_spent" => $spent
+ }
+ };
+}
+
+sub check_lineitem_received {
+ my($mgr, $li_id) = @_;
+
+ my $non_recv = $mgr->editor->search_acq_lineitem_detail(
+ {recv_time => undef, lineitem => $li_id}, {idlist=>1});
+
+ return 1 if @$non_recv;
+
+ my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
+ $li->state('received');
+ return update_lineitem($mgr, $li);
+}
+
+sub receive_lineitem {
+ my($mgr, $li_id, $skip_complete_check) = @_;
+ my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
+
+ my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
+ {lineitem => $li_id, recv_time => undef}, {idlist => 1});
+
+ for my $lid_id (@$lid_ids) {
+ receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
+ }
+
+ $mgr->add_li;
+ $li->state('received');
+
+ $li = update_lineitem($mgr, $li) or return 0;
+ $mgr->post_process( sub { create_lineitem_status_events($mgr, $li_id, 'aur.received'); });
+
+ my $po;
+ return 0 unless
+ $skip_complete_check or (
+ $po = check_purchase_order_received($mgr, $li->purchase_order)
+ );
+
+ my $result = {"li" => {$li->id => {"state" => $li->state}}};
+ $result->{"po"} = describe_affected_po($mgr->editor, $po) if ref $po;
+ return $result;
+}
+
+sub rollback_receive_lineitem {
+ my($mgr, $li_id) = @_;
+ my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
+
+ my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
+ {lineitem => $li_id, recv_time => {'!=' => undef}}, {idlist => 1});
+
+ for my $lid_id (@$lid_ids) {
+ rollback_receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
+ }
+
+ $mgr->add_li;
+ $li->state('on-order');
+ return update_lineitem($mgr, $li);
+}
+
+
+sub create_lineitem_status_events {
+ my($mgr, $li_id, $hook) = @_;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->connect;
+ my $user_reqs = $mgr->editor->search_acq_user_request([
+ {lineitem => $li_id},
+ {flesh => 1, flesh_fields => {aur => ['usr']}}
+ ]);
+
+ for my $user_req (@$user_reqs) {
+ my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $user_req->usr->home_ou);
+ $req->recv;
+ }
+
+ $ses->disconnect;
+ return undef;
+}
+
+# ----------------------------------------------------------------------------
+# Lineitem Detail
+# ----------------------------------------------------------------------------
+sub create_lineitem_detail {
+ my($mgr, %args) = @_;
+ my $lid = Fieldmapper::acq::lineitem_detail->new;
+ $lid->$_($args{$_}) for keys %args;
+ $lid->clear_id;
+ $mgr->add_lid;
+ return $mgr->editor->create_acq_lineitem_detail($lid);
+}
+
+
+# flesh out any required data with default values where appropriate
+sub complete_lineitem_detail {
+ my($mgr, $lid) = @_;
+ unless($lid->barcode) {
+ my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_barcode_prefix') || 'ACQ';
+ $lid->barcode($pfx.$lid->id);
+ }
+
+ unless($lid->cn_label) {
+ my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_callnumber_prefix') || 'ACQ';
+ $lid->cn_label($pfx.$lid->id);
+ }
+
+ if(!$lid->location and my $loc = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.default_copy_location')) {
+ $lid->location($loc);
+ }
+
+ $lid->circ_modifier(get_default_circ_modifier($mgr, $lid->owning_lib))
+ unless defined $lid->circ_modifier;
+
+ $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
+ return $lid;
+}
+
+sub get_default_circ_modifier {
+ my($mgr, $org) = @_;
+ my $code = $mgr->cache($org, 'def_circ_mod');
+ $code = $U->ou_ancestor_setting_value($org, 'acq.default_circ_modifier') unless defined $code;
+ return $mgr->cache($org, 'def_circ_mod', $code) if defined $code;
+ return undef;
+}
+
+sub delete_lineitem_detail {
+ my($mgr, $lid) = @_;
+ $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid) unless ref $lid;
+ return $mgr->editor->delete_acq_lineitem_detail($lid);
+}
+
+
+sub receive_lineitem_detail {
+ my($mgr, $lid_id, $skip_complete_check) = @_;
+ my $e = $mgr->editor;
+
+ my $lid = $e->retrieve_acq_lineitem_detail([
+ $lid_id,
+ { flesh => 1,
+ flesh_fields => {
+ acqlid => ['fund_debit']
+ }
+ }
+ ]) or return 0;
+
+ return 1 if $lid->recv_time;
+
+ $lid->recv_time('now');
+ $e->update_acq_lineitem_detail($lid) or return 0;
+
+ my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
+ $copy->status(OILS_COPY_STATUS_IN_PROCESS);
+ $copy->edit_date('now');
+ $copy->editor($e->requestor->id);
+ $e->update_asset_copy($copy) or return 0;
+
+ $mgr->add_lid;
+
+ return 1 if $skip_complete_check;
+
+ my $li = check_lineitem_received($mgr, $lid->lineitem) or return 0;
+ return 1 if $li == 1; # li not received
+
+ return check_purchase_order_received($mgr, $li->purchase_order) or return 0;
+}
+
+
+sub rollback_receive_lineitem_detail {
+ my($mgr, $lid_id) = @_;
+ my $e = $mgr->editor;
+
+ my $lid = $e->retrieve_acq_lineitem_detail([
+ $lid_id,
+ { flesh => 1,
+ flesh_fields => {
+ acqlid => ['fund_debit']
+ }
+ }
+ ]) or return 0;
+
+ return 1 unless $lid->recv_time;
+
+ $lid->clear_recv_time;
+ $e->update_acq_lineitem_detail($lid) or return 0;
+
+ my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
+ $copy->status(OILS_COPY_STATUS_ON_ORDER);
+ $copy->edit_date('now');
+ $copy->editor($e->requestor->id);
+ $e->update_asset_copy($copy) or return 0;
+
+ $mgr->add_lid;
+ return $lid;
+}
+
+# ----------------------------------------------------------------------------
+# Lineitem Attr
+# ----------------------------------------------------------------------------
+sub set_lineitem_attr {
+ my($mgr, %args) = @_;
+ my $attr_type = $args{attr_type};
+
+ # first, see if it's already set. May just need to overwrite it
+ my $attr = $mgr->editor->search_acq_lineitem_attr({
+ lineitem => $args{lineitem},
+ attr_type => $args{attr_type},
+ attr_name => $args{attr_name}
+ })->[0];
+
+ if($attr) {
+ $attr->attr_value($args{attr_value});
+ return $attr if $mgr->editor->update_acq_lineitem_attr($attr);
+ return undef;
+
+ } else {
+
+ $attr = Fieldmapper::acq::lineitem_attr->new;
+ $attr->$_($args{$_}) for keys %args;
+
+ unless($attr->definition) {
+ my $find = "search_acq_$attr_type";
+ my $attr_def_id = $mgr->editor->$find({code => $attr->attr_name}, {idlist=>1})->[0] or return 0;
+ $attr->definition($attr_def_id);
+ }
+ return $mgr->editor->create_acq_lineitem_attr($attr);
+ }
+}
+
+# ----------------------------------------------------------------------------
+# Lineitem Debits
+# ----------------------------------------------------------------------------
+sub create_lineitem_debits {
+ my ($mgr, $li, $dry_run) = @_;
+
+ unless($li->estimated_unit_price) {
+ $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PRICE', payload => $li->id));
+ $mgr->editor->rollback;
+ return 0;
+ }
+
+ unless($li->provider) {
+ $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PROVIDER', payload => $li->id));
+ $mgr->editor->rollback;
+ return 0;
+ }
+
+ my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
+ {lineitem => $li->id},
+ {idlist=>1}
+ );
+
+ for my $lid_id (@$lid_ids) {
+
+ my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
+ $lid_id,
+ { flesh => 1,
+ flesh_fields => {acqlid => ['fund']}
+ }
+ ]);
+
+ create_lineitem_detail_debit($mgr, $li, $lid, $dry_run) or return 0;
+ }
+
+ return 1;
+}
+
+
+# flesh li->provider
+# flesh lid->fund
+sub create_lineitem_detail_debit {
+ my ($mgr, $li, $lid, $dry_run, $no_translate) = @_;
+
+ # don't create the debit if one already exists
+ return $mgr->editor->retrieve_acq_fund_debit($lid->fund_debit) if $lid->fund_debit;
+
+ my $li_id = ref($li) ? $li->id : $li;
+
+ unless(ref $li and ref $li->provider) {
+ $li = $mgr->editor->retrieve_acq_lineitem([
+ $li_id,
+ { flesh => 1,
+ flesh_fields => {jub => ['provider']},
+ }
+ ]);
+ }
+
+ if(ref $lid) {
+ $lid->fund($mgr->editor->retrieve_acq_fund($lid->fund)) unless(ref $lid->fund);
+ } else {
+ $lid = $mgr->editor->retrieve_acq_lineitem_detail([
+ $lid,
+ { flesh => 1,
+ flesh_fields => {acqlid => ['fund']}
+ }
+ ]);
+ }
+
+ unless ($lid->fund) {
+ $mgr->editor->event(
+ new OpenILS::Event("ACQ_FUND_NOT_FOUND") # close enough
+ );
+ return 0;
+ }
+
+ my $amount = $li->estimated_unit_price;
+ if($li->provider->currency_type ne $lid->fund->currency_type and !$no_translate) {
+
+ # At Fund debit creation time, translate into the currency of the fund
+ # TODO: org setting to disable automatic currency conversion at debit create time?
+
+ $amount = $mgr->editor->json_query({
+ from => [
+ 'acq.exchange_ratio',
+ $li->provider->currency_type, # source currency
+ $lid->fund->currency_type, # destination currency
+ $li->estimated_unit_price # source amount
+ ]
+ })->[0]->{value};
+ }
+
+ my $debit = create_fund_debit(
+ $mgr,
+ $dry_run,
+ fund => $lid->fund->id,
+ origin_amount => $li->estimated_unit_price,
+ origin_currency_type => $li->provider->currency_type,
+ amount => $amount
+ ) or return 0;
+
+ $lid->fund_debit($debit->id);
+ $lid->fund($lid->fund->id);
+ $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
+ return $debit;
+}
+
+
+__PACKAGE__->register_method(
+ "method" => "fund_exceeds_balance_percent_api",
+ "api_name" => "open-ils.acq.fund.check_balance_percentages",
+ "signature" => {
+ "desc" => q/Determine whether a given fund exceeds its defined
+ "balance stop and warning percentages"/,
+ "params" => [
+ {"desc" => "Authentication token", "type" => "string"},
+ {"desc" => "Fund ID", "type" => "number"},
+ {"desc" => "Theoretical debit amount (optional)",
+ "type" => "number"}
+ ],
+ "return" => {"desc" => q/An array of two values, for stop and warning,
+ in that order: 1 if fund exceeds that balance percentage, else 0/}
+ }
+);
+
+sub fund_exceeds_balance_percent_api {
+ my ($self, $conn, $auth, $fund_id, $debit_amount) = @_;
+
+ $debit_amount ||= 0;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $fund = $e->retrieve_acq_fund($fund_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed("VIEW_FUND", $fund->org);
+
+ my $result = [
+ fund_exceeds_balance_percent($fund, $debit_amount, $e, "stop"),
+ fund_exceeds_balance_percent($fund, $debit_amount, $e, "warning")
+ ];
+
+ $e->disconnect;
+ return $result;
+}
+
+sub fund_exceeds_balance_percent {
+ my ($fund, $debit_amount, $e, $which) = @_;
+
+ my ($method_name, $event_name) = @{{
+ "warning" => [
+ "balance_warning_percent", "ACQ_FUND_EXCEEDS_WARN_PERCENT"
+ ],
+ "stop" => [
+ "balance_stop_percent", "ACQ_FUND_EXCEEDS_STOP_PERCENT"
+ ]
+ }->{$which}};
+
+ if ($fund->$method_name) {
+ my $balance =
+ $e->search_acq_fund_combined_balance({"fund" => $fund->id})->[0];
+ my $allocations =
+ $e->search_acq_fund_allocation_total({"fund" => $fund->id})->[0];
+
+ $balance = ($balance) ? $balance->amount : 0;
+ $allocations = ($allocations) ? $allocations->amount : 0;
+
+ if (
+ $allocations == 0 || # if no allocations were ever made, assume we have hit the stop percent
+ ((($allocations - $balance + $debit_amount) / $allocations) * 100) > $fund->$method_name
+ ) {
+ $logger->info("fund would hit a limit: " . $fund->id . ", $balance, $debit_amount, $allocations, $method_name");
+ $e->event(
+ new OpenILS::Event(
+ $event_name,
+ "payload" => {
+ "fund" => $fund, "debit_amount" => $debit_amount
+ }
+ )
+ );
+ return 1;
+ }
+ }
+ return 0;
+}
+
+# ----------------------------------------------------------------------------
+# Fund Debit
+# ----------------------------------------------------------------------------
+sub create_fund_debit {
+ my($mgr, $dry_run, %args) = @_;
+
+ # Verify the fund is not being spent beyond the hard stop amount
+ my $fund = $mgr->editor->retrieve_acq_fund($args{fund}) or return 0;
+
+ return 0 if
+ fund_exceeds_balance_percent(
+ $fund, $args{"amount"}, $mgr->editor, "stop"
+ );
+ return 0 if
+ $dry_run and fund_exceeds_balance_percent(
+ $fund, $args{"amount"}, $mgr->editor, "warning"
+ );
+
+ my $debit = Fieldmapper::acq::fund_debit->new;
+ $debit->debit_type('purchase');
+ $debit->encumbrance('t');
+ $debit->$_($args{$_}) for keys %args;
+ $debit->clear_id;
+ $mgr->add_debit($debit->amount);
+ return $mgr->editor->create_acq_fund_debit($debit);
+}
+
+
+# ----------------------------------------------------------------------------
+# Picklist
+# ----------------------------------------------------------------------------
+sub create_picklist {
+ my($mgr, %args) = @_;
+ my $picklist = Fieldmapper::acq::picklist->new;
+ $picklist->creator($mgr->editor->requestor->id);
+ $picklist->owner($picklist->creator);
+ $picklist->editor($picklist->creator);
+ $picklist->create_time('now');
+ $picklist->edit_time('now');
+ $picklist->org_unit($mgr->editor->requestor->ws_ou);
+ $picklist->owner($mgr->editor->requestor->id);
+ $picklist->$_($args{$_}) for keys %args;
+ $picklist->clear_id;
+ $mgr->picklist($picklist);
+ return $mgr->editor->create_acq_picklist($picklist);
+}
+
+sub update_picklist {
+ my($mgr, $picklist) = @_;
+ $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
+ $picklist->edit_time('now');
+ $picklist->editor($mgr->editor->requestor->id);
+ if ($mgr->editor->update_acq_picklist($picklist)) {
+ $picklist = $mgr->editor->retrieve_acq_picklist($mgr->editor->data);
+ $mgr->picklist($picklist);
+ return $picklist;
+ } else {
+ return undef;
+ }
+}
+
+sub delete_picklist {
+ my($mgr, $picklist) = @_;
+ $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
+
+ # delete all 'new' lineitems
+ my $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => 'new'}, {idlist => 1});
+ for my $li_id (@$li_ids) {
+ my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
+ return 0 unless delete_lineitem($mgr, $li);
+ $mgr->respond;
+ }
+
+ # detach all non-'new' lineitems
+ $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}}, {idlist => 1});
+ for my $li_id (@$li_ids) {
+ my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
+ $li->clear_picklist;
+ return 0 unless update_lineitem($mgr, $li);
+ $mgr->respond;
+ }
+
+ # remove any picklist-specific object perms
+ my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => ''.$picklist->id});
+ for my $op (@$ops) {
+ return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
+ }
+
+ return $mgr->editor->delete_acq_picklist($picklist);
+}
+
+# ----------------------------------------------------------------------------
+# Purchase Order
+# ----------------------------------------------------------------------------
+sub update_purchase_order {
+ my($mgr, $po) = @_;
+ $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
+ $po->editor($mgr->editor->requestor->id);
+ $po->edit_time('now');
+ $mgr->purchase_order($po);
+ return $mgr->editor->retrieve_acq_purchase_order($mgr->editor->data)
+ if $mgr->editor->update_acq_purchase_order($po);
+ return undef;
+}
+
+sub create_purchase_order {
+ my($mgr, %args) = @_;
+
+ # verify the chosen provider is still active
+ my $provider = $mgr->editor->retrieve_acq_provider($args{provider}) or return 0;
+ unless($U->is_true($provider->active)) {
+ $logger->error("provider is not active. cannot create PO");
+ $mgr->editor->event(OpenILS::Event->new('ACQ_PROVIDER_INACTIVE'));
+ return 0;
+ }
+
+ my $po = Fieldmapper::acq::purchase_order->new;
+ $po->creator($mgr->editor->requestor->id);
+ $po->editor($mgr->editor->requestor->id);
+ $po->owner($mgr->editor->requestor->id);
+ $po->edit_time('now');
+ $po->create_time('now');
+ $po->state('pending');
+ $po->ordering_agency($mgr->editor->requestor->ws_ou);
+ $po->$_($args{$_}) for keys %args;
+ $po->clear_id;
+ $mgr->purchase_order($po);
+ return $mgr->editor->create_acq_purchase_order($po);
+}
+
+# ----------------------------------------------------------------------------
+# if all of the lineitems for this PO are received,
+# mark the PO as received
+# ----------------------------------------------------------------------------
+sub check_purchase_order_received {
+ my($mgr, $po_id) = @_;
+
+ my $non_recv_li = $mgr->editor->search_acq_lineitem(
+ { purchase_order => $po_id,
+ state => {'!=' => 'received'}
+ }, {idlist=>1});
+
+ my $po = $mgr->editor->retrieve_acq_purchase_order($po_id);
+ return $po if @$non_recv_li;
+
+ $po->state('received');
+ return update_purchase_order($mgr, $po);
+}
+
+
+# ----------------------------------------------------------------------------
+# Bib, Callnumber, and Copy data
+# ----------------------------------------------------------------------------
+
+sub create_lineitem_assets {
+ my($mgr, $li_id) = @_;
+ my $evt;
+
+ my $li = $mgr->editor->retrieve_acq_lineitem([
+ $li_id,
+ { flesh => 1,
+ flesh_fields => {jub => ['purchase_order', 'attributes']}
+ }
+ ]) or return 0;
+
+ # -----------------------------------------------------------------
+ # first, create the bib record if necessary
+ # -----------------------------------------------------------------
+ my $new_bib = 0;
+ unless($li->eg_bib_id) {
+ create_bib($mgr, $li) or return 0;
+ $new_bib = 1;
+ }
+
+
+ # -----------------------------------------------------------------
+ # The lineitem is going live, promote user request holds to real holds
+ # -----------------------------------------------------------------
+ promote_lineitem_holds($mgr, $li) or return 0;
+
+ my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
+
+ # -----------------------------------------------------------------
+ # for each lineitem_detail, create the volume if necessary, create
+ # a copy, and link them all together.
+ # -----------------------------------------------------------------
+ my $first_cn;
+ for my $lid_id (@{$li_details}) {
+
+ my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
+ next if $lid->eg_copy_id;
+
+ # use the same callnumber label for all items within this lineitem
+ $lid->cn_label($first_cn) if $first_cn and not $lid->cn_label;
+
+ # apply defaults if necessary
+ return 0 unless complete_lineitem_detail($mgr, $lid);
+
+ $first_cn = $lid->cn_label unless $first_cn;
+
+ my $org = $lid->owning_lib;
+ my $label = $lid->cn_label;
+ my $bibid = $li->eg_bib_id;
+
+ my $volume = $mgr->cache($org, "cn.$bibid.$label");
+ unless($volume) {
+ $volume = create_volume($mgr, $li, $lid) or return 0;
+ $mgr->cache($org, "cn.$bibid.$label", $volume);
+ }
+ create_copy($mgr, $volume, $lid, $li) or return 0;
+ }
+
+ return { li => $li, new_bib => $new_bib };
+}
+
+sub create_bib {
+ my($mgr, $li) = @_;
+
+ my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
+ $mgr->editor,
+ $li->marc,
+ undef, # bib source
+ undef,
+ 1, # override tcn collisions
+ );
+
+ if($U->event_code($record)) {
+ $mgr->editor->event($record);
+ $mgr->editor->rollback;
+ return 0;
+ }
+
+ $li->eg_bib_id($record->id);
+ $mgr->add_bib;
+ return update_lineitem($mgr, $li);
+}
+
+sub create_volume {
+ my($mgr, $li, $lid) = @_;
+
+ my ($volume, $evt) =
+ OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
+ $mgr->editor,
+ $lid->cn_label,
+ $li->eg_bib_id,
+ $lid->owning_lib
+ );
+
+ if($evt) {
+ $mgr->editor->event($evt);
+ return 0;
+ }
+
+ return $volume;
+}
+
+sub create_copy {
+ my($mgr, $volume, $lid, $li) = @_;
+ my $copy = Fieldmapper::asset::copy->new;
+ $copy->isnew(1);
+ $copy->loan_duration(2);
+ $copy->fine_level(2);
+ $copy->status(($lid->recv_time) ? OILS_COPY_STATUS_IN_PROCESS : OILS_COPY_STATUS_ON_ORDER);
+ $copy->barcode($lid->barcode);
+ $copy->location($lid->location);
+ $copy->call_number($volume->id);
+ $copy->circ_lib($volume->owning_lib);
+ $copy->circ_modifier($lid->circ_modifier);
+
+ # AKA list price. We might need a $li->list_price field since
+ # estimated price is not necessarily the same as list price
+ $copy->price($li->estimated_unit_price);
+
+ my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
+ if($evt) {
+ $mgr->editor->event($evt);
+ return 0;
+ }
+
+ $mgr->add_copy;
+ $lid->eg_copy_id($copy->id);
+ $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
+}
+
+
+
+
+
+
+# ----------------------------------------------------------------------------
+# Workflow: Build a selection list from a Z39.50 search
+# ----------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'zsearch',
+ api_name => 'open-ils.acq.picklist.search.z3950',
+ stream => 1,
+ signature => {
+ desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Search definition', type => 'object'},
+ {desc => 'Picklist name, optional', type => 'string'},
+ ]
+ }
+);
+
+sub zsearch {
+ my($self, $conn, $auth, $search, $name, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('CREATE_PICKLIST');
+
+ $search->{limit} ||= 10;
+ $options ||= {};
+
+ my $ses = OpenSRF::AppSession->create('open-ils.search');
+ my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
+
+ my $first = 1;
+ my $picklist;
+ my $mgr;
+ while(my $resp = $req->recv(timeout=>60)) {
+
+ if($first) {
+ my $e = new_editor(requestor=>$e->requestor, xact=>1);
+ $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+ $picklist = zsearch_build_pl($mgr, $name);
+ $first = 0;
+ }
+
+ my $result = $resp->content;
+ my $count = $result->{count} || 0;
+ $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
+
+ for my $rec (@{$result->{records}}) {
+
+ my $li = create_lineitem($mgr,
+ picklist => $picklist->id,
+ source_label => $result->{service},
+ marc => $rec->{marcxml},
+ eg_bib_id => $rec->{bibid}
+ );
+
+ if($$options{respond_li}) {
+ $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
+ if $$options{flesh_attrs};
+ $li->clear_marc if $$options{clear_marc};
+ $mgr->respond(lineitem => $li);
+ } else {
+ $mgr->respond;
+ }
+ }
+ }
+
+ $mgr->editor->commit;
+ return $mgr->respond_complete;
+}
+
+sub zsearch_build_pl {
+ my($mgr, $name) = @_;
+ $name ||= '';
+
+ my $picklist = $mgr->editor->search_acq_picklist({
+ owner => $mgr->editor->requestor->id,
+ name => $name
+ })->[0];
+
+ if($name eq '' and $picklist) {
+ return 0 unless delete_picklist($mgr, $picklist);
+ $picklist = undef;
+ }
+
+ return update_picklist($mgr, $picklist) if $picklist;
+ return create_picklist($mgr, name => $name);
+}
+
+
+# ----------------------------------------------------------------------------
+# Workflow: Build a selection list / PO by importing a batch of MARC records
+# ----------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'upload_records',
+ api_name => 'open-ils.acq.process_upload_records',
+ stream => 1,
+);
+
+sub upload_records {
+ my($self, $conn, $auth, $key) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $cache = OpenSRF::Utils::Cache->new;
+
+ my $data = $cache->get_cache("vandelay_import_spool_$key");
+ my $purpose = $data->{purpose};
+ my $filename = $data->{path};
+ my $provider = $data->{provider};
+ my $picklist = $data->{picklist};
+ my $create_po = $data->{create_po};
+ my $activate_po = $data->{activate_po};
+ my $ordering_agency = $data->{ordering_agency};
+ my $create_assets = $data->{create_assets};
+ my $po;
+ my $evt;
+
+ unless(-r $filename) {
+ $logger->error("unable to read MARC file $filename");
+ $e->rollback;
+ return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
+ }
+
+ $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
+
+ if($picklist) {
+ $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
+ if($picklist->owner != $e->requestor->id) {
+ return $e->die_event unless
+ $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
+ }
+ $mgr->picklist($picklist);
+ }
+
+ if($create_po) {
+
+ $po = create_purchase_order($mgr,
+ ordering_agency => $ordering_agency,
+ provider => $provider->id,
+ state => 'on-order'
+ ) or return $mgr->editor->die_event;
+ }
+
+ $logger->info("acq processing MARC file=$filename");
+
+ my $batch = new MARC::Batch ('USMARC', $filename);
+ $batch->strict_off;
+
+ my $count = 0;
+ my @li_list;
+
+ while(1) {
+
+ my ($err, $xml, $r);
+ $count++;
+
+ try {
+ $r = $batch->next;
+ } catch Error with {
+ $err = shift;
+ $logger->warn("Proccessing of record $count in set $key failed with error $err. Skipping this record");
+ };
+
+ next if $err;
+ last unless $r;
+
+ try {
+ ($xml = $r->as_xml_record()) =~ s/\n//sog;
+ $xml =~ s/^<\?xml.+\?\s*>//go;
+ $xml =~ s/>\s+</></go;
+ $xml =~ s/\p{Cc}//go;
+ $xml = $U->entityize($xml);
+ $xml =~ s/[\x00-\x1f]//go;
+
+ } catch Error with {
+ $err = shift;
+ $logger->warn("Proccessing XML of record $count in set $key failed with error $err. Skipping this record");
+ };
+
+ next if $err or not $xml;
+
+ my %args = (
+ source_label => $provider->code,
+ provider => $provider->id,
+ marc => $xml,
+ );
+
+ $args{picklist} = $picklist->id if $picklist;
+ if($po) {
+ $args{purchase_order} = $po->id;
+ $args{state} = 'pending-order';
+ }
+
+ my $li = create_lineitem($mgr, %args) or return $mgr->editor->die_event;
+ $mgr->respond;
+ $li->provider($provider); # flesh it, we'll need it later
+
+ import_lineitem_details($mgr, $ordering_agency, $li) or return $mgr->editor->die_event;
+ $mgr->respond;
+
+ push(@li_list, $li->id);
+ $mgr->respond;
+ }
+
+ my $die_event = activate_purchase_order_impl($mgr, $po->id) if $po and $activate_po;
+ return $die_event if $die_event;
+
+ $e->commit;
+ unlink($filename);
+ $cache->delete_cache('vandelay_import_spool_' . $key);
+
+ if ($create_assets) {
+ create_lineitem_list_assets($mgr, \@li_list) or return $e->die_event;
+ }
+
+ return $mgr->respond_complete;
+}
+
+sub import_lineitem_details {
+ my($mgr, $ordering_agency, $li) = @_;
+
+ my $holdings = $mgr->editor->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
+ return 1 unless @$holdings;
+ my $org_path = $U->get_org_ancestors($ordering_agency);
+ $org_path = [ reverse (@$org_path) ];
+ my $price;
+
+
+ my $idx = 1;
+ while(1) {
+ # create a lineitem detail for each copy in the data
+
+ my $compiled = extract_lineitem_detail_data($mgr, $org_path, $holdings, $idx);
+ last unless defined $compiled;
+ return 0 unless $compiled;
+
+ # this takes the price of the last copy and uses it as the lineitem price
+ # need to determine if a given record would include different prices for the same item
+ $price = $$compiled{estimated_price};
+
+ last unless $$compiled{quantity};
+
+ for(1..$$compiled{quantity}) {
+ my $lid = create_lineitem_detail(
+ $mgr,
+ lineitem => $li->id,
+ owning_lib => $$compiled{owning_lib},
+ cn_label => $$compiled{call_number},
+ fund => $$compiled{fund},
+ circ_modifier => $$compiled{circ_modifier},
+ note => $$compiled{note},
+ location => $$compiled{copy_location},
+ collection_code => $$compiled{collection_code}
+ ) or return 0;
+ }
+
+ $mgr->respond;
+ $idx++;
+ }
+
+ $li->estimated_unit_price($price);
+ update_lineitem($mgr, $li) or return 0;
+ return 1;
+}
+
+# return hash on success, 0 on error, undef on no more holdings
+sub extract_lineitem_detail_data {
+ my($mgr, $org_path, $holdings, $index) = @_;
+
+ my @data_list = grep { $_->{holding} eq $index } @$holdings;
+ return undef unless @data_list;
+
+ my %compiled = map { $_->{attr} => $_->{data} } @data_list;
+ my $base_org = $$org_path[0];
+
+ my $killme = sub {
+ my $msg = shift;
+ $logger->error("Item import extraction error: $msg");
+ $logger->error('Holdings Data: ' . OpenSRF::Utils::JSON->perl2JSON(\%compiled));
+ $mgr->editor->rollback;
+ $mgr->editor->event(OpenILS::Event->new('ACQ_IMPORT_ERROR', payload => $msg));
+ return 0;
+ };
+
+ # ---------------------------------------------------------------------
+ # Fund
+ if(my $code = $compiled{fund_code}) {
+
+ my $fund = $mgr->cache($base_org, "fund.$code");
+ unless($fund) {
+ # search up the org tree for the most appropriate fund
+ for my $org (@$org_path) {
+ $fund = $mgr->editor->search_acq_fund(
+ {org => $org, code => $code, year => DateTime->now->year}, {idlist => 1})->[0];
+ last if $fund;
+ }
+ }
+ return $killme->("no fund with code $code at orgs [@$org_path]") unless $fund;
+ $compiled{fund} = $fund;
+ $mgr->cache($base_org, "fund.$code", $fund);
+ }
+
+
+ # ---------------------------------------------------------------------
+ # Owning lib
+ if(my $sn = $compiled{owning_lib}) {
+ my $org_id = $mgr->cache($base_org, "orgsn.$sn") ||
+ $mgr->editor->search_actor_org_unit({shortname => $sn}, {idlist => 1})->[0];
+ return $killme->("invalid owning_lib defined: $sn") unless $org_id;
+ $compiled{owning_lib} = $org_id;
+ $mgr->cache($$org_path[0], "orgsn.$sn", $org_id);
+ }
+
+
+ # ---------------------------------------------------------------------
+ # Circ Modifier
+ my $code = $compiled{circ_modifier};
+
+ if(defined $code) {
+
+ # verify this is a valid circ modifier
+ return $killme->("invlalid circ_modifier $code") unless
+ defined $mgr->cache($base_org, "mod.$code") or
+ $mgr->editor->retrieve_config_circ_modifier($code);
+
+ # if valid, cache for future tests
+ $mgr->cache($base_org, "mod.$code", $code);
+
+ } else {
+ $compiled{circ_modifier} = get_default_circ_modifier($mgr, $base_org);
+ }
+
+
+ # ---------------------------------------------------------------------
+ # Shelving Location
+ if( my $name = $compiled{copy_location}) {
+ my $loc = $mgr->cache($base_org, "copy_loc.$name");
+ unless($loc) {
+ for my $org (@$org_path) {
+ $loc = $mgr->editor->search_asset_copy_location(
+ {owning_lib => $org, name => $name}, {idlist => 1})->[0];
+ last if $loc;
+ }
+ }
+ return $killme->("Invalid copy location $name") unless $loc;
+ $compiled{copy_location} = $loc;
+ $mgr->cache($base_org, "copy_loc.$name", $loc);
+ }
+
+ return \%compiled;
+}
+
+
+
+# ----------------------------------------------------------------------------
+# Workflow: Given an existing purchase order, import/create the bibs,
+# callnumber and copy objects
+# ----------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'create_po_assets',
+ api_name => 'open-ils.acq.purchase_order.assets.create',
+ signature => {
+ desc => q/Creates assets for each lineitem in the purchase order/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'The purchase order id', type => 'number'},
+ ],
+ return => {desc => 'Streams a total versus completed counts object, event on error'}
+ }
+);
+
+sub create_po_assets {
+ my($self, $conn, $auth, $po_id) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
+
+ my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
+
+ # it's ugly, but it's fast. Get the total count of lineitem detail objects to process
+ my $lid_total = $e->json_query({
+ select => { acqlid => [{aggregate => 1, transform => 'count', column => 'id'}] },
+ from => {
+ acqlid => {
+ jub => {
+ fkey => 'lineitem',
+ field => 'id',
+ join => {acqpo => {fkey => 'purchase_order', field => 'id'}}
+ }
+ }
+ },
+ where => {'+acqpo' => {id => $po_id}}
+ })->[0]->{id};
+
+ $mgr->total(scalar(@$li_ids) + $lid_total);
+
+ create_lineitem_list_assets($mgr, $li_ids) or return $e->die_event;
+
+ $e->xact_begin;
+ update_purchase_order($mgr, $po) or return $e->die_event;
+ $e->commit;
+
+ return $mgr->respond_complete;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'create_purchase_order_api',
+ api_name => 'open-ils.acq.purchase_order.create',
+ signature => {
+ desc => 'Creates a new purchase order',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'purchase_order to create', type => 'object'}
+ ],
+ return => {desc => 'The purchase order id, Event on failure'}
+ }
+);
+
+sub create_purchase_order_api {
+ my($self, $conn, $auth, $po, $args) = @_;
+ $args ||= {};
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ # create the PO
+ my %pargs = (ordering_agency => $e->requestor->ws_ou); # default
+ $pargs{provider} = $po->provider if $po->provider;
+ $pargs{ordering_agency} = $po->ordering_agency if $po->ordering_agency;
+ $pargs{prepayment_required} = $po->prepayment_required if $po->prepayment_required;
+
+ $po = create_purchase_order($mgr, %pargs) or return $e->die_event;
+
+ my $li_ids = $$args{lineitems};
+
+ if($li_ids) {
+
+ for my $li_id (@$li_ids) {
+
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id,
+ {flesh => 1, flesh_fields => {jub => ['attributes']}}
+ ]) or return $e->die_event;
+
+ $li->provider($po->provider);
+ $li->purchase_order($po->id);
+ $li->state('pending-order');
+ update_lineitem($mgr, $li) or return $e->die_event;
+ $mgr->respond;
+ }
+ }
+
+ # commit before starting the asset creation
+ $e->xact_commit;
+
+ if($li_ids and $$args{create_assets}) {
+ create_lineitem_list_assets($mgr, $li_ids) or return $e->die_event;
+ }
+
+ return $mgr->respond_complete;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'update_lineitem_fund_batch',
+ api_name => 'open-ils.acq.lineitem.fund.update.batch',
+ stream => 1,
+ signature => {
+ desc => q/Given a set of lineitem IDS, updates the fund for all attached lineitem details/
+ }
+);
+
+sub update_lineitem_fund_batch {
+ my($self, $conn, $auth, $li_ids, $fund_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+ for my $li_id (@$li_ids) {
+ my ($li, $evt) = fetch_and_check_li($e, $li_id, 'write');
+ return $evt if $evt;
+ my $li_details = $e->search_acq_lineitem_detail({lineitem => $li_id});
+ $_->fund($fund_id) and $_->ischanged(1) for @$li_details;
+ $evt = lineitem_detail_CUD_batch($mgr, $li_details);
+ return $evt if $evt;
+ $mgr->add_li;
+ $mgr->respond;
+ }
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'lineitem_detail_CUD_batch_api',
+ api_name => 'open-ils.acq.lineitem_detail.cud.batch',
+ stream => 1,
+ signature => {
+ desc => q/Creates a new purchase order line item detail. / .
+ q/Additionally creates the associated fund_debit/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'List of lineitem_details to create', type => 'array'},
+ {desc => 'Create Debits. Used for creating post-po-asset-creation debits', type => 'bool'},
+ ],
+ return => {desc => 'Streaming response of current position in the array'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'lineitem_detail_CUD_batch_api',
+ api_name => 'open-ils.acq.lineitem_detail.cud.batch.dry_run',
+ stream => 1,
+ signature => {
+ desc => q/
+ Dry run version of open-ils.acq.lineitem_detail.cud.batch.
+ In dry_run mode, updated fund_debit's the exceed the warning
+ percent return an event.
+ /
+ }
+);
+
+
+sub lineitem_detail_CUD_batch_api {
+ my($self, $conn, $auth, $li_details, $create_debits) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+ my $dry_run = ($self->api_name =~ /dry_run/o);
+ my $evt = lineitem_detail_CUD_batch($mgr, $li_details, $create_debits, $dry_run);
+ return $evt if $evt;
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+sub lineitem_detail_CUD_batch {
+ my($mgr, $li_details, $create_debits, $dry_run) = @_;
+
+ $mgr->total(scalar(@$li_details));
+ my $e = $mgr->editor;
+
+ my $li;
+ my %li_cache;
+ my $fund_cache = {};
+ my $evt;
+
+ for my $lid (@$li_details) {
+
+ unless($li = $li_cache{$lid->lineitem}) {
+ ($li, $evt) = fetch_and_check_li($e, $lid->lineitem, 'write');
+ return $evt if $evt;
+ }
+
+ if($lid->isnew) {
+ $lid = create_lineitem_detail($mgr, %{$lid->to_bare_hash}) or return $e->die_event;
+ if($create_debits) {
+ $li->provider($e->retrieve_acq_provider($li->provider)) or return $e->die_event;
+ $lid->fund($e->retrieve_acq_fund($lid->fund)) or return $e->die_event;
+ create_lineitem_detail_debit($mgr, $li, $lid, 0, 1) or return $e->die_event;
+ }
+
+ } elsif($lid->ischanged) {
+ return $evt if $evt = handle_changed_lid($e, $lid, $dry_run, $fund_cache);
+
+ } elsif($lid->isdeleted) {
+ delete_lineitem_detail($mgr, $lid) or return $e->die_event;
+ }
+
+ $mgr->respond(li => $li);
+ $li_cache{$lid->lineitem} = $li;
+ }
+
+ return undef;
+}
+
+sub handle_changed_lid {
+ my($e, $lid, $dry_run, $fund_cache) = @_;
+
+ my $orig_lid = $e->retrieve_acq_lineitem_detail($lid->id) or return $e->die_event;
+
+ # updating the fund, so update the debit
+ if($orig_lid->fund_debit and $orig_lid->fund != $lid->fund) {
+
+ my $debit = $e->retrieve_acq_fund_debit($orig_lid->fund_debit);
+ my $new_fund = $$fund_cache{$lid->fund} =
+ $$fund_cache{$lid->fund} || $e->retrieve_acq_fund($lid->fund);
+
+ # check the thresholds
+ return $e->die_event if
+ fund_exceeds_balance_percent($new_fund, $debit->amount, $e, "stop");
+ return $e->die_event if $dry_run and
+ fund_exceeds_balance_percent($new_fund, $debit->amount, $e, "warning");
+
+ $debit->fund($new_fund->id);
+ $e->update_acq_fund_debit($debit) or return $e->die_event;
+ }
+
+ $e->update_acq_lineitem_detail($lid) or return $e->die_event;
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'receive_po_api',
+ api_name => 'open-ils.acq.purchase_order.receive'
+);
+
+sub receive_po_api {
+ my($self, $conn, $auth, $po_id) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
+
+ my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
+
+ for my $li_id (@$li_ids) {
+ receive_lineitem($mgr, $li_id) or return $e->die_event;
+ $mgr->respond;
+ }
+
+ $po->state('received');
+ update_purchase_order($mgr, $po) or return $e->die_event;
+
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+# At the moment there's a lack of parallelism between the receive and unreceive
+# API methods for POs and the API methods for LIs and LIDs. The methods for
+# POs stream back objects as they act, whereas the methods for LIs and LIDs
+# atomically return an object that describes only what changed (in LIs and LIDs
+# themselves or in the objects to which to LIs and LIDs belong).
+#
+# The methods for LIs and LIDs work the way they do to faciliate the UI's
+# maintaining correct information about the state of these things when a user
+# wants to receive or unreceive these objects without refreshing their whole
+# display. The UI feature for receiving and un-receiving a whole PO just
+# refreshes the whole display, so this absence of parallelism in the UI is also
+# relected in this module.
+#
+# This could be neatened in the future by making POs receive and unreceive in
+# the same way the LIs and LIDs do.
+
+__PACKAGE__->register_method(
+ method => 'receive_lineitem_detail_api',
+ api_name => 'open-ils.acq.lineitem_detail.receive',
+ signature => {
+ desc => 'Mark a lineitem_detail as received',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem detail ID', type => 'number'}
+ ],
+ return => {desc =>
+ "on success, object describing changes to LID and possibly " .
+ "to LI and PO; on error, Event"
+ }
+ }
+);
+
+sub receive_lineitem_detail_api {
+ my($self, $conn, $auth, $lid_id) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $fleshing = {
+ "flesh" => 2, "flesh_fields" => {
+ "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
+ }
+ };
+
+ my $lid = $e->retrieve_acq_lineitem_detail([$lid_id, $fleshing]);
+
+ return $e->die_event unless $e->allowed(
+ 'RECEIVE_PURCHASE_ORDER', $lid->lineitem->purchase_order->ordering_agency);
+
+ # update ...
+ my $recvd = receive_lineitem_detail($mgr, $lid_id) or return $e->die_event;
+
+ # .. and re-retrieve
+ $lid = $e->retrieve_acq_lineitem_detail([$lid_id, $fleshing]);
+
+ # Now build result data structure.
+ my $result = {"lid" => {$lid->id => {"recv_time" => $lid->recv_time}}};
+
+ if (ref $recvd) {
+ if ($recvd->class_name =~ /::purchase_order/) {
+ $result->{"po"} = describe_affected_po($e, $recvd);
+ $result->{"li"} = {
+ $lid->lineitem->id => {"state" => $lid->lineitem->state}
+ };
+ } elsif ($recvd->class_name =~ /::lineitem/) {
+ $result->{"li"} = {$recvd->id => {"state" => $recvd->state}};
+ }
+ }
+ $result->{"po"} ||=
+ describe_affected_po($e, $lid->lineitem->purchase_order);
+
+ $e->commit;
+ return $result;
+}
+
+__PACKAGE__->register_method(
+ method => 'receive_lineitem_api',
+ api_name => 'open-ils.acq.lineitem.receive',
+ signature => {
+ desc => 'Mark a lineitem as received',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID', type => 'number'}
+ ],
+ return => {desc =>
+ "on success, object describing changes to LI and possibly PO; " .
+ "on error, Event"
+ }
+ }
+);
+
+sub receive_lineitem_api {
+ my($self, $conn, $auth, $li_id) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id, {
+ flesh => 1,
+ flesh_fields => {
+ jub => ['purchase_order']
+ }
+ }
+ ]) or return $e->die_event;
+
+ return $e->die_event unless $e->allowed(
+ 'RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);
+
+ my $res = receive_lineitem($mgr, $li_id) or return $e->die_event;
+ $e->commit;
+ $conn->respond_complete($res);
+ $mgr->run_post_response_hooks;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'rollback_receive_po_api',
+ api_name => 'open-ils.acq.purchase_order.receive.rollback'
+);
+
+sub rollback_receive_po_api {
+ my($self, $conn, $auth, $po_id) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
+
+ my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
+
+ for my $li_id (@$li_ids) {
+ rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
+ $mgr->respond;
+ }
+
+ $po->state('on-order');
+ update_purchase_order($mgr, $po) or return $e->die_event;
+
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'rollback_receive_lineitem_detail_api',
+ api_name => 'open-ils.acq.lineitem_detail.receive.rollback',
+ signature => {
+ desc => 'Mark a lineitem_detail as Un-received',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem detail ID', type => 'number'}
+ ],
+ return => {desc =>
+ "on success, object describing changes to LID and possibly " .
+ "to LI and PO; on error, Event"
+ }
+ }
+);
+
+sub rollback_receive_lineitem_detail_api {
+ my($self, $conn, $auth, $lid_id) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $lid = $e->retrieve_acq_lineitem_detail([
+ $lid_id, {
+ flesh => 2,
+ flesh_fields => {
+ acqlid => ['lineitem'],
+ jub => ['purchase_order']
+ }
+ }
+ ]);
+ my $li = $lid->lineitem;
+ my $po = $li->purchase_order;
+
+ return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
+
+ my $result = {};
+
+ my $recvd = rollback_receive_lineitem_detail($mgr, $lid_id)
+ or return $e->die_event;
+
+ if (ref $recvd) {
+ $result->{"lid"} = {$recvd->id => {"recv_time" => $recvd->recv_time}};
+ } else {
+ $result->{"lid"} = {$lid->id => {"recv_time" => $lid->recv_time}};
+ }
+
+ if ($li->state eq "received") {
+ $li->state("on-order");
+ $li = update_lineitem($mgr, $li) or return $e->die_event;
+ $result->{"li"} = {$li->id => {"state" => $li->state}};
+ }
+
+ if ($po->state eq "received") {
+ $po->state("on-order");
+ $po = update_purchase_order($mgr, $po) or return $e->die_event;
+ }
+ $result->{"po"} = describe_affected_po($e, $po);
+
+ $e->commit and return $result or return $e->die_event;
+}
+
+__PACKAGE__->register_method(
+ method => 'rollback_receive_lineitem_api',
+ api_name => 'open-ils.acq.lineitem.receive.rollback',
+ signature => {
+ desc => 'Mark a lineitem as Un-received',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID', type => 'number'}
+ ],
+ return => {desc =>
+ "on success, object describing changes to LI and possibly PO; " .
+ "on error, Event"
+ }
+ }
+);
+
+sub rollback_receive_lineitem_api {
+ my($self, $conn, $auth, $li_id) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id, {
+ "flesh" => 1, "flesh_fields" => {"jub" => ["purchase_order"]}
+ }
+ ]);
+ my $po = $li->purchase_order;
+
+ return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
+
+ $li = rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
+
+ my $result = {"li" => {$li->id => {"state" => $li->state}}};
+ if ($po->state eq "received") {
+ $po->state("on-order");
+ $po = update_purchase_order($mgr, $po) or return $e->die_event;
+ }
+ $result->{"po"} = describe_affected_po($e, $po);
+
+ $e->commit and return $result or return $e->die_event;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'set_lineitem_price_api',
+ api_name => 'open-ils.acq.lineitem.price.set',
+ signature => {
+ desc => 'Set lineitem price. If debits already exist, update them as well',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'lineitem ID', type => 'number'}
+ ],
+ return => {desc => 'status blob, Event on error'}
+ }
+);
+
+sub set_lineitem_price_api {
+ my($self, $conn, $auth, $li_id, $price) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my ($li, $evt) = fetch_and_check_li($e, $li_id, 'write');
+ return $evt if $evt;
+
+ $li->estimated_unit_price($price);
+ update_lineitem($mgr, $li) or return $e->die_event;
+
+ my $lid_ids = $e->search_acq_lineitem_detail(
+ {lineitem => $li_id, fund_debit => {'!=' => undef}},
+ {idlist => 1}
+ );
+
+ for my $lid_id (@$lid_ids) {
+
+ my $lid = $e->retrieve_acq_lineitem_detail([
+ $lid_id, {
+ flesh => 1, flesh_fields => {acqlid => ['fund', 'fund_debit']}}
+ ]);
+
+ $lid->fund_debit->amount($price);
+ $e->update_acq_fund_debit($lid->fund_debit) or return $e->die_event;
+ $mgr->add_lid;
+ $mgr->respond;
+ }
+
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'clone_picklist_api',
+ api_name => 'open-ils.acq.picklist.clone',
+ signature => {
+ desc => 'Clones a picklist, including lineitem and lineitem details',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist ID', type => 'number'},
+ {desc => 'New Picklist Name', type => 'string'}
+ ],
+ return => {desc => 'status blob, Event on error'}
+ }
+);
+
+sub clone_picklist_api {
+ my($self, $conn, $auth, $pl_id, $name) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ my $old_pl = $e->retrieve_acq_picklist($pl_id);
+ my $new_pl = create_picklist($mgr, %{$old_pl->to_bare_hash}, name => $name) or return $e->die_event;
+
+ my $li_ids = $e->search_acq_lineitem({picklist => $pl_id}, {idlist => 1});
+
+ for my $li_id (@$li_ids) {
+
+ # copy the lineitems
+ my $li = $e->retrieve_acq_lineitem($li_id);
+ my $new_li = create_lineitem($mgr, %{$li->to_bare_hash}, picklist => $new_pl->id) or return $e->die_event;
+
+ my $lid_ids = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist => 1});
+ for my $lid_id (@$lid_ids) {
+
+ # copy the lineitem details
+ my $lid = $e->retrieve_acq_lineitem_detail($lid_id);
+ create_lineitem_detail($mgr, %{$lid->to_bare_hash}, lineitem => $new_li->id) or return $e->die_event;
+ }
+
+ $mgr->respond;
+ }
+
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'merge_picklist_api',
+ api_name => 'open-ils.acq.picklist.merge',
+ signature => {
+ desc => 'Merges 2 or more picklists into a single list',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Lead Picklist ID', type => 'number'},
+ {desc => 'List of subordinate picklist IDs', type => 'array'}
+ ],
+ return => {desc => 'status blob, Event on error'}
+ }
+);
+
+sub merge_picklist_api {
+ my($self, $conn, $auth, $lead_pl, $pl_list) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+
+ # XXX perms on each picklist modified
+
+ $lead_pl = $e->retrieve_acq_picklist($lead_pl) or return $e->die_event;
+ # point all of the lineitems at the lead picklist
+ my $li_ids = $e->search_acq_lineitem({picklist => $pl_list}, {idlist => 1});
+
+ for my $li_id (@$li_ids) {
+ my $li = $e->retrieve_acq_lineitem($li_id);
+ $li->picklist($lead_pl);
+ update_lineitem($mgr, $li) or return $e->die_event;
+ $mgr->respond;
+ }
+
+ # now delete the subordinate lists
+ for my $pl_id (@$pl_list) {
+ my $pl = $e->retrieve_acq_picklist($pl_id);
+ $e->delete_acq_picklist($pl) or return $e->die_event;
+ }
+
+ update_picklist($mgr, $lead_pl) or return $e->die_event;
+
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_picklist_api',
+ api_name => 'open-ils.acq.picklist.delete',
+ signature => {
+ desc => q/Deletes a picklist. It also deletes any lineitems in the "new" state. / .
+ q/Other attached lineitems are detached/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist ID to delete', type => 'number'}
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub delete_picklist_api {
+ my($self, $conn, $auth, $picklist_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+ my $pl = $e->retrieve_acq_picklist($picklist_id) or return $e->die_event;
+ delete_picklist($mgr, $pl) or return $e->die_event;
+ $e->commit;
+ return $mgr->respond_complete;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'activate_purchase_order',
+ api_name => 'open-ils.acq.purchase_order.activate.dry_run'
+);
+
+__PACKAGE__->register_method(
+ method => 'activate_purchase_order',
+ api_name => 'open-ils.acq.purchase_order.activate',
+ signature => {
+ desc => q/Activates a purchase order. This updates the status of the PO / .
+ q/and Lineitems to 'on-order'. Activated PO's are ready for EDI delivery if appropriate./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Purchase ID', type => 'number'}
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub activate_purchase_order {
+ my($self, $conn, $auth, $po_id) = @_;
+
+ my $dry_run = ($self->api_name =~ /\.dry_run/) ? 1 : 0;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
+ my $die_event = activate_purchase_order_impl($mgr, $po_id, $dry_run);
+ return $e->die_event if $die_event;
+ if ($dry_run) {
+ $e->rollback;
+ } else {
+ $e->commit;
+ }
+ $conn->respond_complete(1);
+ $mgr->run_post_response_hooks;
+ return undef;
+}
+
+sub activate_purchase_order_impl {
+ my ($mgr, $po_id, $dry_run) = @_;
+ my $e = $mgr->editor;
+
+ my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
+
+ my $provider = $e->retrieve_acq_provider($po->provider);
+
+ $po->state('on-order');
+ $po->order_date('now');
+ update_purchase_order($mgr, $po) or return $e->die_event;
+
+ my $query = [
+ {
+ purchase_order => $po_id,
+ state => [qw/pending-order new order-ready/]
+ },
+ {limit => 1}
+ ];
+
+ while( my $li_id = $e->search_acq_lineitem($query, {idlist => 1})->[0] ) {
+
+ my $li;
+ if($dry_run) {
+ $li = $e->retrieve_acq_lineitem($li_id);
+ } else {
+ # can't activate a PO w/o assets. Create lineitem assets as necessary
+ my $data = create_lineitem_assets($mgr, $li_id) or return $e->die_event;
+ $li = $data->{li};
+ }
+
+ $li->state('on-order');
+ $li->claim_policy($provider->default_claim_policy)
+ if $provider->default_claim_policy and !$li->claim_policy;
+ create_lineitem_debits($mgr, $li, $dry_run) or return $e->die_event;
+ update_lineitem($mgr, $li) or return $e->die_event;
+ $mgr->post_process( sub { create_lineitem_status_events($mgr, $li->id, 'aur.ordered'); });
+ $mgr->respond;
+ }
+
+ for my $po_item (@{$e->search_acq_po_item({purchase_order => $po_id})}) {
+
+ my $debit = create_fund_debit(
+ $mgr,
+ $dry_run,
+ debit_type => 'direct_charge', # to match invoicing
+ origin_amount => $po_item->estimated_cost,
+ origin_currency_type => $e->retrieve_acq_fund($po_item->fund)->currency_type,
+ amount => $po_item->estimated_cost,
+ fund => $po_item->fund
+ ) or return $e->die_event;
+ $po_item->fund_debit($debit->id);
+ $e->update_acq_po_item($po_item) or return $e->die_event;
+ $mgr->respond;
+ }
+
+ # tell the world we activated a PO
+ $U->create_events_for_hook('acqpo.activated', $po, $po->ordering_agency) unless $dry_run;
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'split_purchase_order_by_lineitems',
+ api_name => 'open-ils.acq.purchase_order.split_by_lineitems',
+ signature => {
+ desc => q/Splits a PO into many POs, 1 per lineitem. Only works for / .
+ q/POs a) with more than one lineitems, and b) in the "pending" state./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Purchase order ID', type => 'number'}
+ ],
+ return => {desc => 'list of new PO IDs on success, Event on error'}
+ }
+);
+
+sub split_purchase_order_by_lineitems {
+ my ($self, $conn, $auth, $po_id) = @_;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $po = $e->retrieve_acq_purchase_order([
+ $po_id, {
+ "flesh" => 1,
+ "flesh_fields" => {"acqpo" => [qw/lineitems notes/]}
+ }
+ ]) or return $e->die_event;
+
+ return $e->die_event
+ unless $e->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
+
+ unless ($po->state eq "pending") {
+ $e->rollback;
+ return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_LATE");
+ }
+
+ unless (@{$po->lineitems} > 1) {
+ $e->rollback;
+ return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_SHORT");
+ }
+
+ # To split an existing PO into many, it seems unwise to just delete the
+ # original PO, so we'll instead detach all of the original POs' lineitems
+ # but the first, then create new POs for each of the remaining LIs, and
+ # then attach the LIs to their new POs.
+
+ my @po_ids = ($po->id);
+ my @moving_li = @{$po->lineitems};
+ shift @moving_li; # discard first LI
+
+ foreach my $li (@moving_li) {
+ my $new_po = $po->clone;
+ $new_po->clear_id;
+ $new_po->clear_name;
+ $new_po->creator($e->requestor->id);
+ $new_po->editor($e->requestor->id);
+ $new_po->owner($e->requestor->id);
+ $new_po->edit_time("now");
+ $new_po->create_time("now");
+
+ $new_po = $e->create_acq_purchase_order($new_po);
+
+ # Clone any notes attached to the old PO and attach to the new one.
+ foreach my $note (@{$po->notes}) {
+ my $new_note = $note->clone;
+ $new_note->clear_id;
+ $new_note->edit_time("now");
+ $new_note->purchase_order($new_po->id);
+ $e->create_acq_po_note($new_note);
+ }
+
+ $li->edit_time("now");
+ $li->purchase_order($new_po->id);
+ $e->update_acq_lineitem($li);
+
+ push @po_ids, $new_po->id;
+ }
+
+ $po->edit_time("now");
+ $e->update_acq_purchase_order($po);
+
+ return \@po_ids if $e->commit;
+ return $e->die_event;
+}
+
+
+sub not_cancelable {
+ my $o = shift;
+ (ref $o eq "HASH" and $o->{"textcode"} eq "ACQ_NOT_CANCELABLE");
+}
+
+__PACKAGE__->register_method(
+ method => "cancel_purchase_order_api",
+ api_name => "open-ils.acq.purchase_order.cancel",
+ signature => {
+ desc => q/Cancels an on-order purchase order/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "PO ID to cancel", type => "number"},
+ {desc => "Cancel reason ID", type => "number"}
+ ],
+ return => {desc => q/Object describing changed POs, LIs and LIDs
+ on success; Event on error./}
+ }
+);
+
+sub cancel_purchase_order_api {
+ my ($self, $conn, $auth, $po_id, $cancel_reason) = @_;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = new OpenILS::Application::Acq::BatchManager(
+ "editor" => $e, "conn" => $conn
+ );
+
+ $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
+ return new OpenILS::Event(
+ "BAD_PARAMS", "note" => "Provide cancel reason ID"
+ );
+
+ my $result = cancel_purchase_order($mgr, $po_id, $cancel_reason) or
+ return $e->die_event;
+ if (not_cancelable($result)) { # event not from CStoreEditor
+ $e->rollback;
+ return $result;
+ } elsif ($result == -1) {
+ $e->rollback;
+ return new OpenILS::Event("ACQ_ALREADY_CANCELED");
+ }
+
+ $e->commit or return $e->die_event;
+
+ # XXX create purchase order status events?
+
+ if ($mgr->{post_commit}) {
+ foreach my $func (@{$mgr->{post_commit}}) {
+ $func->();
+ }
+ }
+
+ return $result;
+}
+
+sub cancel_purchase_order {
+ my ($mgr, $po_id, $cancel_reason) = @_;
+
+ my $po = $mgr->editor->retrieve_acq_purchase_order($po_id) or return 0;
+
+ # XXX is "cancelled" a typo? It's not correct US spelling, anyway.
+ # Depending on context, this may not warrant an event.
+ return -1 if $po->state eq "cancelled";
+
+ # But this always does.
+ return new OpenILS::Event(
+ "ACQ_NOT_CANCELABLE", "note" => "purchase_order $po_id"
+ ) unless ($po->state eq "on-order" or $po->state eq "pending");
+
+ return 0 unless
+ $mgr->editor->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
+
+ $po->state("cancelled");
+ $po->cancel_reason($cancel_reason->id);
+
+ my $li_ids = $mgr->editor->search_acq_lineitem(
+ {"purchase_order" => $po_id}, {"idlist" => 1}
+ );
+
+ my $result = {"li" => {}, "lid" => {}};
+ foreach my $li_id (@$li_ids) {
+ my $li_result = cancel_lineitem($mgr, $li_id, $cancel_reason)
+ or return 0;
+
+ next if $li_result == -1; # already canceled:skip.
+ return $li_result if not_cancelable($li_result); # not cancelable:stop.
+
+ # Merge in each LI result (there's only going to be
+ # one per call to cancel_lineitem).
+ my ($k, $v) = each %{$li_result->{"li"}};
+ $result->{"li"}->{$k} = $v;
+
+ # Merge in each LID result (there may be many per call to
+ # cancel_lineitem).
+ while (($k, $v) = each %{$li_result->{"lid"}}) {
+ $result->{"lid"}->{$k} = $v;
+ }
+ }
+
+ # TODO who/what/where/how do we indicate this change for electronic orders?
+ # TODO return changes to encumbered/spent
+ # TODO maybe cascade up from smaller object to container object if last
+ # smaller object in the container has been canceled?
+
+ update_purchase_order($mgr, $po) or return 0;
+ $result->{"po"} = {
+ $po_id => {"state" => $po->state, "cancel_reason" => $cancel_reason}
+ };
+ return $result;
+}
+
+
+__PACKAGE__->register_method(
+ method => "cancel_lineitem_api",
+ api_name => "open-ils.acq.lineitem.cancel",
+ signature => {
+ desc => q/Cancels an on-order lineitem/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Lineitem ID to cancel", type => "number"},
+ {desc => "Cancel reason ID", type => "number"}
+ ],
+ return => {desc => q/Object describing changed LIs and LIDs on success;
+ Event on error./}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "cancel_lineitem_api",
+ api_name => "open-ils.acq.lineitem.cancel.batch",
+ signature => {
+ desc => q/Batched version of open-ils.acq.lineitem.cancel/,
+ return => {desc => q/Object describing changed LIs and LIDs on success;
+ Event on error./}
+ }
+);
+
+sub cancel_lineitem_api {
+ my ($self, $conn, $auth, $li_id, $cancel_reason) = @_;
+
+ my $batched = $self->api_name =~ /\.batch/;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = new OpenILS::Application::Acq::BatchManager(
+ "editor" => $e, "conn" => $conn
+ );
+
+ $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
+ return new OpenILS::Event(
+ "BAD_PARAMS", "note" => "Provide cancel reason ID"
+ );
+
+ my ($result, $maybe_event);
+
+ if ($batched) {
+ $result = {"li" => {}, "lid" => {}};
+ foreach my $one_li_id (@$li_id) {
+ my $one = cancel_lineitem($mgr, $one_li_id, $cancel_reason) or
+ return $e->die_event;
+ if (not_cancelable($one)) {
+ $maybe_event = $one;
+ } elsif ($result == -1) {
+ $maybe_event = new OpenILS::Event("ACQ_ALREADY_CANCELED");
+ } else {
+ my ($k, $v);
+ if ($one->{"li"}) {
+ while (($k, $v) = each %{$one->{"li"}}) {
+ $result->{"li"}->{$k} = $v;
+ }
+ }
+ if ($one->{"lid"}) {
+ while (($k, $v) = each %{$one->{"lid"}}) {
+ $result->{"lid"}->{$k} = $v;
+ }
+ }
+ }
+ }
+ } else {
+ $result = cancel_lineitem($mgr, $li_id, $cancel_reason) or
+ return $e->die_event;
+
+ if (not_cancelable($result)) {
+ $e->rollback;
+ return $result;
+ } elsif ($result == -1) {
+ $e->rollback;
+ return new OpenILS::Event("ACQ_ALREADY_CANCELED");
+ }
+ }
+
+ if ($batched and not scalar keys %{$result->{"li"}}) {
+ $e->rollback;
+ return $maybe_event;
+ } else {
+ $e->commit or return $e->die_event;
+ # create_lineitem_status_events should handle array li_id ok
+ create_lineitem_status_events($mgr, $li_id, "aur.cancelled");
+
+ if ($mgr->{post_commit}) {
+ foreach my $func (@{$mgr->{post_commit}}) {
+ $func->();
+ }
+ }
+
+ return $result;
+ }
+}
+
+sub cancel_lineitem {
+ my ($mgr, $li_id, $cancel_reason) = @_;
+ my $li = $mgr->editor->retrieve_acq_lineitem([
+ $li_id, {flesh => 1, flesh_fields => {jub => ['purchase_order']}}
+ ]) or return 0;
+
+ return 0 unless $mgr->editor->allowed(
+ "CREATE_PURCHASE_ORDER", $li->purchase_order->ordering_agency
+ );
+
+ # Depending on context, this may not warrant an event.
+ return -1 if $li->state eq "cancelled";
+
+ # But this always does.
+ return new OpenILS::Event(
+ "ACQ_NOT_CANCELABLE", "note" => "lineitem $li_id"
+ ) unless (
+ (! $li->purchase_order) or (
+ $li->purchase_order and (
+ $li->state eq "on-order" or $li->state eq "pending-order"
+ )
+ )
+ );
+
+ $li->state("cancelled");
+ $li->cancel_reason($cancel_reason->id);
+
+ my $lids = $mgr->editor->search_acq_lineitem_detail([{
+ "lineitem" => $li_id
+ }, {
+ flesh => 1,
+ flesh_fields => { acqlid => ['eg_copy_id'] }
+ }]);
+
+ my $result = {"lid" => {}};
+ my $copies = [];
+ foreach my $lid (@$lids) {
+ my $lid_result = cancel_lineitem_detail($mgr, $lid->id, $cancel_reason)
+ or return 0;
+
+ # gathering any real copies for deletion
+ if ($lid->eg_copy_id) {
+ $lid->eg_copy_id->isdeleted('t');
+ push @$copies, $lid->eg_copy_id;
+ }
+
+ next if $lid_result == -1; # already canceled: just skip it.
+ return $lid_result if not_cancelable($lid_result); # not cxlable: stop.
+
+ # Merge in each LID result (there's only going to be one per call to
+ # cancel_lineitem_detail).
+ my ($k, $v) = each %{$lid_result->{"lid"}};
+ $result->{"lid"}->{$k} = $v;
+ }
+
+ # Attempt to delete the gathered copies (this will also handle volume deletion and bib deletion)
+ # Delete empty bibs according org unit setting
+ my $force_delete_empty_bib = $U->ou_ancestor_setting_value(
+ $mgr->editor->requestor->ws_ou, 'cat.bib.delete_on_no_copy_via_acq_lineitem_cancel', $mgr->editor);
+ if (scalar(@$copies)>0) {
+ my $override = 1;
+ my $delete_stats = undef;
+ my $retarget_holds = [];
+ my $cat_evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
+ $mgr->editor, $override, undef, $copies, $delete_stats, $retarget_holds,$force_delete_empty_bib);
+
+ if( $cat_evt ) {
+ $logger->info("fleshed copy update failed with event: ".OpenSRF::Utils::JSON->perl2JSON($cat_evt));
+ return new OpenILS::Event(
+ "ACQ_NOT_CANCELABLE", "note" => "lineitem $li_id", "payload" => $cat_evt
+ );
+ }
+
+ # We can't do the following and stay within the same transaction, but that's okay, the hold targeter will pick these up later.
+ #my $ses = OpenSRF::AppSession->create('open-ils.circ');
+ #$ses->request('open-ils.circ.hold.reset.batch', $auth, $retarget_holds);
+ }
+
+ # if we have a bib, check to see whether it has been deleted. if so, cancel any active holds targeting that bib
+ if ($li->eg_bib_id) {
+ my $bib = $mgr->editor->retrieve_biblio_record_entry($li->eg_bib_id) or return new OpenILS::Event(
+ "ACQ_NOT_CANCELABLE", "note" => "Could not retrieve bib " . $li->eg_bib_id . " for lineitem $li_id"
+ );
+ if ($U->is_true($bib->deleted)) {
+ my $holds = $mgr->editor->search_action_hold_request(
+ { cancel_time => undef,
+ fulfillment_time => undef,
+ target => $li->eg_bib_id
+ }
+ );
+
+ my %cached_usr_home_ou = ();
+
+ for my $hold (@$holds) {
+
+ $logger->info("Cancelling hold ".$hold->id.
+ " due to acq lineitem cancellation.");
+
+ $hold->cancel_time('now');
+ $hold->cancel_cause(5); # 'Staff forced'--we may want a new hold cancel cause reason for this
+ $hold->cancel_note('Corresponding Acquistion Lineitem/Purchase Order was cancelled.');
+ unless($mgr->editor->update_action_hold_request($hold)) {
+ my $evt = $mgr->editor->event;
+ $logger->error("Error updating hold ". $evt->textcode .":". $evt->desc .":". $evt->stacktrace);
+ return new OpenILS::Event(
+ "ACQ_NOT_CANCELABLE", "note" => "Could not cancel hold " . $hold->id . " for lineitem $li_id", "payload" => $evt
+ );
+ }
+ if (! defined $mgr->{post_commit}) { # we need a mechanism for creating trigger events, but only if the transaction gets committed
+ $mgr->{post_commit} = [];
+ }
+ push @{ $mgr->{post_commit} }, sub {
+ my $home_ou = $cached_usr_home_ou{$hold->usr};
+ if (! $home_ou) {
+ my $user = $mgr->editor->retrieve_actor_user($hold->usr); # FIXME: how do we want to handle failures here?
+ $home_ou = $user->home_ou;
+ $cached_usr_home_ou{$hold->usr} = $home_ou;
+ }
+ $U->create_events_for_hook('hold_request.cancel.cancelled_order', $hold, $home_ou);
+ };
+ }
+ }
+ }
+
+ update_lineitem($mgr, $li) or return 0;
+ $result->{"li"} = {
+ $li_id => {
+ "state" => $li->state,
+ "cancel_reason" => $cancel_reason
+ }
+ };
+ return $result;
+}
+
+
+__PACKAGE__->register_method(
+ method => "cancel_lineitem_detail_api",
+ api_name => "open-ils.acq.lineitem_detail.cancel",
+ signature => {
+ desc => q/Cancels an on-order lineitem detail/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Lineitem detail ID to cancel", type => "number"},
+ {desc => "Cancel reason ID", type => "number"}
+ ],
+ return => {desc => q/Object describing changed LIDs on success;
+ Event on error./}
+ }
+);
+
+sub cancel_lineitem_detail_api {
+ my ($self, $conn, $auth, $lid_id, $cancel_reason) = @_;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $mgr = new OpenILS::Application::Acq::BatchManager(
+ "editor" => $e, "conn" => $conn
+ );
+
+ $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
+ return new OpenILS::Event(
+ "BAD_PARAMS", "note" => "Provide cancel reason ID"
+ );
+
+ my $result = cancel_lineitem_detail($mgr, $lid_id, $cancel_reason) or
+ return $e->die_event;
+
+ if (not_cancelable($result)) {
+ $e->rollback;
+ return $result;
+ } elsif ($result == -1) {
+ $e->rollback;
+ return new OpenILS::Event("ACQ_ALREADY_CANCELED");
+ }
+
+ $e->commit or return $e->die_event;
+
+ # XXX create lineitem detail status events?
+ return $result;
+}
+
+sub cancel_lineitem_detail {
+ my ($mgr, $lid_id, $cancel_reason) = @_;
+ my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
+ $lid_id, {
+ "flesh" => 2,
+ "flesh_fields" => {
+ "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
+ }
+ }
+ ]) or return 0;
+
+ # Depending on context, this may not warrant an event.
+ return -1 if $lid->cancel_reason;
+
+ # But this always does.
+ return new OpenILS::Event(
+ "ACQ_NOT_CANCELABLE", "note" => "lineitem_detail $lid_id"
+ ) unless (
+ (! $lid->lineitem->purchase_order) or
+ (
+ (not $lid->recv_time) and
+ $lid->lineitem and
+ $lid->lineitem->purchase_order and (
+ $lid->lineitem->state eq "on-order" or
+ $lid->lineitem->state eq "pending-order"
+ )
+ )
+ );
+
+ return 0 unless $mgr->editor->allowed(
+ "CREATE_PURCHASE_ORDER",
+ $lid->lineitem->purchase_order->ordering_agency
+ ) or (! $lid->lineitem->purchase_order);
+
+ $lid->cancel_reason($cancel_reason->id);
+
+ unless($U->is_true($cancel_reason->keep_debits)) {
+ my $debit_id = $lid->fund_debit;
+ $lid->clear_fund_debit;
+
+ if($debit_id) {
+ # item is cancelled. Remove the fund debit.
+ my $debit = $mgr->editor->retrieve_acq_fund_debit($debit_id);
+ if (!$U->is_true($debit->encumbrance)) {
+ $mgr->editor->rollback;
+ return OpenILS::Event->new('ACQ_NOT_CANCELABLE',
+ note => "Debit is marked as paid: $debit_id");
+ }
+ $mgr->editor->delete_acq_fund_debit($debit) or return $mgr->editor->die_event;
+ }
+ }
+
+ # XXX LIDs don't have either an editor or a edit_time field. Should we
+ # update these on the LI when we alter an LID?
+ $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
+
+ return {"lid" => {$lid_id => {"cancel_reason" => $cancel_reason}}};
+}
+
+
+__PACKAGE__->register_method(
+ method => 'user_requests',
+ api_name => 'open-ils.acq.user_request.retrieve.by_user_id',
+ stream => 1,
+ signature => {
+ desc => 'Retrieve fleshed user requests and related data for a given user.',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User ID of the owner, or array of IDs', },
+ { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
+ type => 'object'
+ }
+ ],
+ return => {
+ desc => 'Fleshed user requests and related data',
+ type => 'object'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'user_requests',
+ api_name => 'open-ils.acq.user_request.retrieve.by_home_ou',
+ stream => 1,
+ signature => {
+ desc => 'Retrieve fleshed user requests and related data for a given org unit or units.',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Org unit ID, or array of IDs', },
+ { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
+ type => 'object'
+ }
+ ],
+ return => {
+ desc => 'Fleshed user requests and related data',
+ type => 'object'
+ }
+ }
+);
+
+sub user_requests {
+ my($self, $conn, $auth, $search_value, $options) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ my $rid = $e->requestor->id;
+ $options ||= {};
+
+ my $query = {
+ "select"=>{"aur"=>["id"],"au"=>["home_ou", {column => 'id', alias => 'usr_id'} ]},
+ "from"=>{ "aur" => { "au" => {}, "jub" => { "type" => "left" } } },
+ "where"=>{
+ "+jub"=> {
+ "-or" => [
+ {"id"=>undef}, # this with the left-join pulls in requests without lineitems
+ {"state"=>["new","on-order","pending-order"]} # FIXME - probably needs softcoding
+ ]
+ }
+ },
+ "order_by"=>[{"class"=>"aur", "field"=>"request_date", "direction"=>"desc"}]
+ };
+
+ foreach (qw/ order_by limit offset /) {
+ $query->{$_} = $options->{$_} if defined $options->{$_};
+ }
+ if (defined $options->{'state'}) {
+ $query->{'where'}->{'+jub'}->{'-or'}->[1]->{'state'} = $options->{'state'};
+ }
+
+ if ($self->api_name =~ /by_user_id/) {
+ $query->{'where'}->{'usr'} = $search_value;
+ } else {
+ $query->{'where'}->{'+au'} = { 'home_ou' => $search_value };
+ }
+
+ my $pertinent_ids = $e->json_query($query);
+
+ my %perm_test = ();
+ for my $id_blob (@$pertinent_ids) {
+ if ($rid != $id_blob->{usr_id}) {
+ if (!defined $perm_test{ $id_blob->{home_ou} }) {
+ $perm_test{ $id_blob->{home_ou} } = $e->allowed( ['user_request.view'], $id_blob->{home_ou} );
+ }
+ if (!$perm_test{ $id_blob->{home_ou} }) {
+ next; # failed test
+ }
+ }
+ my $aur_obj = $e->retrieve_acq_user_request([
+ $id_blob->{id},
+ {flesh => 1, flesh_fields => { "aur" => [ 'lineitem' ] } }
+ ]);
+ if (! $aur_obj) { next; }
+
+ if ($aur_obj->lineitem()) {
+ $aur_obj->lineitem()->clear_marc();
+ }
+ $conn->respond($aur_obj);
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method (
+ method => 'update_user_request',
+ api_name => 'open-ils.acq.user_request.cancel.batch',
+ stream => 1,
+ signature => {
+ desc => 'If given a cancel reason, will update the request with that reason, otherwise, this will delete the request altogether. The ' .
+ 'intention is for staff interfaces or processes to provide cancel reasons, and for patron interfaces to just delete the requests.' ,
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'ID or array of IDs for the user requests to cancel' },
+ { desc => 'Cancel Reason ID (optional)', type => 'string' }
+ ],
+ return => {
+ desc => 'progress object, event on error',
+ }
+ }
+);
+__PACKAGE__->register_method (
+ method => 'update_user_request',
+ api_name => 'open-ils.acq.user_request.set_no_hold.batch',
+ stream => 1,
+ signature => {
+ desc => 'Remove the hold from a user request or set of requests',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'ID or array of IDs for the user requests to modify' }
+ ],
+ return => {
+ desc => 'progress object, event on error',
+ }
+ }
+);
+
+sub update_user_request {
+ my($self, $conn, $auth, $aur_ids, $cancel_reason) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $rid = $e->requestor->id;
+
+ my $x = 1;
+ my %perm_test = ();
+ for my $id (@$aur_ids) {
+
+ my $aur_obj = $e->retrieve_acq_user_request([
+ $id,
+ { flesh => 1,
+ flesh_fields => { "aur" => ['lineitem', 'usr'] }
+ }
+ ]) or return $e->die_event;
+
+ my $context_org = $aur_obj->usr()->home_ou();
+ $aur_obj->usr( $aur_obj->usr()->id() );
+
+ if ($rid != $aur_obj->usr) {
+ if (!defined $perm_test{ $context_org }) {
+ $perm_test{ $context_org } = $e->allowed( ['user_request.update'], $context_org );
+ }
+ if (!$perm_test{ $context_org }) {
+ next; # failed test
+ }
+ }
+
+ if($self->api_name =~ /set_no_hold/) {
+ if ($U->is_true($aur_obj->hold)) {
+ $aur_obj->hold(0);
+ $e->update_acq_user_request($aur_obj) or return $e->die_event;
+ }
+ }
+
+ if($self->api_name =~ /cancel/) {
+ if ( $cancel_reason ) {
+ $aur_obj->cancel_reason( $cancel_reason );
+ $e->update_acq_user_request($aur_obj) or return $e->die_event;
+ create_user_request_events( $e, [ $aur_obj ], 'aur.rejected' );
+ } else {
+ $e->delete_acq_user_request($aur_obj);
+ }
+ }
+
+ $conn->respond({maximum => scalar(@$aur_ids), progress => $x++});
+ }
+
+ $e->commit;
+ return {complete => 1};
+}
+
+__PACKAGE__->register_method (
+ method => 'new_user_request',
+ api_name => 'open-ils.acq.user_request.create',
+ signature => {
+ desc => 'Create a new user request object in the DB',
+ param => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User request data hash. Hash keys match the fields for the "aur" object', type => 'object' }
+ ],
+ return => {
+ desc => 'The created user request object, or event on error'
+ }
+ }
+);
+
+sub new_user_request {
+ my($self, $conn, $auth, $form_data) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $rid = $e->requestor->id;
+ my $target_user_fleshed;
+ if (! defined $$form_data{'usr'}) {
+ $$form_data{'usr'} = $rid;
+ }
+ if ($$form_data{'usr'} != $rid) {
+ # See if the requestor can place the request on behalf of a different user.
+ $target_user_fleshed = $e->retrieve_actor_user($$form_data{'usr'}) or return $e->die_event;
+ $e->allowed('user_request.create', $target_user_fleshed->home_ou) or return $e->die_event;
+ } else {
+ $target_user_fleshed = $e->requestor;
+ $e->allowed('CREATE_PURCHASE_REQUEST') or return $e->die_event;
+ }
+ if (! defined $$form_data{'pickup_lib'}) {
+ if ($target_user_fleshed->ws_ou) {
+ $$form_data{'pickup_lib'} = $target_user_fleshed->ws_ou;
+ } else {
+ $$form_data{'pickup_lib'} = $target_user_fleshed->home_ou;
+ }
+ }
+ if (! defined $$form_data{'request_type'}) {
+ $$form_data{'request_type'} = 1; # Books
+ }
+ my $aur_obj = new Fieldmapper::acq::user_request;
+ $aur_obj->isnew(1);
+ $aur_obj->usr( $$form_data{'usr'} );
+ $aur_obj->request_date( 'now' );
+ for my $field ( keys %$form_data ) {
+ if (defined $$form_data{$field} and $field !~ /^(id|lineitem|eg_bib|request_date|cancel_reason)$/) {
+ $aur_obj->$field( $$form_data{$field} );
+ }
+ }
+
+ $aur_obj = $e->create_acq_user_request($aur_obj) or return $e->die_event;
+
+ $e->commit and create_user_request_events( $e, [ $aur_obj ], 'aur.created' );
+
+ return $aur_obj;
+}
+
+sub create_user_request_events {
+ my($e, $user_reqs, $hook) = @_;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->connect;
+
+ my %cached_usr_home_ou = ();
+ for my $user_req (@$user_reqs) {
+ my $home_ou = $cached_usr_home_ou{$user_req->usr};
+ if (! $home_ou) {
+ my $user = $e->retrieve_actor_user($user_req->usr) or return $e->die_event;
+ $home_ou = $user->home_ou;
+ $cached_usr_home_ou{$user_req->usr} = $home_ou;
+ }
+ my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $home_ou);
+ $req->recv;
+ }
+
+ $ses->disconnect;
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "po_note_CUD_batch",
+ api_name => "open-ils.acq.po_note.cud.batch",
+ stream => 1,
+ signature => {
+ desc => q/Manage purchase order notes/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "List of po_notes to manage", type => "array"},
+ ],
+ return => {desc => "Stream of successfully managed objects"}
+ }
+);
+
+sub po_note_CUD_batch {
+ my ($self, $conn, $auth, $notes) = @_;
+
+ my $e = new_editor("xact"=> 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+ # XXX perms
+
+ my $total = @$notes;
+ my $count = 0;
+
+ foreach my $note (@$notes) {
+
+ $note->editor($e->requestor->id);
+ $note->edit_time("now");
+
+ if ($note->isnew) {
+ $note->creator($e->requestor->id);
+ $note = $e->create_acq_po_note($note) or return $e->die_event;
+ } elsif ($note->isdeleted) {
+ $e->delete_acq_po_note($note) or return $e->die_event;
+ } elsif ($note->ischanged) {
+ $e->update_acq_po_note($note) or return $e->die_event;
+ }
+
+ unless ($note->isdeleted) {
+ $note = $e->retrieve_acq_po_note($note->id) or
+ return $e->die_event;
+ }
+
+ $conn->respond(
+ {"maximum" => $total, "progress" => ++$count, "note" => $note}
+ );
+ }
+
+ $e->commit and $conn->respond_complete or return $e->die_event;
+}
+
+
+# retrieves a lineitem, fleshes its PO and PL, checks perms
+sub fetch_and_check_li {
+ my $e = shift;
+ my $li_id = shift;
+ my $perm_mode = shift || 'read';
+
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id,
+ { flesh => 1,
+ flesh_fields => {jub => ['purchase_order', 'picklist']}
+ }
+ ]) or return $e->die_event;
+
+ if(my $po = $li->purchase_order) {
+ my $perms = ($perm_mode eq 'read') ? 'VIEW_PURCHASE_ORDER' : 'CREATE_PURCHASE_ORDER';
+ return ($li, $e->die_event) unless $e->allowed($perms, $po->ordering_agency);
+
+ } elsif(my $pl = $li->picklist) {
+ my $perms = ($perm_mode eq 'read') ? 'VIEW_PICKLIST' : 'CREATE_PICKLIST';
+ return ($li, $e->die_event) unless $e->allowed($perms, $pl->org_unit);
+ }
+
+ return ($li);
+}
+
+
+__PACKAGE__->register_method(
+ method => "clone_distrib_form",
+ api_name => "open-ils.acq.distribution_formula.clone",
+ stream => 1,
+ signature => {
+ desc => q/Clone a distribution formula/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Original formula ID", type => 'integer'},
+ {desc => "Name of new formula", type => 'string'},
+ ],
+ return => {desc => "ID of newly created formula"}
+ }
+);
+
+sub clone_distrib_form {
+ my($self, $client, $auth, $form_id, $new_name) = @_;
+
+ my $e = new_editor("xact"=> 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $old_form = $e->retrieve_acq_distribution_formula($form_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('ADMIN_ACQ_DISTRIB_FORMULA', $old_form->owner);
+
+ my $new_form = Fieldmapper::acq::distribution_formula->new;
+
+ $new_form->owner($old_form->owner);
+ $new_form->name($new_name);
+ $e->create_acq_distribution_formula($new_form) or return $e->die_event;
+
+ my $entries = $e->search_acq_distribution_formula_entry({formula => $form_id});
+ for my $entry (@$entries) {
+ my $new_entry = Fieldmapper::acq::distribution_formula_entry->new;
+ $new_entry->$_($entry->$_()) for $entry->real_fields;
+ $new_entry->formula($new_form->id);
+ $new_entry->clear_id;
+ $e->create_acq_distribution_formula_entry($new_entry) or return $e->die_event;
+ }
+
+ $e->commit;
+ return $new_form->id;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Acq::Picklist;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::EX q/:try/;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Const qw/:const/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Event;
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils::Cache;
+use MARC::Record;
+use MARC::Batch;
+use MARC::File::XML;
+use MIME::Base64;
+use Digest::MD5 qw/md5_hex/;
+use OpenILS::Application::Acq::Financials;
+use DateTime;
+
+my $U = 'OpenILS::Application::AppUtils';
+
+
+__PACKAGE__->register_method(
+ method => 'create_picklist',
+ api_name => 'open-ils.acq.picklist.create',
+ signature => {
+ desc => 'Creates a new picklist',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist object to create', type => 'object'}
+ ],
+ return => {desc => 'The ID of the new picklist'}
+ }
+);
+
+sub create_picklist {
+ my($self, $conn, $auth, $picklist) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ $picklist->creator($e->requestor->id);
+ $picklist->editor($e->requestor->id);
+ $picklist->org_unit($e->requestor->ws_ou) unless $picklist->org_unit;
+ return $e->die_event unless $e->allowed('CREATE_PICKLIST', $picklist->org_unit);
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $e->requestor->id == $picklist->owner;
+ $e->create_acq_picklist($picklist) or return $e->die_event;
+ $e->commit;
+ return $picklist->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'update_picklist',
+ api_name => 'open-ils.acq.picklist.update',
+ signature => {
+ desc => 'Updates a new picklist',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist object to update', type => 'object'}
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub update_picklist {
+ my($self, $conn, $auth, $picklist) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ # don't let them change the owner
+ my $o_picklist = $e->retrieve_acq_picklist($picklist->id)
+ or return $e->die_event;
+ if($o_picklist->owner != $e->requestor->id) {
+ return $e->die_event unless
+ $e->allowed('UPDATE_PICKLIST', $o_picklist->org_unit);
+ }
+ return OpenILS::Event->new('BAD_PARAMS') unless $o_picklist->org_unit == $picklist->org_unit;
+
+ $picklist->edit_time('now');
+ $picklist->editor($e->requestor->id);
+ $e->update_acq_picklist($picklist) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_picklist',
+ api_name => 'open-ils.acq.picklist.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a picklist',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist ID to retrieve', type => 'number'},
+ {desc => 'Options hash, including "flesh_lineitem_count" to get the count of attached entries', type => 'hash'},
+ ],
+ return => {desc => 'Picklist object on success, Event on error'}
+ }
+);
+
+sub retrieve_picklist {
+ my($self, $conn, $auth, $picklist_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ return retrieve_picklist_impl($e, $picklist_id, $options);
+}
+
+sub retrieve_picklist_impl {
+ my ($e, $picklist_id, $options) = @_;
+ $options ||= {};
+
+ my $picklist = $e->retrieve_acq_picklist($picklist_id)
+ or return $e->event;
+
+ $picklist->entry_count(retrieve_lineitem_count($e, $picklist_id))
+ if $$options{flesh_lineitem_count};
+
+ if($e->requestor->id != $picklist->owner) {
+ return $e->event unless
+ $e->allowed('VIEW_PICKLIST', $picklist->org_unit, $picklist);
+ }
+
+ $picklist->owner($e->retrieve_actor_user($picklist->owner))
+ if($$options{flesh_owner});
+ $picklist->owner($e->retrieve_actor_user($picklist->owner)->usrname)
+ if($$options{flesh_username});
+
+ return $picklist;
+}
+
+
+# Returns the number of entries associated with this picklist
+sub retrieve_lineitem_count {
+ my($e, $picklist_id) = @_;
+ my $count = $e->json_query({
+ select => {
+ jub => [{transform => 'count', column => 'id', alias => 'count'}]
+ },
+ from => 'jub',
+ where => {picklist => $picklist_id}}
+ );
+ return $count->[0]->{count};
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_picklist_name',
+ api_name => 'open-ils.acq.picklist.name.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a picklist by name. Owner is implied by the caller',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist name to retrieve', type => 'string'},
+ ],
+ return => {desc => 'Picklist object on success, null on not found'}
+ }
+);
+
+sub retrieve_picklist_name {
+ my($self, $conn, $auth, $name) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $picklist = $e->search_acq_picklist(
+ {name => $name, owner => $e->requestor->id})->[0];
+ if($e->requestor->id != $picklist->owner) {
+ return $e->event unless
+ $e->allowed('VIEW_PICKLIST', $picklist->org_unit, $picklist);
+ }
+ return $picklist;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_user_picklist',
+ api_name => 'open-ils.acq.picklist.user.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves a user\'s picklists',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Options, including "idlist", whch forces the return
+ of a list of IDs instead of objects', type => 'hash'},
+ ],
+ return => {desc => 'Picklist object on success, Event on error'}
+ }
+);
+
+sub retrieve_user_picklist {
+ my($self, $conn, $auth, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ $options ||= {};
+
+ # don't grab the PL with name == "", because that is the designated temporary picklist
+ my $list = $e->search_acq_picklist([
+ {
+ owner => $e->requestor->id,
+ name => {'!=' => ''}
+ }, {
+ order_by => $$options{order_by} || {acqpl => 'edit_time DESC'},
+ limit => $$options{limit} || 10,
+ offset => $$options{offset} || 0,
+ }
+ ],
+ {idlist=>1}
+ );
+
+ for my $id (@$list) {
+ if($$options{idlist}) {
+ $conn->respond($id);
+ } else {
+ my $pl = $e->retrieve_acq_picklist($id);
+ $pl->entry_count(retrieve_lineitem_count($e, $id)) if $$options{flesh_lineitem_count};
+ $pl->owner($e->retrieve_actor_user($pl->owner)) if $$options{flesh_owner};
+ $pl->owner($e->retrieve_actor_user($pl->owner)->usrname) if $$options{flesh_username};
+ $conn->respond($pl);
+ }
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_all_user_picklist',
+ api_name => 'open-ils.acq.picklist.user.all.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves all of the picklists a user is allowed to see',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Options, including "idlist", whch forces the return
+ of a list of IDs instead of objects', type => 'hash'},
+ ],
+ return => {desc => 'Picklist objects on success, Event on error'}
+ }
+);
+
+sub retrieve_all_user_picklist {
+ my($self, $conn, $auth, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $my_list = $e->search_acq_picklist(
+ {owner=>$e->requestor->id, name=>{'!='=>''}}, {idlist=>1});
+
+ my $picklist_ids = $e->objects_allowed('VIEW_PICKLIST', 'acqpl');
+ my $p_orgs = $U->user_has_work_perm_at($e, 'VIEW_PICKLIST', {descendants =>1});
+ my $picklist_ids_2 = $e->search_acq_picklist(
+ {name=>{'!='=>''}, org_unit => $p_orgs}, {idlist=>1});
+
+ return undef unless @$my_list or @$picklist_ids or @$picklist_ids_2;
+
+ my @list = (@$my_list, @$picklist_ids, @$picklist_ids_2);
+ my %dedup;
+ $dedup{$_} = 1 for @list;
+ @list = keys %dedup;
+
+ return \@list if $$options{idlist};
+
+ for my $pl (@list) {
+ my $picklist = $e->retrieve_acq_picklist($pl) or return $e->event;
+ $picklist->entry_count(retrieve_lineitem_count($e, $picklist->id))
+ if($$options{flesh_lineitem_count});
+ $picklist->owner($e->retrieve_actor_user($picklist->owner))
+ if $$options{flesh_owner};
+ $picklist->owner($e->retrieve_actor_user($picklist->owner)->usrname)
+ if $$options{flesh_username};
+ $conn->respond($picklist);
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_pl_lineitem',
+ api_name => 'open-ils.acq.lineitem.picklist.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves lineitem objects according to picklist',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Picklist ID whose entries to retrieve', type => 'number'},
+ {desc => q/Options, including
+ "sort_attr", which defines the attribute to sort on;
+ "sort_attr_type", which defines the attribute type sort on;
+ "sort_dir", which defines the sort order between "asc" and "desc";
+ "limit", retrieval limit;
+ "offset", retrieval offset;
+ "idlist", return a list of IDs instead of objects
+ "flesh_attrs", additionaly return the list of flattened attributes
+ "clear_marc", discards the raw MARC data to reduce data size
+ "flesh_notes", flesh lineitem notes
+ "flesh_cancel_reason", flesh cancel_reason
+ /,
+ type => 'hash'}
+ ],
+ return => {desc => 'Array of lineitem objects or IDs, on success, Event on error'}
+ }
+);
+
+
+my $PL_ENTRY_JSON_QUERY = {
+ select => {jub => ["id"], "acqlia" => ["attr_value"]},
+ "from" => {
+ "jub" => {
+ "acqlia" => {
+ "fkey" => "id",
+ "field" => "lineitem",
+ "type" => "left",
+ "filter" => {
+ "attr_type" => "lineitem_marc_attr_definition",
+ "attr_name" => "author"
+ }
+ }
+ }
+ },
+ "order_by" => {"acqlia" => {"attr_value" => {"direction"=>"asc"}}},
+ "limit" => 10,
+ "where" => {"+jub" => {"picklist"=>2}},
+ "offset" => 0
+};
+
+sub retrieve_pl_lineitem {
+ my($self, $conn, $auth, $picklist_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ # collect the retrieval options
+ my $sort_attr = $$options{sort_attr} || 'title';
+ my $sort_attr_type = $$options{sort_attr_type} || 'lineitem_marc_attr_definition';
+ my $sort_dir = $$options{sort_dir} || 'asc';
+ my $limit = $$options{limit} || 10;
+ my $offset = $$options{offset} || 0;
+
+ $PL_ENTRY_JSON_QUERY->{where}->{'+jub'}->{picklist} = $picklist_id;
+ $PL_ENTRY_JSON_QUERY->{from}->{jub}->{acqlia}->{filter}->{attr_name} = $sort_attr;
+ $PL_ENTRY_JSON_QUERY->{from}->{jub}->{acqlia}->{filter}->{attr_type} = $sort_attr_type;
+ $PL_ENTRY_JSON_QUERY->{order_by}->{acqlia}->{attr_value}->{direction} = $sort_dir;
+ $PL_ENTRY_JSON_QUERY->{limit} = $limit;
+ $PL_ENTRY_JSON_QUERY->{offset} = $offset;
+
+ my $entries = $e->json_query($PL_ENTRY_JSON_QUERY);
+
+ my @ids;
+ for my $entry (@$entries) {
+ push(@ids, $entry->{id}) unless grep { $_ eq $entry->{id} } @ids;
+ }
+
+ for my $id (@ids) {
+ if($$options{idlist}) {
+ $conn->respond($id);
+ next;
+ }
+
+ my $entry;
+ my $flesh = {};
+ if($$options{flesh_attrs} or $$options{flesh_notes} or $$options{flesh_cancel_reason}) {
+ $flesh = {flesh => 2, flesh_fields => {jub => []}};
+ if($$options{flesh_notes}) {
+ push(@{$flesh->{flesh_fields}->{jub}}, 'lineitem_notes');
+ $flesh->{flesh_fields}->{acqlin} = ['alert_text'];
+ }
+ push(@{$flesh->{flesh_fields}->{jub}}, 'attributes') if $$options{flesh_attrs};
+ push @{$flesh->{flesh_fields}->{jub}}, 'cancel_reason' if $$options{flesh_cancel_reason};
+ }
+
+ $entry = $e->retrieve_acq_lineitem([$id, $flesh]);
+ my $details = $e->search_acq_lineitem_detail({lineitem => $id}, {idlist=>1});
+ $entry->item_count(scalar(@$details));
+ $entry->clear_marc if $$options{clear_marc};
+ $conn->respond($entry);
+ }
+
+ return undef;
+}
+
+=head comment
+request open-ils.cstore open-ils.cstore.json_query.atomic {"select":{"jub":[{"transform":"count", "attregate":1, "column":"id","alias":"count"}]}, "from":"jub","where":{"picklist":1}}
+=cut
+
+
+
+__PACKAGE__->register_method(
+ method => "record_distribution_formula_application",
+ api_name => "open-ils.acq.distribution_formula.record_application",
+ signature => {
+ desc => "Record the application (which actually happens on the " .
+ "client side) of a distribution formula to a PO or a PL",
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Formulae applied", "type" => "array"},
+ {desc => "Lineitem ID", "type" => "number"}
+ ],
+ return => {desc => "acqdfa IDs on success; event on failure"}
+ }
+);
+
+sub record_distribution_formula_application {
+ my ($self, $conn, $auth, $formulae, $li_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth, "xact" => 1);
+ return $e->die_event unless $e->checkauth;
+
+ # We need this to determine relevant OU for testing permissions...
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id, {
+ "flesh" => 1,
+ "flesh_fields" => {"jub" => [qw/purchase_order picklist/]}
+ }
+ ]) or return $e->die_event;
+
+ # ... which we do here.
+ my $ou;
+ if ($li->purchase_order) {
+ $ou = $li->purchase_order->ordering_agency;
+ } elsif ($li->picklist) {
+ $ou = $li->picklist->org_unit;
+ } else {
+ $e->rollback;
+ return new OpenILS::Event("BAD_PARAMS");
+ }
+
+ return $e->die_event unless $e->allowed("CREATE_PURCHASE_ORDER", $ou);
+
+ # Just deal with it if $formulate is a scalar instead of an array.
+ $formulae = [ $formulae ] if not ref $formulae;
+
+ my @results = ();
+ foreach (@{$formulae}) {
+ my $acqdfa = new Fieldmapper::acq::distribution_formula_application;
+
+ $acqdfa->creator($e->requestor->id);
+ $acqdfa->formula($_);
+ $acqdfa->lineitem($li_id);
+
+ $acqdfa = $e->create_acq_distribution_formula_application($acqdfa)
+ or return $e->die_event;
+ push @results, $acqdfa->id;
+ }
+
+ $e->commit or return $e->die_event;
+ \@results;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'ranged_distrib_formulas',
+ api_name => 'open-ils.acq.distribution_formula.ranged.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Ranged distribution formulas, fleshed with entries',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => "offset", type => "number"},
+ {desc => "limit", type => "number"}
+ ],
+ return => {desc => 'List of distribution formulas'}
+ }
+);
+
+sub ranged_distrib_formulas {
+ my ($self, $conn, $auth, $offset, $limit) = @_;
+
+ $offset ||= 0;
+ $limit ||= 10;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $orgs = $U->user_has_work_perm_at($e, 'CREATE_PICKLIST', {descendants =>1});
+
+ my $forms = $e->search_acq_distribution_formula([
+ {owner => $orgs},
+ {
+ flesh => 1,
+ flesh_fields => {acqdf => ['entries']},
+ order_by => {acqdf => "name"},
+ limit => $limit,
+ offset => $offset
+ }
+ ]) or return $e->die_event;
+
+ for (@$forms) {
+
+ # how many times has this DF been used
+ my $count = $e->json_query({
+ select => {acqdfa => [{column => 'formula', aggregate => 1, transform => 'count', alias => 'count'}]},
+ from => 'acqdfa',
+ where => {formula => $_->id}
+ })->[0];
+
+ $_->use_count($count->{count});
+ $conn->respond($_);
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "ranged_distrib_formula_applications",
+ api_name => "open-ils.acq.distribution_formula_application.ranged.retrieve",
+ stream => 1,
+ signature => {
+ desc => "Ranged distribution formulas applications, fleshed with formulas and users",
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Lineitem Id", type => "number"}
+ ],
+ return => {desc => "List of distribution formula applications"}
+ }
+);
+
+sub ranged_distrib_formula_applications {
+ my ($self, $conn, $auth, $li_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $li = $e->retrieve_acq_lineitem([
+ $li_id, {
+ "flesh" => 1,
+ "flesh_fields" => {"jub" => [qw/purchase_order picklist/]}
+ }
+ ]) or return $e->die_event;
+
+ if ($li->picklist) {
+ return $e->die_event unless $e->allowed(
+ "VIEW_PICKLIST", $li->picklist->org_unit
+ );
+ } elsif ($li->purchase_order) {
+ return $e->die_event unless $e->allowed(
+ "VIEW_PURCHASE_ORDER", $li->purchase_order->ordering_agency
+ );
+ } else {
+ # For the moment no use cases are forseen for using this
+ # method with LIs that don't belong to a PL or a PO.
+ $e->disconnect;
+ return new OpenILS::Event("BAD_PARAMS", "note" => "Freestanding LI");
+ }
+
+ my $dfa = $e->search_acq_distribution_formula_application([
+ {"lineitem" => $li_id},
+ {"flesh" => 1, "flesh_fields" => {"acqdfa" => [qw/formula creator/]}}
+ ]);
+
+ $conn->respond($_) foreach (@$dfa);
+
+ $e->disconnect;
+ undef;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Acq::Provider;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenILS::Event;
+use OpenILS::Const qw/:const/;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::AppUtils;
+
+my $U = 'OpenILS::Application::AppUtils';
+
+__PACKAGE__->register_method(
+ method => 'create_provider',
+ api_name => 'open-ils.acq.provider.create',
+ signature => {
+ desc => 'Creates a new provider',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'provider object to create', type => 'object'}
+ ],
+ return => {desc => 'The ID of the new provider'}
+ }
+);
+
+sub create_provider {
+ my($self, $conn, $auth, $provider) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
+ $e->create_acq_provider($provider) or return $e->die_event;
+ $e->commit;
+ return $provider->id;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_provider',
+ api_name => 'open-ils.acq.provider.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieves a new provider',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'provider ID', type => 'number'}
+ ],
+ return => {desc => 'The provider object on success, Event on failure'}
+ }
+);
+
+sub retrieve_provider {
+ my($self, $conn, $auth, $provider_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $provider = $e->retrieve_acq_provider($provider_id) or return $e->event;
+ return $e->event unless $e->allowed(
+ ['ADMIN_PROVIDER', 'MANAGE_PROVIDER', 'VIEW_PROVIDER'], $provider->owner, $provider);
+ return $provider;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_org_providers',
+ api_name => 'open-ils.acq.provider.org.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves all the providers associated with an org unit that the requestor has access to see',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'List of org Unit IDs. If no IDs are provided, this method returns the
+ full set of funding sources this user has permission to view', type => 'number'},
+ {desc => q/Limiting permission. this permission is used find the work-org tree from which
+ the list of orgs is generated if no org ids are provided.
+ The default is ADMIN_PROVIDER/, type => 'string'},
+ ],
+ return => {desc => 'The provider objects on success, empty array otherwise'}
+ }
+);
+
+sub retrieve_org_providers {
+ my($self, $conn, $auth, $org_id_list, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $limit_perm = ($$options{limit_perm}) ? $$options{limit_perm} : 'ADMIN_PROVIDER';
+
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $limit_perm =~ /(ADMIN|MANAGE|VIEW)_PROVIDER/;
+
+ my $org_ids = ($org_id_list and @$org_id_list) ? $org_id_list :
+ $U->user_has_work_perm_at($e, $limit_perm, {descendants =>1});
+
+ return [] unless @$org_ids;
+ $conn->respond($_) for @{
+ $e->search_acq_provider([
+ {owner => $org_ids, active => 't'},
+ {order_by => {acqpro => 'code'}}
+ ])
+ };
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_provider_attr_def',
+ api_name => 'open-ils.acq.lineitem_provider_attr_definition.provider.retrieve',
+ stream => 1,
+ signature => {
+ desc => 'Retrieves all of the lineitem_provider_attr_definition for a given provider',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Provider ID', type => 'number'}
+ ],
+ return => {desc => 'Streams a of lineitem_provider_attr_definition objects'}
+ }
+);
+
+sub retrieve_provider_attr_def {
+ my($self, $conn, $auth, $prov_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $provider = $e->retrieve_acq_provider($prov_id)
+ or return $e->event;
+ return $e->event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
+ for my $id (@{$e->search_acq_lineitem_provider_attr_definition({provider=>$prov_id},{idlist=>1})}) {
+ $conn->respond($e->retrieve_acq_lineitem_provider_attr_definition($id));
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'create_provider_attr_def',
+ api_name => 'open-ils.acq.lineitem_provider_attr_definition.create',
+ signature => {
+ desc => 'Retrieves all of the lineitem_provider_attr_definition for a given provider',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Provider ID', type => 'number'}
+ ],
+ return => {desc => 'Streams a of lineitem_provider_attr_definition objects'}
+ }
+);
+
+sub create_provider_attr_def {
+ my($self, $conn, $auth, $attr_def) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my $provider = $e->retrieve_acq_provider($attr_def->provider)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
+ $e->create_acq_lineitem_provider_attr_definition($attr_def)
+ or return $e->die_event;
+ $e->commit;
+ return $attr_def->id;
+}
+
+__PACKAGE__->register_method(
+ method => 'delete_provider_attr_def',
+ api_name => 'open-ils.acq.lineitem_provider_attr_definition.delete',
+ signature => {
+ desc => 'Deletes a lineitem_provider_attr_definition',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'ID', type => 'number'}
+ ],
+ return => {desc => '1 on success, event on failure'}
+ }
+);
+
+sub delete_provider_attr_def {
+ my($self, $conn, $auth, $id) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my $attr_def = $e->retrieve_acq_lineitem_provider_attr_definition($id)
+ or return $e->die_event;
+ my $provider = $e->retrieve_acq_provider($attr_def->provider)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('ADMIN_PROVIDER', $provider->owner);
+ $e->delete_acq_lineitem_provider_attr_definition($attr_def)
+ or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Acq::Search;
+use base "OpenILS::Application";
+
+use strict;
+use warnings;
+
+use OpenSRF::AppSession;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Event;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Application::Acq::Lineitem;
+use OpenILS::Application::Acq::Financials;
+use OpenILS::Application::Acq::Picklist;
+use OpenILS::Application::Acq::Invoice;
+use OpenILS::Application::Acq::Order;
+
+my %RETRIEVERS = (
+ "lineitem" =>
+ \&{"OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl"},
+ "picklist" =>
+ \&{"OpenILS::Application::Acq::Picklist::retrieve_picklist_impl"},
+ "purchase_order" => \&{
+ "OpenILS::Application::Acq::Financials::retrieve_purchase_order_impl"
+ },
+ "invoice" => \&{
+ "OpenILS::Application::Acq::Invoice::fetch_invoice_impl"
+ },
+);
+
+sub F { $Fieldmapper::fieldmap->{"Fieldmapper::" . $_[0]}; }
+
+# This subroutine returns 1 if the argument is a) a scalar OR
+# b) an array of ONLY scalars. Otherwise it returns 0.
+sub check_1d_max {
+ my ($o) = @_;
+ return 1 unless ref $o;
+ if (ref($o) eq "ARRAY") {
+ foreach (@$o) { return 0 if ref $_; }
+ return 1;
+ }
+ 0;
+}
+
+# Returns 1 if and only if argument is an array of exactly two scalars.
+sub could_be_range {
+ my ($o) = @_;
+ if (ref $o eq "ARRAY") {
+ return 1 if (scalar(@$o) == 2 && (!ref $o->[0] && !ref $o->[1]));
+ }
+ 0;
+}
+
+sub castdate {
+ my ($value, $gte, $lte) = @_;
+
+ my $op = "=";
+ $op = ">=" if $gte;
+ $op = "<=" if $lte;
+
+ +{$op => {"transform" => "date", "value" => $value}};
+}
+
+sub prepare_acqlia_search_and {
+ my ($acqlia) = @_;
+
+ my @phrases = ();
+ foreach my $unit (@{$acqlia}) {
+ my $subquery = {
+ "select" => {"acqlia" => ["id"]},
+ "from" => "acqlia",
+ "where" => {"-and" => [{"lineitem" => {"=" => {"+jub" => "id"}}}]}
+ };
+
+ # castdate not supported for acqlia fields: they're all type text
+ my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
+ my $point = $subquery->{"where"}->{"-and"};
+ my $term_clause;
+
+ push @$point, {"definition" => $k};
+
+ if ($fuzzy and not ref $v) {
+ push @$point, {"attr_value" => {"ilike" => "%" . $v . "%"}};
+ } elsif ($between and could_be_range($v)) {
+ push @$point, {"attr_value" => {"between" => $v}};
+ } elsif (check_1d_max($v)) {
+ push @$point, {"attr_value" => $v};
+ } else {
+ next;
+ }
+
+ my $operator = $not ? "-not-exists" : "-exists";
+ push @phrases, {$operator => $subquery};
+ }
+ @phrases;
+}
+
+sub prepare_acqlia_search_or {
+ my ($acqlia) = @_;
+
+ my $point = [];
+ my $result = {"+acqlia" => {"-or" => $point}};
+
+ foreach my $unit (@$acqlia) {
+ # castdate not supported for acqlia fields: they're all type text
+ my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
+ my $term_clause;
+ if ($fuzzy and not ref $v) {
+ $term_clause = {
+ "-and" => {
+ "definition" => $k,
+ "attr_value" => {"ilike" => "%" . $v . "%"}
+ }
+ };
+ } elsif ($between and could_be_range($v)) {
+ $term_clause = {
+ "-and" => {
+ "definition" => $k, "attr_value" => {"between" => $v}
+ }
+ };
+ } elsif (check_1d_max($v)) {
+ $term_clause = {
+ "-and" => {"definition" => $k, "attr_value" => $v}
+ };
+ } else {
+ next;
+ }
+
+ push @$point, $not ? {"-not" => $term_clause} : $term_clause;
+ }
+ $result;
+}
+
+sub breakdown_term {
+ my ($term) = @_;
+
+ my $key = (grep { !/^__/ } keys %$term)[0];
+ (
+ $key, $term->{$key},
+ $term->{"__fuzzy"} ? 1 : 0,
+ $term->{"__between"} ? 1 : 0,
+ $term->{"__not"} ? 1 : 0,
+ $term->{"__castdate"} ? 1 : 0,
+ $term->{"__gte"} ? 1 : 0,
+ $term->{"__lte"} ? 1 : 0
+ );
+}
+
+sub get_fm_links_by_hint {
+ my ($hint) = @_;
+ foreach my $field (values %{$Fieldmapper::fieldmap}) {
+ return $field->{"links"} if $field->{"hint"} eq $hint;
+ }
+ undef;
+}
+
+sub gen_au_term {
+ my ($value, $n) = @_;
+ +{
+ "-or" => [
+ {"+au$n" => {"usrname" => $value}},
+ {"+au$n" => {"first_given_name" => $value}},
+ {"+au$n" => {"second_given_name" => $value}},
+ {"+au$n" => {"family_name" => $value}},
+ {"+ac$n" => {"barcode" => $value}}
+ ]
+ };
+}
+
+# go through the terms hash, find keys that correspond to fields links
+# to actor.usr, and rewrite the search as one that searches not by
+# actor.usr.id but by any of these user properties: card barcode, username,
+# given names and family name.
+sub prepare_au_terms {
+ my ($terms, $join_num) = @_;
+
+ my @joins = ();
+ my $nots = 0;
+ $join_num ||= 0;
+
+ foreach my $conj (qw/-and -or/) {
+ next unless exists $terms->{$conj};
+
+ my @new_outer_terms = ();
+ HINT_UNIT: foreach my $hint_unit (@{$terms->{$conj}}) {
+ my $hint = (keys %$hint_unit)[0];
+ (my $plain_hint = $hint) =~ y/+//d;
+ if ($hint eq "-not") {
+ $hint_unit = $hint_unit->{$hint};
+ $nots++;
+ redo HINT_UNIT;
+ }
+
+ if (my $links = get_fm_links_by_hint($plain_hint) and
+ $plain_hint ne "acqlia") {
+ my @new_terms = ();
+ my ($attr, $value) = breakdown_term($hint_unit->{$hint});
+ if ($links->{$attr} and
+ $links->{$attr}->{"class"} eq "au") {
+ push @joins, [$plain_hint, $attr, $join_num];
+ my $au_term = gen_au_term($value, $join_num);
+ if ($nots > 0) {
+ $au_term = {"-not" => $au_term};
+ $nots--;
+ }
+ push @new_outer_terms, $au_term;
+ $join_num++;
+ delete $hint_unit->{$hint};
+ }
+ }
+ if ($nots > 0) {
+ $hint_unit = {"-not" => $hint_unit};
+ $nots--;
+ }
+ push @new_outer_terms, $hint_unit if scalar keys %$hint_unit;
+ }
+ $terms->{$conj} = [ @new_outer_terms ];
+ }
+ @joins;
+}
+
+sub prepare_terms {
+ my ($terms, $is_and) = @_;
+
+ my $conj = $is_and ? "-and" : "-or";
+ my $outer_clause = {};
+
+ foreach my $class (qw/acqpo acqpl acqinv jub/) {
+ next if not exists $terms->{$class};
+
+ $outer_clause->{$conj} = [] unless $outer_clause->{$conj};
+ foreach my $unit (@{$terms->{$class}}) {
+ my ($k, $v, $fuzzy, $between, $not, $castdate, $gte, $lte) =
+ breakdown_term($unit);
+
+ my $term_clause;
+ if ($fuzzy and not ref $v) {
+ $term_clause = {$k => {"ilike" => "%" . $v . "%"}};
+ } elsif ($between and could_be_range($v)) {
+ $term_clause = {$k => {"between" => $v}};
+ } elsif (check_1d_max($v)) {
+ $v = castdate($v, $gte, $lte) if $castdate;
+ $term_clause = {$k => $v};
+ } else {
+ next;
+ }
+
+ my $clause = {"+" . $class => $term_clause};
+ $clause = {"-not" => $clause} if $not;
+ push @{$outer_clause->{$conj}}, $clause;
+ }
+ }
+
+ if ($terms->{"acqlia"}) {
+ push @{$outer_clause->{$conj}},
+ $is_and ? prepare_acqlia_search_and($terms->{"acqlia"}) :
+ prepare_acqlia_search_or($terms->{"acqlia"});
+ }
+
+ return undef unless scalar keys %$outer_clause;
+ $outer_clause;
+}
+
+sub add_au_joins {
+ my ($from) = shift;
+
+ my $n = 0;
+ foreach my $join (@_) {
+ my ($hint, $attr, $num) = @$join;
+ my $start;
+ if ($hint eq "jub") {
+ $start = $from->{$hint};
+ } elsif ($hint eq "acqinv") {
+ $start = $from->{"jub"}->{"acqie"}->{"join"}->{$hint};
+ } else {
+ $start = $from->{"jub"}->{$hint};
+ }
+ my $clause = {
+ "class" => "au",
+ "type" => "left",
+ "field" => "id",
+ "fkey" => $attr,
+ "join" => {
+ "ac$num" => {
+ "class" => "ac",
+ "type" => "left",
+ "field" => "id",
+ "fkey" => "card"
+ }
+ }
+ };
+ if ($hint eq "jub") {
+ $start->{"au$num"} = $clause;
+ } else {
+ $start->{"join"} ||= {};
+ $start->{"join"}->{"au$num"} = $clause;
+ }
+ $n++;
+ }
+ $n;
+}
+
+__PACKAGE__->register_method(
+ method => "unified_search",
+ api_name => "open-ils.acq.lineitem.unified_search",
+ stream => 1,
+ signature => {
+ desc => q/Returns lineitems based on flexible search terms./,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "Field/value pairs for AND'ing", type => "object"},
+ {desc => "Field/value pairs for OR'ing", type => "object"},
+ {desc => "Conjunction between AND pairs and OR pairs " .
+ "(can be 'and' or 'or')", type => "string"},
+ {desc => "Retrieval options (clear_marc, flesh_notes, etc) " .
+ "- XXX detail all the options",
+ type => "object"}
+ ],
+ return => {desc => "A stream of LIs on success, Event on failure"}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "unified_search",
+ api_name => "open-ils.acq.purchase_order.unified_search",
+ stream => 1,
+ signature => {
+ desc => q/Returns purchase orders based on flexible search terms.
+ See open-ils.acq.lineitem.unified_search/,
+ return => {desc => "A stream of POs on success, Event on failure"}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "unified_search",
+ api_name => "open-ils.acq.picklist.unified_search",
+ stream => 1,
+ signature => {
+ desc => q/Returns pick lists based on flexible search terms.
+ See open-ils.acq.lineitem.unified_search/,
+ return => {desc => "A stream of PLs on success, Event on failure"}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "unified_search",
+ api_name => "open-ils.acq.invoice.unified_search",
+ stream => 1,
+ signature => {
+ desc => q/Returns invoices lists based on flexible search terms.
+ See open-ils.acq.lineitem.unified_search/,
+ return => {desc => "A stream of invoices on success, Event on failure"}
+ }
+);
+
+sub unified_search {
+ my ($self, $conn, $auth, $and_terms, $or_terms, $conj, $options) = @_;
+ $options ||= {};
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ # What kind of object are we returning? Important: (\w+) had better be
+ # a legit acq classname particle, so don't register any crazy api_names.
+ my $ret_type = ($self->api_name =~ /cq.(\w+).un/)[0];
+ my $retriever = $RETRIEVERS{$ret_type};
+ my $hint = F("acq::$ret_type")->{"hint"};
+
+ my $select_clause = {
+ $hint => [{"column" => "id", "transform" => "distinct"}]
+ };
+
+ if ($options->{"order_by"}) {
+ # What's the point of this block? When using ORDER BY in conjuction
+ # with SELECT DISTINCT, the fields present in ORDER BY have to also
+ # be in the SELECT clause. This will take _one_ such field and add
+ # it to the SELECT clause as needed.
+ my ($order_by, $class, $field);
+ unless (
+ ($order_by = $options->{"order_by"}->[0]) &&
+ ($class = $order_by->{"class"}) =~ /^[\da-z_]+$/ &&
+ ($field = $order_by->{"field"}) =~ /^[\da-z_]+$/
+ ) {
+ $e->disconnect;
+ return new OpenILS::Event(
+ "BAD_PARAMS", "note" =>
+q/order_by clause must be of the long form, like:
+"order_by": [{"class": "foo", "field": "bar", "direction": "asc"}]/
+ );
+ } else {
+ $select_clause->{$class} ||= [];
+ push @{$select_clause->{$class}}, $field;
+ }
+ }
+
+ my $query = {
+ "select" => $select_clause,
+ "from" => {
+ "jub" => {
+ "acqpo" => {
+ "type" => "full",
+ "field" => "id",
+ "fkey" => "purchase_order"
+ },
+ "acqpl" => {
+ "type" => "full",
+ "field" => "id",
+ "fkey" => "picklist"
+ },
+ "acqie" => {
+ "type" => "full",
+ "field" => "lineitem",
+ "fkey" => "id",
+ "join" => {
+ "acqinv" => {
+ "type" => "full",
+ "fkey" => "invoice",
+ "field" => "id"
+ }
+ }
+ }
+ }
+ },
+ "order_by" => ($options->{"order_by"} || {$hint => {"id" => {}}}),
+ "offset" => ($options->{"offset"} || 0)
+ };
+
+ $query->{"limit"} = $options->{"limit"} if $options->{"limit"};
+
+ # XXX for the future? but it doesn't quite work as is.
+# # Remove anything in temporary picklists from search results.
+# $and_terms ||= {};
+# $and_terms->{"acqpl"} ||= [];
+# push @{$and_terms->{"acqpl"}}, {"name" => "", "__not" => 1};
+
+ $and_terms = prepare_terms($and_terms, 1);
+ $or_terms = prepare_terms($or_terms, 0) and do {
+ $query->{"from"}->{"jub"}->{"acqlia"} = {
+ "type" => "left", "field" => "lineitem", "fkey" => "id",
+ };
+ };
+
+ my $offset = add_au_joins($query->{"from"}, prepare_au_terms($and_terms));
+ add_au_joins($query->{"from"}, prepare_au_terms($or_terms, $offset));
+
+ if ($and_terms and $or_terms) {
+ $query->{"where"} = {
+ "-" . (lc $conj eq "or" ? "or" : "and") => [$and_terms, $or_terms]
+ };
+ } elsif ($and_terms) {
+ $query->{"where"} = $and_terms;
+ } elsif ($or_terms) {
+ $query->{"where"} = $or_terms;
+ } else {
+ $e->disconnect;
+ return new OpenILS::Event("BAD_PARAMS", "desc" => "No usable terms");
+ }
+
+ my $results = $e->json_query($query) or return $e->die_event;
+ my @id_list = map { $_->{"id"} } (grep { $_->{"id"} } @$results);
+
+ if ($options->{"id_list"}) {
+ $conn->respond($_) foreach @id_list;
+ } else {
+ $conn->respond($retriever->($e, $_, $options)) foreach @id_list;
+ }
+
+ $e->disconnect;
+ undef;
+}
+
+__PACKAGE__->register_method(
+ method => "bib_search",
+ api_name => "open-ils.acq.biblio.wrapped_search",
+ stream => 1,
+ signature => {
+ desc => q/Returns new lineitems for each matching bib record/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "search string", type => "string"},
+ {desc => "search options", type => "object"}
+ ],
+ return => {desc => "A stream of LIs on success, Event on failure"}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "bib_search",
+ api_name => "open-ils.acq.biblio.create_by_id",
+ stream => 1,
+ signature => {
+ desc => q/Returns new lineitems for each matching bib record/,
+ params => [
+ {desc => "Authentication token", type => "string"},
+ {desc => "list of bib IDs", type => "array"},
+ {desc => "options (for lineitem fleshing)", type => "object"}
+ ],
+ return => {desc => "A stream of LIs on success, Event on failure"}
+ }
+);
+
+# This is very similar to zsearch() in Order.pm
+sub bib_search {
+ my ($self, $conn, $auth, $search, $opts) = @_;
+
+ my $e = new_editor("authtoken" => $auth, "xact" => 1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("CREATE_PICKLIST");
+
+ my $mgr = new OpenILS::Application::Acq::BatchManager(
+ "editor" => $e, "conn" => $conn
+ );
+
+ $opts ||= {};
+
+ my $picklist;
+ my @li_ids = ();
+ if ($self->api_name =~ /create_by_id/) {
+ $search = [ sort @$search ]; # for consitency
+ my $bibs = $e->search_biblio_record_entry(
+ {"id" => $search}, {"order_by" => {"bre" => ["id"]}}
+ ) or return $e->die_event;
+
+ if ($opts->{"reuse_picklist"}) {
+ $picklist = $e->retrieve_acq_picklist($opts->{"reuse_picklist"}) or
+ return $e->die_event;
+ return $e->die_event unless
+ $e->allowed("UPDATE_PICKLIST", $picklist->org_unit);
+
+ # If we're reusing an existing picklist, we don't need to
+ # create new lineitems for any bib records for which we already
+
+ my $already_have = $e->search_acq_lineitem({
+ "picklist" => $picklist->id,
+ "eg_bib_id" => [ map { $_->id } @$bibs ]
+ }) or return $e->die_event;
+
+ # So in that case we a) save the lineitem id's of the relevant
+ # items that already exist so that we can return those items later,
+ # and b) remove the bib id's in question from our list of bib
+ # id's to lineitemize.
+ if (@$already_have) {
+ push @li_ids, $_->id foreach (@$already_have);
+ my @new_bibs = ();
+ foreach my $bib (@$bibs) {
+ push @new_bibs, $bib unless
+ grep { $_->eg_bib_id == $bib->id } @$already_have;
+ }
+ $bibs = [ @new_bibs ];
+ }
+ } else {
+ $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl($mgr, undef)
+ or return $e->die_event;
+ }
+
+ $conn->respond($picklist->id);
+
+ push @li_ids, map {
+ OpenILS::Application::Acq::Order::create_lineitem(
+ $mgr,
+ "picklist" => $picklist->id,
+ "source_label" => "native-evergreen-catalog",
+ "marc" => $_->marc,
+ "eg_bib_id" => $_->id
+ )->id;
+ } (@$bibs);
+ } else {
+ $opts->{"limit"} ||= 10;
+
+ my $ses = create OpenSRF::AppSession("open-ils.search");
+ my $req = $ses->request(
+ "open-ils.search.biblio.multiclass.query.staff", $opts, $search
+ );
+
+ my $count = 0;
+ while (my $resp = $req->recv("timeout" => 60)) {
+ $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl(
+ $mgr, undef
+ ) unless $count++;
+
+ my $result = $resp->content;
+ next if not ref $result;
+
+ # The result object contains a whole heck of a lot more information
+ # than just bib IDs, so maybe we could tell the client something
+ # useful (progress meter at least) in the future...
+ push @li_ids, map {
+ my $bib = $_->[0];
+ OpenILS::Application::Acq::Order::create_lineitem(
+ $mgr,
+ "picklist" => $picklist->id,
+ "source_label" => "native-evergreen-catalog",
+ "marc" => $e->retrieve_biblio_record_entry($bib)->marc,
+ "eg_bib_id" => $bib
+ )->id;
+ } (@{$result->{"ids"}});
+ }
+ $ses->disconnect;
+ }
+
+ $e->commit;
+
+ $logger->info("created @li_ids new lineitems for picklist $picklist");
+
+ # new editor, but still using transaction to ensure correct retrieval
+ # in a replicated setup
+ $e = new_editor("authtoken" => $auth, xact => 1) or return $e->die_event;
+ return $e->die_event unless $e->checkauth;
+ $conn->respond($RETRIEVERS{"lineitem"}->($e, $_, $opts)) foreach @li_ids;
+ $e->rollback;
+ $e->disconnect;
+
+ undef;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Actor;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use Data::Dumper;
+$Data::Dumper::Indent = 0;
+use OpenILS::Event;
+
+use Digest::MD5 qw(md5_hex);
+
+use OpenSRF::EX qw(:try);
+use OpenILS::Perm;
+
+use OpenILS::Application::AppUtils;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::ModsParser;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::SettingsClient;
+
+use OpenSRF::Utils::Cache;
+
+use OpenSRF::Utils::JSON;
+use DateTime;
+use DateTime::Format::ISO8601;
+use OpenILS::Const qw/:const/;
+
+use OpenILS::Application::Actor::Container;
+use OpenILS::Application::Actor::ClosedDates;
+use OpenILS::Application::Actor::UserGroups;
+use OpenILS::Application::Actor::Friends;
+use OpenILS::Application::Actor::Stage;
+
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Utils::Penalty;
+use List::Util qw/max/;
+
+use UUID::Tiny qw/:std/;
+
+sub initialize {
+ OpenILS::Application::Actor::Container->initialize();
+ OpenILS::Application::Actor::UserGroups->initialize();
+ OpenILS::Application::Actor::ClosedDates->initialize();
+}
+
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+
+sub _d { warn "Patron:\n" . Dumper(shift()); }
+
+my $cache;
+my $set_user_settings;
+my $set_ou_settings;
+
+
+#__PACKAGE__->register_method(
+# method => "allowed_test",
+# api_name => "open-ils.actor.allowed_test",
+#);
+#sub allowed_test {
+# my($self, $conn, $auth, $orgid, $permcode) = @_;
+# my $e = new_editor(authtoken => $auth);
+# return $e->die_event unless $e->checkauth;
+#
+# return {
+# orgid => $orgid,
+# permcode => $permcode,
+# result => $e->allowed($permcode, $orgid)
+# };
+#}
+
+__PACKAGE__->register_method(
+ method => "update_user_setting",
+ api_name => "open-ils.actor.patron.settings.update",
+);
+sub update_user_setting {
+ my($self, $conn, $auth, $user_id, $settings) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ $user_id = $e->requestor->id unless defined $user_id;
+
+ unless($e->requestor->id == $user_id) {
+ my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+ }
+
+ for my $name (keys %$settings) {
+ my $val = $$settings{$name};
+ my $set = $e->search_actor_user_setting({usr => $user_id, name => $name})->[0];
+
+ if(defined $val) {
+ $val = OpenSRF::Utils::JSON->perl2JSON($val);
+ if($set) {
+ $set->value($val);
+ $e->update_actor_user_setting($set) or return $e->die_event;
+ } else {
+ $set = Fieldmapper::actor::user_setting->new;
+ $set->usr($user_id);
+ $set->name($name);
+ $set->value($val);
+ $e->create_actor_user_setting($set) or return $e->die_event;
+ }
+ } elsif($set) {
+ $e->delete_actor_user_setting($set) or return $e->die_event;
+ }
+ }
+
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "set_ou_settings",
+ api_name => "open-ils.actor.org_unit.settings.update",
+ signature => {
+ desc => "Updates the value for a given org unit setting. The permission to update " .
+ "an org unit setting is either the UPDATE_ORG_UNIT_SETTING_ALL, or a specific " .
+ "permission specified in the update_perm column of the config.org_unit_setting_type " .
+ "table's row corresponding to the setting being changed." ,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Org unit ID', type => 'number'},
+ {desc => 'Hash of setting name-value pairs', type => 'object'}
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub set_ou_settings {
+ my( $self, $client, $auth, $org_id, $settings ) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $all_allowed = $e->allowed("UPDATE_ORG_UNIT_SETTING_ALL", $org_id);
+
+ for my $name (keys %$settings) {
+ my $val = $$settings{$name};
+
+ my $type = $e->retrieve_config_org_unit_setting_type([
+ $name,
+ {flesh => 1, flesh_fields => {'coust' => ['update_perm']}}
+ ]) or return $e->die_event;
+ my $set = $e->search_actor_org_unit_setting({org_unit => $org_id, name => $name})->[0];
+
+ # If there is no relevant permission, the default assumption will
+ # be, "no, the caller cannot change that value."
+ return $e->die_event unless ($all_allowed ||
+ ($type->update_perm && $e->allowed($type->update_perm->code, $org_id)));
+
+ if(defined $val) {
+ $val = OpenSRF::Utils::JSON->perl2JSON($val);
+ if($set) {
+ $set->value($val);
+ $e->update_actor_org_unit_setting($set) or return $e->die_event;
+ } else {
+ $set = Fieldmapper::actor::org_unit_setting->new;
+ $set->org_unit($org_id);
+ $set->name($name);
+ $set->value($val);
+ $e->create_actor_org_unit_setting($set) or return $e->die_event;
+ }
+ } elsif($set) {
+ $e->delete_actor_org_unit_setting($set) or return $e->die_event;
+ }
+ }
+
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "user_settings",
+ authoritative => 1,
+ api_name => "open-ils.actor.patron.settings.retrieve",
+);
+sub user_settings {
+ my( $self, $client, $auth, $user_id, $setting ) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ $user_id = $e->requestor->id unless defined $user_id;
+
+ my $patron = $e->retrieve_actor_user($user_id) or return $e->event;
+ if($e->requestor->id != $user_id) {
+ return $e->event unless $e->allowed('VIEW_USER', $patron->home_ou);
+ }
+
+ sub get_setting {
+ my($e, $user_id, $setting) = @_;
+ my $val = $e->search_actor_user_setting({usr => $user_id, name => $setting})->[0];
+ return undef unless $val; # XXX this should really return undef, but needs testing
+ return OpenSRF::Utils::JSON->JSON2perl($val->value);
+ }
+
+ if($setting) {
+ if(ref $setting eq 'ARRAY') {
+ my %settings;
+ $settings{$_} = get_setting($e, $user_id, $_) for @$setting;
+ return \%settings;
+ } else {
+ return get_setting($e, $user_id, $setting);
+ }
+ } else {
+ my $s = $e->search_actor_user_setting({usr => $user_id});
+ return { map { ( $_->name => OpenSRF::Utils::JSON->JSON2perl($_->value) ) } @$s };
+ }
+}
+
+
+__PACKAGE__->register_method(
+ method => "ranged_ou_settings",
+ api_name => "open-ils.actor.org_unit_setting.values.ranged.retrieve",
+ signature => {
+ desc => "Retrieves all org unit settings for the given org_id, up to whatever limit " .
+ "is implied for retrieving OU settings by the authenticated users' permissions.",
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Org unit ID', type => 'number'},
+ ],
+ return => {desc => 'A hashref of "ranged" settings, event on error'}
+ }
+);
+sub ranged_ou_settings {
+ my( $self, $client, $auth, $org_id ) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my %ranged_settings;
+ my $org_list = $U->get_org_ancestors($org_id);
+ my $settings = $e->search_actor_org_unit_setting({org_unit => $org_list});
+ $org_list = [ reverse @$org_list ];
+
+ # start at the context org and capture the setting value
+ # without clobbering settings we've already captured
+ for my $this_org_id (@$org_list) {
+
+ my @sets = grep { $_->org_unit == $this_org_id } @$settings;
+
+ for my $set (@sets) {
+ my $type = $e->retrieve_config_org_unit_setting_type([
+ $set->name,
+ {flesh => 1, flesh_fields => {coust => ['view_perm']}}
+ ]);
+
+ # If there is no relevant permission, the default assumption will
+ # be, "yes, the caller can have that value."
+ if ($type && $type->view_perm) {
+ next if not $e->allowed($type->view_perm->code, $org_id);
+ }
+
+ $ranged_settings{$set->name} = OpenSRF::Utils::JSON->JSON2perl($set->value)
+ unless defined $ranged_settings{$set->name};
+ }
+ }
+
+ return \%ranged_settings;
+}
+
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.actor.ou_setting.ancestor_default',
+ method => 'ou_ancestor_setting',
+ signature => {
+ desc => 'Get the org unit setting value associated with the setting name as seen from the specified org unit. ' .
+ 'IF AND ONLY IF an authentication token is provided, this method will make sure that the given ' .
+ 'user has permission to view that setting, if there is a permission associated with the setting.' ,
+ params => [
+ { desc => 'Org unit ID', type => 'number' },
+ { desc => 'setting name', type => 'string' },
+ { desc => 'authtoken (optional)', type => 'string' }
+ ],
+ return => {desc => 'A value for the org unit setting, or undef'}
+ }
+);
+
+# ------------------------------------------------------------------
+# Attempts to find the org setting value for a given org. if not
+# found at the requested org, searches up the org tree until it
+# finds a parent that has the requested setting.
+# when found, returns { org => $id, value => $value }
+# otherwise, returns NULL
+# ------------------------------------------------------------------
+sub ou_ancestor_setting {
+ my( $self, $client, $orgid, $name, $auth ) = @_;
+ return $U->ou_ancestor_setting($orgid, $name, undef, $auth);
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.actor.ou_setting.ancestor_default.batch',
+ method => 'ou_ancestor_setting_batch',
+ signature => {
+ desc => 'Get org unit setting name => value pairs for a list of names, as seen from the specified org unit. ' .
+ 'IF AND ONLY IF an authentication token is provided, this method will make sure that the given ' .
+ 'user has permission to view that setting, if there is a permission associated with the setting.' ,
+ params => [
+ { desc => 'Org unit ID', type => 'number' },
+ { desc => 'setting name list', type => 'array' },
+ { desc => 'authtoken (optional)', type => 'string' }
+ ],
+ return => {desc => 'A hash with name => value pairs for the org unit settings'}
+ }
+);
+sub ou_ancestor_setting_batch {
+ my( $self, $client, $orgid, $name_list, $auth ) = @_;
+ my %values;
+ $values{$_} = $U->ou_ancestor_setting($orgid, $_, undef, $auth) for @$name_list;
+ return \%values;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "update_patron",
+ api_name => "open-ils.actor.patron.update",
+ signature => {
+ desc => q/
+ Update an existing user, or create a new one. Related objects,
+ like cards, addresses, survey responses, and stat cats,
+ can be updated by attaching them to the user object in their
+ respective fields. For examples, the billing address object
+ may be inserted into the 'billing_address' field, etc. For each
+ attached object, indicate if the object should be created,
+ updated, or deleted using the built-in 'isnew', 'ischanged',
+ and 'isdeleted' fields on the object.
+ /,
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Patron data object', type => 'object' }
+ ],
+ return => {desc => 'A fleshed user object, event on error'}
+ }
+);
+
+sub update_patron {
+ my( $self, $client, $user_session, $patron ) = @_;
+
+ my $session = $apputils->start_db_session();
+
+ $logger->info($patron->isnew ? "Creating new patron..." : "Updating Patron: " . $patron->id);
+
+ my( $user_obj, $evt ) = $U->checkses($user_session);
+ return $evt if $evt;
+
+ $evt = check_group_perm($session, $user_obj, $patron);
+ return $evt if $evt;
+
+
+ # $new_patron is the patron in progress. $patron is the original patron
+ # passed in with the method. new_patron will change as the components
+ # of patron are added/updated.
+
+ my $new_patron;
+
+ # unflesh the real items on the patron
+ $patron->card( $patron->card->id ) if(ref($patron->card));
+ $patron->billing_address( $patron->billing_address->id )
+ if(ref($patron->billing_address));
+ $patron->mailing_address( $patron->mailing_address->id )
+ if(ref($patron->mailing_address));
+
+ # create/update the patron first so we can use his id
+ if($patron->isnew()) {
+ ( $new_patron, $evt ) = _add_patron($session, _clone_patron($patron), $user_obj);
+ return $evt if $evt;
+ } else { $new_patron = $patron; }
+
+ ( $new_patron, $evt ) = _add_update_addresses($session, $patron, $new_patron, $user_obj);
+ return $evt if $evt;
+
+ ( $new_patron, $evt ) = _add_update_cards($session, $patron, $new_patron, $user_obj);
+ return $evt if $evt;
+
+ ( $new_patron, $evt ) = _add_survey_responses($session, $patron, $new_patron, $user_obj);
+ return $evt if $evt;
+
+ # re-update the patron if anything has happened to him during this process
+ if($new_patron->ischanged()) {
+ ( $new_patron, $evt ) = _update_patron($session, $new_patron, $user_obj);
+ return $evt if $evt;
+ }
+
+ ($new_patron, $evt) = _create_stat_maps($session, $user_session, $patron, $new_patron, $user_obj);
+ return $evt if $evt;
+
+ ($new_patron, $evt) = _create_perm_maps($session, $user_session, $patron, $new_patron, $user_obj);
+ return $evt if $evt;
+
+ $apputils->commit_db_session($session);
+
+ $evt = apply_invalid_addr_penalty($patron);
+ return $evt if $evt;
+
+ my $tses = OpenSRF::AppSession->create('open-ils.trigger');
+ if($patron->isnew) {
+ $tses->request('open-ils.trigger.event.autocreate', 'au.create', $new_patron, $new_patron->home_ou);
+ } else {
+ $tses->request('open-ils.trigger.event.autocreate', 'au.update', $new_patron, $new_patron->home_ou);
+ }
+
+ return flesh_user($new_patron->id(), new_editor(requestor => $user_obj, xact => 1));
+}
+
+sub apply_invalid_addr_penalty {
+ my $patron = shift;
+ my $e = new_editor(xact => 1);
+
+ # grab the invalid address penalty if set
+ my $penalties = OpenILS::Utils::Penalty->retrieve_usr_penalties($e, $patron->id, $patron->home_ou);
+
+ my ($addr_penalty) = grep
+ { $_->standing_penalty->name eq 'INVALID_PATRON_ADDRESS' } @$penalties;
+
+ # do we enforce invalid address penalty
+ my $enforce = $U->ou_ancestor_setting_value(
+ $patron->home_ou, 'circ.patron_invalid_address_apply_penalty') || 0;
+
+ my $addrs = $e->search_actor_user_address(
+ {usr => $patron->id, valid => 'f', id => {'>' => 0}}, {idlist => 1});
+ my $addr_count = scalar(@$addrs);
+
+ if($addr_count == 0 and $addr_penalty) {
+
+ # regardless of any settings, remove the penalty when the user has no invalid addresses
+ $e->delete_actor_user_standing_penalty($addr_penalty) or return $e->die_event;
+ $e->commit;
+
+ } elsif($enforce and $addr_count > 0 and !$addr_penalty) {
+
+ my $ptype = $e->retrieve_config_standing_penalty(29) or return $e->die_event;
+ my $depth = $ptype->org_depth;
+ my $ctx_org = $U->org_unit_ancestor_at_depth($patron->home_ou, $depth) if defined $depth;
+ $ctx_org = $patron->home_ou unless defined $ctx_org;
+
+ my $penalty = Fieldmapper::actor::user_standing_penalty->new;
+ $penalty->usr($patron->id);
+ $penalty->org_unit($ctx_org);
+ $penalty->standing_penalty(OILS_PENALTY_INVALID_PATRON_ADDRESS);
+
+ $e->create_actor_user_standing_penalty($penalty) or return $e->die_event;
+ $e->commit;
+
+ } else {
+ $e->rollback;
+ }
+
+ return undef;
+}
+
+
+sub flesh_user {
+ my $id = shift;
+ my $e = shift;
+ my $home_ou = shift;
+
+ my $fields = [
+ "cards",
+ "card",
+ "standing_penalties",
+ "addresses",
+ "billing_address",
+ "mailing_address",
+ "stat_cat_entries"
+ ];
+ push @$fields, "home_ou" if $home_ou;
+ return new_flesh_user($id, $fields, $e );
+}
+
+
+
+
+
+
+# clone and clear stuff that would break the database
+sub _clone_patron {
+ my $patron = shift;
+
+ my $new_patron = $patron->clone;
+ # clear these
+ $new_patron->clear_billing_address();
+ $new_patron->clear_mailing_address();
+ $new_patron->clear_addresses();
+ $new_patron->clear_card();
+ $new_patron->clear_cards();
+ $new_patron->clear_id();
+ $new_patron->clear_isnew();
+ $new_patron->clear_ischanged();
+ $new_patron->clear_isdeleted();
+ $new_patron->clear_stat_cat_entries();
+ $new_patron->clear_permissions();
+ $new_patron->clear_standing_penalties();
+
+ return $new_patron;
+}
+
+
+sub _add_patron {
+
+ my $session = shift;
+ my $patron = shift;
+ my $user_obj = shift;
+
+ my $evt = $U->check_perms($user_obj->id, $patron->home_ou, 'CREATE_USER');
+ return (undef, $evt) if $evt;
+
+ my $ex = $session->request(
+ 'open-ils.storage.direct.actor.user.search.usrname', $patron->usrname())->gather(1);
+ if( $ex and @$ex ) {
+ return (undef, OpenILS::Event->new('USERNAME_EXISTS'));
+ }
+
+ $logger->info("Creating new user in the DB with username: ".$patron->usrname());
+
+ my $id = $session->request(
+ "open-ils.storage.direct.actor.user.create", $patron)->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($patron)) unless $id;
+
+ $logger->info("Successfully created new user [$id] in DB");
+
+ return ( $session->request(
+ "open-ils.storage.direct.actor.user.retrieve", $id)->gather(1), undef );
+}
+
+
+sub check_group_perm {
+ my( $session, $requestor, $patron ) = @_;
+ my $evt;
+
+ # first let's see if the requestor has
+ # priveleges to update this user in any way
+ if( ! $patron->isnew ) {
+ my $p = $session->request(
+ 'open-ils.storage.direct.actor.user.retrieve', $patron->id )->gather(1);
+
+ # If we are the requestor (trying to update our own account)
+ # and we are not trying to change our profile, we're good
+ if( $p->id == $requestor->id and
+ $p->profile == $patron->profile ) {
+ return undef;
+ }
+
+
+ $evt = group_perm_failed($session, $requestor, $p);
+ return $evt if $evt;
+ }
+
+ # They are allowed to edit this patron.. can they put the
+ # patron into the group requested?
+ $evt = group_perm_failed($session, $requestor, $patron);
+ return $evt if $evt;
+ return undef;
+}
+
+
+sub group_perm_failed {
+ my( $session, $requestor, $patron ) = @_;
+
+ my $perm;
+ my $grp;
+ my $grpid = $patron->profile;
+
+ do {
+
+ $logger->debug("user update looking for group perm for group $grpid");
+ $grp = $session->request(
+ 'open-ils.storage.direct.permission.grp_tree.retrieve', $grpid )->gather(1);
+ return OpenILS::Event->new('PERMISSION_GRP_TREE_NOT_FOUND') unless $grp;
+
+ } while( !($perm = $grp->application_perm) and ($grpid = $grp->parent) );
+
+ $logger->info("user update checking perm $perm on user ".
+ $requestor->id." for update/create on user username=".$patron->usrname);
+
+ my $evt = $U->check_perms($requestor->id, $patron->home_ou, $perm);
+ return $evt if $evt;
+ return undef;
+}
+
+
+
+sub _update_patron {
+ my( $session, $patron, $user_obj, $noperm) = @_;
+
+ $logger->info("Updating patron ".$patron->id." in DB");
+
+ my $evt;
+
+ if(!$noperm) {
+ $evt = $U->check_perms($user_obj->id, $patron->home_ou, 'UPDATE_USER');
+ return (undef, $evt) if $evt;
+ }
+
+ # update the password by itself to avoid the password protection magic
+ if( $patron->passwd ) {
+ my $s = $session->request(
+ 'open-ils.storage.direct.actor.user.remote_update',
+ {id => $patron->id}, {passwd => $patron->passwd})->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($patron)) unless defined($s);
+ $patron->clear_passwd;
+ }
+
+ if(!$patron->ident_type) {
+ $patron->clear_ident_type;
+ $patron->clear_ident_value;
+ }
+
+ $evt = verify_last_xact($session, $patron);
+ return (undef, $evt) if $evt;
+
+ my $stat = $session->request(
+ "open-ils.storage.direct.actor.user.update",$patron )->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($patron)) unless defined($stat);
+
+ return ($patron);
+}
+
+sub verify_last_xact {
+ my( $session, $patron ) = @_;
+ return undef unless $patron->id and $patron->id > 0;
+ my $p = $session->request(
+ 'open-ils.storage.direct.actor.user.retrieve', $patron->id)->gather(1);
+ my $xact = $p->last_xact_id;
+ return undef unless $xact;
+ $logger->info("user xact = $xact, saving with xact " . $patron->last_xact_id);
+ return OpenILS::Event->new('XACT_COLLISION')
+ if $xact != $patron->last_xact_id;
+ return undef;
+}
+
+
+sub _check_dup_ident {
+ my( $session, $patron ) = @_;
+
+ return undef unless $patron->ident_value;
+
+ my $search = {
+ ident_type => $patron->ident_type,
+ ident_value => $patron->ident_value,
+ };
+
+ $logger->debug("patron update searching for dup ident values: " .
+ $patron->ident_type . ':' . $patron->ident_value);
+
+ $search->{id} = {'!=' => $patron->id} if $patron->id and $patron->id > 0;
+
+ my $dups = $session->request(
+ 'open-ils.storage.direct.actor.user.search_where.atomic', $search )->gather(1);
+
+
+ return OpenILS::Event->new('PATRON_DUP_IDENT1', payload => $patron )
+ if $dups and @$dups;
+
+ return undef;
+}
+
+
+sub _add_update_addresses {
+
+ my $session = shift;
+ my $patron = shift;
+ my $new_patron = shift;
+
+ my $evt;
+
+ my $current_id; # id of the address before creation
+
+ for my $address (@{$patron->addresses()}) {
+
+ next unless ref $address;
+ $current_id = $address->id();
+
+ if( $patron->billing_address() and
+ $patron->billing_address() == $current_id ) {
+ $logger->info("setting billing addr to $current_id");
+ $new_patron->billing_address($address->id());
+ $new_patron->ischanged(1);
+ }
+
+ if( $patron->mailing_address() and
+ $patron->mailing_address() == $current_id ) {
+ $new_patron->mailing_address($address->id());
+ $logger->info("setting mailing addr to $current_id");
+ $new_patron->ischanged(1);
+ }
+
+
+ if($address->isnew()) {
+
+ $address->usr($new_patron->id());
+
+ ($address, $evt) = _add_address($session,$address);
+ return (undef, $evt) if $evt;
+
+ # we need to get the new id
+ if( $patron->billing_address() and
+ $patron->billing_address() == $current_id ) {
+ $new_patron->billing_address($address->id());
+ $logger->info("setting billing addr to $current_id");
+ $new_patron->ischanged(1);
+ }
+
+ if( $patron->mailing_address() and
+ $patron->mailing_address() == $current_id ) {
+ $new_patron->mailing_address($address->id());
+ $logger->info("setting mailing addr to $current_id");
+ $new_patron->ischanged(1);
+ }
+
+ } elsif($address->ischanged() ) {
+
+ ($address, $evt) = _update_address($session, $address);
+ return (undef, $evt) if $evt;
+
+ } elsif($address->isdeleted() ) {
+
+ if( $address->id() == $new_patron->mailing_address() ) {
+ $new_patron->clear_mailing_address();
+ ($new_patron, $evt) = _update_patron($session, $new_patron);
+ return (undef, $evt) if $evt;
+ }
+
+ if( $address->id() == $new_patron->billing_address() ) {
+ $new_patron->clear_billing_address();
+ ($new_patron, $evt) = _update_patron($session, $new_patron);
+ return (undef, $evt) if $evt;
+ }
+
+ $evt = _delete_address($session, $address);
+ return (undef, $evt) if $evt;
+ }
+ }
+
+ return ( $new_patron, undef );
+}
+
+
+# adds an address to the db and returns the address with new id
+sub _add_address {
+ my($session, $address) = @_;
+ $address->clear_id();
+
+ $logger->info("Creating new address at street ".$address->street1);
+
+ # put the address into the database
+ my $id = $session->request(
+ "open-ils.storage.direct.actor.user_address.create", $address )->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($address)) unless $id;
+
+ $address->id( $id );
+ return ($address, undef);
+}
+
+
+sub _update_address {
+ my( $session, $address ) = @_;
+
+ $logger->info("Updating address ".$address->id." in the DB");
+
+ my $stat = $session->request(
+ "open-ils.storage.direct.actor.user_address.update", $address )->gather(1);
+
+ return (undef, $U->DB_UPDATE_FAILED($address)) unless defined($stat);
+ return ($address, undef);
+}
+
+
+
+sub _add_update_cards {
+
+ my $session = shift;
+ my $patron = shift;
+ my $new_patron = shift;
+
+ my $evt;
+
+ my $virtual_id; #id of the card before creation
+ for my $card (@{$patron->cards()}) {
+
+ $card->usr($new_patron->id());
+
+ if(ref($card) and $card->isnew()) {
+
+ $virtual_id = $card->id();
+ ( $card, $evt ) = _add_card($session,$card);
+ return (undef, $evt) if $evt;
+
+ #if(ref($patron->card)) { $patron->card($patron->card->id); }
+ if($patron->card() == $virtual_id) {
+ $new_patron->card($card->id());
+ $new_patron->ischanged(1);
+ }
+
+ } elsif( ref($card) and $card->ischanged() ) {
+ $evt = _update_card($session, $card);
+ return (undef, $evt) if $evt;
+ }
+ }
+
+ return ( $new_patron, undef );
+}
+
+
+# adds an card to the db and returns the card with new id
+sub _add_card {
+ my( $session, $card ) = @_;
+ $card->clear_id();
+
+ $logger->info("Adding new patron card ".$card->barcode);
+
+ my $id = $session->request(
+ "open-ils.storage.direct.actor.card.create", $card )->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($card)) unless $id;
+ $logger->info("Successfully created patron card $id");
+
+ $card->id($id);
+ return ( $card, undef );
+}
+
+
+# returns event on error. returns undef otherwise
+sub _update_card {
+ my( $session, $card ) = @_;
+ $logger->info("Updating patron card ".$card->id);
+
+ my $stat = $session->request(
+ "open-ils.storage.direct.actor.card.update", $card )->gather(1);
+ return $U->DB_UPDATE_FAILED($card) unless defined($stat);
+ return undef;
+}
+
+
+
+
+# returns event on error. returns undef otherwise
+sub _delete_address {
+ my( $session, $address ) = @_;
+
+ $logger->info("Deleting address ".$address->id." from DB");
+
+ my $stat = $session->request(
+ "open-ils.storage.direct.actor.user_address.delete", $address )->gather(1);
+
+ return $U->DB_UPDATE_FAILED($address) unless defined($stat);
+ return undef;
+}
+
+
+
+sub _add_survey_responses {
+ my ($session, $patron, $new_patron) = @_;
+
+ $logger->info( "Updating survey responses for patron ".$new_patron->id );
+
+ my $responses = $patron->survey_responses;
+
+ if($responses) {
+
+ $_->usr($new_patron->id) for (@$responses);
+
+ my $evt = $U->simplereq( "open-ils.circ",
+ "open-ils.circ.survey.submit.user_id", $responses );
+
+ return (undef, $evt) if defined($U->event_code($evt));
+
+ }
+
+ return ( $new_patron, undef );
+}
+
+
+sub _create_stat_maps {
+
+ my($session, $user_session, $patron, $new_patron) = @_;
+
+ my $maps = $patron->stat_cat_entries();
+
+ for my $map (@$maps) {
+
+ my $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.update";
+
+ if ($map->isdeleted()) {
+ $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.delete";
+
+ } elsif ($map->isnew()) {
+ $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.create";
+ $map->clear_id;
+ }
+
+
+ $map->target_usr($new_patron->id);
+
+ #warn "
+ $logger->info("Updating stat entry with method $method and map $map");
+
+ my $stat = $session->request($method, $map)->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($map)) unless defined($stat);
+
+ }
+
+ return ($new_patron, undef);
+}
+
+sub _create_perm_maps {
+
+ my($session, $user_session, $patron, $new_patron) = @_;
+
+ my $maps = $patron->permissions;
+
+ for my $map (@$maps) {
+
+ my $method = "open-ils.storage.direct.permission.usr_perm_map.update";
+ if ($map->isdeleted()) {
+ $method = "open-ils.storage.direct.permission.usr_perm_map.delete";
+ } elsif ($map->isnew()) {
+ $method = "open-ils.storage.direct.permission.usr_perm_map.create";
+ $map->clear_id;
+ }
+
+
+ $map->usr($new_patron->id);
+
+ #warn( "Updating permissions with method $method and session $user_session and map $map" );
+ $logger->info( "Updating permissions with method $method and map $map" );
+
+ my $stat = $session->request($method, $map)->gather(1);
+ return (undef, $U->DB_UPDATE_FAILED($map)) unless defined($stat);
+
+ }
+
+ return ($new_patron, undef);
+}
+
+
+__PACKAGE__->register_method(
+ method => "set_user_work_ous",
+ api_name => "open-ils.actor.user.work_ous.update",
+);
+
+sub set_user_work_ous {
+ my $self = shift;
+ my $client = shift;
+ my $ses = shift;
+ my $maps = shift;
+
+ my( $requestor, $evt ) = $apputils->checksesperm( $ses, 'ASSIGN_WORK_ORG_UNIT' );
+ return $evt if $evt;
+
+ my $session = $apputils->start_db_session();
+
+ for my $map (@$maps) {
+
+ my $method = "open-ils.storage.direct.permission.usr_work_ou_map.update";
+ if ($map->isdeleted()) {
+ $method = "open-ils.storage.direct.permission.usr_work_ou_map.delete";
+ } elsif ($map->isnew()) {
+ $method = "open-ils.storage.direct.permission.usr_work_ou_map.create";
+ $map->clear_id;
+ }
+
+ #warn( "Updating permissions with method $method and session $ses and map $map" );
+ $logger->info( "Updating work_ou map with method $method and map $map" );
+
+ my $stat = $session->request($method, $map)->gather(1);
+ $logger->warn( "update failed: ".$U->DB_UPDATE_FAILED($map) ) unless defined($stat);
+
+ }
+
+ $apputils->commit_db_session($session);
+
+ return scalar(@$maps);
+}
+
+
+__PACKAGE__->register_method(
+ method => "set_user_perms",
+ api_name => "open-ils.actor.user.permissions.update",
+);
+
+sub set_user_perms {
+ my $self = shift;
+ my $client = shift;
+ my $ses = shift;
+ my $maps = shift;
+
+ my $session = $apputils->start_db_session();
+
+ my( $user_obj, $evt ) = $U->checkses($ses);
+ return $evt if $evt;
+
+ my $perms = $session->request('open-ils.storage.permission.user_perms.atomic', $user_obj->id)->gather(1);
+
+ my $all = undef;
+ $all = 1 if ($U->is_true($user_obj->super_user()));
+ $all = 1 unless ($U->check_perms($user_obj->id, $user_obj->home_ou, 'EVERYTHING'));
+
+ for my $map (@$maps) {
+
+ my $method = "open-ils.storage.direct.permission.usr_perm_map.update";
+ if ($map->isdeleted()) {
+ $method = "open-ils.storage.direct.permission.usr_perm_map.delete";
+ } elsif ($map->isnew()) {
+ $method = "open-ils.storage.direct.permission.usr_perm_map.create";
+ $map->clear_id;
+ }
+
+ next if (!$all and !grep { $_->perm eq $map->perm and $U->is_true($_->grantable) and $_->depth <= $map->depth } @$perms);
+ #warn( "Updating permissions with method $method and session $ses and map $map" );
+ $logger->info( "Updating permissions with method $method and map $map" );
+
+ my $stat = $session->request($method, $map)->gather(1);
+ $logger->warn( "update failed: ".$U->DB_UPDATE_FAILED($map) ) unless defined($stat);
+
+ }
+
+ $apputils->commit_db_session($session);
+
+ return scalar(@$maps);
+}
+
+
+__PACKAGE__->register_method(
+ method => "user_retrieve_by_barcode",
+ authoritative => 1,
+ api_name => "open-ils.actor.user.fleshed.retrieve_by_barcode",);
+
+sub user_retrieve_by_barcode {
+ my($self, $client, $auth, $barcode, $flesh_home_ou) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $card = $e->search_actor_card({barcode => $barcode})->[0]
+ or return $e->event;
+
+ my $user = flesh_user($card->usr, $e, $flesh_home_ou);
+ return $e->event unless $e->allowed(
+ "VIEW_USER", $flesh_home_ou ? $user->home_ou->id : $user->home_ou
+ );
+ return $user;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "get_user_by_id",
+ authoritative => 1,
+ api_name => "open-ils.actor.user.retrieve",
+);
+
+sub get_user_by_id {
+ my ($self, $client, $auth, $id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $user = $e->retrieve_actor_user($id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ return $user;
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_org_types",
+ api_name => "open-ils.actor.org_types.retrieve",
+);
+sub get_org_types {
+ return $U->get_org_types();
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_user_ident_types",
+ api_name => "open-ils.actor.user.ident_types.retrieve",
+);
+my $ident_types;
+sub get_user_ident_types {
+ return $ident_types if $ident_types;
+ return $ident_types =
+ new_editor()->retrieve_all_config_identification_type();
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_org_unit",
+ api_name => "open-ils.actor.org_unit.retrieve",
+);
+
+sub get_org_unit {
+ my( $self, $client, $user_session, $org_id ) = @_;
+ my $e = new_editor(authtoken => $user_session);
+ if(!$org_id) {
+ return $e->event unless $e->checkauth;
+ $org_id = $e->requestor->ws_ou;
+ }
+ my $o = $e->retrieve_actor_org_unit($org_id)
+ or return $e->event;
+ return $o;
+}
+
+__PACKAGE__->register_method(
+ method => "search_org_unit",
+ api_name => "open-ils.actor.org_unit_list.search",
+);
+
+sub search_org_unit {
+
+ my( $self, $client, $field, $value ) = @_;
+
+ my $list = OpenILS::Application::AppUtils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.actor.org_unit.search.atomic",
+ { $field => $value } );
+
+ return $list;
+}
+
+
+# build the org tree
+
+__PACKAGE__->register_method(
+ method => "get_org_tree",
+ api_name => "open-ils.actor.org_tree.retrieve",
+ argc => 0,
+ note => "Returns the entire org tree structure",
+);
+
+sub get_org_tree {
+ my $self = shift;
+ my $client = shift;
+ return $U->get_org_tree($client->session->session_locale);
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_org_descendants",
+ api_name => "open-ils.actor.org_tree.descendants.retrieve"
+);
+
+# depth is optional. org_unit is the id
+sub get_org_descendants {
+ my( $self, $client, $org_unit, $depth ) = @_;
+
+ if(ref $org_unit eq 'ARRAY') {
+ $depth ||= [];
+ my @trees;
+ for my $i (0..scalar(@$org_unit)-1) {
+ my $list = $U->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.actor.org_unit.descendants.atomic",
+ $org_unit->[$i], $depth->[$i] );
+ push(@trees, $U->build_org_tree($list));
+ }
+ return \@trees;
+
+ } else {
+ my $orglist = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.actor.org_unit.descendants.atomic",
+ $org_unit, $depth );
+ return $U->build_org_tree($orglist);
+ }
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_org_ancestors",
+ api_name => "open-ils.actor.org_tree.ancestors.retrieve"
+);
+
+# depth is optional. org_unit is the id
+sub get_org_ancestors {
+ my( $self, $client, $org_unit, $depth ) = @_;
+ my $orglist = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.actor.org_unit.ancestors.atomic",
+ $org_unit, $depth );
+ return $U->build_org_tree($orglist);
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_standings",
+ api_name => "open-ils.actor.standings.retrieve"
+);
+
+my $user_standings;
+sub get_standings {
+ return $user_standings if $user_standings;
+ return $user_standings =
+ $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.config.standing.search.atomic",
+ { id => { "!=" => undef } }
+ );
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_my_org_path",
+ api_name => "open-ils.actor.org_unit.full_path.retrieve"
+);
+
+sub get_my_org_path {
+ my( $self, $client, $auth, $org_id ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $org_id = $e->requestor->ws_ou unless defined $org_id;
+
+ return $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.actor.org_unit.full_path.atomic",
+ $org_id );
+}
+
+
+__PACKAGE__->register_method(
+ method => "patron_adv_search",
+ api_name => "open-ils.actor.patron.search.advanced"
+);
+sub patron_adv_search {
+ my( $self, $client, $auth, $search_hash,
+ $search_limit, $search_sort, $include_inactive, $search_depth ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER');
+ return $U->storagereq(
+ "open-ils.storage.actor.user.crazy_search", $search_hash,
+ $search_limit, $search_sort, $include_inactive, $e->requestor->ws_ou, $search_depth);
+}
+
+
+__PACKAGE__->register_method(
+ method => "update_passwd",
+ api_name => "open-ils.actor.user.password.update",
+ signature => {
+ desc => "Update the operator's password",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'New password', type => 'string' },
+ { desc => 'Current password', type => 'string' }
+ ],
+ return => {desc => '1 on success, Event on error or incorrect current password'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "update_passwd",
+ api_name => "open-ils.actor.user.username.update",
+ signature => {
+ desc => "Update the operator's username",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'New username', type => 'string' }
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "update_passwd",
+ api_name => "open-ils.actor.user.email.update",
+ signature => {
+ desc => "Update the operator's email address",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'New email address', type => 'string' }
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+
+sub update_passwd {
+ my( $self, $conn, $auth, $new_val, $orig_pw ) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $db_user = $e->retrieve_actor_user($e->requestor->id)
+ or return $e->die_event;
+ my $api = $self->api_name;
+
+ if( $api =~ /password/o ) {
+ # make sure the original password matches the in-database password
+ if (md5_hex($orig_pw) ne $db_user->passwd) {
+ $e->rollback;
+ return new OpenILS::Event('INCORRECT_PASSWORD');
+ }
+ $db_user->passwd($new_val);
+
+ } else {
+
+ # if we don't clear the password, the user will be updated with
+ # a hashed version of the hashed version of their password
+ $db_user->clear_passwd;
+
+ if( $api =~ /username/o ) {
+
+ # make sure no one else has this username
+ my $exist = $e->search_actor_user({usrname=>$new_val},{idlist=>1});
+ if (@$exist) {
+ $e->rollback;
+ return new OpenILS::Event('USERNAME_EXISTS');
+ }
+ $db_user->usrname($new_val);
+
+ } elsif( $api =~ /email/o ) {
+ $db_user->email($new_val);
+ }
+ }
+
+ $e->update_actor_user($db_user) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "check_user_perms",
+ api_name => "open-ils.actor.user.perm.check",
+ notes => <<" NOTES");
+ Takes a login session, user id, an org id, and an array of perm type strings. For each
+ perm type, if the user does *not* have the given permission it is added
+ to a list which is returned from the method. If all permissions
+ are allowed, an empty list is returned
+ if the logged in user does not match 'user_id', then the logged in user must
+ have VIEW_PERMISSION priveleges.
+ NOTES
+
+sub check_user_perms {
+ my( $self, $client, $login_session, $user_id, $org_id, $perm_types ) = @_;
+
+ my( $staff, $evt ) = $apputils->checkses($login_session);
+ return $evt if $evt;
+
+ if($staff->id ne $user_id) {
+ if( $evt = $apputils->check_perms(
+ $staff->id, $org_id, 'VIEW_PERMISSION') ) {
+ return $evt;
+ }
+ }
+
+ my @not_allowed;
+ for my $perm (@$perm_types) {
+ if($apputils->check_perms($user_id, $org_id, $perm)) {
+ push @not_allowed, $perm;
+ }
+ }
+
+ return \@not_allowed
+}
+
+__PACKAGE__->register_method(
+ method => "check_user_perms2",
+ api_name => "open-ils.actor.user.perm.check.multi_org",
+ notes => q/
+ Checks the permissions on a list of perms and orgs for a user
+ @param authtoken The login session key
+ @param user_id The id of the user to check
+ @param orgs The array of org ids
+ @param perms The array of permission names
+ @return An array of [ orgId, permissionName ] arrays that FAILED the check
+ if the logged in user does not match 'user_id', then the logged in user must
+ have VIEW_PERMISSION priveleges.
+ /);
+
+sub check_user_perms2 {
+ my( $self, $client, $authtoken, $user_id, $orgs, $perms ) = @_;
+
+ my( $staff, $target, $evt ) = $apputils->checkses_requestor(
+ $authtoken, $user_id, 'VIEW_PERMISSION' );
+ return $evt if $evt;
+
+ my @not_allowed;
+ for my $org (@$orgs) {
+ for my $perm (@$perms) {
+ if($apputils->check_perms($user_id, $org, $perm)) {
+ push @not_allowed, [ $org, $perm ];
+ }
+ }
+ }
+
+ return \@not_allowed
+}
+
+
+__PACKAGE__->register_method(
+ method => 'check_user_perms3',
+ api_name => 'open-ils.actor.user.perm.highest_org',
+ notes => q/
+ Returns the highest org unit id at which a user has a given permission
+ If the requestor does not match the target user, the requestor must have
+ 'VIEW_PERMISSION' rights at the home org unit of the target user
+ @param authtoken The login session key
+ @param userid The id of the user in question
+ @param perm The permission to check
+ @return The org unit highest in the org tree within which the user has
+ the requested permission
+ /);
+
+sub check_user_perms3 {
+ my($self, $client, $authtoken, $user_id, $perm) = @_;
+ my $e = new_editor(authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ my $tree = $U->get_org_tree();
+
+ unless($e->requestor->id == $user_id) {
+ my $user = $e->retrieve_actor_user($user_id)
+ or return $e->event;
+ return $e->event unless $e->allowed('VIEW_PERMISSION', $user->home_ou);
+ return $U->find_highest_perm_org($perm, $user_id, $user->home_ou, $tree );
+ }
+
+ return $U->find_highest_perm_org($perm, $user_id, $e->requestor->ws_ou, $tree);
+}
+
+__PACKAGE__->register_method(
+ method => 'user_has_work_perm_at',
+ api_name => 'open-ils.actor.user.has_work_perm_at',
+ authoritative => 1,
+ signature => {
+ desc => q/
+ Returns a set of org unit IDs which represent the highest orgs in
+ the org tree where the user has the requested permission. The
+ purpose of this method is to return the smallest set of org units
+ which represent the full expanse of the user's ability to perform
+ the requested action. The user whose perms this method should
+ check is implied by the authtoken. /,
+ params => [
+ {desc => 'authtoken', type => 'string'},
+ {desc => 'permission name', type => 'string'},
+ {desc => q/user id, optional. If present, check perms for
+ this user instead of the logged in user/, type => 'number'},
+ ],
+ return => {desc => 'An array of org IDs'}
+ }
+);
+
+sub user_has_work_perm_at {
+ my($self, $conn, $auth, $perm, $user_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ if(defined $user_id) {
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_PERMISSION', $user->home_ou);
+ }
+ return $U->user_has_work_perm_at($e, $perm, undef, $user_id);
+}
+
+__PACKAGE__->register_method(
+ method => 'user_has_work_perm_at_batch',
+ api_name => 'open-ils.actor.user.has_work_perm_at.batch',
+ authoritative => 1,
+);
+
+sub user_has_work_perm_at_batch {
+ my($self, $conn, $auth, $perms, $user_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ if(defined $user_id) {
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_PERMISSION', $user->home_ou);
+ }
+ my $map = {};
+ $map->{$_} = $U->user_has_work_perm_at($e, $_) for @$perms;
+ return $map;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'check_user_perms4',
+ api_name => 'open-ils.actor.user.perm.highest_org.batch',
+ notes => q/
+ Returns the highest org unit id at which a user has a given permission
+ If the requestor does not match the target user, the requestor must have
+ 'VIEW_PERMISSION' rights at the home org unit of the target user
+ @param authtoken The login session key
+ @param userid The id of the user in question
+ @param perms An array of perm names to check
+ @return An array of orgId's representing the org unit
+ highest in the org tree within which the user has the requested permission
+ The arrah of orgId's has matches the order of the perms array
+ /);
+
+sub check_user_perms4 {
+ my( $self, $client, $authtoken, $userid, $perms ) = @_;
+
+ my( $staff, $target, $org, $evt );
+
+ ( $staff, $target, $evt ) = $apputils->checkses_requestor(
+ $authtoken, $userid, 'VIEW_PERMISSION' );
+ return $evt if $evt;
+
+ my @arr;
+ return [] unless ref($perms);
+ my $tree = $U->get_org_tree();
+
+ for my $p (@$perms) {
+ push( @arr, $U->find_highest_perm_org( $p, $userid, $target->home_ou, $tree ) );
+ }
+ return \@arr;
+}
+
+
+__PACKAGE__->register_method(
+ method => "user_fines_summary",
+ api_name => "open-ils.actor.user.fines.summary",
+ authoritative => 1,
+ signature => {
+ desc => 'Returns a short summary of the users total open fines, ' .
+ 'excluding voided fines Params are login_session, user_id' ,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'User ID', type => 'string'} # number?
+ ],
+ return => {
+ desc => "a 'mous' object, event on error",
+ }
+ }
+);
+
+sub user_fines_summary {
+ my( $self, $client, $auth, $user_id ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ if( $user_id ne $e->requestor->id ) {
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless
+ $e->allowed('VIEW_USER_FINES_SUMMARY', $user->home_ou);
+ }
+
+ return $e->search_money_open_user_summary({usr => $user_id})->[0];
+}
+
+
+__PACKAGE__->register_method(
+ method => "user_opac_vitals",
+ api_name => "open-ils.actor.user.opac.vital_stats",
+ argc => 1,
+ authoritative => 1,
+ signature => {
+ desc => 'Returns a short summary of the users vital stats, including ' .
+ 'identification information, accumulated balance, number of holds, ' .
+ 'and current open circulation stats' ,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Optional User ID, for use in the staff client', type => 'number'} # number?
+ ],
+ return => {
+ desc => "An object with four properties: user, fines, checkouts and holds."
+ }
+ }
+);
+
+sub user_opac_vitals {
+ my( $self, $client, $auth, $user_id ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ $user_id ||= $e->requestor->id;
+
+ my $user = $e->retrieve_actor_user( $user_id );
+
+ my ($fines) = $self
+ ->method_lookup('open-ils.actor.user.fines.summary')
+ ->run($auth => $user_id);
+ return $fines if (defined($U->event_code($fines)));
+
+ if (!$fines) {
+ $fines = new Fieldmapper::money::open_user_summary ();
+ $fines->balance_owed(0.00);
+ $fines->total_owed(0.00);
+ $fines->total_paid(0.00);
+ $fines->usr($user_id);
+ }
+
+ my ($holds) = $self
+ ->method_lookup('open-ils.actor.user.hold_requests.count')
+ ->run($auth => $user_id);
+ return $holds if (defined($U->event_code($holds)));
+
+ my ($out) = $self
+ ->method_lookup('open-ils.actor.user.checked_out.count')
+ ->run($auth => $user_id);
+ return $out if (defined($U->event_code($out)));
+
+ return {
+ user => {
+ first_given_name => $user->first_given_name,
+ second_given_name => $user->second_given_name,
+ family_name => $user->family_name,
+ alias => $user->alias,
+ usrname => $user->usrname
+ },
+ fines => $fines->to_bare_hash,
+ checkouts => $out,
+ holds => $holds
+ };
+}
+
+
+##### a small consolidation of related method registrations
+my $common_params = [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User ID', type => 'string' },
+ { desc => 'Transactions type (optional, defaults to all)', type => 'string' },
+ { desc => 'Options hash. May contain limit and offset for paged results.', type => 'object' },
+];
+my %methods = (
+ 'open-ils.actor.user.transactions' => '',
+ 'open-ils.actor.user.transactions.fleshed' => '',
+ 'open-ils.actor.user.transactions.have_charge' => ' that have an initial charge',
+ 'open-ils.actor.user.transactions.have_charge.fleshed' => ' that have an initial charge',
+ 'open-ils.actor.user.transactions.have_balance' => ' that have an outstanding balance',
+ 'open-ils.actor.user.transactions.have_balance.fleshed' => ' that have an outstanding balance',
+);
+
+foreach (keys %methods) {
+ my %args = (
+ method => "user_transactions",
+ api_name => $_,
+ signature => {
+ desc => 'For a given user, retrieve a list of '
+ . (/\.fleshed/ ? 'fleshed ' : '')
+ . 'transactions' . $methods{$_}
+ . ' optionally limited to transactions of a given type.',
+ params => $common_params,
+ return => {
+ desc => "List of objects, or event on error. Each object is a hash containing: transaction, circ, record. "
+ . 'These represent the relevant (mbts) transaction, attached circulation and title pointed to in the circ, respectively.',
+ }
+ }
+ );
+ /\.have_balance/ and $args{authoritative} = 1; # FIXME: I don't know why have_charge isn't authoritative
+ __PACKAGE__->register_method(%args);
+}
+
+# Now for the counts
+%methods = (
+ 'open-ils.actor.user.transactions.count' => '',
+ 'open-ils.actor.user.transactions.have_charge.count' => ' that have an initial charge',
+ 'open-ils.actor.user.transactions.have_balance.count' => ' that have an outstanding balance',
+);
+
+foreach (keys %methods) {
+ my %args = (
+ method => "user_transactions",
+ api_name => $_,
+ signature => {
+ desc => 'For a given user, retrieve a count of open '
+ . 'transactions' . $methods{$_}
+ . ' optionally limited to transactions of a given type.',
+ params => $common_params,
+ return => { desc => "Integer count of transactions, or event on error" }
+ }
+ );
+ /\.have_balance/ and $args{authoritative} = 1; # FIXME: I don't know why have_charge isn't authoritative
+ __PACKAGE__->register_method(%args);
+}
+
+__PACKAGE__->register_method(
+ method => "user_transactions",
+ api_name => "open-ils.actor.user.transactions.have_balance.total",
+ authoritative => 1,
+ signature => {
+ desc => 'For a given user, retrieve the total balance owed for open transactions,'
+ . ' optionally limited to transactions of a given type.',
+ params => $common_params,
+ return => { desc => "Decimal balance value, or event on error" }
+ }
+);
+
+
+sub user_transactions {
+ my( $self, $client, $login_session, $user_id, $type, $options ) = @_;
+ $options ||= {};
+
+ my( $user_obj, $target, $evt ) = $apputils->checkses_requestor(
+ $login_session, $user_id, 'VIEW_USER_TRANSACTIONS' );
+ return $evt if $evt;
+
+ my $api = $self->api_name();
+
+ my $filter = ($api =~ /have_balance/o) ?
+ { 'balance_owed' => { '<>' => 0 } }:
+ { 'total_owed' => { '>' => 0 } };
+
+ my ($trans) = $self->method_lookup(
+ 'open-ils.actor.user.transactions.history.still_open')
+ ->run( $login_session, $user_id, $type, $filter, $options );
+
+ if($api =~ /total/o) {
+ my $total = 0.0;
+ for my $t (@$trans) {
+ $total += $t->balance_owed;
+ }
+
+ $logger->debug("Total balance owed by user $user_id: $total");
+ return $total;
+ }
+
+ ($api =~ /count/o ) and return scalar @$trans;
+ ($api !~ /fleshed/o) and return $trans;
+
+ my @resp;
+ for my $t (@$trans) {
+
+ if( $t->xact_type ne 'circulation' ) {
+ push @resp, {transaction => $t};
+ next;
+ }
+
+ my $circ = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.action.circulation.retrieve",
+ $t->id );
+
+ next unless $circ;
+
+ my $title = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.fleshed.biblio.record_entry.retrieve_by_copy",
+ $circ->target_copy );
+
+ next unless $title;
+
+ my $u = OpenILS::Utils::ModsParser->new();
+ $u->start_mods_batch($title->marc());
+ my $mods = $u->finish_mods_batch();
+ $mods->doc_id($title->id) if $mods;
+
+ push @resp, {transaction => $t, circ => $circ, record => $mods };
+
+ }
+
+ return \@resp;
+}
+
+
+__PACKAGE__->register_method(
+ method => "user_transaction_retrieve",
+ api_name => "open-ils.actor.user.transaction.fleshed.retrieve",
+ argc => 1,
+ notes => "Returns a fleshed transaction record"
+);
+
+__PACKAGE__->register_method(
+ method => "user_transaction_retrieve",
+ api_name => "open-ils.actor.user.transaction.retrieve",
+ argc => 1,
+ notes => "Returns a transaction record"
+);
+
+sub user_transaction_retrieve {
+ my( $self, $client, $login_session, $bill_id ) = @_;
+
+ # I think I'm deprecated... make sure. phasefx says, "No, I'll use you :)
+
+ my $trans = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.money.billable_transaction_summary.retrieve",
+ $bill_id
+ );
+
+ my( $user_obj, $target, $evt ) = $apputils->checkses_requestor(
+ $login_session, $trans->usr, 'VIEW_USER_TRANSACTIONS' );
+ return $evt if $evt;
+
+ my $api = $self->api_name();
+ if($api !~ /fleshed/o) { return $trans; }
+
+ if( $trans->xact_type ne 'circulation' ) {
+ $logger->debug("Returning non-circ transaction");
+ return {transaction => $trans};
+ }
+
+ my $circ = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.action.circulation.retrieve",
+ $trans->id );
+
+ return {transaction => $trans} unless $circ;
+ $logger->debug("Found the circ transaction");
+
+ my $title = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.fleshed.biblio.record_entry.retrieve_by_copy",
+ $circ->target_copy );
+
+ return {transaction => $trans, circ => $circ } unless $title;
+ $logger->debug("Found the circ title");
+
+ my $mods;
+ my $copy = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.asset.copy.retrieve",
+ $circ->target_copy );
+
+ try {
+ my $u = OpenILS::Utils::ModsParser->new();
+ $u->start_mods_batch($title->marc());
+ $mods = $u->finish_mods_batch();
+ } otherwise {
+ if ($title->id == OILS_PRECAT_RECORD) {
+ $mods = new Fieldmapper::metabib::virtual_record;
+ $mods->doc_id(OILS_PRECAT_RECORD);
+ $mods->title($copy->dummy_title);
+ $mods->author($copy->dummy_author);
+ }
+ };
+
+ $logger->debug("MODSized the circ title");
+
+ return {transaction => $trans, circ => $circ, record => $mods, copy => $copy };
+}
+
+
+__PACKAGE__->register_method(
+ method => "hold_request_count",
+ api_name => "open-ils.actor.user.hold_requests.count",
+ authoritative => 1,
+ argc => 1,
+ notes => 'Returns hold ready/total counts'
+);
+
+sub hold_request_count {
+ my( $self, $client, $login_session, $userid ) = @_;
+
+ my( $user_obj, $target, $evt ) = $apputils->checkses_requestor(
+ $login_session, $userid, 'VIEW_HOLD' );
+ return $evt if $evt;
+
+
+ my $holds = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.action.hold_request.search.atomic",
+ {
+ usr => $userid,
+ fulfillment_time => {"=" => undef },
+ cancel_time => undef,
+ }
+ );
+
+ my @ready;
+ for my $h (@$holds) {
+ next unless $h->capture_time and $h->current_copy;
+
+ my $copy = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.asset.copy.retrieve",
+ $h->current_copy
+ );
+
+ if ($copy and $copy->status == 8) {
+ push @ready, $h;
+ }
+ }
+
+ return { total => scalar(@$holds), ready => scalar(@ready) };
+}
+
+__PACKAGE__->register_method(
+ method => "checked_out",
+ api_name => "open-ils.actor.user.checked_out",
+ authoritative => 1,
+ argc => 2,
+ signature => {
+ desc => "For a given user, returns a structure of circulations objects sorted by out, overdue, lost, claims_returned, long_overdue. "
+ . "A list of IDs are returned of each type. Circs marked lost, long_overdue, and claims_returned will not be 'finished' "
+ . "(i.e., outstanding balance or some other pending action on the circ). "
+ . "The .count method also includes a 'total' field which sums all open circs.",
+ params => [
+ { desc => 'Authentication Token', type => 'string'},
+ { desc => 'User ID', type => 'string'},
+ ],
+ return => {
+ desc => 'Returns event on error, or an object with ID lists, like: '
+ . '{"out":[12552,451232], "claims_returned":[], "long_overdue":[23421] "overdue":[], "lost":[]}'
+ },
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "checked_out",
+ api_name => "open-ils.actor.user.checked_out.count",
+ authoritative => 1,
+ argc => 2,
+ signature => q/@see open-ils.actor.user.checked_out/
+);
+
+sub checked_out {
+ my( $self, $conn, $auth, $userid ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ if( $userid ne $e->requestor->id ) {
+ my $user = $e->retrieve_actor_user($userid) or return $e->event;
+ unless($e->allowed('VIEW_CIRCULATIONS', $user->home_ou)) {
+
+ # see if there is a friend link allowing circ.view perms
+ my $allowed = OpenILS::Application::Actor::Friends->friend_perm_allowed(
+ $e, $userid, $e->requestor->id, 'circ.view');
+ return $e->event unless $allowed;
+ }
+ }
+
+ my $count = $self->api_name =~ /count/;
+ return _checked_out( $count, $e, $userid );
+}
+
+sub _checked_out {
+ my( $iscount, $e, $userid ) = @_;
+
+ my %result = (
+ out => [],
+ overdue => [],
+ lost => [],
+ claims_returned => [],
+ long_overdue => []
+ );
+ my $meth = 'retrieve_action_open_circ_';
+
+ if ($iscount) {
+ $meth .= 'count';
+ %result = (
+ out => 0,
+ overdue => 0,
+ lost => 0,
+ claims_returned => 0,
+ long_overdue => 0
+ );
+ } else {
+ $meth .= 'list';
+ }
+
+ my $data = $e->$meth($userid);
+
+ if ($data) {
+ if ($iscount) {
+ $result{$_} += $data->$_() for (keys %result);
+ $result{total} += $data->$_() for (keys %result);
+ } else {
+ for my $k (keys %result) {
+ $result{$k} = [ grep { $_ > 0 } split( ',', $data->$k()) ];
+ }
+ }
+ }
+
+ return \%result;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "checked_in_with_fines",
+ api_name => "open-ils.actor.user.checked_in_with_fines",
+ authoritative => 1,
+ argc => 2,
+ signature => q/@see open-ils.actor.user.checked_out/
+);
+
+sub checked_in_with_fines {
+ my( $self, $conn, $auth, $userid ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ if( $userid ne $e->requestor->id ) {
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
+ }
+
+ # money is owed on these items and they are checked in
+ my $open = $e->search_action_circulation(
+ {
+ usr => $userid,
+ xact_finish => undef,
+ checkin_time => { "!=" => undef },
+ }
+ );
+
+
+ my( @lost, @cr, @lo );
+ for my $c (@$open) {
+ push( @lost, $c->id ) if $c->stop_fines eq 'LOST';
+ push( @cr, $c->id ) if $c->stop_fines eq 'CLAIMSRETURNED';
+ push( @lo, $c->id ) if $c->stop_fines eq 'LONGOVERDUE';
+ }
+
+ return {
+ lost => \@lost,
+ claims_returned => \@cr,
+ long_overdue => \@lo
+ };
+}
+
+
+sub _sigmaker {
+ my ($api, $desc, $auth) = @_;
+ $desc = $desc ? (" " . $desc) : '';
+ my $ids = ($api =~ /ids$/) ? 1 : 0;
+ my @sig = (
+ argc => 1,
+ method => "user_transaction_history",
+ api_name => "open-ils.actor.user.transactions.$api",
+ signature => {
+ desc => "For a given User ID, returns a list of billable transaction" .
+ ($ids ? " id" : '') .
+ "s$desc, optionally filtered by type and/or fields in money.billable_xact_summary. " .
+ "The VIEW_USER_TRANSACTIONS permission is required to view another user's transactions",
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'User ID', type => 'number'},
+ {desc => 'Transaction type (optional)', type => 'number'},
+ {desc => 'Hash of Billable Transaction Summary filters (optional)', type => 'object'}
+ ],
+ return => {
+ desc => 'List of transaction' . ($ids ? " id" : '') . 's, Event on error'
+ },
+ }
+ );
+ $auth and push @sig, (authoritative => 1);
+ return @sig;
+}
+
+my %hist_methods = (
+ 'history' => '',
+ 'history.have_charge' => 'that have an initial charge',
+ 'history.still_open' => 'that are not finished',
+);
+my %auth_hist_methods = (
+ 'history.have_balance' => 'that have a balance',
+ 'history.have_bill' => 'that have billings',
+ 'history.have_bill_or_payment' => 'that have non-zero-sum billings or at least 1 payment',
+);
+foreach (keys %hist_methods) {
+ __PACKAGE__->register_method(_sigmaker($_, $hist_methods{$_}));
+ __PACKAGE__->register_method(_sigmaker("$_.ids", $hist_methods{$_}));
+}
+foreach (keys %auth_hist_methods) {
+ __PACKAGE__->register_method(_sigmaker($_, $auth_hist_methods{$_}, 1));
+ __PACKAGE__->register_method(_sigmaker("$_.ids", $auth_hist_methods{$_}, 1));
+}
+
+sub user_transaction_history {
+ my( $self, $conn, $auth, $userid, $type, $filter, $options ) = @_;
+ $filter ||= {};
+ $options ||= {};
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ if ($e->requestor->id ne $userid) {
+ return $e->die_event unless $e->allowed('VIEW_USER_TRANSACTIONS');
+ }
+
+ my $api = $self->api_name;
+ my @xact_finish = (xact_finish => undef ) if ($api =~ /history\.still_open$/); # What about history.still_open.ids?
+
+ if(defined($type)) {
+ $filter->{'xact_type'} = $type;
+ }
+
+ if($api =~ /have_bill_or_payment/o) {
+
+ # transactions that have a non-zero sum across all billings or at least 1 payment
+ $filter->{'-or'} = {
+ 'balance_owed' => { '<>' => 0 },
+ 'last_payment_ts' => { '<>' => undef }
+ };
+
+ } elsif( $api =~ /have_balance/o) {
+
+ # transactions that have a non-zero overall balance
+ $filter->{'balance_owed'} = { '<>' => 0 };
+
+ } elsif( $api =~ /have_charge/o) {
+
+ # transactions that have at least 1 billing, regardless of whether it was voided
+ $filter->{'last_billing_ts'} = { '<>' => undef };
+
+ } elsif( $api =~ /have_bill/o) { # needs to be an elsif, or we double-match have_bill_or_payment!
+
+ # transactions that have non-zero sum across all billings. This will exclude
+ # xacts where all billings have been voided
+ $filter->{'total_owed'} = { '<>' => 0 };
+ }
+
+ my $options_clause = { order_by => { mbt => 'xact_start DESC' } };
+ $options_clause->{'limit'} = $options->{'limit'} if $options->{'limit'};
+ $options_clause->{'offset'} = $options->{'offset'} if $options->{'offset'};
+
+ my $mbts = $e->search_money_billable_transaction_summary(
+ [
+ { usr => $userid, @xact_finish, %$filter },
+ $options_clause
+ ]
+ );
+
+ if ($api =~ /\.ids/) {
+ return [map {$_->id} @$mbts];
+ } else {
+ return $mbts;
+ }
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "user_perms",
+ api_name => "open-ils.actor.permissions.user_perms.retrieve",
+ argc => 1,
+ notes => "Returns a list of permissions"
+);
+
+sub user_perms {
+ my( $self, $client, $authtoken, $user ) = @_;
+
+ my( $staff, $evt ) = $apputils->checkses($authtoken);
+ return $evt if $evt;
+
+ $user ||= $staff->id;
+
+ if( $user != $staff->id and $evt = $apputils->check_perms( $staff->id, $staff->home_ou, 'VIEW_PERMISSION') ) {
+ return $evt;
+ }
+
+ return $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.permission.user_perms.atomic",
+ $user);
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_perms",
+ api_name => "open-ils.actor.permissions.retrieve",
+ notes => "Returns a list of permissions"
+);
+sub retrieve_perms {
+ my( $self, $client ) = @_;
+ return $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.permission.perm_list.search.atomic",
+ { id => { '!=' => undef } }
+ );
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_groups",
+ api_name => "open-ils.actor.groups.retrieve",
+ notes => "Returns a list of user groups"
+);
+sub retrieve_groups {
+ my( $self, $client ) = @_;
+ return new_editor()->retrieve_all_permission_grp_tree();
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_org_address",
+ api_name => "open-ils.actor.org_unit.address.retrieve",
+ notes => <<' NOTES');
+ Returns an org_unit address by ID
+ @param An org_address ID
+ NOTES
+sub retrieve_org_address {
+ my( $self, $client, $id ) = @_;
+ return $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.actor.org_address.retrieve",
+ $id
+ );
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_groups_tree",
+ api_name => "open-ils.actor.groups.tree.retrieve",
+ notes => "Returns a list of user groups"
+);
+
+sub retrieve_groups_tree {
+ my( $self, $client ) = @_;
+ return new_editor()->search_permission_grp_tree(
+ [
+ { parent => undef},
+ {
+ flesh => -1,
+ flesh_fields => { pgt => ["children"] },
+ order_by => { pgt => 'name'}
+ }
+ ]
+ )->[0];
+}
+
+
+__PACKAGE__->register_method(
+ method => "add_user_to_groups",
+ api_name => "open-ils.actor.user.set_groups",
+ notes => "Adds a user to one or more permission groups"
+);
+
+sub add_user_to_groups {
+ my( $self, $client, $authtoken, $userid, $groups ) = @_;
+
+ my( $requestor, $target, $evt ) = $apputils->checkses_requestor(
+ $authtoken, $userid, 'CREATE_USER_GROUP_LINK' );
+ return $evt if $evt;
+
+ ( $requestor, $target, $evt ) = $apputils->checkses_requestor(
+ $authtoken, $userid, 'REMOVE_USER_GROUP_LINK' );
+ return $evt if $evt;
+
+ $apputils->simplereq(
+ 'open-ils.storage',
+ 'open-ils.storage.direct.permission.usr_grp_map.mass_delete', { usr => $userid } );
+
+ for my $group (@$groups) {
+ my $link = Fieldmapper::permission::usr_grp_map->new;
+ $link->grp($group);
+ $link->usr($userid);
+
+ my $id = $apputils->simplereq(
+ 'open-ils.storage',
+ 'open-ils.storage.direct.permission.usr_grp_map.create', $link );
+ }
+
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "get_user_perm_groups",
+ api_name => "open-ils.actor.user.get_groups",
+ notes => "Retrieve a user's permission groups."
+);
+
+
+sub get_user_perm_groups {
+ my( $self, $client, $authtoken, $userid ) = @_;
+
+ my( $requestor, $target, $evt ) = $apputils->checkses_requestor(
+ $authtoken, $userid, 'VIEW_PERM_GROUPS' );
+ return $evt if $evt;
+
+ return $apputils->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.permission.usr_grp_map.search.atomic', { usr => $userid } );
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_user_work_ous",
+ api_name => "open-ils.actor.user.get_work_ous",
+ notes => "Retrieve a user's work org units."
+);
+
+__PACKAGE__->register_method(
+ method => "get_user_work_ous",
+ api_name => "open-ils.actor.user.get_work_ous.ids",
+ notes => "Retrieve a user's work org units."
+);
+
+sub get_user_work_ous {
+ my( $self, $client, $auth, $userid ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $userid ||= $e->requestor->id;
+
+ if($e->requestor->id != $userid) {
+ my $user = $e->retrieve_actor_user($userid)
+ or return $e->event;
+ return $e->event unless $e->allowed('ASSIGN_WORK_ORG_UNIT', $user->home_ou);
+ }
+
+ return $e->search_permission_usr_work_ou_map({usr => $userid})
+ unless $self->api_name =~ /.ids$/;
+
+ # client just wants a list of org IDs
+ return $U->get_user_work_ou_ids($e, $userid);
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'register_workstation',
+ api_name => 'open-ils.actor.workstation.register.override',
+ signature => q/@see open-ils.actor.workstation.register/
+);
+
+__PACKAGE__->register_method(
+ method => 'register_workstation',
+ api_name => 'open-ils.actor.workstation.register',
+ signature => q/
+ Registers a new workstion in the system
+ @param authtoken The login session key
+ @param name The name of the workstation id
+ @param owner The org unit that owns this workstation
+ @return The workstation id on success, WORKSTATION_NAME_EXISTS
+ if the name is already in use.
+ /
+);
+
+sub register_workstation {
+ my( $self, $conn, $authtoken, $name, $owner ) = @_;
+
+ my $e = new_editor(authtoken=>$authtoken, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('REGISTER_WORKSTATION', $owner);
+ my $existing = $e->search_actor_workstation({name => $name})->[0];
+
+ if( $existing ) {
+
+ if( $self->api_name =~ /override/o ) {
+ # workstation with the given name exists.
+
+ if($owner ne $existing->owning_lib) {
+ # if necessary, update the owning_lib of the workstation
+
+ $logger->info("changing owning lib of workstation ".$existing->id.
+ " from ".$existing->owning_lib." to $owner");
+ return $e->die_event unless
+ $e->allowed('UPDATE_WORKSTATION', $existing->owning_lib);
+
+ return $e->die_event unless $e->allowed('UPDATE_WORKSTATION', $owner);
+
+ $existing->owning_lib($owner);
+ return $e->die_event unless $e->update_actor_workstation($existing);
+
+ $e->commit;
+
+ } else {
+ $logger->info(
+ "attempt to register an existing workstation. returning existing ID");
+ }
+
+ return $existing->id;
+
+ } else {
+ return OpenILS::Event->new('WORKSTATION_NAME_EXISTS')
+ }
+ }
+
+ my $ws = Fieldmapper::actor::workstation->new;
+ $ws->owning_lib($owner);
+ $ws->name($name);
+ $e->create_actor_workstation($ws) or return $e->die_event;
+ $e->commit;
+ return $ws->id; # note: editor sets the id on the new object for us
+}
+
+__PACKAGE__->register_method(
+ method => 'workstation_list',
+ api_name => 'open-ils.actor.workstation.list',
+ signature => q/
+ Returns a list of workstations registered at the given location
+ @param authtoken The login session key
+ @param ids A list of org_unit.id's for the workstation owners
+ /
+);
+
+sub workstation_list {
+ my( $self, $conn, $authtoken, @orgs ) = @_;
+
+ my $e = new_editor(authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+ my %results;
+
+ for my $o (@orgs) {
+ return $e->event
+ unless $e->allowed('REGISTER_WORKSTATION', $o);
+ $results{$o} = $e->search_actor_workstation({owning_lib=>$o});
+ }
+ return \%results;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_patron_note',
+ api_name => 'open-ils.actor.note.retrieve.all',
+ authoritative => 1,
+ signature => q/
+ Returns a list of notes for a given user
+ Requestor must have VIEW_USER permission if pub==false and
+ @param authtoken The login session key
+ @param args Hash of params including
+ patronid : the patron's id
+ pub : true if retrieving only public notes
+ /
+);
+
+sub fetch_patron_note {
+ my( $self, $conn, $authtoken, $args ) = @_;
+ my $patronid = $$args{patronid};
+
+ my($reqr, $evt) = $U->checkses($authtoken);
+ return $evt if $evt;
+
+ my $patron;
+ ($patron, $evt) = $U->fetch_user($patronid);
+ return $evt if $evt;
+
+ if($$args{pub}) {
+ if( $patronid ne $reqr->id ) {
+ $evt = $U->check_perms($reqr->id, $patron->home_ou, 'VIEW_USER');
+ return $evt if $evt;
+ }
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.actor.usr_note.search.atomic',
+ { usr => $patronid, pub => 't' } );
+ }
+
+ $evt = $U->check_perms($reqr->id, $patron->home_ou, 'VIEW_USER');
+ return $evt if $evt;
+
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.actor.usr_note.search.atomic', { usr => $patronid } );
+}
+
+__PACKAGE__->register_method(
+ method => 'create_user_note',
+ api_name => 'open-ils.actor.note.create',
+ signature => q/
+ Creates a new note for the given user
+ @param authtoken The login session key
+ @param note The note object
+ /
+);
+sub create_user_note {
+ my( $self, $conn, $authtoken, $note ) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+
+ my $user = $e->retrieve_actor_user($note->usr)
+ or return $e->die_event;
+
+ return $e->die_event unless
+ $e->allowed('UPDATE_USER',$user->home_ou);
+
+ $note->creator($e->requestor->id);
+ $e->create_actor_usr_note($note) or return $e->die_event;
+ $e->commit;
+ return $note->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_user_note',
+ api_name => 'open-ils.actor.note.delete',
+ signature => q/
+ Deletes a note for the given user
+ @param authtoken The login session key
+ @param noteid The note id
+ /
+);
+sub delete_user_note {
+ my( $self, $conn, $authtoken, $noteid ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+ my $note = $e->retrieve_actor_usr_note($noteid)
+ or return $e->die_event;
+ my $user = $e->retrieve_actor_user($note->usr)
+ or return $e->die_event;
+ return $e->die_event unless
+ $e->allowed('UPDATE_USER', $user->home_ou);
+
+ $e->delete_actor_usr_note($note) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'update_user_note',
+ api_name => 'open-ils.actor.note.update',
+ signature => q/
+ @param authtoken The login session key
+ @param note The note
+ /
+);
+
+sub update_user_note {
+ my( $self, $conn, $auth, $note ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my $patron = $e->retrieve_actor_user($note->usr)
+ or return $e->die_event;
+ return $e->die_event unless
+ $e->allowed('UPDATE_USER', $patron->home_ou);
+ $e->update_actor_user_note($note)
+ or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'create_closed_date',
+ api_name => 'open-ils.actor.org_unit.closed_date.create',
+ signature => q/
+ Creates a new closing entry for the given org_unit
+ @param authtoken The login session key
+ @param note The closed_date object
+ /
+);
+sub create_closed_date {
+ my( $self, $conn, $authtoken, $cd ) = @_;
+
+ my( $user, $evt ) = $U->checkses($authtoken);
+ return $evt if $evt;
+
+ $evt = $U->check_perms($user->id, $cd->org_unit, 'CREATE_CLOSEING');
+ return $evt if $evt;
+
+ $logger->activity("user ".$user->id." creating library closing for ".$cd->org_unit);
+
+ my $id = $U->storagereq(
+ 'open-ils.storage.direct.actor.org_unit.closed_date.create', $cd );
+ return $U->DB_UPDATE_FAILED($cd) unless $id;
+ return $id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_closed_date',
+ api_name => 'open-ils.actor.org_unit.closed_date.delete',
+ signature => q/
+ Deletes a closing entry for the given org_unit
+ @param authtoken The login session key
+ @param noteid The close_date id
+ /
+);
+sub delete_closed_date {
+ my( $self, $conn, $authtoken, $cd ) = @_;
+
+ my( $user, $evt ) = $U->checkses($authtoken);
+ return $evt if $evt;
+
+ my $cd_obj;
+ ($cd_obj, $evt) = fetch_closed_date($cd);
+ return $evt if $evt;
+
+ $evt = $U->check_perms($user->id, $cd->org_unit, 'DELETE_CLOSEING');
+ return $evt if $evt;
+
+ $logger->activity("user ".$user->id." deleting library closing for ".$cd->org_unit);
+
+ my $stat = $U->storagereq(
+ 'open-ils.storage.direct.actor.org_unit.closed_date.delete', $cd );
+ return $U->DB_UPDATE_FAILED($cd) unless $stat;
+ return $stat;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'usrname_exists',
+ api_name => 'open-ils.actor.username.exists',
+ signature => {
+ desc => 'Check if a username is already taken (by an undeleted patron)',
+ param => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Username', type => 'string'}
+ ],
+ return => {
+ desc => 'id of existing user if username exists, undef otherwise. Event on error'
+ },
+ }
+);
+
+sub usrname_exists {
+ my( $self, $conn, $auth, $usrname ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $a = $e->search_actor_user({usrname => $usrname, deleted=>'f'}, {idlist=>1});
+ return $$a[0] if $a and @$a;
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'barcode_exists',
+ api_name => 'open-ils.actor.barcode.exists',
+ authoritative => 1,
+ signature => 'Returns 1 if the requested barcode exists, returns 0 otherwise'
+);
+
+sub barcode_exists {
+ my( $self, $conn, $auth, $barcode ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $card = $e->search_actor_card({barcode => $barcode});
+ if (@$card) {
+ return 1;
+ } else {
+ return 0;
+ }
+ #return undef unless @$card;
+ #return $card->[0]->usr;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_net_levels',
+ api_name => 'open-ils.actor.net_access_level.retrieve.all',
+);
+
+sub retrieve_net_levels {
+ my( $self, $conn, $auth ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->retrieve_all_config_net_access_level();
+}
+
+# Retain the old typo API name just in case
+__PACKAGE__->register_method(
+ method => 'fetch_org_by_shortname',
+ api_name => 'open-ils.actor.org_unit.retrieve_by_shorname',
+);
+__PACKAGE__->register_method(
+ method => 'fetch_org_by_shortname',
+ api_name => 'open-ils.actor.org_unit.retrieve_by_shortname',
+);
+sub fetch_org_by_shortname {
+ my( $self, $conn, $sname ) = @_;
+ my $e = new_editor();
+ my $org = $e->search_actor_org_unit({ shortname => uc($sname)})->[0];
+ return $e->event unless $org;
+ return $org;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'session_home_lib',
+ api_name => 'open-ils.actor.session.home_lib',
+);
+
+sub session_home_lib {
+ my( $self, $conn, $auth ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return undef unless $e->checkauth;
+ my $org = $e->retrieve_actor_org_unit($e->requestor->home_ou);
+ return $org->shortname;
+}
+
+__PACKAGE__->register_method(
+ method => 'session_safe_token',
+ api_name => 'open-ils.actor.session.safe_token',
+ signature => q/
+ Returns a hashed session ID that is safe for export to the world.
+ This safe token will expire after 1 hour of non-use.
+ @param auth Active authentication token
+ /
+);
+
+sub session_safe_token {
+ my( $self, $conn, $auth ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return undef unless $e->checkauth;
+
+ my $safe_token = md5_hex($auth);
+
+ $cache ||= OpenSRF::Utils::Cache->new("global", 0);
+
+ # Add more like the following if needed...
+ $cache->put_cache(
+ "safe-token-home_lib-shortname-$safe_token",
+ $e->retrieve_actor_org_unit(
+ $e->requestor->home_ou
+ )->shortname,
+ 60 * 60
+ );
+
+ return $safe_token;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'safe_token_home_lib',
+ api_name => 'open-ils.actor.safe_token.home_lib.shortname',
+ signature => q/
+ Returns the home library shortname from the session
+ asscociated with a safe token from generated by
+ open-ils.actor.session.safe_token.
+ @param safe_token Active safe token
+ /
+);
+
+sub safe_token_home_lib {
+ my( $self, $conn, $safe_token ) = @_;
+
+ $cache ||= OpenSRF::Utils::Cache->new("global", 0);
+ return $cache->get_cache( 'safe-token-home_lib-shortname-'. $safe_token );
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'slim_tree',
+ api_name => "open-ils.actor.org_tree.slim_hash.retrieve",
+);
+sub slim_tree {
+ my $tree = new_editor()->search_actor_org_unit(
+ [
+ {"parent_ou" => undef },
+ {
+ flesh => -1,
+ flesh_fields => { aou => ['children'] },
+ order_by => { aou => 'name'},
+ select => { aou => ["id","shortname", "name"]},
+ }
+ ]
+ )->[0];
+
+ return trim_tree($tree);
+}
+
+
+sub trim_tree {
+ my $tree = shift;
+ return undef unless $tree;
+ my $htree = {
+ code => $tree->shortname,
+ name => $tree->name,
+ };
+ if( $tree->children and @{$tree->children} ) {
+ $htree->{children} = [];
+ for my $c (@{$tree->children}) {
+ push( @{$htree->{children}}, trim_tree($c) );
+ }
+ }
+
+ return $htree;
+}
+
+
+__PACKAGE__->register_method(
+ method => "update_penalties",
+ api_name => "open-ils.actor.user.penalties.update"
+);
+
+sub update_penalties {
+ my($self, $conn, $auth, $user_id) = @_;
+ my $e = new_editor(authtoken=>$auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+ my $evt = OpenILS::Utils::Penalty->calculate_penalties($e, $user_id, $e->requestor->ws_ou);
+ return $evt if $evt;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "apply_penalty",
+ api_name => "open-ils.actor.user.penalty.apply"
+);
+
+sub apply_penalty {
+ my($self, $conn, $auth, $penalty) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $user = $e->retrieve_actor_user($penalty->usr) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+
+ my $ptype = $e->retrieve_config_standing_penalty($penalty->standing_penalty) or return $e->die_event;
+
+ my $ctx_org =
+ (defined $ptype->org_depth) ?
+ $U->org_unit_ancestor_at_depth($penalty->org_unit, $ptype->org_depth) :
+ $penalty->org_unit;
+
+ $penalty->org_unit($ctx_org);
+ $penalty->staff($e->requestor->id);
+ $e->create_actor_user_standing_penalty($penalty) or return $e->die_event;
+
+ $e->commit;
+ return $penalty->id;
+}
+
+__PACKAGE__->register_method(
+ method => "remove_penalty",
+ api_name => "open-ils.actor.user.penalty.remove"
+);
+
+sub remove_penalty {
+ my($self, $conn, $auth, $penalty) = @_;
+ my $e = new_editor(authtoken=>$auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ my $user = $e->retrieve_actor_user($penalty->usr) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+
+ $e->delete_actor_user_standing_penalty($penalty) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "update_penalty_note",
+ api_name => "open-ils.actor.user.penalty.note.update"
+);
+
+sub update_penalty_note {
+ my($self, $conn, $auth, $penalty_ids, $note) = @_;
+ my $e = new_editor(authtoken=>$auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ for my $penalty_id (@$penalty_ids) {
+ my $penalty = $e->search_actor_user_standing_penalty( { id => $penalty_id } )->[0];
+ if (! $penalty ) { return $e->die_event; }
+ my $user = $e->retrieve_actor_user($penalty->usr) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+
+ $penalty->note( $note ); $penalty->ischanged( 1 );
+
+ $e->update_actor_user_standing_penalty($penalty) or return $e->die_event;
+ }
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "ranged_penalty_thresholds",
+ api_name => "open-ils.actor.grp_penalty_threshold.ranged.retrieve",
+ stream => 1
+);
+
+sub ranged_penalty_thresholds {
+ my($self, $conn, $auth, $context_org) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_GROUP_PENALTY_THRESHOLD', $context_org);
+ my $list = $e->search_permission_grp_penalty_threshold([
+ {org_unit => $U->get_org_ancestors($context_org)},
+ {order_by => {pgpt => 'id'}}
+ ]);
+ $conn->respond($_) for @$list;
+ return undef;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "user_retrieve_fleshed_by_id",
+ authoritative => 1,
+ api_name => "open-ils.actor.user.fleshed.retrieve",
+);
+
+sub user_retrieve_fleshed_by_id {
+ my( $self, $client, $auth, $user_id, $fields ) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ if( $e->requestor->id != $user_id ) {
+ return $e->event unless $e->allowed('VIEW_USER');
+ }
+
+ $fields ||= [
+ "cards",
+ "card",
+ "standing_penalties",
+ "addresses",
+ "billing_address",
+ "mailing_address",
+ "stat_cat_entries" ];
+ return new_flesh_user($user_id, $fields, $e);
+}
+
+
+sub new_flesh_user {
+
+ my $id = shift;
+ my $fields = shift || [];
+ my $e = shift;
+
+ my $fetch_penalties = 0;
+ if(grep {$_ eq 'standing_penalties'} @$fields) {
+ $fields = [grep {$_ ne 'standing_penalties'} @$fields];
+ $fetch_penalties = 1;
+ }
+
+ my $user = $e->retrieve_actor_user(
+ [
+ $id,
+ {
+ "flesh" => 1,
+ "flesh_fields" => { "au" => $fields }
+ }
+ ]
+ ) or return $e->die_event;
+
+
+ if( grep { $_ eq 'addresses' } @$fields ) {
+
+ $user->addresses([]) unless @{$user->addresses};
+ # don't expose "replaced" addresses by default
+ $user->addresses([grep {$_->id >= 0} @{$user->addresses}]);
+
+ if( ref $user->billing_address ) {
+ unless( grep { $user->billing_address->id == $_->id } @{$user->addresses} ) {
+ push( @{$user->addresses}, $user->billing_address );
+ }
+ }
+
+ if( ref $user->mailing_address ) {
+ unless( grep { $user->mailing_address->id == $_->id } @{$user->addresses} ) {
+ push( @{$user->addresses}, $user->mailing_address );
+ }
+ }
+ }
+
+ if($fetch_penalties) {
+ # grab the user penalties ranged for this location
+ $user->standing_penalties(
+ $e->search_actor_user_standing_penalty([
+ { usr => $id,
+ '-or' => [
+ {stop_date => undef},
+ {stop_date => {'>' => 'now'}}
+ ],
+ org_unit => $U->get_org_ancestors($e->requestor->ws_ou)
+ },
+ { flesh => 1,
+ flesh_fields => {ausp => ['standing_penalty']}
+ }
+ ])
+ );
+ }
+
+ $e->rollback;
+ $user->clear_passwd();
+ return $user;
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => "user_retrieve_parts",
+ api_name => "open-ils.actor.user.retrieve.parts",
+);
+
+sub user_retrieve_parts {
+ my( $self, $client, $auth, $user_id, $fields ) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ $user_id ||= $e->requestor->id;
+ if( $e->requestor->id != $user_id ) {
+ return $e->event unless $e->allowed('VIEW_USER');
+ }
+ my @resp;
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ push(@resp, $user->$_()) for(@$fields);
+ return \@resp;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'user_opt_in_enabled',
+ api_name => 'open-ils.actor.user.org_unit_opt_in.enabled',
+ signature => '@return 1 if user opt-in is globally enabled, 0 otherwise.'
+);
+
+sub user_opt_in_enabled {
+ my($self, $conn) = @_;
+ my $sc = OpenSRF::Utils::SettingsClient->new;
+ return 1 if lc($sc->config_value(share => user => 'opt_in')) eq 'true';
+ return 0;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'user_opt_in_at_org',
+ api_name => 'open-ils.actor.user.org_unit_opt_in.check',
+ signature => q/
+ @param $auth The auth token
+ @param user_id The ID of the user to test
+ @return 1 if the user has opted in at the specified org,
+ event on error, and 0 otherwise. /
+);
+sub user_opt_in_at_org {
+ my($self, $conn, $auth, $user_id) = @_;
+
+ # see if we even need to enforce the opt-in value
+ return 1 unless user_opt_in_enabled($self);
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ my $org_id = $e->requestor->ws_ou;
+
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+
+ # user is automatically opted-in at the home org
+ return 1 if $user->home_ou eq $org_id;
+
+ my $vals = $e->search_actor_usr_org_unit_opt_in(
+ {org_unit=>$org_id, usr=>$user_id},{idlist=>1});
+
+ return 1 if @$vals;
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => 'create_user_opt_in_at_org',
+ api_name => 'open-ils.actor.user.org_unit_opt_in.create',
+ signature => q/
+ @param $auth The auth token
+ @param user_id The ID of the user to test
+ @return The ID of the newly created object, event on error./
+);
+
+sub create_user_opt_in_at_org {
+ my($self, $conn, $auth, $user_id) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my $org_id = $e->requestor->ws_ou;
+
+ my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+
+ my $opt_in = Fieldmapper::actor::usr_org_unit_opt_in->new;
+
+ $opt_in->org_unit($org_id);
+ $opt_in->usr($user_id);
+ $opt_in->staff($e->requestor->id);
+ $opt_in->opt_in_ts('now');
+ $opt_in->opt_in_ws($e->requestor->wsid);
+
+ $opt_in = $e->create_actor_usr_org_unit_opt_in($opt_in)
+ or return $e->die_event;
+
+ $e->commit;
+
+ return $opt_in->id;
+}
+
+
+__PACKAGE__->register_method (
+ method => 'retrieve_org_hours',
+ api_name => 'open-ils.actor.org_unit.hours_of_operation.retrieve',
+ signature => q/
+ Returns the hours of operation for a specified org unit
+ @param authtoken The login session key
+ @param org_id The org_unit ID
+ /
+);
+
+sub retrieve_org_hours {
+ my($self, $conn, $auth, $org_id) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ $org_id ||= $e->requestor->ws_ou;
+ return $e->retrieve_actor_org_unit_hours_of_operation($org_id);
+}
+
+
+__PACKAGE__->register_method (
+ method => 'verify_user_password',
+ api_name => 'open-ils.actor.verify_user_password',
+ signature => q/
+ Given a barcode or username and the MD5 encoded password,
+ returns 1 if the password is correct. Returns 0 otherwise.
+ /
+);
+
+sub verify_user_password {
+ my($self, $conn, $auth, $barcode, $username, $password) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $user;
+ my $user_by_barcode;
+ my $user_by_username;
+ if($barcode) {
+ my $card = $e->search_actor_card([
+ {barcode => $barcode},
+ {flesh => 1, flesh_fields => {ac => ['usr']}}])->[0] or return 0;
+ $user_by_barcode = $card->usr;
+ $user = $user_by_barcode;
+ }
+ if ($username) {
+ $user_by_username = $e->search_actor_user({usrname => $username})->[0] or return 0;
+ $user = $user_by_username;
+ }
+ return 0 if (!$user);
+ return 0 if ($user_by_username && $user_by_barcode && $user_by_username->id != $user_by_barcode->id);
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ return 1 if $user->passwd eq $password;
+ return 0;
+}
+
+__PACKAGE__->register_method (
+ method => 'retrieve_usr_id_via_barcode_or_usrname',
+ api_name => "open-ils.actor.user.retrieve_id_by_barcode_or_username",
+ signature => q/
+ Given a barcode or username returns the id for the user or
+ a failure event.
+ /
+);
+
+sub retrieve_usr_id_via_barcode_or_usrname {
+ my($self, $conn, $auth, $barcode, $username) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $id_as_barcode= OpenSRF::Utils::SettingsClient->new->config_value(apps => 'open-ils.actor' => app_settings => 'id_as_barcode');
+ my $user;
+ my $user_by_barcode;
+ my $user_by_username;
+ $logger->info("$id_as_barcode is the ID as BARCODE");
+ if($barcode) {
+ my $card = $e->search_actor_card([
+ {barcode => $barcode},
+ {flesh => 1, flesh_fields => {ac => ['usr']}}])->[0];
+ if ($id_as_barcode =~ /^t/i) {
+ if (!$card) {
+ $user = $e->retrieve_actor_user($barcode);
+ return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if(!$user);
+ }else {
+ $user_by_barcode = $card->usr;
+ $user = $user_by_barcode;
+ }
+ }else {
+ return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if(!$card);
+ $user_by_barcode = $card->usr;
+ $user = $user_by_barcode;
+ }
+ }
+
+ if ($username) {
+ $user_by_username = $e->search_actor_user({usrname => $username})->[0] or return OpenILS::Event->new( 'ACTOR_USR_NOT_FOUND' );
+
+ $user = $user_by_username;
+ }
+ return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if (!$user);
+ return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' ) if ($user_by_username && $user_by_barcode && $user_by_username->id != $user_by_barcode->id);
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ return $user->id;
+}
+
+
+__PACKAGE__->register_method (
+ method => 'merge_users',
+ api_name => 'open-ils.actor.user.merge',
+ signature => {
+ desc => q/
+ Given a list of source users and destination user, transfer all data from the source
+ to the dest user and delete the source user. All user related data is
+ transferred, including circulations, holds, bookbags, etc.
+ /
+ }
+);
+
+sub merge_users {
+ my($self, $conn, $auth, $master_id, $user_ids, $options) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ # disallow the merge if any subordinate accounts are in collections
+ my $colls = $e->search_money_collections_tracker({usr => $user_ids}, {idlist => 1});
+ return OpenILS::Event->new('MERGED_USER_IN_COLLECTIONS', payload => $user_ids) if @$colls;
+
+ my $master_user = $e->retrieve_actor_user($master_id) or return $e->die_event;
+ my $del_addrs = ($U->ou_ancestor_setting_value(
+ $master_user->home_ou, 'circ.user_merge.delete_addresses', $e)) ? 't' : 'f';
+ my $del_cards = ($U->ou_ancestor_setting_value(
+ $master_user->home_ou, 'circ.user_merge.delete_cards', $e)) ? 't' : 'f';
+ my $deactivate_cards = ($U->ou_ancestor_setting_value(
+ $master_user->home_ou, 'circ.user_merge.deactivate_cards', $e)) ? 't' : 'f';
+
+ for my $src_id (@$user_ids) {
+ my $src_user = $e->retrieve_actor_user($src_id) or return $e->die_event;
+
+ return $e->die_event unless $e->allowed('MERGE_USERS', $src_user->home_ou);
+ if($src_user->home_ou ne $master_user->home_ou) {
+ return $e->die_event unless $e->allowed('MERGE_USERS', $master_user->home_ou);
+ }
+
+ return $e->die_event unless
+ $e->json_query({from => [
+ 'actor.usr_merge',
+ $src_id,
+ $master_id,
+ $del_addrs,
+ $del_cards,
+ $deactivate_cards
+ ]});
+ }
+
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method (
+ method => 'approve_user_address',
+ api_name => 'open-ils.actor.user.pending_address.approve',
+ signature => {
+ desc => q/
+ /
+ }
+);
+
+sub approve_user_address {
+ my($self, $conn, $auth, $addr) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ if(ref $addr) {
+ # if the caller passes an address object, assume they want to
+ # update it first before approving it
+ $e->update_actor_user_address($addr) or return $e->die_event;
+ } else {
+ $addr = $e->retrieve_actor_user_address($addr) or return $e->die_event;
+ }
+ my $user = $e->retrieve_actor_user($addr->usr);
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+ my $result = $e->json_query({from => ['actor.approve_pending_address', $addr->id]})->[0]
+ or return $e->die_event;
+ $e->commit;
+ return [values %$result]->[0];
+}
+
+
+__PACKAGE__->register_method (
+ method => 'retrieve_friends',
+ api_name => 'open-ils.actor.friends.retrieve',
+ signature => {
+ desc => q/
+ returns { confirmed: [], pending_out: [], pending_in: []}
+ pending_out are users I'm requesting friendship with
+ pending_in are users requesting friendship with me
+ /
+ }
+);
+
+sub retrieve_friends {
+ my($self, $conn, $auth, $user_id, $options) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ $user_id ||= $e->requestor->id;
+
+ if($user_id != $e->requestor->id) {
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ }
+
+ return OpenILS::Application::Actor::Friends->retrieve_friends(
+ $e, $user_id, $options);
+}
+
+
+
+__PACKAGE__->register_method (
+ method => 'apply_friend_perms',
+ api_name => 'open-ils.actor.friends.perms.apply',
+ signature => {
+ desc => q/
+ /
+ }
+);
+sub apply_friend_perms {
+ my($self, $conn, $auth, $user_id, $delegate_id, @perms) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ if($user_id != $e->requestor->id) {
+ my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('VIEW_USER', $user->home_ou);
+ }
+
+ for my $perm (@perms) {
+ my $evt =
+ OpenILS::Application::Actor::Friends->apply_friend_perm(
+ $e, $user_id, $delegate_id, $perm);
+ return $evt if $evt;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method (
+ method => 'update_user_pending_address',
+ api_name => 'open-ils.actor.user.address.pending.cud'
+);
+
+sub update_user_pending_address {
+ my($self, $conn, $auth, $addr) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ if($addr->usr != $e->requestor->id) {
+ my $user = $e->retrieve_actor_user($addr->usr) or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+ }
+
+ if($addr->isnew) {
+ $e->create_actor_user_address($addr) or return $e->die_event;
+ } elsif($addr->isdeleted) {
+ $e->delete_actor_user_address($addr) or return $e->die_event;
+ } else {
+ $e->update_actor_user_address($addr) or return $e->die_event;
+ }
+
+ $e->commit;
+ return $addr->id;
+}
+
+
+__PACKAGE__->register_method (
+ method => 'user_events',
+ api_name => 'open-ils.actor.user.events.circ',
+ stream => 1,
+);
+__PACKAGE__->register_method (
+ method => 'user_events',
+ api_name => 'open-ils.actor.user.events.ahr',
+ stream => 1,
+);
+
+sub user_events {
+ my($self, $conn, $auth, $user_id, $filters) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ (my $obj_type = $self->api_name) =~ s/.*\.([a-z]+)$/$1/;
+ my $user_field = 'usr';
+
+ $filters ||= {};
+ $filters->{target} = {
+ select => { $obj_type => ['id'] },
+ from => $obj_type,
+ where => {usr => $user_id}
+ };
+
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ if($e->requestor->id != $user_id) {
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ }
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ my $req = $ses->request('open-ils.trigger.events_by_target',
+ $obj_type, $filters, {atevdef => ['reactor', 'validator']}, 2);
+
+ while(my $resp = $req->recv) {
+ my $val = $resp->content;
+ my $tgt = $val->target;
+
+ if($obj_type eq 'circ') {
+ $tgt->target_copy($e->retrieve_asset_copy($tgt->target_copy));
+
+ } elsif($obj_type eq 'ahr') {
+ $tgt->current_copy($e->retrieve_asset_copy($tgt->current_copy))
+ if $tgt->current_copy;
+ }
+
+ $conn->respond($val) if $val;
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method (
+ method => 'copy_events',
+ api_name => 'open-ils.actor.copy.events.circ',
+ stream => 1,
+);
+__PACKAGE__->register_method (
+ method => 'copy_events',
+ api_name => 'open-ils.actor.copy.events.ahr',
+ stream => 1,
+);
+
+sub copy_events {
+ my($self, $conn, $auth, $copy_id, $filters) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ (my $obj_type = $self->api_name) =~ s/.*\.([a-z]+)$/$1/;
+
+ my $copy = $e->retrieve_asset_copy($copy_id) or return $e->event;
+
+ my $copy_field = 'target_copy';
+ $copy_field = 'current_copy' if $obj_type eq 'ahr';
+
+ $filters ||= {};
+ $filters->{target} = {
+ select => { $obj_type => ['id'] },
+ from => $obj_type,
+ where => {$copy_field => $copy_id}
+ };
+
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ my $req = $ses->request('open-ils.trigger.events_by_target',
+ $obj_type, $filters, {atevdef => ['reactor', 'validator']}, 2);
+
+ while(my $resp = $req->recv) {
+ my $val = $resp->content;
+ my $tgt = $val->target;
+
+ my $user = $e->retrieve_actor_user($tgt->usr);
+ if($e->requestor->id != $user->id) {
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ }
+
+ $tgt->$copy_field($copy);
+
+ $tgt->usr($user);
+ $conn->respond($val) if $val;
+ }
+
+ return undef;
+}
+
+
+
+
+__PACKAGE__->register_method (
+ method => 'update_events',
+ api_name => 'open-ils.actor.user.event.cancel.batch',
+ stream => 1,
+);
+__PACKAGE__->register_method (
+ method => 'update_events',
+ api_name => 'open-ils.actor.user.event.reset.batch',
+ stream => 1,
+);
+
+sub update_events {
+ my($self, $conn, $auth, $event_ids) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $x = 1;
+ for my $id (@$event_ids) {
+
+ # do a little dance to determine what user we are ultimately affecting
+ my $event = $e->retrieve_action_trigger_event([
+ $id,
+ { flesh => 2,
+ flesh_fields => {atev => ['event_def'], atevdef => ['hook']}
+ }
+ ]) or return $e->die_event;
+
+ my $user_id;
+ if($event->event_def->hook->core_type eq 'circ') {
+ $user_id = $e->retrieve_action_circulation($event->target)->usr;
+ } elsif($event->event_def->hook->core_type eq 'ahr') {
+ $user_id = $e->retrieve_action_hold_request($event->target)->usr;
+ } else {
+ return 0;
+ }
+
+ my $user = $e->retrieve_actor_user($user_id);
+ return $e->die_event unless $e->allowed('UPDATE_USER', $user->home_ou);
+
+ if($self->api_name =~ /cancel/) {
+ $event->state('invalid');
+ } elsif($self->api_name =~ /reset/) {
+ $event->clear_start_time;
+ $event->clear_update_time;
+ $event->state('pending');
+ }
+
+ $e->update_action_trigger_event($event) or return $e->die_event;
+ $conn->respond({maximum => scalar(@$event_ids), progress => $x++});
+ }
+
+ $e->commit;
+ return {complete => 1};
+}
+
+
+__PACKAGE__->register_method (
+ method => 'really_delete_user',
+ api_name => 'open-ils.actor.user.delete',
+ signature => q/
+ It anonymizes all personally identifiable information in actor.usr. By calling actor.usr_purge_data()
+ it also purges related data from other tables, sometimes by transferring it to a designated destination user.
+ The usrname field (along with first_given_name and family_name) is updated to id '-PURGED-' now().
+ dest_usr_id is only required when deleting a user that performs staff functions.
+ /
+);
+
+sub really_delete_user {
+ my($self, $conn, $auth, $user_id, $dest_user_id) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ my $user = $e->retrieve_actor_user($user_id) or return $e->die_event;
+ return $e->die_event unless $e->allowed('DELETE_USER', $user->home_ou);
+ my $stat = $e->json_query(
+ {from => ['actor.usr_delete', $user_id, $dest_user_id]})->[0]
+ or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method (
+ method => 'user_payments',
+ api_name => 'open-ils.actor.user.payments.retrieve',
+ stream => 1,
+ signature => q/
+ Returns all payments for a given user. Default order is newest payments first.
+ @param auth Authentication token
+ @param user_id The user ID
+ @param filters An optional hash of filters, including limit, offset, and order_by definitions
+ /
+);
+
+sub user_payments {
+ my($self, $conn, $auth, $user_id, $filters) = @_;
+ $filters ||= {};
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_USER_TRANSACTIONS', $user->home_ou);
+
+ # Find all payments for all transactions for user $user_id
+ my $query = {
+ select => {mp => ['id']},
+ from => 'mp',
+ where => {
+ xact => {
+ in => {
+ select => {mbt => ['id']},
+ from => 'mbt',
+ where => {usr => $user_id}
+ }
+ }
+ },
+ order_by => [{ # by default, order newest payments first
+ class => 'mp',
+ field => 'payment_ts',
+ direction => 'desc'
+ }]
+ };
+
+ for (qw/order_by limit offset/) {
+ $query->{$_} = $filters->{$_} if defined $filters->{$_};
+ }
+
+ if(defined $filters->{where}) {
+ foreach (keys %{$filters->{where}}) {
+ # don't allow the caller to expand the result set to other users
+ $query->{where}->{$_} = $filters->{where}->{$_} unless $_ eq 'xact';
+ }
+ }
+
+ my $payment_ids = $e->json_query($query);
+ for my $pid (@$payment_ids) {
+ my $pay = $e->retrieve_money_payment([
+ $pid->{id},
+ { flesh => 6,
+ flesh_fields => {
+ mp => ['xact'],
+ mbt => ['summary', 'circulation', 'grocery'],
+ circ => ['target_copy'],
+ acp => ['call_number'],
+ acn => ['record']
+ }
+ }
+ ]);
+
+ my $resp = {
+ mp => $pay,
+ xact_type => $pay->xact->summary->xact_type,
+ last_billing_type => $pay->xact->summary->last_billing_type,
+ };
+
+ if($pay->xact->summary->xact_type eq 'circulation') {
+ $resp->{barcode} = $pay->xact->circulation->target_copy->barcode;
+ $resp->{title} = $U->record_to_mvr($pay->xact->circulation->target_copy->call_number->record)->title;
+ }
+
+ $pay->xact($pay->xact->id); # de-flesh
+ $conn->respond($resp);
+ }
+
+ return undef;
+}
+
+
+
+__PACKAGE__->register_method (
+ method => 'negative_balance_users',
+ api_name => 'open-ils.actor.users.negative_balance',
+ stream => 1,
+ signature => q/
+ Returns all users that have an overall negative balance
+ @param auth Authentication token
+ @param org_id The context org unit as an ID or list of IDs. This will be the home
+ library of the user. If no org_unit is specified, no org unit filter is applied
+ /
+);
+
+sub negative_balance_users {
+ my($self, $conn, $auth, $org_id) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('VIEW_USER', $org_id);
+
+ my $query = {
+ select => {
+ mous => ['usr', 'balance_owed'],
+ au => ['home_ou'],
+ mbts => [
+ {column => 'last_billing_ts', transform => 'max', aggregate => 1},
+ {column => 'last_payment_ts', transform => 'max', aggregate => 1},
+ ]
+ },
+ from => {
+ mous => {
+ au => {
+ fkey => 'usr',
+ field => 'id',
+ join => {
+ mbts => {
+ key => 'id',
+ field => 'usr'
+ }
+ }
+ }
+ }
+ },
+ where => {'+mous' => {balance_owed => {'<' => 0}}}
+ };
+
+ $query->{from}->{mous}->{au}->{filter}->{home_ou} = $org_id if $org_id;
+
+ my $list = $e->json_query($query, {timeout => 600});
+
+ for my $data (@$list) {
+ $conn->respond({
+ usr => $e->retrieve_actor_user([$data->{usr}, {flesh => 1, flesh_fields => {au => ['card']}}]),
+ balance_owed => $data->{balance_owed},
+ last_billing_activity => max($data->{last_billing_ts}, $data->{last_payment_ts})
+ });
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "request_password_reset",
+ api_name => "open-ils.actor.patron.password_reset.request",
+ signature => {
+ desc => "Generates a UUID token usable with the open-ils.actor.patron.password_reset.commit " .
+ "method for changing a user's password. The UUID token is distributed via A/T " .
+ "templates (i.e. email to the user).",
+ params => [
+ { desc => 'user_id_type', type => 'string' },
+ { desc => 'user_id', type => 'string' },
+ { desc => 'optional (based on library setting) matching email address for authorizing request', type => 'string' },
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+sub request_password_reset {
+ my($self, $conn, $user_id_type, $user_id, $email) = @_;
+
+ # Check to see if password reset requests are already being throttled:
+ # 0. Check cache to see if we're in throttle mode (avoid hitting database)
+
+ my $e = new_editor(xact => 1);
+ my $user;
+
+ # Get the user, if any, depending on the input value
+ if ($user_id_type eq 'username') {
+ $user = $e->search_actor_user({usrname => $user_id})->[0];
+ if (!$user) {
+ $e->die_event;
+ return OpenILS::Event->new( 'ACTOR_USER_NOT_FOUND' );
+ }
+ } elsif ($user_id_type eq 'barcode') {
+ my $card = $e->search_actor_card([
+ {barcode => $user_id},
+ {flesh => 1, flesh_fields => {ac => ['usr']}}])->[0];
+ if (!$card) {
+ $e->die_event;
+ return OpenILS::Event->new('ACTOR_USER_NOT_FOUND');
+ }
+ $user = $card->usr;
+ }
+
+ # If the user doesn't have an email address, we can't help them
+ if (!$user->email) {
+ $e->die_event;
+ return OpenILS::Event->new('PATRON_NO_EMAIL_ADDRESS');
+ }
+
+ my $email_must_match = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_requires_matching_email');
+ if ($email_must_match) {
+ if ($user->email ne $email) {
+ return OpenILS::Event->new('EMAIL_VERIFICATION_FAILED');
+ }
+ }
+
+ _reset_password_request($conn, $e, $user);
+}
+
+# Once we have the user, we can issue the password reset request
+# XXX Add a wrapper method that accepts barcode + email input
+sub _reset_password_request {
+ my ($conn, $e, $user) = @_;
+
+ # 1. Get throttle threshold and time-to-live from OU_settings
+ my $aupr_throttle = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_throttle') || 1000;
+ my $aupr_ttl = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_time_to_live') || 24*60*60;
+
+ my $threshold_time = DateTime->now(time_zone => 'local')->subtract(seconds => $aupr_ttl)->iso8601();
+
+ # 2. Get time of last request and number of active requests (num_active)
+ my $active_requests = $e->json_query({
+ from => 'aupr',
+ select => {
+ aupr => [
+ {
+ column => 'uuid',
+ transform => 'COUNT'
+ },
+ {
+ column => 'request_time',
+ transform => 'MAX'
+ }
+ ]
+ },
+ where => {
+ has_been_reset => { '=' => 'f' },
+ request_time => { '>' => $threshold_time }
+ }
+ });
+
+ # Guard against no active requests
+ if ($active_requests->[0]->{'request_time'}) {
+ my $last_request = DateTime::Format::ISO8601->parse_datetime(clense_ISO8601($active_requests->[0]->{'request_time'}));
+ my $now = DateTime::Format::ISO8601->new();
+
+ # 3. if (num_active > throttle_threshold) and (now - last_request < 1 minute)
+ if (($active_requests->[0]->{'usr'} > $aupr_throttle) &&
+ ($last_request->add_duration('1 minute') > $now)) {
+ $cache->put_cache('open-ils.actor.password.throttle', DateTime::Format::ISO8601->new(), 60);
+ $e->die_event;
+ return OpenILS::Event->new('PATRON_TOO_MANY_ACTIVE_PASSWORD_RESET_REQUESTS');
+ }
+ }
+
+ # TODO Check to see if the user is in a password-reset-restricted group
+
+ # Otherwise, go ahead and try to get the user.
+
+ # Check the number of active requests for this user
+ $active_requests = $e->json_query({
+ from => 'aupr',
+ select => {
+ aupr => [
+ {
+ column => 'usr',
+ transform => 'COUNT'
+ }
+ ]
+ },
+ where => {
+ usr => { '=' => $user->id },
+ has_been_reset => { '=' => 'f' },
+ request_time => { '>' => $threshold_time }
+ }
+ });
+
+ $logger->info("User " . $user->id . " has " . $active_requests->[0]->{'usr'} . " active password reset requests.");
+
+ # if less than or equal to per-user threshold, proceed; otherwise, return event
+ my $aupr_per_user_limit = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_per_user_limit') || 3;
+ if ($active_requests->[0]->{'usr'} > $aupr_per_user_limit) {
+ $e->die_event;
+ return OpenILS::Event->new('PATRON_TOO_MANY_ACTIVE_PASSWORD_RESET_REQUESTS');
+ }
+
+ # Create the aupr object and insert into the database
+ my $reset_request = Fieldmapper::actor::usr_password_reset->new;
+ my $uuid = create_uuid_as_string(UUID_V4);
+ $reset_request->uuid($uuid);
+ $reset_request->usr($user->id);
+
+ my $aupr = $e->create_actor_usr_password_reset($reset_request) or return $e->die_event;
+ $e->commit;
+
+ # Create an event to notify user of the URL to reset their password
+
+ # Can we stuff this in the user_data param for trigger autocreate?
+ my $hostname = $U->ou_ancestor_setting_value($user->home_ou, 'lib.hostname') || 'localhost';
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'password.reset_request', $aupr, $user->home_ou);
+
+ # Trunk only
+ # $U->create_trigger_event('password.reset_request', $aupr, $user->home_ou);
+
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "commit_password_reset",
+ api_name => "open-ils.actor.patron.password_reset.commit",
+ signature => {
+ desc => "Checks a UUID token generated by the open-ils.actor.patron.password_reset.request method for " .
+ "validity, and if valid, uses it as authorization for changing the associated user's password " .
+ "with the supplied password.",
+ params => [
+ { desc => 'uuid', type => 'string' },
+ { desc => 'password', type => 'string' },
+ ],
+ return => {desc => '1 on success, Event on error'}
+ }
+);
+sub commit_password_reset {
+ my($self, $conn, $uuid, $password) = @_;
+
+ # Check to see if password reset requests are already being throttled:
+ # 0. Check cache to see if we're in throttle mode (avoid hitting database)
+ $cache ||= OpenSRF::Utils::Cache->new("global", 0);
+ my $throttle = $cache->get_cache('open-ils.actor.password.throttle') || undef;
+ if ($throttle) {
+ return OpenILS::Event->new('PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST');
+ }
+
+ my $e = new_editor(xact => 1);
+
+ my $aupr = $e->search_actor_usr_password_reset({
+ uuid => $uuid,
+ has_been_reset => 0
+ });
+
+ if (!$aupr->[0]) {
+ $e->die_event;
+ return OpenILS::Event->new('PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST');
+ }
+ my $user_id = $aupr->[0]->usr;
+ my $user = $e->retrieve_actor_user($user_id);
+
+ # Ensure we're still within the TTL for the request
+ my $aupr_ttl = $U->ou_ancestor_setting_value($user->home_ou, 'circ.password_reset_request_time_to_live') || 24*60*60;
+ my $threshold = DateTime::Format::ISO8601->parse_datetime(clense_ISO8601($aupr->[0]->request_time))->add(seconds => $aupr_ttl);
+ if ($threshold < DateTime->now(time_zone => 'local')) {
+ $e->die_event;
+ $logger->info("Password reset request needed to be submitted before $threshold");
+ return OpenILS::Event->new('PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST');
+ }
+
+ # Check complexity of password against OU-defined regex
+ my $pw_regex = $U->ou_ancestor_setting_value($user->home_ou, 'global.password_regex');
+
+ my $is_strong = 0;
+ if ($pw_regex) {
+ # Calling JSON2perl on the $pw_regex causes failure, even before the fancy Unicode regex
+ # ($pw_regex = OpenSRF::Utils::JSON->JSON2perl($pw_regex)) =~ s/\\u([0-9a-fA-F]{4})/\\x{$1}/gs;
+ $is_strong = check_password_strength_custom($password, $pw_regex);
+ } else {
+ $is_strong = check_password_strength_default($password);
+ }
+
+ if (!$is_strong) {
+ $e->die_event;
+ return OpenILS::Event->new('PATRON_PASSWORD_WAS_NOT_STRONG');
+ }
+
+ # All is well; update the password
+ $user->passwd($password);
+ $e->update_actor_user($user);
+
+ # And flag that this password reset request has been honoured
+ $aupr->[0]->has_been_reset('t');
+ $e->update_actor_usr_password_reset($aupr->[0]);
+ $e->commit;
+
+ return 1;
+}
+
+sub check_password_strength_default {
+ my $password = shift;
+ # Use the default set of checks
+ if ( (length($password) < 7) or
+ ($password !~ m/.*\d+.*/) or
+ ($password !~ m/.*[A-Za-z]+.*/)
+ ) {
+ return 0;
+ }
+ return 1;
+}
+
+sub check_password_strength_custom {
+ my ($password, $pw_regex) = @_;
+
+ $pw_regex = qr/$pw_regex/;
+ if ($password !~ /$pw_regex/) {
+ return 0;
+ }
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "event_def_opt_in_settings",
+ api_name => "open-ils.actor.event_def.opt_in.settings",
+ stream => 1,
+ signature => {
+ desc => 'Streams the set of "cust" objects that are used as opt-in settings for event definitions',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ {
+ desc => 'Org Unit ID. (optional). If no org ID is present, the home_ou of the requesting user is used',
+ type => 'number'
+ },
+ ],
+ return => {
+ desc => q/set of "cust" objects that are used as opt-in settings for event definitions at the specified org unit/,
+ type => 'object',
+ class => 'cust'
+ }
+ }
+);
+
+sub event_def_opt_in_settings {
+ my($self, $conn, $auth, $org_id) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ if(defined $org_id and $org_id != $e->requestor->home_ou) {
+ return $e->event unless
+ $e->allowed(['VIEW_USER_SETTING_TYPE', 'ADMIN_USER_SETTING_TYPE'], $org_id);
+ } else {
+ $org_id = $e->requestor->home_ou;
+ }
+
+ # find all config.user_setting_type's related to event_defs for the requested org unit
+ my $types = $e->json_query({
+ select => {cust => ['name']},
+ from => {atevdef => 'cust'},
+ where => {
+ '+atevdef' => {
+ owner => $U->get_org_ancestors($org_id), # context org plus parents
+ active => 't'
+ }
+ }
+ });
+
+ if(@$types) {
+ $conn->respond($_) for
+ @{$e->search_config_usr_setting_type({name => [map {$_->{name}} @$types]})};
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "user_visible_circs",
+ api_name => "open-ils.actor.history.circ.visible",
+ stream => 1,
+ signature => {
+ desc => 'Returns the set of opt-in visible circulations accompanied by circulation chain summaries',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
+ { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
+ ],
+ return => {
+ desc => q/An object with 2 fields: circulation and summary.
+ circulation is the "circ" object. summary is the related "accs" object/,
+ type => 'object',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "user_visible_circs",
+ api_name => "open-ils.actor.history.circ.visible.print",
+ stream => 1,
+ signature => {
+ desc => 'Returns printable output for the set of opt-in visible circulations',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
+ { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
+ ],
+ return => {
+ desc => q/An action_trigger.event object or error event./,
+ type => 'object',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "user_visible_circs",
+ api_name => "open-ils.actor.history.circ.visible.email",
+ stream => 1,
+ signature => {
+ desc => 'Emails the set of opt-in visible circulations to the requestor',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
+ { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
+ ],
+ return => {
+ desc => q/undef, or event on error/
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "user_visible_circs",
+ api_name => "open-ils.actor.history.hold.visible",
+ stream => 1,
+ signature => {
+ desc => 'Returns the set of opt-in visible holds',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
+ { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
+ ],
+ return => {
+ desc => q/An object with 1 field: "hold"/,
+ type => 'object',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "user_visible_circs",
+ api_name => "open-ils.actor.history.hold.visible.print",
+ stream => 1,
+ signature => {
+ desc => 'Returns printable output for the set of opt-in visible holds',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
+ { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
+ ],
+ return => {
+ desc => q/An action_trigger.event object or error event./,
+ type => 'object',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "user_visible_circs",
+ api_name => "open-ils.actor.history.hold.visible.email",
+ stream => 1,
+ signature => {
+ desc => 'Emails the set of opt-in visible holds to the requestor',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'User ID. If no user id is present, the authenticated user is assumed', type => 'number' },
+ { desc => 'Options hash. Supported fields are "limit" and "offset"', type => 'object' },
+ ],
+ return => {
+ desc => q/undef, or event on error/
+ }
+ }
+);
+
+sub user_visible_circs {
+ my($self, $conn, $auth, $user_id, $options) = @_;
+
+ my $is_hold = ($self->api_name =~ /hold/);
+ my $for_print = ($self->api_name =~ /print/);
+ my $for_email = ($self->api_name =~ /email/);
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ $user_id ||= $e->requestor->id;
+ $options ||= {};
+ $options->{limit} ||= 50;
+ $options->{offset} ||= 0;
+
+ if($user_id != $e->requestor->id) {
+ my $perm = ($is_hold) ? 'VIEW_HOLD' : 'VIEW_CIRCULATIONS';
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed($perm, $user->home_ou);
+ }
+
+ my $db_func = ($is_hold) ? 'action.usr_visible_holds' : 'action.usr_visible_circs';
+
+ my $data = $e->json_query({
+ from => [$db_func, $user_id],
+ limit => $$options{limit},
+ offset => $$options{offset}
+
+ # TODO: I only want IDs. code below didn't get me there
+ # {"select":{"au":[{"column":"id", "result_field":"id",
+ # "transform":"action.usr_visible_circs"}]}, "where":{"id":10}, "from":"au"}
+ },{
+ substream => 1
+ });
+
+ return undef unless @$data;
+
+ if ($for_print) {
+
+ # collect the batch of objects
+
+ if($is_hold) {
+
+ my $hold_list = $e->search_action_hold_request({id => [map { $_->{id} } @$data]});
+ return $U->fire_object_event(undef, 'ahr.format.history.print', $hold_list, $$hold_list[0]->request_lib);
+
+ } else {
+
+ my $circ_list = $e->search_action_circulation({id => [map { $_->{id} } @$data]});
+ return $U->fire_object_event(undef, 'circ.format.history.print', $circ_list, $$circ_list[0]->circ_lib);
+ }
+
+ } elsif ($for_email) {
+
+ $conn->respond_complete(1) if $for_email; # no sense in waiting
+
+ foreach (@$data) {
+
+ my $id = $_->{id};
+
+ if($is_hold) {
+
+ my $hold = $e->retrieve_action_hold_request($id);
+ $U->create_events_for_hook('ahr.format.history.email', $hold, $hold->request_lib, undef, undef, 1);
+ # events will be fired from action_trigger_runner
+
+ } else {
+
+ my $circ = $e->retrieve_action_circulation($id);
+ $U->create_events_for_hook('circ.format.history.email', $circ, $circ->circ_lib, undef, undef, 1);
+ # events will be fired from action_trigger_runner
+ }
+ }
+
+ } else { # just give me the data please
+
+ foreach (@$data) {
+
+ my $id = $_->{id};
+
+ if($is_hold) {
+
+ my $hold = $e->retrieve_action_hold_request($id);
+ $conn->respond({hold => $hold});
+
+ } else {
+
+ my $circ = $e->retrieve_action_circulation($id);
+ $conn->respond({
+ circ => $circ,
+ summary => $U->create_circ_chain_summary($e, $id)
+ });
+ }
+ }
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "user_saved_search_cud",
+ api_name => "open-ils.actor.user.saved_search.cud",
+ stream => 1,
+ signature => {
+ desc => 'Create/Update/Delete Access to user saved searches',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Saved Search Object', type => 'object', class => 'auss' }
+ ],
+ return => {
+ desc => q/The retrieved or updated saved search object, or id of a deleted object; Event on error/,
+ class => 'auss'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "user_saved_search_cud",
+ api_name => "open-ils.actor.user.saved_search.retrieve",
+ stream => 1,
+ signature => {
+ desc => 'Retrieve a saved search object',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Saved Search ID', type => 'number' }
+ ],
+ return => {
+ desc => q/The saved search object, Event on error/,
+ class => 'auss'
+ }
+ }
+);
+
+sub user_saved_search_cud {
+ my( $self, $client, $auth, $search ) = @_;
+ my $e = new_editor( authtoken=>$auth );
+ return $e->die_event unless $e->checkauth;
+
+ my $o_search; # prior version of the object, if any
+ my $res; # to be returned
+
+ # branch on the operation type
+
+ if( $self->api_name =~ /retrieve/ ) { # Retrieve
+
+ # Get the old version, to check ownership
+ $o_search = $e->retrieve_actor_usr_saved_search( $search )
+ or return $e->die_event;
+
+ # You can't read somebody else's search
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $o_search->owner == $e->requestor->id;
+
+ $res = $o_search;
+
+ } else {
+
+ $e->xact_begin; # start an editor transaction
+
+ if( $search->isnew ) { # Create
+
+ # You can't create a search for somebody else
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $search->owner == $e->requestor->id;
+
+ $e->create_actor_usr_saved_search( $search )
+ or return $e->die_event;
+
+ $res = $search->id;
+
+ } elsif( $search->ischanged ) { # Update
+
+ # You can't change ownership of a search
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $search->owner == $e->requestor->id;
+
+ # Get the old version, to check ownership
+ $o_search = $e->retrieve_actor_usr_saved_search( $search->id )
+ or return $e->die_event;
+
+ # You can't update somebody else's search
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $o_search->owner == $e->requestor->id;
+
+ # Do the update
+ $e->update_actor_usr_saved_search( $search )
+ or return $e->die_event;
+
+ $res = $search;
+
+ } elsif( $search->isdeleted ) { # Delete
+
+ # Get the old version, to check ownership
+ $o_search = $e->retrieve_actor_usr_saved_search( $search->id )
+ or return $e->die_event;
+
+ # You can't delete somebody else's search
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $o_search->owner == $e->requestor->id;
+
+ # Do the delete
+ $e->delete_actor_usr_saved_search( $o_search )
+ or return $e->die_event;
+
+ $res = $search->id;
+ }
+
+ $e->commit;
+ }
+
+ return $res;
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::Actor::ClosedDates;
+use base 'OpenILS::Application';
+use strict; use warnings;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Editor q/:funcs/;
+
+sub initialize { return 1; }
+
+__PACKAGE__->register_method(
+ method => 'fetch_dates',
+ api_name => 'open-ils.actor.org_unit.closed.retrieve.all',
+ signature => q/
+ Retrieves a list of closed date object IDs
+ /
+);
+
+sub fetch_dates {
+ my( $self, $conn, $auth, $args ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $org = $$args{orgid} || $e->requestor->ws_ou;
+ my @date = localtime;
+ my $start = $$args{start_date} || #default to today
+ ($date[5] + 1900) .'-'. ($date[4] + 1) .'-'. $date[3];
+ my $end = $$args{end_date} || '3000-01-01'; # Y3K, here I come..
+
+ my $dates = $e->search_actor_org_unit_closed_date(
+ {
+ close_start => { ">=" => $start },
+ close_end => { "<=" => $end },
+ org_unit => $org,
+ }, { idlist => $$args{idlist} } ) or return $e->event;
+
+ if(!$$args{idlist} and @$dates) {
+ $dates = [ sort { $a->close_start cmp $b->close_start } @$dates ];
+ }
+
+ return $dates;
+}
+
+__PACKAGE__->register_method(
+ method => 'fetch_date',
+ api_name => 'open-ils.actor.org_unit.closed.retrieve',
+ signature => q/
+ Retrieves a single date object
+ /
+);
+
+sub fetch_date {
+ my( $self, $conn, $auth, $id ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $date = $e->retrieve_actor_org_unit_closed_date($id) or return $e->event;
+ return $date;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_date',
+ api_name => 'open-ils.actor.org_unit.closed.delete',
+ signature => q/
+ Removes a single date object
+ /
+);
+
+sub delete_date {
+ my( $self, $conn, $auth, $id ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $date = $e->retrieve_actor_org_unit_closed_date($id) or return $e->event;
+ return $e->event unless $e->allowed( # rely on the editor perm eventually
+ 'actor.org_unit.closed_date.delete', $date->org_unit);
+ $e->delete_actor_org_unit_closed_date($date) or return $e->event;
+ return 1;
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => 'create_date',
+ api_name => 'open-ils.actor.org_unit.closed.create',
+ signature => q/
+ Creates a new org closed data
+ /
+);
+
+sub create_date {
+ my( $self, $conn, $auth, $date ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact =>1);
+ return $e->event unless $e->checkauth;
+
+ return $e->event unless $e->allowed( # rely on the editor perm eventually
+ 'actor.org_unit.closed_date.create', $date->org_unit);
+
+ $e->create_actor_org_unit_closed_date($date) or return $e->event;
+
+ my $newobj = $e->retrieve_actor_org_unit_closed_date($date->id)
+ or return $e->event;
+
+ $e->commit;
+ return $newobj;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'edit_date',
+ api_name => 'open-ils.actor.org_unit.closed.update',
+ signature => q/
+ Updates a closed date object
+ /
+);
+
+sub edit_date {
+ my( $self, $conn, $auth, $date ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact =>1);
+ return $e->event unless $e->checkauth;
+
+ # First make sure they have the right to update the selected date object
+ my $odate = $e->retrieve_actor_org_unit_closed_date($date->id)
+ or return $e->event;
+
+ return $e->event unless $e->allowed( # rely on the editor perm eventually
+ 'actor.org_unit.closed_date.update', $odate->org_unit);
+
+ $e->update_actor_org_unit_closed_date($date) or return $e->event;
+
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'closed_dates_overlap',
+ api_name => 'open-ils.actor.org_unit.closed_date.overlap',
+ signature => q/
+ Returns an object with 'start' and 'end' fields
+ start is the first day the org is open going backwards from
+ 'date'. end is the next day the org is open going
+ forward from 'date'.
+ @param orgid The org unit in question
+ @param date The date to search
+ /
+);
+sub closed_dates_overlap {
+ my( $self, $conn, $auth, $orgid, $date ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->request(
+ 'open-ils.storage.actor.org_unit.closed_date.overlap', $orgid, $date );
+}
+
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::Actor::Container;
+use base 'OpenILS::Application';
+use strict; use warnings;
+use OpenILS::Application::AppUtils;
+use OpenILS::Perm;
+use Data::Dumper;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Cache;
+use Digest::MD5 qw(md5_hex);
+use OpenSRF::Utils::JSON;
+
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+my $logger = "OpenSRF::Utils::Logger";
+
+sub initialize { return 1; }
+
+my $svc = 'open-ils.cstore';
+my $meth = 'open-ils.cstore.direct.container';
+my %types;
+my %ctypes;
+$types{'biblio'} = "$meth.biblio_record_entry_bucket";
+$types{'callnumber'} = "$meth.call_number_bucket";
+$types{'copy'} = "$meth.copy_bucket";
+$types{'user'} = "$meth.user_bucket";
+$ctypes{'biblio'} = "container_biblio_record_entry_bucket";
+$ctypes{'callnumber'} = "container_call_number_bucket";
+$ctypes{'copy'} = "container_copy_bucket";
+$ctypes{'user'} = "container_user_bucket";
+my $event;
+
+sub _sort_buckets {
+ my $buckets = shift;
+ return $buckets unless ($buckets && $buckets->[0]);
+ return [ sort { $a->name cmp $b->name } @$buckets ];
+}
+
+__PACKAGE__->register_method(
+ method => "bucket_retrieve_all",
+ api_name => "open-ils.actor.container.all.retrieve_by_user",
+ authoritative => 1,
+ notes => <<" NOTES");
+ Retrieves all un-fleshed buckets assigned to given user
+ PARAMS(authtoken, bucketOwnerId)
+ If requestor ID is different than bucketOwnerId, requestor must have
+ VIEW_CONTAINER permissions.
+ NOTES
+
+sub bucket_retrieve_all {
+ my($self, $client, $auth, $user_id) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ if($e->requestor->id ne $user_id) {
+ return $e->event unless $e->allowed('VIEW_CONTAINER');
+ }
+
+ my %buckets;
+ for my $type (keys %ctypes) {
+ my $meth = "search_" . $ctypes{$type};
+ $buckets{$type} = $e->$meth({owner => $user_id});
+ }
+
+ return \%buckets;
+}
+
+__PACKAGE__->register_method(
+ method => "bucket_flesh",
+ api_name => "open-ils.actor.container.flesh",
+ authoritative => 1,
+ argc => 3,
+);
+
+__PACKAGE__->register_method(
+ method => "bucket_flesh_pub",
+ api_name => "open-ils.actor.container.public.flesh",
+ argc => 3,
+);
+
+sub bucket_flesh {
+ my($self, $conn, $auth, $class, $bucket_id) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return _bucket_flesh($self, $conn, $e, $class, $bucket_id);
+}
+
+sub bucket_flesh_pub {
+ my($self, $conn, $class, $bucket_id) = @_;
+ my $e = new_editor();
+ return _bucket_flesh($self, $conn, $e, $class, $bucket_id);
+}
+
+sub _bucket_flesh {
+ my($self, $conn, $e, $class, $bucket_id) = @_;
+ my $meth = 'retrieve_' . $ctypes{$class};
+ my $bkt = $e->$meth($bucket_id) or return $e->event;
+
+ unless($U->is_true($bkt->pub)) {
+ return undef if $self->api_name =~ /public/;
+ unless($bkt->owner eq $e->requestor->id) {
+ my $owner = $e->retrieve_actor_user($bkt->owner)
+ or return $e->die_event;
+ return $e->event unless $e->allowed('VIEW_CONTAINER', $owner->home_ou);
+ }
+ }
+
+ my $fmclass = $bkt->class_name . "i";
+ $meth = 'search_' . $ctypes{$class} . '_item';
+ $bkt->items(
+ $e->$meth(
+ {bucket => $bucket_id},
+ { order_by => {$fmclass => "pos"},
+ flesh => 1,
+ flesh_fields => {$fmclass => ['notes']}
+ }
+ )
+ );
+
+ return $bkt;
+}
+
+
+__PACKAGE__->register_method(
+ method => "item_note_cud",
+ api_name => "open-ils.actor.container.item_note.cud",
+);
+
+
+sub item_note_cud {
+ my($self, $conn, $auth, $class, $note) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $meth = 'retrieve_' . $ctypes{$class};
+ my $nclass = $note->class_name;
+ (my $iclass = $nclass) =~ s/n$//og;
+
+ my $db_note = $e->$meth($note->id, {
+ flesh => 2,
+ flesh_fields => {
+ $nclass => ['item'],
+ $iclass => ['bucket']
+ }
+ });
+
+ if($db_note->item->bucket->owner ne $e->requestor->id) {
+ return $e->die_event unless
+ $e->allowed('UPDATE_CONTAINER', $db_note->item->bucket);
+ }
+
+ $meth = 'create_' . $ctypes{$class} if $note->isnew;
+ $meth = 'update_' . $ctypes{$class} if $note->ischanged;
+ $meth = 'delete_' . $ctypes{$class} if $note->isdeleted;
+ return $e->die_event unless $e->$meth($note);
+ $e->commit;
+}
+
+
+__PACKAGE__->register_method(
+ method => "bucket_retrieve_class",
+ api_name => "open-ils.actor.container.retrieve_by_class",
+ argc => 3,
+ notes => <<" NOTES");
+ Retrieves all un-fleshed buckets by class assigned to given user
+ PARAMS(authtoken, bucketOwnerId, class [, type])
+ class can be one of "biblio", "callnumber", "copy", "user"
+ The optional "type" parameter allows you to limit the search by
+ bucket type.
+ If bucketOwnerId is not defined, the authtoken is used as the
+ bucket owner.
+ If requestor ID is different than bucketOwnerId, requestor must have
+ VIEW_CONTAINER permissions.
+ NOTES
+
+sub bucket_retrieve_class {
+ my( $self, $client, $authtoken, $userid, $class, $type ) = @_;
+
+ my( $staff, $user, $evt ) =
+ $apputils->checkses_requestor( $authtoken, $userid, 'VIEW_CONTAINER' );
+ return $evt if $evt;
+
+ $logger->debug("User " . $staff->id .
+ " retrieving buckets for user $userid [class=$class, type=$type]");
+
+ my $meth = $types{$class} . ".search.atomic";
+ my $buckets;
+
+ if( $type ) {
+ $buckets = $apputils->simplereq( $svc,
+ $meth, { owner => $userid, btype => $type } );
+ } else {
+ $logger->debug("Grabbing buckets by class $class: $svc : $meth : {owner => $userid}");
+ $buckets = $apputils->simplereq( $svc, $meth, { owner => $userid } );
+ }
+
+ return _sort_buckets($buckets);
+}
+
+__PACKAGE__->register_method(
+ method => "bucket_create",
+ api_name => "open-ils.actor.container.create",
+ notes => <<" NOTES");
+ Creates a new bucket object. If requestor is different from
+ bucketOwner, requestor needs CREATE_CONTAINER permissions
+ PARAMS(authtoken, bucketObject);
+ Returns the new bucket object
+ NOTES
+
+sub bucket_create {
+ my( $self, $client, $authtoken, $class, $bucket ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ if( $bucket->owner ne $e->requestor->id ) {
+ return $e->event unless
+ $e->allowed('CREATE_CONTAINER');
+
+ } else {
+ return $e->event unless
+ $e->allowed('CREATE_MY_CONTAINER');
+ }
+
+ $bucket->clear_id;
+
+ my $evt = OpenILS::Event->new('CONTAINER_EXISTS',
+ payload => [$class, $bucket->owner, $bucket->btype, $bucket->name]);
+ my $search = {name => $bucket->name, owner => $bucket->owner, btype => $bucket->btype};
+
+ my $obj;
+ if( $class eq 'copy' ) {
+ return $evt if $e->search_container_copy_bucket($search)->[0];
+ return $e->event unless
+ $obj = $e->create_container_copy_bucket($bucket);
+ }
+
+ if( $class eq 'callnumber' ) {
+ return $evt if $e->search_container_call_number_bucket($search)->[0];
+ return $e->event unless
+ $obj = $e->create_container_call_number_bucket($bucket);
+ }
+
+ if( $class eq 'biblio' ) {
+ return $evt if $e->search_container_biblio_record_entry_bucket($search)->[0];
+ return $e->event unless
+ $obj = $e->create_container_biblio_record_entry_bucket($bucket);
+ }
+
+ if( $class eq 'user') {
+ return $evt if $e->search_container_user_bucket($search)->[0];
+ return $e->event unless
+ $obj = $e->create_container_user_bucket($bucket);
+ }
+
+ $e->commit;
+ return $obj->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => "item_create",
+ api_name => "open-ils.actor.container.item.create",
+ signature => {
+ desc => q/
+ Adds one or more items to an existing container
+ /,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Container class. Can be "copy", "callnumber", "biblio", or "user"', type => 'string'},
+ {desc => 'Item or items. Can either be a single container item object, or an array of them', type => 'object'},
+ ],
+ return => {
+ desc => 'The ID of the newly created item(s). In batch context, an array of IDs is returned'
+ }
+ }
+);
+
+
+sub item_create {
+ my( $self, $client, $authtoken, $class, $item ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+ my $items = (ref $item eq 'ARRAY') ? $item : [$item];
+
+ my ( $bucket, $evt ) = $apputils->fetch_container_e($e, $item->bucket, $class);
+ return $evt if $evt;
+
+ if( $bucket->owner ne $e->requestor->id ) {
+ return $e->die_event unless
+ $e->allowed('CREATE_CONTAINER_ITEM');
+
+ } else {
+# return $e->event unless
+# $e->allowed('CREATE_CONTAINER_ITEM'); # new perm here?
+ }
+
+ for my $one_item (@$items) {
+
+ $one_item->clear_id;
+
+ my $stat;
+ if( $class eq 'copy' ) {
+ return $e->die_event unless
+ $stat = $e->create_container_copy_bucket_item($one_item);
+ }
+
+ if( $class eq 'callnumber' ) {
+ return $e->die_event unless
+ $stat = $e->create_container_call_number_bucket_item($one_item);
+ }
+
+ if( $class eq 'biblio' ) {
+ return $e->die_event unless
+ $stat = $e->create_container_biblio_record_entry_bucket_item($one_item);
+ }
+
+ if( $class eq 'user') {
+ return $e->die_event unless
+ $stat = $e->create_container_user_bucket_item($one_item);
+ }
+ }
+
+ $e->commit;
+
+ # CStoreEeditor inserts the id (pkey) on newly created objects
+ return [ map { $_->id } @$items ] if ref $item eq 'ARRAY';
+ return $item->id;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "item_delete",
+ api_name => "open-ils.actor.container.item.delete",
+ notes => <<" NOTES");
+ PARAMS(authtoken, class, itemId)
+ NOTES
+
+sub item_delete {
+ my( $self, $client, $authtoken, $class, $itemid ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ my $ret = __item_delete($e, $class, $itemid);
+ $e->commit unless $U->event_code($ret);
+ return $ret;
+}
+
+sub __item_delete {
+ my( $e, $class, $itemid ) = @_;
+ my( $bucket, $item, $evt);
+
+ ( $item, $evt ) = $U->fetch_container_item_e( $e, $itemid, $class );
+ return $evt if $evt;
+
+ ( $bucket, $evt ) = $U->fetch_container_e($e, $item->bucket, $class);
+ return $evt if $evt;
+
+ if( $bucket->owner ne $e->requestor->id ) {
+ my $owner = $e->retrieve_actor_user($bucket->owner)
+ or return $e->die_event;
+ return $e->event unless $e->allowed('DELETE_CONTAINER_ITEM', $owner->home_ou);
+ }
+
+ my $stat;
+ if( $class eq 'copy' ) {
+ for my $note (@{$e->search_container_copy_bucket_item_note({item => $item->id})}) {
+ return $e->event unless
+ $e->delete_container_copy_bucket_item_note($note);
+ }
+ return $e->event unless
+ $stat = $e->delete_container_copy_bucket_item($item);
+ }
+
+ if( $class eq 'callnumber' ) {
+ for my $note (@{$e->search_container_call_number_bucket_item_note({item => $item->id})}) {
+ return $e->event unless
+ $e->delete_container_call_number_bucket_item_note($note);
+ }
+ return $e->event unless
+ $stat = $e->delete_container_call_number_bucket_item($item);
+ }
+
+ if( $class eq 'biblio' ) {
+ for my $note (@{$e->search_container_biblio_record_entry_bucket_item_note({item => $item->id})}) {
+ return $e->event unless
+ $e->delete_container_biblio_record_entry_bucket_item_note($note);
+ }
+ return $e->event unless
+ $stat = $e->delete_container_biblio_record_entry_bucket_item($item);
+ }
+
+ if( $class eq 'user') {
+ for my $note (@{$e->search_container_user_bucket_item_note({item => $item->id})}) {
+ return $e->event unless
+ $e->delete_container_user_bucket_item_note($note);
+ }
+ return $e->event unless
+ $stat = $e->delete_container_user_bucket_item($item);
+ }
+
+ return $stat;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'full_delete',
+ api_name => 'open-ils.actor.container.full_delete',
+ notes => "Complety removes a container including all attached items",
+);
+
+sub full_delete {
+ my( $self, $client, $authtoken, $class, $containerId ) = @_;
+ my( $container, $evt);
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ ( $container, $evt ) = $apputils->fetch_container_e($e, $containerId, $class);
+ return $evt if $evt;
+
+ if( $container->owner ne $e->requestor->id ) {
+ my $owner = $e->retrieve_actor_user($container->owner)
+ or return $e->die_event;
+ return $e->event unless $e->allowed('DELETE_CONTAINER', $owner->home_ou);
+ }
+
+ my $items;
+
+ my @s = ({bucket => $containerId}, {idlist=>1});
+
+ if( $class eq 'copy' ) {
+ $items = $e->search_container_copy_bucket_item(@s);
+ }
+
+ if( $class eq 'callnumber' ) {
+ $items = $e->search_container_call_number_bucket_item(@s);
+ }
+
+ if( $class eq 'biblio' ) {
+ $items = $e->search_container_biblio_record_entry_bucket_item(@s);
+ }
+
+ if( $class eq 'user') {
+ $items = $e->search_container_user_bucket_item(@s);
+ }
+
+ __item_delete($e, $class, $_) for @$items;
+
+ my $stat;
+ if( $class eq 'copy' ) {
+ return $e->event unless
+ $stat = $e->delete_container_copy_bucket($container);
+ }
+
+ if( $class eq 'callnumber' ) {
+ return $e->event unless
+ $stat = $e->delete_container_call_number_bucket($container);
+ }
+
+ if( $class eq 'biblio' ) {
+ return $e->event unless
+ $stat = $e->delete_container_biblio_record_entry_bucket($container);
+ }
+
+ if( $class eq 'user') {
+ return $e->event unless
+ $stat = $e->delete_container_user_bucket($container);
+ }
+
+ $e->commit;
+ return $stat;
+}
+
+__PACKAGE__->register_method(
+ method => 'container_update',
+ api_name => 'open-ils.actor.container.update',
+ signature => q/
+ Updates the given container item.
+ @param authtoken The login session key
+ @param class The container class
+ @param container The container item
+ @return true on success, 0 on no update, Event on error
+ /
+);
+
+sub container_update {
+ my( $self, $conn, $authtoken, $class, $container ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ my ( $dbcontainer, $evt ) = $U->fetch_container_e($e, $container->id, $class);
+ return $evt if $evt;
+
+ if( $e->requestor->id ne $container->owner ) {
+ return $e->event unless $e->allowed('UPDATE_CONTAINER');
+ }
+
+ my $stat;
+ if( $class eq 'copy' ) {
+ return $e->event unless
+ $stat = $e->update_container_copy_bucket($container);
+ }
+
+ if( $class eq 'callnumber' ) {
+ return $e->event unless
+ $stat = $e->update_container_call_number_bucket($container);
+ }
+
+ if( $class eq 'biblio' ) {
+ return $e->event unless
+ $stat = $e->update_container_biblio_record_entry_bucket($container);
+ }
+
+ if( $class eq 'user') {
+ return $e->event unless
+ $stat = $e->update_container_user_bucket($container);
+ }
+
+ $e->commit;
+ return $stat;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "anon_cache",
+ api_name => "open-ils.actor.anon_cache.set_value",
+ signature => {
+ desc => q/
+ Sets a value in the anon web cache. If the session key is
+ undefined, one will be automatically generated.
+ /,
+ params => [
+ {desc => 'Session key', type => 'string'},
+ {
+ desc => q/Field name. The name of the field in this cache session whose value to set/,
+ type => 'string'
+ },
+ {
+ desc => q/The cached value. This can be any type of object (hash, array, string, etc.)/,
+ type => 'any'
+ },
+ ],
+ return => {
+ desc => 'session key on success, undef on error',
+ type => 'string'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "anon_cache",
+ api_name => "open-ils.actor.anon_cache.get_value",
+ signature => {
+ desc => q/
+ Returns the cached data at the specified field within the specified cache session.
+ /,
+ params => [
+ {desc => 'Session key', type => 'string'},
+ {
+ desc => q/Field name. The name of the field in this cache session whose value to set/,
+ type => 'string'
+ },
+ ],
+ return => {
+ desc => 'cached value on success, undef on error',
+ type => 'any'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "anon_cache",
+ api_name => "open-ils.actor.anon_cache.delete_session",
+ signature => {
+ desc => q/
+ Deletes a cache session.
+ /,
+ params => [
+ {desc => 'Session key', type => 'string'},
+ ],
+ return => {
+ desc => 'Session key',
+ type => 'string'
+ }
+ }
+);
+
+sub anon_cache {
+ my($self, $conn, $ses_key, $field_key, $value) = @_;
+
+ my $sc = OpenSRF::Utils::SettingsClient->new;
+ my $cache = OpenSRF::Utils::Cache->new('anon');
+ my $cache_timeout = $sc->config_value(cache => anon => 'max_cache_time') || 1800; # 30 minutes
+ my $cache_size = $sc->config_value(cache => anon => 'max_cache_size') || 102400; # 100k
+
+ if($self->api_name =~ /delete_session/) {
+
+ return $cache->delete_cache($ses_key);
+
+ } elsif( $self->api_name =~ /set_value/ ) {
+
+ $ses_key = md5_hex(time . rand($$)) unless $ses_key;
+ my $blob = $cache->get_cache($ses_key) || {};
+ $blob->{$field_key} = $value;
+ return undef if
+ length(OpenSRF::Utils::JSON->perl2JSON($blob)) > $cache_size; # bytes, characters, whatever ;)
+ $cache->put_cache($ses_key, $blob, $cache_timeout);
+ return $ses_key;
+
+ } else {
+
+ my $blob = $cache->get_cache($ses_key) or return undef;
+ return $blob if (!defined($field_key));
+ return $blob->{$field_key};
+ }
+}
+
+
+
+1;
+
+
--- /dev/null
+package OpenILS::Application::Actor::Friends;
+use strict; use warnings;
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger q/$logger/;
+use OpenILS::Utils::Fieldmapper;
+my $U = "OpenILS::Application::AppUtils";
+
+# ----------------------------------------------------------------
+# Shared Friend utilities. Thar be no methods published here...
+# ----------------------------------------------------------------
+
+# export these fields for friend display
+my @expose_user_fields = qw/id usrname first_given_name second_given_name family_name alias/;
+
+my $out_links_query = {
+ select => {cubi => ['target_user']},
+ from => {
+ cub => {
+ cubi => {field => 'bucket', fkey => 'id'}
+ }
+ },
+ where => {
+ '+cub' => {btype => 'folks', owner => undef}
+ }
+};
+
+my $in_links_query = {
+ select => {cub => ['owner'] },
+ from => {
+ cub => {
+ cubi => {field => 'bucket', fkey => 'id'}
+ }
+ },
+ where => {
+ '+cubi' => {target_user => undef},
+ '+cub' => {btype => 'folks'}
+ }
+};
+
+my $perm_check_query = {
+ select => {cub => ['btype'] },
+ from => {
+ cub => {
+ cubi => {field => 'bucket', fkey => 'id'}
+ }
+ },
+};
+
+sub retrieve_friends {
+ my($self, $e, $user_id, $options) = @_;
+ $options ||= {};
+
+ # users I have links to
+ $out_links_query->{where}->{'+cub'}->{owner} = $user_id;
+ my @out_linked = map {$_->{target_user}} @{$e->json_query($out_links_query)};
+
+ # users who link to me
+ $in_links_query->{where}->{'+cubi'}->{target_user} = $user_id;
+ my @in_linked = map {$_->{owner}} @{$e->json_query($in_links_query)};
+
+ # determine which users are confirmed, pending outbound
+ # requests, and pending inbound requests
+ my @confirmed;
+ my @pending_out;
+ my @pending_in;
+
+ for my $out_link (@out_linked) {
+ if(grep {$_ == $out_link} @in_linked) {
+ push(@confirmed, $out_link);
+ } else {
+ push(@pending_out, $out_link);
+ }
+ }
+
+ for my $in_link (@in_linked) {
+ push(@pending_in, $in_link)
+ unless grep {$_ == $in_link} @confirmed;
+ }
+
+ if($$options{confirmed_only}) {
+ return {
+ confirmed => $self->load_linked_user_perms($e, $user_id, @confirmed),
+ };
+ } else {
+ return {
+ confirmed => $self->load_linked_user_perms($e, $user_id, @confirmed),
+ pending_out => $self->load_linked_user_perms($e, $user_id, @pending_out),
+ pending_in => $self->load_linked_user_perms($e, $user_id, @pending_in)
+ };
+ }
+}
+
+# given a base user and set of linked users, returns the trimmed linked user
+# records, plus the perms (by name) each user has been granted
+sub load_linked_user_perms {
+ my($self, $e, $user_id, @users) = @_;
+ my $items = [];
+
+ # use this query to retrieve trimmed linked user objects
+ my $user_select =
+ {select => {au => \@expose_user_fields}, from => 'au', where => undef};
+
+ for my $d_user (@users) {
+
+ # fetch all of the bucket items linked from base user to
+ # delegate user with the folks: prefix on the bucket type
+ $perm_check_query->{where} = {
+ '+cubi' => {target_user => $d_user},
+ '+cub' => {btype => {like => 'folks:%'}, owner => $user_id}
+ };
+
+ my $perms_granted = [
+ map {substr($_->{btype}, 6)} @{$e->json_query($perm_check_query)}];
+
+ # fetch all of the bucket items linked from the delegate user
+ # to the base user with the folks: prefix on the bucket type
+ $perm_check_query->{where} = {
+ '+cubi' => {target_user => $user_id},
+ '+cub' => {btype => {like => 'folks:%'}, owner => $d_user}
+ };
+
+ my $perms_received = [
+ map {substr($_->{btype}, 6)} @{$e->json_query($perm_check_query)}];
+
+ $user_select->{where} = {id => $d_user};
+ push(@$items, {
+ user => $e->json_query($user_select)->[0],
+ perms_granted => $perms_granted,
+ perms_received => $perms_received
+ }
+ );
+ }
+ return $items;
+}
+
+
+my $direct_links_query = {
+ select => {cub => ['id'] },
+ from => {
+ cub => {
+ cubi => {field => 'bucket', fkey => 'id'}
+ }
+ },
+ where => {
+ '+cubi' => {target_user => undef},
+ '+cub' => {btype => 'folks', owner => undef}
+ },
+ limit => 1
+};
+
+sub confirmed_friends {
+ my($self, $e, $user1_id, $user2_id) = @_;
+
+ $direct_links_query->{where}->{'+cub'}->{owner} = $user1_id;
+ $direct_links_query->{where}->{'+cubi'}->{target_user} = $user2_id;
+
+ if($e->json_query($direct_links_query)->[0]) {
+
+ $direct_links_query->{where}->{'+cub'}->{owner} = $user2_id;
+ $direct_links_query->{where}->{'+cubi'}->{target_user} = $user1_id;
+ return 1 if $e->json_query($direct_links_query)->[0];
+ }
+
+ return 0;
+}
+
+
+
+# returns 1 if delegate_user is allowed to perform 'perm' for base_user
+sub friend_perm_allowed {
+ my($self, $e, $base_user_id, $delegate_user_id, $perm) = @_;
+ return 0 unless $self->confirmed_friends($e, $base_user_id, $delegate_user_id);
+ $perm_check_query->{where} = {
+ '+cubi' => {target_user => $delegate_user_id},
+ '+cub' => {btype => "folks:$perm", owner => $base_user_id}
+ };
+ return 1 if $e->json_query($perm_check_query)->[0];
+ return 0;
+}
+
+sub apply_friend_perm {
+ my($self, $e, $base_user_id, $delegate_user_id, $perm) = @_;
+
+ my $bucket = $e->search_container_user_bucket(
+ {owner => $base_user_id, btype => "folks:$perm"})->[0];
+
+ if($bucket) {
+ # is the permission already set?
+ return undef if $e->search_container_user_bucket_item(
+ {bucket => $bucket->id, target_user => $delegate_user_id})->[0];
+
+ } else {
+ # make sure the perm-specific bucket exists for this user
+ $bucket = Fieldmapper::container::user_bucket->new;
+ $bucket->owner($base_user_id);
+ $bucket->btype("folks:$perm");
+ $bucket->name("folks:$perm");
+ $e->create_container_user_bucket($bucket) or return $e->die_event;
+ }
+
+ my $item = Fieldmapper::container::user_bucket_item->new;
+ $item->bucket($bucket->id);
+ $item->target_user($delegate_user_id);
+ $e->create_container_user_bucket_item($item) or return $e->die_event;
+ return undef;
+}
+
+23;
--- /dev/null
+package OpenILS::Application::Actor::Stage;
+use strict; use warnings;
+use base 'OpenILS::Application';
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger q/$logger/;
+use OpenILS::Utils::Fieldmapper;
+my $U = "OpenILS::Application::AppUtils";
+
+
+__PACKAGE__->register_method (
+ method => 'create_user_stage',
+ api_name => 'open-ils.actor.user.stage.create',
+ signature => {
+ desc => q/
+ Creates a new pending user account including addresses and statcats.
+ Users are added to staging tables pending staff review.
+ /,
+ params => [
+ {desc => 'user', type => 'object', class => 'stgu'},
+ {desc => 'Mailing address. Optional', type => 'object', class => 'stgma'},
+ {desc => 'Billing address. Optional', type => 'object', class => 'stgba'},
+ {desc => 'Statcats. Optional. This is an array of "stgsc" objects', type => 'array'},
+ ],
+ return => {
+ desc => 'username on success, Event on error',
+ type => ''
+ }
+
+ }
+);
+
+sub create_user_stage {
+ my($self, $conn, $user, $mail_addr, $bill_addr, $statcats) = @_; # more?
+
+ return 0 unless $U->ou_ancestor_setting_value('opac.allow_pending_user');
+ return OpenILS::Event->new('BAD_PARAMS') unless $user;
+
+ my $e = new_editor(xact => 1);
+
+ my $uname = $U->create_uuid_string;
+ $user->usrname($uname);
+
+ $e->create_staging_user_stage($user) or return $e->die_event;
+
+ if($mail_addr) {
+ $mail_addr->usrname($uname);
+ $e->create_staging_mailing_address_stage($mail_addr) or return $e->die_event;
+ }
+
+ if($bill_addr) {
+ $bill_addr->usrname($uname);
+ $e->create_staging_billing_address_stage($bill_addr) or return $e->die_event;
+ }
+
+ if($statcats) {
+ foreach (@$statcats) {
+ $_->usrname($uname);
+ $e->create_staging_statcat_stage($_) or return $e->die_event;
+ }
+ }
+
+ $e->commit;
+ $conn->respond_complete($uname);
+
+ $U->create_events_for_hook('stgu.create', $user, $user->home_ou);
+ return undef;
+}
+
+__PACKAGE__->register_method (
+ method => 'user_stage_by_org',
+ api_name => 'open-ils.actor.user.stage.retrieve.by_org',
+ stream => 1
+);
+
+sub user_stage_by_org {
+ my($self, $conn, $auth, $org_id, $limit, $offset) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ $org_id ||= $e->requestor->ws_ou;
+ return $e->event unless $e->allowed('VIEW_USER', $org_id);
+
+ $limit ||= 100;
+ $offset ||= 0;
+
+ my $stage_ids = $e->search_staging_user_stage(
+ [
+ { home_ou => $org_id, complete => 'f'},
+ { limit => $limit,
+ offset => $offset,
+ order_by => {stgu => 'row_id'}
+ }
+ ],
+ {idlist => 1}
+ );
+
+ $conn->respond(flesh_user_stage($e, $_)) for @$stage_ids;
+ return undef;
+}
+
+sub flesh_user_stage {
+ my($e, $row_id) = @_;
+ my $user = $e->retrieve_staging_user_stage($row_id) or return undef;
+ return {
+ user => $user,
+ billing_addresses => $e->search_staging_billing_address_stage({usrname => $user->usrname}),
+ mailing_addresses => $e->search_staging_mailing_address_stage({usrname => $user->usrname}),
+ cards => $e->search_staging_card_stage({usrname => $user->usrname}),
+ statcats => $e->search_staging_statcat_stage({usrname => $user->usrname})
+ };
+}
+
+
+__PACKAGE__->register_method (
+ method => 'user_stage_by_uname',
+ api_name => 'open-ils.actor.user.stage.retrieve.by_username',
+);
+
+sub user_stage_by_uname {
+ my($self, $conn, $auth, $username) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $user = $e->search_staging_user_stage({
+ usrname => $username,
+ complete => 'f'
+ })->[0] or return $e->event;
+
+ return $e->event unless $e->allowed('VIEW_USER', $user->home_ou);
+ return flesh_user_stage($e, $user->row_id);
+}
+
+
+
+
+__PACKAGE__->register_method (
+ method => 'delete_user_stage',
+ api_name => 'open-ils.actor.user.stage.delete',
+);
+
+sub delete_user_stage {
+ my($self, $conn, $auth, $row_id) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ my $data = flesh_user_stage($e, $row_id) or return $e->die_event;
+
+ return $e->die_event unless $e->allowed('UPDATE_USER', $data->{user}->home_ou);
+
+ $e->delete_staging_user_stage($data->{user}) or return $e->die_event;
+
+ for my $addr (@{$data->{mailing_addresses}}) {
+ $e->delete_staging_mailing_address_stage($addr) or return $e->die_event;
+ }
+
+ for my $addr (@{$data->{billing_addresses}}) {
+ $e->delete_staging_billing_address_stage($addr) or return $e->die_event;
+ }
+
+ for my $card (@{$data->{cards}}) {
+ $e->delete_staging_card_stage($card) or return $e->die_event;
+ }
+
+ for my $statcat (@{$data->{statcats}}) {
+ $e->delete_staging_statcat_stage($statcat) or return $e->die_event;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Actor::UserGroups;
+use base 'OpenILS::Application';
+use strict; use warnings;
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger q/$logger/;
+use OpenSRF::EX qw(:try);
+my $U = "OpenILS::Application::AppUtils";
+
+sub initialize { return 1; }
+
+
+
+__PACKAGE__->register_method(
+ method => 'group_money_summary',
+ api_name => 'open-ils.actor.usergroup.members.balance_owed',
+ authoritative => 1,
+ signature => q/
+ /
+);
+
+sub group_money_summary {
+ my($self, $conn, $auth, $group_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER');
+
+ my $users = $e->search_actor_user({usrgroup => $group_id}, {idlist => 1});
+ my @mous;
+
+ for my $uid ( @$users ) {
+ push @mous, @{$e->json_query(
+ {
+ select => {mous => ['usr', 'balance_owed']},
+ from => 'mous',
+ where => { usr => $uid }
+ }
+ )};
+ }
+
+ return \@mous;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'get_users_from_usergroup',
+ api_name => 'open-ils.actor.usergroup.members.retrieve',
+ authoritative => 1,
+ signature => q/
+ Returns a list of ids for users that are in the given usergroup
+ /
+);
+
+sub get_users_from_usergroup {
+ my( $self, $conn, $auth, $usergroup ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER'); # XXX reley on editor perm
+ return $e->search_actor_user({usrgroup => $usergroup}, {idlist => 1});
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'get_leaders_from_usergroup',
+ api_name => 'open-ils.actor.usergroup.leaders.retrieve',
+ signature => q/
+ Returns a list of ids for users that are leaders of the given usergroup
+ /
+);
+
+sub get_leaders_from_usergroup {
+ my( $self, $conn, $auth, $usergroup ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER'); # XXX reley on editor perm
+ my $users = $e->search_actor_user({usrgroup => $usergroup})
+ or return $e->event;
+
+ my @res;
+ for my $u (@$users) {
+ push( @res, $u->id ) if $u->master_account;
+ }
+
+ return \@res;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'get_address_members',
+ api_name => 'open-ils.actor.address.members',
+ signature => q/
+ Returns a list of ids for users that link to the given address
+ @param auth
+ @param addrid The address id
+ /
+);
+
+sub get_address_members {
+ my( $self, $conn, $auth, $addrid ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER'); # XXX reley on editor perm
+
+ my $ad = $e->retrieve_actor_user_address($addrid) or return $e->event;
+ my $ma = $e->search_actor_user({mailing_address => $addrid}, {idlist => 1});
+ my $ba = $e->search_actor_user({billing_address => $addrid}, {idlist => 1});
+
+ my @list = (@$ma, @$ba, $ad->usr);
+ my %dedup = map { $_ => 1 } @list;
+ return [ keys %dedup ];
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'reset_group',
+ api_name => 'open-ils.actor.usergroup.new',
+ signature => q/
+ Gives the requested user a new empty usergroup.
+ @param auth The auth token
+ @param userid The id of the user who needs the new usergroup
+ @param leader If true, this user will be marked as the group leader
+ /
+);
+
+sub reset_group {
+ my( $self, $conn, $auth, $userid, $leader ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('UPDATE_USER'); # XXX reley on editor perm
+
+ my $user = $e->retrieve_actor_user($userid) or return $e->die_event;
+
+ # ask for a new group id
+ my $groupid = $U->storagereq('open-ils.storage.actor.user.group_id.new');
+
+ $user->usrgroup($groupid);
+ $user->master_account('t') if $leader;
+
+ $e->update_actor_user($user) or return $e->die_event;
+ $e->commit;
+ return $groupid;
+}
+
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::AppUtils;
+# vim:noet:ts=4
+use strict; use warnings;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use OpenSRF::Utils::Cache;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Utils::ModsParser;
+use OpenSRF::EX qw(:try);
+use OpenILS::Event;
+use Data::Dumper;
+use OpenILS::Utils::CStoreEditor;
+use OpenILS::Const qw/:const/;
+use Unicode::Normalize;
+use OpenSRF::Utils::SettingsClient;
+use UUID::Tiny;
+use Encode;
+
+# ---------------------------------------------------------------------------
+# Pile of utilty methods used accross applications.
+# ---------------------------------------------------------------------------
+my $cache_client = "OpenSRF::Utils::Cache";
+
+
+# ---------------------------------------------------------------------------
+# on sucess, returns the created session, on failure throws ERROR exception
+# ---------------------------------------------------------------------------
+sub start_db_session {
+
+ my $self = shift;
+ my $session = OpenSRF::AppSession->connect( "open-ils.storage" );
+ my $trans_req = $session->request( "open-ils.storage.transaction.begin" );
+
+ my $trans_resp = $trans_req->recv();
+ if(ref($trans_resp) and UNIVERSAL::isa($trans_resp,"Error")) { throw $trans_resp; }
+ if( ! $trans_resp->content() ) {
+ throw OpenSRF::ERROR
+ ("Unable to Begin Transaction with database" );
+ }
+ $trans_req->finish();
+
+ $logger->debug("Setting global storage session to ".
+ "session: " . $session->session_id . " : " . $session->app );
+
+ return $session;
+}
+
+my $PERM_QUERY = {
+ select => {
+ au => [ {
+ transform => 'permission.usr_has_perm',
+ alias => 'has_perm',
+ column => 'id',
+ params => []
+ } ]
+ },
+ from => 'au',
+ where => {},
+};
+
+
+# returns undef if user has all of the perms provided
+# returns the first failed perm on failure
+sub check_user_perms {
+ my($self, $user_id, $org_id, @perm_types ) = @_;
+ $logger->debug("Checking perms with user : $user_id , org: $org_id, @perm_types");
+
+ for my $type (@perm_types) {
+ $PERM_QUERY->{select}->{au}->[0]->{params} = [$type, $org_id];
+ $PERM_QUERY->{where}->{id} = $user_id;
+ return $type unless $self->is_true(OpenILS::Utils::CStoreEditor->new->json_query($PERM_QUERY)->[0]->{has_perm});
+ }
+ return undef;
+}
+
+# checks the list of user perms. The first one that fails returns a new
+sub check_perms {
+ my( $self, $user_id, $org_id, @perm_types ) = @_;
+ my $t = $self->check_user_perms( $user_id, $org_id, @perm_types );
+ return OpenILS::Event->new('PERM_FAILURE', ilsperm => $t, ilspermloc => $org_id ) if $t;
+ return undef;
+}
+
+
+
+# ---------------------------------------------------------------------------
+# commits and destroys the session
+# ---------------------------------------------------------------------------
+sub commit_db_session {
+ my( $self, $session ) = @_;
+
+ my $req = $session->request( "open-ils.storage.transaction.commit" );
+ my $resp = $req->recv();
+
+ if(!$resp) {
+ throw OpenSRF::EX::ERROR ("Unable to commit db session");
+ }
+
+ if(UNIVERSAL::isa($resp,"Error")) {
+ throw $resp ($resp->stringify);
+ }
+
+ if(!$resp->content) {
+ throw OpenSRF::EX::ERROR ("Unable to commit db session");
+ }
+
+ $session->finish();
+ $session->disconnect();
+ $session->kill_me();
+}
+
+sub rollback_db_session {
+ my( $self, $session ) = @_;
+
+ my $req = $session->request("open-ils.storage.transaction.rollback");
+ my $resp = $req->recv();
+ if(UNIVERSAL::isa($resp,"Error")) { throw $resp; }
+
+ $session->finish();
+ $session->disconnect();
+ $session->kill_me();
+}
+
+
+# returns undef it the event is not an ILS event
+# returns the event code otherwise
+sub event_code {
+ my( $self, $evt ) = @_;
+ return $evt->{ilsevent} if( ref($evt) eq 'HASH' and defined($evt->{ilsevent})) ;
+ return undef;
+}
+
+# ---------------------------------------------------------------------------
+# Checks to see if a user is logged in. Returns the user record on success,
+# throws an exception on error.
+# ---------------------------------------------------------------------------
+sub check_user_session {
+ my( $self, $user_session ) = @_;
+
+ my $content = $self->simplereq(
+ 'open-ils.auth',
+ 'open-ils.auth.session.retrieve', $user_session);
+
+ return undef if (!$content) or $self->event_code($content);
+ return $content;
+}
+
+# generic simple request returning a scalar value
+sub simplereq {
+ my($self, $service, $method, @params) = @_;
+ return $self->simple_scalar_request($service, $method, @params);
+}
+
+
+sub simple_scalar_request {
+ my($self, $service, $method, @params) = @_;
+
+ my $session = OpenSRF::AppSession->create( $service );
+
+ my $request = $session->request( $method, @params );
+
+ my $val;
+ my $err;
+ try {
+
+ $val = $request->gather(1);
+
+ } catch Error with {
+ $err = shift;
+ };
+
+ if( $err ) {
+ warn "received error : service=$service : method=$method : params=".Dumper(\@params) . "\n $err";
+ throw $err ("Call to $service for method $method \n failed with exception: $err : " );
+ }
+
+ return $val;
+}
+
+
+
+
+
+my $tree = undef;
+my $orglist = undef;
+my $org_typelist = undef;
+my $org_typelist_hash = {};
+
+sub __get_org_tree {
+
+ # can we throw this version away??
+
+ my $self = shift;
+ if($tree) { return $tree; }
+
+ # see if it's in the cache
+ $tree = $cache_client->new()->get_cache('_orgtree');
+ if($tree) { return $tree; }
+
+ if(!$orglist) {
+ warn "Retrieving Org Tree\n";
+ $orglist = $self->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.actor.org_unit.search.atomic",
+ { id => { '!=' => undef } }
+ );
+ }
+
+ if( ! $org_typelist ) {
+ warn "Retrieving org types\n";
+ $org_typelist = $self->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.actor.org_unit_type.search.atomic",
+ { id => { '!=' => undef } }
+ );
+ $self->build_org_type($org_typelist);
+ }
+
+ $tree = $self->build_org_tree($orglist,1);
+ $cache_client->new()->put_cache('_orgtree', $tree);
+ return $tree;
+
+}
+
+my $slimtree = undef;
+sub get_slim_org_tree {
+
+ my $self = shift;
+ if($slimtree) { return $slimtree; }
+
+ # see if it's in the cache
+ $slimtree = $cache_client->new()->get_cache('slimorgtree');
+ if($slimtree) { return $slimtree; }
+
+ if(!$orglist) {
+ warn "Retrieving Org Tree\n";
+ $orglist = $self->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.actor.org_unit.search.atomic",
+ { id => { '!=' => undef } }
+ );
+ }
+
+ $slimtree = $self->build_org_tree($orglist);
+ $cache_client->new->put_cache('slimorgtree', $slimtree);
+ return $slimtree;
+
+}
+
+
+sub build_org_type {
+ my($self, $org_typelist) = @_;
+ for my $type (@$org_typelist) {
+ $org_typelist_hash->{$type->id()} = $type;
+ }
+}
+
+
+
+sub build_org_tree {
+
+ my( $self, $orglist, $add_types ) = @_;
+
+ return $orglist unless ref $orglist;
+ return $$orglist[0] if @$orglist == 1;
+
+ my @list = sort {
+ $a->ou_type <=> $b->ou_type ||
+ $a->name cmp $b->name } @$orglist;
+
+ for my $org (@list) {
+
+ next unless ($org);
+
+ if(!ref($org->ou_type()) and $add_types) {
+ $org->ou_type( $org_typelist_hash->{$org->ou_type()});
+ }
+
+ next if (!defined($org->parent_ou) || $org->parent_ou eq "");
+
+ my ($parent) = grep { $_->id == $org->parent_ou } @list;
+ next unless $parent;
+ $parent->children([]) unless defined($parent->children);
+ push( @{$parent->children}, $org );
+ }
+
+ return $list[0];
+}
+
+sub fetch_closed_date {
+ my( $self, $cd ) = @_;
+ my $evt;
+
+ $logger->debug("Fetching closed_date $cd from cstore");
+
+ my $cd_obj = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.actor.org_unit.closed_date.retrieve', $cd );
+
+ if(!$cd_obj) {
+ $logger->info("closed_date $cd not found in the db");
+ $evt = OpenILS::Event->new('ACTOR_USER_NOT_FOUND');
+ }
+
+ return ($cd_obj, $evt);
+}
+
+sub fetch_user {
+ my( $self, $userid ) = @_;
+ my( $user, $evt );
+
+ $logger->debug("Fetching user $userid from cstore");
+
+ $user = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.actor.user.retrieve', $userid );
+
+ if(!$user) {
+ $logger->info("User $userid not found in the db");
+ $evt = OpenILS::Event->new('ACTOR_USER_NOT_FOUND');
+ }
+
+ return ($user, $evt);
+}
+
+sub checkses {
+ my( $self, $session ) = @_;
+ my $user = $self->check_user_session($session) or
+ return (undef, OpenILS::Event->new('NO_SESSION'));
+ return ($user);
+}
+
+
+# verifiese the session and checks the permissions agains the
+# session user and the user's home_ou as the org id
+sub checksesperm {
+ my( $self, $session, @perms ) = @_;
+ my $user; my $evt; my $e;
+ $logger->debug("Checking user session $session and perms @perms");
+ ($user, $evt) = $self->checkses($session);
+ return (undef, $evt) if $evt;
+ $evt = $self->check_perms($user->id, $user->home_ou, @perms);
+ return ($user, $evt);
+}
+
+
+sub checkrequestor {
+ my( $self, $staffobj, $userid, @perms ) = @_;
+ my $user; my $evt;
+ $userid = $staffobj->id unless defined $userid;
+
+ $logger->debug("checkrequestor(): requestor => " . $staffobj->id . ", target => $userid");
+
+ if( $userid ne $staffobj->id ) {
+ ($user, $evt) = $self->fetch_user($userid);
+ return (undef, $evt) if $evt;
+ $evt = $self->check_perms( $staffobj->id, $user->home_ou, @perms );
+
+ } else {
+ $user = $staffobj;
+ }
+
+ return ($user, $evt);
+}
+
+sub checkses_requestor {
+ my( $self, $authtoken, $targetid, @perms ) = @_;
+ my( $requestor, $target, $evt );
+
+ ($requestor, $evt) = $self->checkses($authtoken);
+ return (undef, undef, $evt) if $evt;
+
+ ($target, $evt) = $self->checkrequestor( $requestor, $targetid, @perms );
+ return( $requestor, $target, $evt);
+}
+
+sub fetch_copy {
+ my( $self, $copyid ) = @_;
+ my( $copy, $evt );
+
+ $logger->debug("Fetching copy $copyid from cstore");
+
+ $copy = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.asset.copy.retrieve', $copyid );
+
+ if(!$copy) { $evt = OpenILS::Event->new('ASSET_COPY_NOT_FOUND'); }
+
+ return( $copy, $evt );
+}
+
+
+# retrieves a circ object by id
+sub fetch_circulation {
+ my( $self, $circid ) = @_;
+ my $circ; my $evt;
+
+ $logger->debug("Fetching circ $circid from cstore");
+
+ $circ = $self->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.action.circulation.retrieve", $circid );
+
+ if(!$circ) {
+ $evt = OpenILS::Event->new('ACTION_CIRCULATION_NOT_FOUND', circid => $circid );
+ }
+
+ return ( $circ, $evt );
+}
+
+sub fetch_record_by_copy {
+ my( $self, $copyid ) = @_;
+ my( $record, $evt );
+
+ $logger->debug("Fetching record by copy $copyid from cstore");
+
+ $record = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.asset.copy.retrieve', $copyid,
+ { flesh => 3,
+ flesh_fields => { bre => [ 'fixed_fields' ],
+ acn => [ 'record' ],
+ acp => [ 'call_number' ],
+ }
+ }
+ );
+
+ if(!$record) {
+ $evt = OpenILS::Event->new('BIBLIO_RECORD_ENTRY_NOT_FOUND');
+ } else {
+ $record = $record->call_number->record;
+ }
+
+ return ($record, $evt);
+}
+
+# turns a record object into an mvr (mods) object
+sub record_to_mvr {
+ my( $self, $record ) = @_;
+ return undef unless $record and $record->marc;
+ my $u = OpenILS::Utils::ModsParser->new();
+ $u->start_mods_batch( $record->marc );
+ my $mods = $u->finish_mods_batch();
+ $mods->doc_id($record->id);
+ $mods->tcn($record->tcn_value);
+ return $mods;
+}
+
+sub fetch_hold {
+ my( $self, $holdid ) = @_;
+ my( $hold, $evt );
+
+ $logger->debug("Fetching hold $holdid from cstore");
+
+ $hold = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.action.hold_request.retrieve', $holdid);
+
+ $evt = OpenILS::Event->new('ACTION_HOLD_REQUEST_NOT_FOUND', holdid => $holdid) unless $hold;
+
+ return ($hold, $evt);
+}
+
+
+sub fetch_hold_transit_by_hold {
+ my( $self, $holdid ) = @_;
+ my( $transit, $evt );
+
+ $logger->debug("Fetching transit by hold $holdid from cstore");
+
+ $transit = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.action.hold_transit_copy.search', { hold => $holdid } );
+
+ $evt = OpenILS::Event->new('ACTION_HOLD_TRANSIT_COPY_NOT_FOUND', holdid => $holdid) unless $transit;
+
+ return ($transit, $evt );
+}
+
+# fetches the captured, but not fulfilled hold attached to a given copy
+sub fetch_open_hold_by_copy {
+ my( $self, $copyid ) = @_;
+ $logger->debug("Searching for active hold for copy $copyid");
+ my( $hold, $evt );
+
+ $hold = $self->cstorereq(
+ 'open-ils.cstore.direct.action.hold_request.search',
+ {
+ current_copy => $copyid ,
+ capture_time => { "!=" => undef },
+ fulfillment_time => undef,
+ cancel_time => undef,
+ } );
+
+ $evt = OpenILS::Event->new('ACTION_HOLD_REQUEST_NOT_FOUND', copyid => $copyid) unless $hold;
+ return ($hold, $evt);
+}
+
+sub fetch_hold_transit {
+ my( $self, $transid ) = @_;
+ my( $htransit, $evt );
+ $logger->debug("Fetching hold transit with hold id $transid");
+ $htransit = $self->cstorereq(
+ 'open-ils.cstore.direct.action.hold_transit_copy.retrieve', $transid );
+ $evt = OpenILS::Event->new('ACTION_HOLD_TRANSIT_COPY_NOT_FOUND', id => $transid) unless $htransit;
+ return ($htransit, $evt);
+}
+
+sub fetch_copy_by_barcode {
+ my( $self, $barcode ) = @_;
+ my( $copy, $evt );
+
+ $logger->debug("Fetching copy by barcode $barcode from cstore");
+
+ $copy = $self->simplereq( 'open-ils.cstore',
+ 'open-ils.cstore.direct.asset.copy.search', { barcode => $barcode, deleted => 'f'} );
+ #'open-ils.storage.direct.asset.copy.search.barcode', $barcode );
+
+ $evt = OpenILS::Event->new('ASSET_COPY_NOT_FOUND', barcode => $barcode) unless $copy;
+
+ return ($copy, $evt);
+}
+
+sub fetch_open_billable_transaction {
+ my( $self, $transid ) = @_;
+ my( $transaction, $evt );
+
+ $logger->debug("Fetching open billable transaction $transid from cstore");
+
+ $transaction = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.money.open_billable_transaction_summary.retrieve', $transid);
+
+ $evt = OpenILS::Event->new(
+ 'MONEY_OPEN_BILLABLE_TRANSACTION_SUMMARY_NOT_FOUND', transid => $transid ) unless $transaction;
+
+ return ($transaction, $evt);
+}
+
+
+
+my %buckets;
+$buckets{'biblio'} = 'biblio_record_entry_bucket';
+$buckets{'callnumber'} = 'call_number_bucket';
+$buckets{'copy'} = 'copy_bucket';
+$buckets{'user'} = 'user_bucket';
+
+sub fetch_container {
+ my( $self, $id, $type ) = @_;
+ my( $bucket, $evt );
+
+ $logger->debug("Fetching container $id with type $type");
+
+ my $e = 'CONTAINER_CALL_NUMBER_BUCKET_NOT_FOUND';
+ $e = 'CONTAINER_BIBLIO_RECORD_ENTRY_BUCKET_NOT_FOUND' if $type eq 'biblio';
+ $e = 'CONTAINER_USER_BUCKET_NOT_FOUND' if $type eq 'user';
+ $e = 'CONTAINER_COPY_BUCKET_NOT_FOUND' if $type eq 'copy';
+
+ my $meth = $buckets{$type};
+ $bucket = $self->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.container.$meth.retrieve", $id );
+
+ $evt = OpenILS::Event->new(
+ $e, container => $id, container_type => $type ) unless $bucket;
+
+ return ($bucket, $evt);
+}
+
+
+sub fetch_container_e {
+ my( $self, $editor, $id, $type ) = @_;
+
+ my( $bucket, $evt );
+ $bucket = $editor->retrieve_container_copy_bucket($id) if $type eq 'copy';
+ $bucket = $editor->retrieve_container_call_number_bucket($id) if $type eq 'callnumber';
+ $bucket = $editor->retrieve_container_biblio_record_entry_bucket($id) if $type eq 'biblio';
+ $bucket = $editor->retrieve_container_user_bucket($id) if $type eq 'user';
+
+ $evt = $editor->event unless $bucket;
+ return ($bucket, $evt);
+}
+
+sub fetch_container_item_e {
+ my( $self, $editor, $id, $type ) = @_;
+
+ my( $bucket, $evt );
+ $bucket = $editor->retrieve_container_copy_bucket_item($id) if $type eq 'copy';
+ $bucket = $editor->retrieve_container_call_number_bucket_item($id) if $type eq 'callnumber';
+ $bucket = $editor->retrieve_container_biblio_record_entry_bucket_item($id) if $type eq 'biblio';
+ $bucket = $editor->retrieve_container_user_bucket_item($id) if $type eq 'user';
+
+ $evt = $editor->event unless $bucket;
+ return ($bucket, $evt);
+}
+
+
+
+
+
+sub fetch_container_item {
+ my( $self, $id, $type ) = @_;
+ my( $bucket, $evt );
+
+ $logger->debug("Fetching container item $id with type $type");
+
+ my $meth = $buckets{$type} . "_item";
+
+ $bucket = $self->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.container.$meth.retrieve", $id );
+
+
+ my $e = 'CONTAINER_CALL_NUMBER_BUCKET_ITEM_NOT_FOUND';
+ $e = 'CONTAINER_BIBLIO_RECORD_ENTRY_BUCKET_ITEM_NOT_FOUND' if $type eq 'biblio';
+ $e = 'CONTAINER_USER_BUCKET_ITEM_NOT_FOUND' if $type eq 'user';
+ $e = 'CONTAINER_COPY_BUCKET_ITEM_NOT_FOUND' if $type eq 'copy';
+
+ $evt = OpenILS::Event->new(
+ $e, itemid => $id, container_type => $type ) unless $bucket;
+
+ return ($bucket, $evt);
+}
+
+
+sub fetch_patron_standings {
+ my $self = shift;
+ $logger->debug("Fetching patron standings");
+ return $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.standing.search.atomic', { id => { '!=' => undef } });
+}
+
+
+sub fetch_permission_group_tree {
+ my $self = shift;
+ $logger->debug("Fetching patron profiles");
+ return $self->simplereq(
+ 'open-ils.actor',
+ 'open-ils.actor.groups.tree.retrieve' );
+}
+
+sub fetch_permission_group_descendants {
+ my( $self, $profile ) = @_;
+ my $group_tree = $self->fetch_permission_group_tree();
+ my $start_here;
+ my @groups;
+
+ # FIXME: okay, so it's not an org tree, but it is compatible
+ $self->walk_org_tree($group_tree, sub {
+ my $g = shift;
+ if ($g->id == $profile) {
+ $start_here = $g;
+ }
+ });
+
+ $self->walk_org_tree($start_here, sub {
+ my $g = shift;
+ push(@groups,$g->id);
+ });
+
+ return \@groups;
+}
+
+sub fetch_patron_circ_summary {
+ my( $self, $userid ) = @_;
+ $logger->debug("Fetching patron summary for $userid");
+ my $summary = $self->simplereq(
+ 'open-ils.storage',
+ "open-ils.storage.action.circulation.patron_summary", $userid );
+
+ if( $summary ) {
+ $summary->[0] ||= 0;
+ $summary->[1] ||= 0.0;
+ return $summary;
+ }
+ return undef;
+}
+
+
+sub fetch_copy_statuses {
+ my( $self ) = @_;
+ $logger->debug("Fetching copy statuses");
+ return $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.copy_status.search.atomic', { id => { '!=' => undef } });
+}
+
+sub fetch_copy_location {
+ my( $self, $id ) = @_;
+ my $evt;
+ my $cl = $self->cstorereq(
+ 'open-ils.cstore.direct.asset.copy_location.retrieve', $id );
+ $evt = OpenILS::Event->new('ASSET_COPY_LOCATION_NOT_FOUND') unless $cl;
+ return ($cl, $evt);
+}
+
+sub fetch_copy_locations {
+ my $self = shift;
+ return $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.asset.copy_location.search.atomic', { id => { '!=' => undef } });
+}
+
+sub fetch_copy_location_by_name {
+ my( $self, $name, $org ) = @_;
+ my $evt;
+ my $cl = $self->cstorereq(
+ 'open-ils.cstore.direct.asset.copy_location.search',
+ { name => $name, owning_lib => $org } );
+ $evt = OpenILS::Event->new('ASSET_COPY_LOCATION_NOT_FOUND') unless $cl;
+ return ($cl, $evt);
+}
+
+sub fetch_callnumber {
+ my( $self, $id ) = @_;
+ my $evt = undef;
+
+ my $e = OpenILS::Event->new( 'ASSET_CALL_NUMBER_NOT_FOUND', id => $id );
+ return( undef, $e ) unless $id;
+
+ $logger->debug("Fetching callnumber $id");
+
+ my $cn = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.asset.call_number.retrieve', $id );
+ $evt = $e unless $cn;
+
+ return ( $cn, $evt );
+}
+
+my %ORG_CACHE; # - these rarely change, so cache them..
+sub fetch_org_unit {
+ my( $self, $id ) = @_;
+ return undef unless $id;
+ return $id if( ref($id) eq 'Fieldmapper::actor::org_unit' );
+ return $ORG_CACHE{$id} if $ORG_CACHE{$id};
+ $logger->debug("Fetching org unit $id");
+ my $evt = undef;
+
+ my $org = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.actor.org_unit.retrieve', $id );
+ $evt = OpenILS::Event->new( 'ACTOR_ORG_UNIT_NOT_FOUND', id => $id ) unless $org;
+ $ORG_CACHE{$id} = $org;
+
+ return ($org, $evt);
+}
+
+sub fetch_stat_cat {
+ my( $self, $type, $id ) = @_;
+ my( $cat, $evt );
+ $logger->debug("Fetching $type stat cat: $id");
+ $cat = $self->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.$type.stat_cat.retrieve", $id );
+
+ my $e = 'ASSET_STAT_CAT_NOT_FOUND';
+ $e = 'ACTOR_STAT_CAT_NOT_FOUND' if $type eq 'actor';
+
+ $evt = OpenILS::Event->new( $e, id => $id ) unless $cat;
+ return ( $cat, $evt );
+}
+
+sub fetch_stat_cat_entry {
+ my( $self, $type, $id ) = @_;
+ my( $entry, $evt );
+ $logger->debug("Fetching $type stat cat entry: $id");
+ $entry = $self->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.$type.stat_cat_entry.retrieve", $id );
+
+ my $e = 'ASSET_STAT_CAT_ENTRY_NOT_FOUND';
+ $e = 'ACTOR_STAT_CAT_ENTRY_NOT_FOUND' if $type eq 'actor';
+
+ $evt = OpenILS::Event->new( $e, id => $id ) unless $entry;
+ return ( $entry, $evt );
+}
+
+
+sub find_org {
+ my( $self, $org_tree, $orgid ) = @_;
+ return undef unless $org_tree and defined $orgid;
+ return $org_tree if ( $org_tree->id eq $orgid );
+ return undef unless ref($org_tree->children);
+ for my $c (@{$org_tree->children}) {
+ my $o = $self->find_org($c, $orgid);
+ return $o if $o;
+ }
+ return undef;
+}
+
+sub fetch_non_cat_type_by_name_and_org {
+ my( $self, $name, $orgId ) = @_;
+ $logger->debug("Fetching non cat type $name at org $orgId");
+ my $types = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.non_cataloged_type.search.atomic',
+ { name => $name, owning_lib => $orgId } );
+ return ($types->[0], undef) if($types and @$types);
+ return (undef, OpenILS::Event->new('CONFIG_NON_CATALOGED_TYPE_NOT_FOUND') );
+}
+
+sub fetch_non_cat_type {
+ my( $self, $id ) = @_;
+ $logger->debug("Fetching non cat type $id");
+ my( $type, $evt );
+ $type = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.non_cataloged_type.retrieve', $id );
+ $evt = OpenILS::Event->new('CONFIG_NON_CATALOGED_TYPE_NOT_FOUND') unless $type;
+ return ($type, $evt);
+}
+
+sub DB_UPDATE_FAILED {
+ my( $self, $payload ) = @_;
+ return OpenILS::Event->new('DATABASE_UPDATE_FAILED',
+ payload => ($payload) ? $payload : undef );
+}
+
+sub fetch_booking_reservation {
+ my( $self, $id ) = @_;
+ my( $res, $evt );
+
+ $res = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.booking.reservation.retrieve', $id
+ );
+
+ # simplereq doesn't know how to flesh so ...
+ if ($res) {
+ $res->usr(
+ $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.actor.user.retrieve', $res->usr
+ )
+ );
+
+ $res->target_resource_type(
+ $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.booking.resource_type.retrieve', $res->target_resource_type
+ )
+ );
+
+ if ($res->current_resource) {
+ $res->current_resource(
+ $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.booking.resource.retrieve', $res->current_resource
+ )
+ );
+
+ if ($self->is_true( $res->target_resource_type->catalog_item )) {
+ $res->current_resource->catalog_item( $self->fetch_copy_by_barcode( $res->current_resource->barcode ) );
+ }
+ }
+
+ if ($res->target_resource) {
+ $res->target_resource(
+ $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.booking.resource.retrieve', $res->target_resource
+ )
+ );
+
+ if ($self->is_true( $res->target_resource_type->catalog_item )) {
+ $res->target_resource->catalog_item( $self->fetch_copy_by_barcode( $res->target_resource->barcode ) );
+ }
+ }
+
+ } else {
+ $evt = OpenILS::Event->new('RESERVATION_NOT_FOUND');
+ }
+
+ return ($res, $evt);
+}
+
+sub fetch_circ_duration_by_name {
+ my( $self, $name ) = @_;
+ my( $dur, $evt );
+ $dur = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.rules.circ_duration.search.atomic', { name => $name } );
+ $dur = $dur->[0];
+ $evt = OpenILS::Event->new('CONFIG_RULES_CIRC_DURATION_NOT_FOUND') unless $dur;
+ return ($dur, $evt);
+}
+
+sub fetch_recurring_fine_by_name {
+ my( $self, $name ) = @_;
+ my( $obj, $evt );
+ $obj = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.rules.recurring_fine.search.atomic', { name => $name } );
+ $obj = $obj->[0];
+ $evt = OpenILS::Event->new('CONFIG_RULES_RECURRING_FINE_NOT_FOUND') unless $obj;
+ return ($obj, $evt);
+}
+
+sub fetch_max_fine_by_name {
+ my( $self, $name ) = @_;
+ my( $obj, $evt );
+ $obj = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.rules.max_fine.search.atomic', { name => $name } );
+ $obj = $obj->[0];
+ $evt = OpenILS::Event->new('CONFIG_RULES_MAX_FINE_NOT_FOUND') unless $obj;
+ return ($obj, $evt);
+}
+
+sub fetch_hard_due_date_by_name {
+ my( $self, $name ) = @_;
+ my( $obj, $evt );
+ $obj = $self->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.config.hard_due_date.search.atomic', { name => $name } );
+ $obj = $obj->[0];
+ $evt = OpenILS::Event->new('CONFIG_RULES_HARD_DUE_DATE_NOT_FOUND') unless $obj;
+ return ($obj, $evt);
+}
+
+sub storagereq {
+ my( $self, $method, @params ) = @_;
+ return $self->simplereq(
+ 'open-ils.storage', $method, @params );
+}
+
+sub storagereq_xact {
+ my($self, $method, @params) = @_;
+ my $ses = $self->start_db_session();
+ my $val = $ses->request($method, @params)->gather(1);
+ $self->rollback_db_session($ses);
+ return $val;
+}
+
+sub cstorereq {
+ my( $self, $method, @params ) = @_;
+ return $self->simplereq(
+ 'open-ils.cstore', $method, @params );
+}
+
+sub event_equals {
+ my( $self, $e, $name ) = @_;
+ if( $e and ref($e) eq 'HASH' and
+ defined($e->{textcode}) and $e->{textcode} eq $name ) {
+ return 1 ;
+ }
+ return 0;
+}
+
+sub logmark {
+ my( undef, $f, $l ) = caller(0);
+ my( undef, undef, undef, $s ) = caller(1);
+ $s =~ s/.*:://g;
+ $f =~ s/.*\///g;
+ $logger->debug("LOGMARK: $f:$l:$s");
+}
+
+# takes a copy id
+sub fetch_open_circulation {
+ my( $self, $cid ) = @_;
+ $self->logmark;
+
+ my $e = OpenILS::Utils::CStoreEditor->new;
+ my $circ = $e->search_action_circulation({
+ target_copy => $cid,
+ stop_fines_time => undef,
+ checkin_time => undef
+ })->[0];
+
+ return ($circ, $e->event);
+}
+
+my $copy_statuses;
+sub copy_status_from_name {
+ my( $self, $name ) = @_;
+ $copy_statuses = $self->fetch_copy_statuses unless $copy_statuses;
+ for my $status (@$copy_statuses) {
+ return $status if( $status->name =~ /$name/i );
+ }
+ return undef;
+}
+
+sub copy_status_to_name {
+ my( $self, $sid ) = @_;
+ $copy_statuses = $self->fetch_copy_statuses unless $copy_statuses;
+ for my $status (@$copy_statuses) {
+ return $status->name if( $status->id == $sid );
+ }
+ return undef;
+}
+
+
+sub copy_status {
+ my( $self, $arg ) = @_;
+ return $arg if ref $arg;
+ $copy_statuses = $self->fetch_copy_statuses unless $copy_statuses;
+ my ($stat) = grep { $_->id == $arg } @$copy_statuses;
+ return $stat;
+}
+
+sub fetch_open_transit_by_copy {
+ my( $self, $copyid ) = @_;
+ my($transit, $evt);
+ $transit = $self->cstorereq(
+ 'open-ils.cstore.direct.action.transit_copy.search',
+ { target_copy => $copyid, dest_recv_time => undef });
+ $evt = OpenILS::Event->new('ACTION_TRANSIT_COPY_NOT_FOUND') unless $transit;
+ return ($transit, $evt);
+}
+
+sub unflesh_copy {
+ my( $self, $copy ) = @_;
+ return undef unless $copy;
+ $copy->status( $copy->status->id ) if ref($copy->status);
+ $copy->location( $copy->location->id ) if ref($copy->location);
+ $copy->circ_lib( $copy->circ_lib->id ) if ref($copy->circ_lib);
+ return $copy;
+}
+
+sub unflesh_reservation {
+ my( $self, $reservation ) = @_;
+ return undef unless $reservation;
+ $reservation->usr( $reservation->usr->id ) if ref($reservation->usr);
+ $reservation->target_resource_type( $reservation->target_resource_type->id ) if ref($reservation->target_resource_type);
+ $reservation->target_resource( $reservation->target_resource->id ) if ref($reservation->target_resource);
+ $reservation->current_resource( $reservation->current_resource->id ) if ref($reservation->current_resource);
+ return $reservation;
+}
+
+# un-fleshes a copy and updates it in the DB
+# returns a DB_UPDATE_FAILED event on error
+# returns undef on success
+sub update_copy {
+ my( $self, %params ) = @_;
+
+ my $copy = $params{copy} || die "update_copy(): copy required";
+ my $editor = $params{editor} || die "update_copy(): copy editor required";
+ my $session = $params{session};
+
+ $logger->debug("Updating copy in the database: " . $copy->id);
+
+ $self->unflesh_copy($copy);
+ $copy->editor( $editor );
+ $copy->edit_date( 'now' );
+
+ my $s;
+ my $meth = 'open-ils.storage.direct.asset.copy.update';
+
+ $s = $session->request( $meth, $copy )->gather(1) if $session;
+ $s = $self->storagereq( $meth, $copy ) unless $session;
+
+ $logger->debug("Update of copy ".$copy->id." returned: $s");
+
+ return $self->DB_UPDATE_FAILED($copy) unless $s;
+ return undef;
+}
+
+sub update_reservation {
+ my( $self, %params ) = @_;
+
+ my $reservation = $params{reservation} || die "update_reservation(): reservation required";
+ my $editor = $params{editor} || die "update_reservation(): copy editor required";
+ my $session = $params{session};
+
+ $logger->debug("Updating copy in the database: " . $reservation->id);
+
+ $self->unflesh_reservation($reservation);
+
+ my $s;
+ my $meth = 'open-ils.cstore.direct.booking.reservation.update';
+
+ $s = $session->request( $meth, $reservation )->gather(1) if $session;
+ $s = $self->cstorereq( $meth, $reservation ) unless $session;
+
+ $logger->debug("Update of copy ".$reservation->id." returned: $s");
+
+ return $self->DB_UPDATE_FAILED($reservation) unless $s;
+ return undef;
+}
+
+sub fetch_billable_xact {
+ my( $self, $id ) = @_;
+ my($xact, $evt);
+ $logger->debug("Fetching billable transaction %id");
+ $xact = $self->cstorereq(
+ 'open-ils.cstore.direct.money.billable_transaction.retrieve', $id );
+ $evt = OpenILS::Event->new('MONEY_BILLABLE_TRANSACTION_NOT_FOUND') unless $xact;
+ return ($xact, $evt);
+}
+
+sub fetch_billable_xact_summary {
+ my( $self, $id ) = @_;
+ my($xact, $evt);
+ $logger->debug("Fetching billable transaction summary %id");
+ $xact = $self->cstorereq(
+ 'open-ils.cstore.direct.money.billable_transaction_summary.retrieve', $id );
+ $evt = OpenILS::Event->new('MONEY_BILLABLE_TRANSACTION_NOT_FOUND') unless $xact;
+ return ($xact, $evt);
+}
+
+sub fetch_fleshed_copy {
+ my( $self, $id ) = @_;
+ my( $copy, $evt );
+ $logger->info("Fetching fleshed copy $id");
+ $copy = $self->cstorereq(
+ "open-ils.cstore.direct.asset.copy.retrieve", $id,
+ { flesh => 1,
+ flesh_fields => { acp => [ qw/ circ_lib location status stat_cat_entries / ] }
+ }
+ );
+ $evt = OpenILS::Event->new('ASSET_COPY_NOT_FOUND', id => $id) unless $copy;
+ return ($copy, $evt);
+}
+
+
+# returns the org that owns the callnumber that the copy
+# is attached to
+sub fetch_copy_owner {
+ my( $self, $copyid ) = @_;
+ my( $copy, $cn, $evt );
+ $logger->debug("Fetching copy owner $copyid");
+ ($copy, $evt) = $self->fetch_copy($copyid);
+ return (undef,$evt) if $evt;
+ ($cn, $evt) = $self->fetch_callnumber($copy->call_number);
+ return (undef,$evt) if $evt;
+ return ($cn->owning_lib);
+}
+
+sub fetch_copy_note {
+ my( $self, $id ) = @_;
+ my( $note, $evt );
+ $logger->debug("Fetching copy note $id");
+ $note = $self->cstorereq(
+ 'open-ils.cstore.direct.asset.copy_note.retrieve', $id );
+ $evt = OpenILS::Event->new('ASSET_COPY_NOTE_NOT_FOUND', id => $id ) unless $note;
+ return ($note, $evt);
+}
+
+sub fetch_call_numbers_by_title {
+ my( $self, $titleid ) = @_;
+ $logger->info("Fetching call numbers by title $titleid");
+ return $self->cstorereq(
+ 'open-ils.cstore.direct.asset.call_number.search.atomic',
+ { record => $titleid, deleted => 'f' });
+ #'open-ils.storage.direct.asset.call_number.search.record.atomic', $titleid);
+}
+
+sub fetch_copies_by_call_number {
+ my( $self, $cnid ) = @_;
+ $logger->info("Fetching copies by call number $cnid");
+ return $self->cstorereq(
+ 'open-ils.cstore.direct.asset.copy.search.atomic', { call_number => $cnid, deleted => 'f' } );
+ #'open-ils.storage.direct.asset.copy.search.call_number.atomic', $cnid );
+}
+
+sub fetch_user_by_barcode {
+ my( $self, $bc ) = @_;
+ my $cardid = $self->cstorereq(
+ 'open-ils.cstore.direct.actor.card.id_list', { barcode => $bc } );
+ return (undef, OpenILS::Event->new('ACTOR_CARD_NOT_FOUND', barcode => $bc)) unless $cardid;
+ my $user = $self->cstorereq(
+ 'open-ils.cstore.direct.actor.user.search', { card => $cardid } );
+ return (undef, OpenILS::Event->new('ACTOR_USER_NOT_FOUND', card => $cardid)) unless $user;
+ return ($user);
+
+}
+
+sub fetch_bill {
+ my( $self, $billid ) = @_;
+ $logger->debug("Fetching billing $billid");
+ my $bill = $self->cstorereq(
+ 'open-ils.cstore.direct.money.billing.retrieve', $billid );
+ my $evt = OpenILS::Event->new('MONEY_BILLING_NOT_FOUND') unless $bill;
+ return($bill, $evt);
+}
+
+my $ORG_TREE;
+sub fetch_org_tree {
+ my $self = shift;
+ return $ORG_TREE if $ORG_TREE;
+ return $ORG_TREE = OpenILS::Utils::CStoreEditor->new->search_actor_org_unit(
+ [
+ {"parent_ou" => undef },
+ {
+ flesh => -1,
+ flesh_fields => { aou => ['children'] },
+ order_by => { aou => 'name'}
+ }
+ ]
+ )->[0];
+}
+
+sub walk_org_tree {
+ my( $self, $node, $callback ) = @_;
+ return unless $node;
+ $callback->($node);
+ if( $node->children ) {
+ $self->walk_org_tree($_, $callback) for @{$node->children};
+ }
+}
+
+sub is_true {
+ my( $self, $item ) = @_;
+ return 1 if $item and $item !~ /^f$/i;
+ return 0;
+}
+
+
+sub patientreq {
+ my ($self, $client, $service, $method, @params) = @_;
+ my ($response, $err);
+
+ my $session = create OpenSRF::AppSession($service);
+ my $request = $session->request($method, @params);
+
+ my $spurt = 10;
+ my $give_up = time + 1000;
+
+ try {
+ while (time < $give_up) {
+ $response = $request->recv("timeout" => $spurt);
+ last if $request->complete;
+
+ $client->status(new OpenSRF::DomainObject::oilsContinueStatus);
+ }
+ } catch Error with {
+ $err = shift;
+ };
+
+ if ($err) {
+ warn "received error : service=$service : method=$method : params=".Dumper(\@params) . "\n $err";
+ throw $err ("Call to $service for method $method \n failed with exception: $err : " );
+ }
+
+ return $response->content;
+}
+
+# This logic now lives in storage
+sub __patron_money_owed {
+ my( $self, $patronid ) = @_;
+ my $ses = OpenSRF::AppSession->create('open-ils.storage');
+ my $req = $ses->request(
+ 'open-ils.storage.money.billable_transaction.summary.search',
+ { usr => $patronid, xact_finish => undef } );
+
+ my $total = 0;
+ my $data;
+ while( $data = $req->recv ) {
+ $data = $data->content;
+ $total += $data->balance_owed;
+ }
+ return $total;
+}
+
+sub patron_money_owed {
+ my( $self, $userid ) = @_;
+ my $ses = $self->start_db_session();
+ my $val = $ses->request(
+ 'open-ils.storage.actor.user.total_owed', $userid)->gather(1);
+ $self->rollback_db_session($ses);
+ return $val;
+}
+
+sub patron_total_items_out {
+ my( $self, $userid ) = @_;
+ my $ses = $self->start_db_session();
+ my $val = $ses->request(
+ 'open-ils.storage.actor.user.total_out', $userid)->gather(1);
+ $self->rollback_db_session($ses);
+ return $val;
+}
+
+
+
+
+#---------------------------------------------------------------------
+# Returns ($summary, $event)
+#---------------------------------------------------------------------
+sub fetch_mbts {
+ my $self = shift;
+ my $id = shift;
+ my $e = shift || OpenILS::Utils::CStoreEditor->new;
+ $id = $id->id if ref($id);
+
+ my $xact = $e->retrieve_money_billable_transaction_summary($id)
+ or return (undef, $e->event);
+
+ return ($xact);
+}
+
+
+#---------------------------------------------------------------------
+# Given a list of money.billable_transaction objects, this creates
+# transaction summary objects for each
+#--------------------------------------------------------------------
+sub make_mbts {
+ my $self = shift;
+ my $e = shift;
+ my @xacts = @_;
+ return () if (!@xacts);
+ return @{$e->search_money_billable_transaction_summary({id => [ map { $_->id } @xacts ]})};
+}
+
+
+sub ou_ancestor_setting_value {
+ my($self, $org_id, $name, $e) = @_;
+ $e = $e || OpenILS::Utils::CStoreEditor->new;
+ my $set = $self->ou_ancestor_setting($org_id, $name, $e);
+ return $set->{value} if $set;
+ return undef;
+}
+
+
+# If an authentication token is provided AND this org unit setting has a
+# view_perm, then make sure the user referenced by the auth token has
+# that permission. This means that if you call this method without an
+# authtoken param, you can get whatever org unit setting values you want.
+# API users beware.
+#
+# NOTE: If you supply an editor ($e) arg AND an auth token arg, the editor's
+# authtoken is checked, but the $auth arg is NOT checked. To say that another
+# way, be sure NOT to pass an editor argument if you want your token checked.
+# Otherwise the auth arg is just a flag saying "check the editor".
+
+sub ou_ancestor_setting {
+ my( $self, $orgid, $name, $e, $auth ) = @_;
+ $e = $e || OpenILS::Utils::CStoreEditor->new(
+ (defined $auth) ? (authtoken => $auth) : ()
+ );
+ my $coust = $e->retrieve_config_org_unit_setting_type([
+ $name, {flesh => 1, flesh_fields => {coust => ['view_perm']}}
+ ]);
+
+ if ($auth && $coust && $coust->view_perm) {
+ # And you can't have permission if you don't have a valid session.
+ return undef if not $e->checkauth;
+ # And now that we know you MIGHT have permission, we check it.
+ return undef if not $e->allowed($coust->view_perm->code, $orgid);
+ }
+
+ my $query = {from => ['actor.org_unit_ancestor_setting', $name, $orgid]};
+ my $setting = $e->json_query($query)->[0];
+ return undef unless $setting;
+ return {org => $setting->{org_unit}, value => OpenSRF::Utils::JSON->JSON2perl($setting->{value})};
+}
+
+
+# returns the ISO8601 string representation of the requested epoch in GMT
+sub epoch2ISO8601 {
+ my( $self, $epoch ) = @_;
+ my ($sec,$min,$hour,$mday,$mon,$year) = gmtime($epoch);
+ $year += 1900; $mon += 1;
+ my $date = sprintf(
+ '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d-00',
+ $year, $mon, $mday, $hour, $min, $sec);
+ return $date;
+}
+
+sub find_highest_perm_org {
+ my ( $self, $perm, $userid, $start_org, $org_tree ) = @_;
+ my $org = $self->find_org($org_tree, $start_org );
+
+ my $lastid = -1;
+ while( $org ) {
+ last if ($self->check_perms( $userid, $org->id, $perm )); # perm failed
+ $lastid = $org->id;
+ $org = $self->find_org( $org_tree, $org->parent_ou() );
+ }
+
+ return $lastid;
+}
+
+
+# returns the org_unit ID's
+sub user_has_work_perm_at {
+ my($self, $e, $perm, $options, $user_id) = @_;
+ $options ||= {};
+ $user_id = (defined $user_id) ? $user_id : $e->requestor->id;
+
+ my $func = 'permission.usr_has_perm_at';
+ $func = $func.'_all' if $$options{descendants};
+
+ my $orgs = $e->json_query({from => [$func, $user_id, $perm]});
+ $orgs = [map { $_->{ (keys %$_)[0] } } @$orgs];
+
+ return $orgs unless $$options{objects};
+
+ return $e->search_actor_org_unit({id => $orgs});
+}
+
+sub get_user_work_ou_ids {
+ my($self, $e, $userid) = @_;
+ my $work_orgs = $e->json_query({
+ select => {puwoum => ['work_ou']},
+ from => 'puwoum',
+ where => {usr => $e->requestor->id}});
+
+ return [] unless @$work_orgs;
+ my @work_orgs;
+ push(@work_orgs, $_->{work_ou}) for @$work_orgs;
+
+ return \@work_orgs;
+}
+
+
+my $org_types;
+sub get_org_types {
+ my($self, $client) = @_;
+ return $org_types if $org_types;
+ return $org_types = OpenILS::Utils::CStoreEditor->new->retrieve_all_actor_org_unit_type();
+}
+
+sub get_org_tree {
+ my $self = shift;
+ my $locale = shift || '';
+ my $cache = OpenSRF::Utils::Cache->new("global", 0);
+ my $tree = $cache->get_cache("orgtree.$locale");
+ return $tree if $tree;
+
+ my $ses = OpenILS::Utils::CStoreEditor->new;
+ $ses->session->session_locale($locale);
+ $tree = $ses->search_actor_org_unit(
+ [
+ {"parent_ou" => undef },
+ {
+ flesh => -1,
+ flesh_fields => { aou => ['children'] },
+ order_by => { aou => 'name'}
+ }
+ ]
+ )->[0];
+
+ $cache->put_cache("orgtree.$locale", $tree);
+ return $tree;
+}
+
+sub get_org_descendants {
+ my($self, $org_id, $depth) = @_;
+
+ my $select = {
+ transform => 'actor.org_unit_descendants',
+ column => 'id',
+ result_field => 'id',
+ };
+ $select->{params} = [$depth] if defined $depth;
+
+ my $org_list = OpenILS::Utils::CStoreEditor->new->json_query({
+ select => {aou => [$select]},
+ from => 'aou',
+ where => {id => $org_id}
+ });
+ my @orgs;
+ push(@orgs, $_->{id}) for @$org_list;
+ return \@orgs;
+}
+
+sub get_org_ancestors {
+ my($self, $org_id) = @_;
+
+ my $org_list = OpenILS::Utils::CStoreEditor->new->json_query({
+ select => {
+ aou => [{
+ transform => 'actor.org_unit_ancestors',
+ column => 'id',
+ result_field => 'id',
+ params => []
+ }],
+ },
+ from => 'aou',
+ where => {id => $org_id}
+ });
+
+ my @orgs;
+ push(@orgs, $_->{id}) for @$org_list;
+ return \@orgs;
+}
+
+sub get_org_full_path {
+ my($self, $org_id, $depth) = @_;
+
+ my $query = {
+ select => {
+ aou => [{
+ transform => 'actor.org_unit_full_path',
+ column => 'id',
+ result_field => 'id',
+ }],
+ },
+ from => 'aou',
+ where => {id => $org_id}
+ };
+
+ $query->{select}->{aou}->[0]->{params} = [$depth] if defined $depth;
+ my $org_list = OpenILS::Utils::CStoreEditor->new->json_query($query);
+ return [ map {$_->{id}} @$org_list ];
+}
+
+# returns the ID of the org unit ancestor at the specified depth
+sub org_unit_ancestor_at_depth {
+ my($class, $org_id, $depth) = @_;
+ my $resp = OpenILS::Utils::CStoreEditor->new->json_query(
+ {from => ['actor.org_unit_ancestor_at_depth', $org_id, $depth]})->[0];
+ return ($resp) ? $resp->{id} : undef;
+}
+
+# returns the user's configured locale as a string. Defaults to en-US if none is configured.
+sub get_user_locale {
+ my($self, $user_id, $e) = @_;
+ $e ||= OpenILS::Utils::CStoreEditor->new;
+
+ # first, see if the user has an explicit locale set
+ my $setting = $e->search_actor_user_setting(
+ {usr => $user_id, name => 'global.locale'})->[0];
+ return OpenSRF::Utils::JSON->JSON2perl($setting->value) if $setting;
+
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $self->get_org_locale($user->home_ou, $e);
+}
+
+# returns org locale setting
+sub get_org_locale {
+ my($self, $org_id, $e) = @_;
+ $e ||= OpenILS::Utils::CStoreEditor->new;
+
+ my $locale;
+ if(defined $org_id) {
+ $locale = $self->ou_ancestor_setting_value($org_id, 'global.default_locale', $e);
+ return $locale if $locale;
+ }
+
+ # system-wide default
+ my $sclient = OpenSRF::Utils::SettingsClient->new;
+ $locale = $sclient->config_value('default_locale');
+ return $locale if $locale;
+
+ # if nothing else, fallback to locale=cowboy
+ return 'en-US';
+}
+
+
+# xml-escape non-ascii characters
+sub entityize {
+ my($self, $string, $form) = @_;
+ $form ||= "";
+
+ # If we're going to convert non-ASCII characters to XML entities,
+ # we had better be dealing with a UTF8 string to begin with
+ $string = decode_utf8($string);
+
+ if ($form eq 'D') {
+ $string = NFD($string);
+ } else {
+ $string = NFC($string);
+ }
+
+ # Convert raw ampersands to entities
+ $string =~ s/&(?!\S+;)/&/gso;
+
+ # Convert Unicode characters to entities
+ $string =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
+
+ return $string;
+}
+
+# x0000-x0008 isn't legal in XML documents
+# XXX Perhaps this should just go into our standard entityize method
+sub strip_ctrl_chars {
+ my ($self, $string) = @_;
+
+ $string =~ s/([\x{0000}-\x{0008}])//sgoe;
+ return $string;
+}
+
+sub get_copy_price {
+ my($self, $e, $copy, $volume) = @_;
+
+ $copy->price(0) if $copy->price and $copy->price < 0;
+
+ return $copy->price if $copy->price and $copy->price > 0;
+
+
+ my $owner;
+ if(ref $volume) {
+ if($volume->id == OILS_PRECAT_CALL_NUMBER) {
+ $owner = $copy->circ_lib;
+ } else {
+ $owner = $volume->owning_lib;
+ }
+ } else {
+ if($copy->call_number == OILS_PRECAT_CALL_NUMBER) {
+ $owner = $copy->circ_lib;
+ } else {
+ $owner = $e->retrieve_asset_call_number($copy->call_number)->owning_lib;
+ }
+ }
+
+ my $default_price = $self->ou_ancestor_setting_value(
+ $owner, OILS_SETTING_DEF_ITEM_PRICE, $e) || 0;
+
+ return $default_price unless defined $copy->price;
+
+ # price is 0. Use the default?
+ my $charge_on_0 = $self->ou_ancestor_setting_value(
+ $owner, OILS_SETTING_CHARGE_LOST_ON_ZERO, $e) || 0;
+
+ return $default_price if $charge_on_0;
+ return 0;
+}
+
+# given a transaction ID, this returns the context org_unit for the transaction
+sub xact_org {
+ my($self, $xact_id, $e) = @_;
+ $e ||= OpenILS::Utils::CStoreEditor->new;
+
+ my $loc = $e->json_query({
+ "select" => {circ => ["circ_lib"]},
+ from => "circ",
+ "where" => {id => $xact_id},
+ });
+
+ return $loc->[0]->{circ_lib} if @$loc;
+
+ $loc = $e->json_query({
+ "select" => {bresv => ["request_lib"]},
+ from => "bresv",
+ "where" => {id => $xact_id},
+ });
+
+ return $loc->[0]->{request_lib} if @$loc;
+
+ $loc = $e->json_query({
+ "select" => {mg => ["billing_location"]},
+ from => "mg",
+ "where" => {id => $xact_id},
+ });
+
+ return $loc->[0]->{billing_location};
+}
+
+
+sub find_event_def_by_hook {
+ my($self, $hook, $context_org, $e) = @_;
+
+ $e ||= OpenILS::Utils::CStoreEditor->new;
+
+ my $orgs = $self->get_org_ancestors($context_org);
+
+ # search from the context org up
+ for my $org_id (reverse @$orgs) {
+
+ my $def = $e->search_action_trigger_event_definition(
+ {hook => $hook, owner => $org_id})->[0];
+
+ return $def if $def;
+ }
+
+ return undef;
+}
+
+
+
+# If an event_def ID is not provided, use the hook and context org to find the
+# most appropriate event. create the event, fire it, then return the resulting
+# event with fleshed template_output and error_output
+sub fire_object_event {
+ my($self, $event_def, $hook, $object, $context_org, $granularity, $user_data, $client) = @_;
+
+ my $e = OpenILS::Utils::CStoreEditor->new;
+ my $def;
+
+ my $auto_method = "open-ils.trigger.event.autocreate.by_definition";
+
+ if($event_def) {
+ $def = $e->retrieve_action_trigger_event_definition($event_def)
+ or return $e->event;
+
+ $auto_method .= '.include_inactive';
+
+ } else {
+
+ # find the most appropriate event def depending on context org
+ $def = $self->find_event_def_by_hook($hook, $context_org, $e)
+ or return $e->event;
+ }
+
+ my $final_resp;
+
+ if($def->group_field) {
+ # we have a list of objects
+ $object = [$object] unless ref $object eq 'ARRAY';
+
+ my @event_ids;
+ $user_data ||= [];
+ for my $i (0..$#$object) {
+ my $obj = $$object[$i];
+ my $udata = $$user_data[$i];
+ my $event_id = $self->simplereq(
+ 'open-ils.trigger', $auto_method, $def->id, $obj, $context_org, $udata);
+ push(@event_ids, $event_id);
+ }
+
+ $logger->info("EVENTS = " . OpenSRF::Utils::JSON->perl2JSON(\@event_ids));
+
+ my $resp;
+ if (not defined $client) {
+ $resp = $self->simplereq(
+ 'open-ils.trigger',
+ 'open-ils.trigger.event_group.fire',
+ \@event_ids);
+ } else {
+ $resp = $self->patientreq(
+ $client,
+ "open-ils.trigger", "open-ils.trigger.event_group.fire",
+ \@event_ids
+ );
+ }
+
+ if($resp and $resp->{events} and @{$resp->{events}}) {
+
+ $e->xact_begin;
+ $final_resp = $e->retrieve_action_trigger_event([
+ $resp->{events}->[0]->id,
+ {flesh => 1, flesh_fields => {atev => ['template_output', 'error_output']}}
+ ]);
+ $e->rollback;
+ }
+
+ } else {
+
+ $object = $$object[0] if ref $object eq 'ARRAY';
+
+ my $event_id;
+ my $resp;
+
+ if (not defined $client) {
+ $event_id = $self->simplereq(
+ 'open-ils.trigger',
+ $auto_method, $def->id, $object, $context_org, $user_data
+ );
+
+ $resp = $self->simplereq(
+ 'open-ils.trigger',
+ 'open-ils.trigger.event.fire',
+ $event_id
+ );
+ } else {
+ $event_id = $self->patientreq(
+ $client,
+ 'open-ils.trigger',
+ $auto_method, $def->id, $object, $context_org, $user_data
+ );
+
+ $resp = $self->patientreq(
+ $client,
+ 'open-ils.trigger',
+ 'open-ils.trigger.event.fire',
+ $event_id
+ );
+ }
+
+ if($resp and $resp->{event}) {
+ $e->xact_begin;
+ $final_resp = $e->retrieve_action_trigger_event([
+ $resp->{event}->id,
+ {flesh => 1, flesh_fields => {atev => ['template_output', 'error_output']}}
+ ]);
+ $e->rollback;
+ }
+ }
+
+ return $final_resp;
+}
+
+
+sub create_events_for_hook {
+ my($self, $hook, $obj, $org_id, $granularity, $user_data, $wait) = @_;
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ my $req = $ses->request('open-ils.trigger.event.autocreate',
+ $hook, $obj, $org_id, $granularity, $user_data);
+ return undef unless $wait;
+ my $resp = $req->recv;
+ return $resp->content if $resp;
+}
+
+sub create_uuid_string {
+ return create_UUID_as_string();
+}
+
+sub create_circ_chain_summary {
+ my($class, $e, $circ_id) = @_;
+ my $sum = $e->json_query({from => ['action.summarize_circ_chain', $circ_id]})->[0];
+ return undef unless $sum;
+ my $obj = Fieldmapper::action::circ_chain_summary->new;
+ $obj->$_($sum->{$_}) for keys %$sum;
+ return $obj;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Booking;
+
+use strict;
+use warnings;
+
+use POSIX qw/strftime/;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+use OpenSRF::Utils qw/:datetime/;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Application::AppUtils;
+my $U = "OpenILS::Application::AppUtils";
+
+use OpenSRF::Utils::Logger qw/$logger/;
+
+sub prepare_new_brt {
+ my ($record_id, $owning_lib, $mvr) = @_;
+
+ my $brt = new Fieldmapper::booking::resource_type;
+ $brt->isnew(1);
+ $brt->name($mvr->title);
+ $brt->record($record_id);
+ $brt->catalog_item('t');
+ $brt->transferable('t');
+ $brt->owner($owning_lib);
+
+ return $brt;
+}
+
+sub get_existing_brt {
+ my ($e, $record_id, $owning_lib, $mvr) = @_;
+ my $results = $e->search_booking_resource_type(
+ {name => $mvr->title, owner => $owning_lib, record => $record_id}
+ );
+
+ return $results->[0] if scalar(@$results) > 0;
+ return undef;
+}
+
+sub get_mvr {
+ return $U->simplereq(
+ 'open-ils.search',
+ 'open-ils.search.biblio.record.mods_slim.retrieve.authoritative',
+ shift # record id
+ );
+}
+
+sub get_unique_owning_libs {
+ my %hash = ();
+ $hash{$_->call_number->owning_lib} = 1 foreach (@_); # @_ are copies
+ return keys %hash;
+}
+
+sub fetch_copies_by_ids {
+ my ($e, $copy_ids) = @_;
+ my $results = $e->search_asset_copy([
+ {id => $copy_ids},
+ {flesh => 1, flesh_fields => {acp => ['call_number']}}
+ ]);
+ return $results if ref($results) eq 'ARRAY';
+ return [];
+}
+
+sub get_single_record_id {
+ my $record_id = undef;
+ foreach (@_) { # @_ are copies
+ return undef if
+ (defined $record_id && $record_id != $_->call_number->record);
+ $record_id = $_->call_number->record;
+ }
+ return $record_id;
+}
+
+# This function generates the correct json_query clause for determining
+# whether two given ranges overlap. Each range is composed of a start
+# and an end point. All four points should be the same type (could be int,
+# date, time, timestamp, or perhaps other types).
+#
+# The first range (or the first two points) should be specified as
+# literal values. The second range (or the last two points) should be
+# specified as the names of columns, the values of which in a given row
+# will constitute the second range in the comparison.
+#
+# ALSO: PostgreSQL includes an OVERLAPS operator which provides the same
+# functionality in a much more concise way, but json_query does not (yet).
+sub json_query_ranges_overlap {
+ +{ '-or' => [
+ { '-and' => [{$_[2] => {'>=', $_[0]}}, {$_[2] => {'<', $_[1]}}]},
+ { '-and' => [{$_[3] => {'>', $_[0]}}, {$_[3] => {'<', $_[1]}}]},
+ { '-and' => { $_[3] => {'>', $_[0]}, $_[2] => {'<=', $_[0]}}},
+ { '-and' => { $_[3] => {'>', $_[1]}, $_[2] => {'<', $_[1]}}},
+ ]};
+}
+
+sub create_brt_and_brsrc {
+ my ($self, $conn, $authtoken, $copy_ids) = @_;
+ my (@created_brt, @created_brsrc);
+ my %brt_table = ();
+
+ my $e = new_editor(xact => 1, authtoken => $authtoken);
+ return $e->die_event unless $e->checkauth;
+
+ my @copies = @{fetch_copies_by_ids($e, $copy_ids)};
+ my $record_id = get_single_record_id(@copies) or return $e->die_event;
+ my $mvr = get_mvr($record_id) or return $e->die_event;
+
+ foreach (get_unique_owning_libs(@copies)) {
+ $brt_table{$_} = get_existing_brt($e, $record_id, $_, $mvr) ||
+ prepare_new_brt($record_id, $_, $mvr);
+ }
+
+ while (my ($owning_lib, $brt) = each %brt_table) {
+ my $pre_existing = 1;
+ if ($brt->isnew) {
+ if ($e->allowed('ADMIN_BOOKING_RESOURCE_TYPE', $owning_lib)) {
+ $pre_existing = 0;
+ return $e->die_event unless (
+ # v-- Important: assignment modifies original hash
+ $brt = $e->create_booking_resource_type($brt)
+ );
+ }
+ }
+ push @created_brt, [$brt->id, $brt->record, $pre_existing];
+ }
+
+ foreach (@copies) {
+ if ($e->allowed(
+ 'ADMIN_BOOKING_RESOURCE', $_->call_number->owning_lib
+ )) {
+ # This block needs to disregard any cstore failures and just
+ # return what results it can.
+ my $brsrc = new Fieldmapper::booking::resource;
+ $brsrc->isnew(1);
+ $brsrc->type($brt_table{$_->call_number->owning_lib}->id);
+ $brsrc->owner($_->call_number->owning_lib);
+ $brsrc->barcode($_->barcode);
+
+ $e->set_savepoint("alpha");
+ my $pre_existing = 0;
+ my $usable_result = undef;
+ if (!($usable_result = $e->create_booking_resource($brsrc))) {
+ $e->rollback_savepoint("alpha");
+ if (($usable_result = $e->search_booking_resource(
+ +{ map { ($_, $brsrc->$_()) } qw/type owner barcode/ }
+ ))) {
+ $usable_result = $usable_result->[0];
+ $pre_existing = 1;
+ } else {
+ # So we failed to create a booking resource for this copy.
+ # For now, let's just keep going. If the calling app wants
+ # to consider this an error, it can notice the absence
+ # of a booking resource for the copy in the returned
+ # results.
+ $logger->warn(
+ "Couldn't create or find brsrc for acp #" . $_->id
+ );
+ }
+ } else {
+ $e->release_savepoint("alpha");
+ }
+
+ if ($usable_result) {
+ push @created_brsrc,
+ [$usable_result->id, $_->id, $pre_existing];
+ }
+ }
+ }
+
+ $e->commit and
+ return {brt => \@created_brt, brsrc => \@created_brsrc} or
+ return $e->die_event;
+}
+__PACKAGE__->register_method(
+ method => "create_brt_and_brsrc",
+ api_name => "open-ils.booking.resources.create_from_copies",
+ signature => {
+ params => [
+ {type => 'string', desc => 'Authentication token'},
+ {type => 'array', desc => 'Copy IDs'},
+ ],
+ return => { desc => "A two-element hash. The 'brt' element " .
+ "is a list of created booking resource types described by " .
+ "3-tuples (id, copy id, was pre-existing). The 'brsrc' " .
+ "element is a similar list of created booking resources " .
+ "described by (id, record id, was pre-existing) 3-tuples."}
+ }
+);
+
+
+sub create_bresv {
+ my ($self, $client, $authtoken,
+ $target_user_barcode, $datetime_range, $pickup_lib,
+ $brt, $brsrc_list, $attr_values) = @_;
+
+ $brsrc_list = [ undef ] if not defined $brsrc_list;
+ return undef if scalar(@$brsrc_list) < 1; # Empty list not ok.
+
+ my $e = new_editor(xact => 1, authtoken => $authtoken);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
+
+ my $usr = $U->fetch_user_by_barcode($target_user_barcode);
+ return $usr if ref($usr) eq 'HASH' and exists($usr->{"ilsevent"});
+
+ my $results = [];
+ foreach my $brsrc (@$brsrc_list) {
+ my $bresv = new Fieldmapper::booking::reservation;
+ $bresv->usr($usr->id);
+ $bresv->request_lib($e->requestor->ws_ou);
+ $bresv->pickup_lib($pickup_lib);
+ $bresv->start_time($datetime_range->[0]);
+ $bresv->end_time($datetime_range->[1]);
+
+ # A little sanity checking: don't agree to put a reservation on a
+ # brsrc and a brt when they don't match. In fact, bomb out of
+ # this transaction entirely.
+ if ($brsrc) {
+ my $brsrc_itself = $e->retrieve_booking_resource([
+ $brsrc, {
+ "flesh" => 1,
+ "flesh_fields" => {"brsrc" => ["type"]}
+ }
+ ]);
+
+ if (not $brsrc_itself) {
+ my $ev = new OpenILS::Event(
+ "RESERVATION_BAD_PARAMS",
+ desc => "brsrc $brsrc doesn't exist"
+ );
+ $e->disconnect;
+ return $ev;
+ }
+ elsif ($brsrc_itself->type->id != $brt) {
+ my $ev = new OpenILS::Event(
+ "RESERVATION_BAD_PARAMS",
+ desc => "brsrc $brsrc doesn't match given brt $brt"
+ );
+ $e->disconnect;
+ return $ev;
+ }
+
+ # Also bail if the user is trying to create a reservation at
+ # a pickup lib to which our resource won't go.
+ if (
+ $brsrc_itself->owner != $pickup_lib and
+ not $brsrc_itself->type->transferable
+ ) {
+ my $ev = new OpenILS::Event(
+ "RESERVATION_BAD_PARAMS",
+ desc => "brsrc $brsrc doesn't belong to $pickup_lib and " .
+ "is not transferable"
+ );
+ $e->disconnect;
+ return $ev;
+ }
+ }
+ $bresv->target_resource($brsrc); # undef is ok here
+ $bresv->target_resource_type($brt);
+
+ ($bresv = $e->create_booking_reservation($bresv)) or
+ return $e->die_event;
+
+ # We could/should do some sanity checking on this too: namely, on
+ # whether the attribute values given actually apply to the relevant
+ # brt. Not seeing any grievous side effects of not checking, though.
+ my @bravm = ();
+ foreach my $value (@$attr_values) {
+ my $bravm = new Fieldmapper::booking::reservation_attr_value_map;
+ $bravm->reservation($bresv->id);
+ $bravm->attr_value($value);
+ $bravm = $e->create_booking_reservation_attr_value_map($bravm) or
+ return $e->die_event;
+ push @bravm, $bravm;
+ }
+ push @$results, {
+ "bresv" => $bresv->id,
+ "bravm" => \@bravm,
+ };
+ }
+
+ $e->commit or return $e->die_event;
+
+ # Targeting must be tacked on _after_ committing the transaction where the
+ # reservations are actually created.
+ foreach (@$results) {
+ $_->{"targeting"} = $U->storagereq(
+ "open-ils.storage.booking.reservation.resource_targeter",
+ $_->{"bresv"}
+ )->[0];
+ }
+ return $results;
+}
+__PACKAGE__->register_method(
+ method => "create_bresv",
+ api_name => "open-ils.booking.reservations.create",
+ signature => {
+ params => [
+ {type => 'string', desc => 'Authentication token'},
+ {type => 'string', desc => 'Barcode of user for whom to reserve'},
+ {type => 'array', desc => 'Two elements: start and end timestamp'},
+ {type => 'int', desc => 'Desired reservation pickup lib'},
+ {type => 'int', desc => 'Booking resource type'},
+ {type => 'list', desc => 'Booking resource (undef ok; empty not ok)'},
+ {type => 'array', desc => 'Attribute values selected'},
+ ],
+ return => { desc => "A hash containing the new bresv and a list " .
+ "of new bravm"}
+ }
+);
+
+
+sub resource_list_by_attrs {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift; # Keep as argument, though not used just now.
+ my $filters = shift;
+
+ return undef unless ($filters->{type} || $filters->{attribute_values});
+
+ my $query = {
+ "select" => {brsrc => [qw/id owner/], brt => ["elbow_room"]},
+ "from" => {brsrc => {"brt" => {}}},
+ "where" => {},
+ "distinct" => 1
+ };
+
+ $query->{where} = {"-and" => []};
+ if ($filters->{type}) {
+ push @{$query->{where}->{"-and"}}, {"type" => $filters->{type}};
+ }
+
+ if ($filters->{pickup_lib}) {
+ push @{$query->{where}->{"-and"}},
+ {"-or" => [
+ {"owner" => $filters->{pickup_lib}},
+ {"+brt" => {"transferable" => "t"}}
+ ]};
+ }
+
+ if ($filters->{attribute_values}) {
+
+ $query->{from}->{brsrc}->{bram} = { field => 'resource' };
+
+ $filters->{attribute_values} = [$filters->{attribute_values}]
+ if (!ref($filters->{attribute_values}));
+
+ $query->{having}->{'+bram'}->{value}->{'@>'} = {
+ transform => 'array_accum',
+ value => '$_' . $$ . '${' .
+ join(',', @{$filters->{attribute_values}}) .
+ '}$_' . $$ . '$'
+ };
+ }
+
+ if ($filters->{available}) {
+ # If only one timestamp has been provided, make it into a range.
+ if (!ref($filters->{available})) {
+ $filters->{available} = [($filters->{available}) x 2];
+ }
+
+ push @{$query->{where}->{"-and"}}, {
+ "-or" => [
+ {"overbook" => "t"},
+ {"-not-exists" => {
+ "select" => {"bresv" => ["id"]},
+ "from" => "bresv",
+ "where" => {"-and" => [
+ json_query_ranges_overlap(
+ $filters->{available}->[0],
+ $filters->{available}->[1],
+ "start_time",
+ "end_time"
+ ),
+ {"cancel_time" => undef},
+ {"return_time" => undef},
+ {"current_resource" => {"=" => {"+brsrc" => "id"}}}
+ ]},
+ }}
+ ]
+ };
+ }
+ if ($filters->{booked}) {
+ # If only one timestamp has been provided, make it into a range.
+ if (!ref($filters->{booked})) {
+ $filters->{booked} = [($filters->{booked}) x 2];
+ }
+
+ push @{$query->{where}->{"-and"}}, {
+ "-exists" => {
+ "select" => {"bresv" => ["id"]},
+ "from" => "bresv",
+ "where" => {"-and" => [
+ json_query_ranges_overlap(
+ $filters->{booked}->[0],
+ $filters->{booked}->[1],
+ "start_time",
+ "end_time"
+ ),
+ {"cancel_time" => undef},
+ {"current_resource" => { "=" => {"+brsrc" => "id"}}}
+ ]},
+ }
+ };
+ # I think that the "booked" case could be done with a JOIN instead of
+ # an EXISTS, but I'm leaving it this way for symmetry with the
+ # "available" case for now. The available case cannot be done with a
+ # join.
+ }
+
+ my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
+ my $rows = $cstore->request(
+ "open-ils.cstore.json_query.atomic", $query
+ )->gather(1);
+ $cstore->disconnect;
+
+ return [] if not @$rows;
+
+ if ($filters->{"pickup_lib"} && $filters->{"available"}) {
+ my @new_rows = ();
+ my $general_elbow_room = $U->ou_ancestor_setting_value(
+ $filters->{"pickup_lib"},
+ "circ.booking_reservation.default_elbow_room"
+ ) || '0 seconds';
+ my $would_start = $filters->{"available"}->[0];
+ my $dt_parser = new DateTime::Format::ISO8601;
+
+ $logger->info(
+ "general_elbow_room: '$general_elbow_room', " .
+ "would_start: '$would_start'"
+ );
+
+ # Here, elbow_room will double as required transit time padding.
+ foreach (@$rows) {
+ my $elbow_room = $_->{"elbow_room"} || $general_elbow_room;
+ if ($_->{"owner"} != $filters->{"pickup_lib"}) {
+ (my $ws = $would_start) =~ s/ /T/;
+ push @new_rows, $_ if DateTime->compare(
+ $dt_parser->parse_datetime($ws),
+ DateTime->now(
+ "time_zone" => DateTime::TimeZone->new(
+ "name" => "local"
+ )
+ )->add(seconds => interval_to_seconds($elbow_room))
+ ) >= 0;
+ } else {
+ push @new_rows, $_;
+ }
+ }
+ return [map { $_->{id} } @new_rows];
+ } else {
+ return [map { $_->{id} } @$rows];
+ }
+}
+__PACKAGE__->register_method(
+ method => "resource_list_by_attrs",
+ api_name => "open-ils.booking.resources.filtered_id_list",
+ argc => 2,
+ signature=> {
+ params => [
+ {type => 'string', desc => 'Authentication token (unused for now,' .
+ ' but at least pass undef here)'},
+ {type => 'object', desc => 'Filter object: see notes for details'},
+ ],
+ return => { desc => "An array of brsrc ids matching the requested filters." },
+ },
+ notes => <<'NOTES'
+
+The filter object parameter can contain the following keys:
+ * type => The id of a booking resource type (brt)
+ * attribute_values => The ids of booking resource type attribute values that the resource must have assigned to it (brav)
+ * available => Either:
+ A timestamp during which the resources are not reserved. If the resource is overbookable, this is ignored.
+ A range of two timestamps which do not overlap any reservations for the resources. If the resource is overbookable, this is ignored.
+ * booked => Either:
+ A timestamp during which the resources are reserved.
+ A range of two timestamps which overlap a reservation of the resources.
+
+Note that at least one of 'type' or 'attribute_values' is required.
+
+NOTES
+);
+
+
+sub reservation_list_by_filters {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $filters = shift;
+ my $whole_obj = shift;
+
+ return undef unless ($filters->{user} || $filters->{user_barcode} || $filters->{resource} || $filters->{type} || $filters->{attribute_values});
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_TRANSACTION');
+
+ my $query = {
+ 'select' => { bresv => [ 'id', 'start_time' ] },
+ 'from' => { bresv => {} },
+ 'where' => {},
+ 'order_by' => [{ class => bresv => field => start_time => direction => 'asc' }],
+ 'distinct' => 1
+ };
+
+ if ($filters->{fields}) {
+ $query->{where} = $filters->{fields};
+ }
+
+
+ if ($filters->{user}) {
+ $query->{where}->{usr} = $filters->{user};
+ }
+ elsif ($filters->{user_barcode}) { # just one of user and user_barcode
+ my $usr = $U->fetch_user_by_barcode($filters->{user_barcode});
+ return $usr if ref($usr) eq 'HASH' and exists($usr->{"ilsevent"});
+ $query->{where}->{usr} = $usr->id;
+ }
+
+
+ if ($filters->{type}) {
+ $query->{where}->{target_resource_type} = $filters->{type};
+ }
+
+ $query->{where}->{"-and"} = [];
+ if ($filters->{resource}) {
+# $query->{where}->{target_resource} = $filters->{resource};
+ push @{$query->{where}->{"-and"}}, {
+ "-or" => {
+ "target_resource" => $filters->{resource},
+ "current_resource" => $filters->{resource}
+ }
+ };
+ }
+
+ if ($filters->{attribute_values}) {
+
+ $query->{from}->{bresv}->{bravm} = { field => 'reservation' };
+
+ $filters->{attribute_values} = [$filters->{attribute_values}]
+ if (!ref($filters->{attribute_values}));
+
+ $query->{having}->{'+bravm'}->{attr_value}->{'@>'} = {
+ transform => 'array_accum',
+ value => '$_' . $$ . '${' .
+ join(',', @{$filters->{attribute_values}}) .
+ '}$_' . $$ . '$'
+ };
+ }
+
+ if ($filters->{search_start} || $filters->{search_end}) {
+ my $or = {};
+
+ $or->{start_time} =
+ {'between' => [ $filters->{search_start}, $filters->{search_end}]}
+ if $filters->{search_start};
+
+ $or->{end_time} =
+ {'between' =>[$filters->{search_start}, $filters->{search_end}]}
+ if $filters->{search_end};
+
+ push @{$query->{where}->{"-and"}}, {"-or" => $or};
+ }
+
+ if (not scalar @{$query->{"where"}->{"-and"}}) {
+ delete $query->{"where"}->{"-and"};
+ }
+
+ my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
+ my $ids = [ map { $_->{id} } @{
+ $cstore->request(
+ 'open-ils.cstore.json_query.atomic', $query
+ )->gather(1)
+ } ];
+ $cstore->disconnect;
+
+ if (not $whole_obj or @$ids < 1) {
+ $e->disconnect;
+ return $ids;
+ }
+
+ my $bresv_list = $e->search_booking_reservation([
+ {"id" => $ids},
+ {"flesh" => 1,
+ "flesh_fields" => {
+ "bresv" =>
+ [qw/target_resource current_resource target_resource_type/]
+ }
+ }]
+ );
+ $e->disconnect;
+ return $bresv_list ? $bresv_list : [];
+}
+__PACKAGE__->register_method(
+ method => "reservation_list_by_filters",
+ api_name => "open-ils.booking.reservations.filtered_id_list",
+ argc => 3,
+ signature=> {
+ params => [
+ {type => 'string', desc => 'Authentication token'},
+ {type => "object", desc => "Filter object: see notes for details"},
+ {type => "bool", desc => "Return whole object instead of ID? (default false)"}
+ ],
+ return => { desc => "An array of bresv ids matching the requested filters." },
+ },
+ notes => <<'NOTES'
+
+The filter object parameter can contain the following keys:
+ * user => The id of a user that has requested a bookable item -- filters on bresv.usr
+ * barcode => The barcode of a user that has requested a bookable item
+ * type => The id of a booking resource type (brt) -- filters on bresv.target_resource_type
+ * resource => The id of a booking resource (brsrc) -- filters on bresv.target_resource
+ * attribute_values => The ids of booking resource type attribute values that the resource must have assigned to it (brav)
+ * search_start => If search_end is not specified, booking interval (start_time to end_time) must contain this timestamp.
+ * search_end => If search_start is not specified, booking interval (start_time to end_time) must contain this timestamp.
+ * fields => An object containing any combination of bresv search filters in standard cstore/pcrud search format.
+
+Note that at least one of 'user', 'type', 'resource' or 'attribute_values' is required. If both search_start and search_end are specified,
+then the result includes any reservations that overlap with that time range. Any filter fields supplied in 'fields' are overridden
+by the top-level filters ('user', 'type', 'resource').
+
+NOTES
+);
+
+
+sub naive_ts_string {strftime("%F %T", localtime($_[0] || time));}
+sub naive_start_of_day {strftime("%F", localtime($_[0] || time))." 00:00:00";}
+
+# Return a map of bresv or an ilsevent on failure.
+sub get_uncaptured_bresv_for_brsrc {
+ my ($e, $o) = @_; # o's keys (all optional): owning_lib, barcode, range
+
+ my $from_clause = {
+ "bresv" => {
+ "brsrc" => {"field" => "id", "fkey" => "current_resource"}
+ }
+ };
+
+ my $query = {
+ "select" => {
+ "bresv" => [
+ "current_resource",
+ {
+ "column" => "start_time",
+ "transform" => "min",
+ "aggregate" => 1
+ }
+ ]
+ },
+ "from" => $from_clause,
+ "where" => {
+ "-and" => [
+ {"current_resource" => {"!=" => undef}},
+ {"capture_time" => undef},
+ {"cancel_time" => undef},
+ {"return_time" => undef},
+ {"pickup_time" => undef}
+ ]
+ }
+ };
+ if ($o->{"owning_lib"}) {
+ push @{$query->{"where"}->{"-and"}},
+ {"+brsrc" => {"owner" => $o->{"owning_lib"}}};
+ }
+ if ($o->{"range"}) {
+ push @{$query->{"where"}->{"-and"}},
+ json_query_ranges_overlap(
+ $o->{"range"}->[0], $o->{"range"}->[1],
+ "start_time", "end_time"
+ );
+ }
+ if ($o->{"barcode"}) {
+ push @{$query->{"where"}->{"-and"}},
+ {"+brsrc" => {"barcode" => $o->{"barcode"}}};
+ }
+
+ my $rows = $e->json_query($query);
+ my $current_resource_bresv_map = {};
+ if (@$rows) {
+ my $id_query = {
+ "select" => {"bresv" => ["id"]},
+ "from" => $from_clause,
+ "where" => {
+ "-and" => [
+ {"current_resource" => "PLACEHOLDER"},
+ {"start_time" => "PLACEHOLDER"},
+ {"capture_time" => undef},
+ {"cancel_time" => undef},
+ {"return_time" => undef},
+ {"pickup_time" => undef}
+ ]
+ }
+ };
+ if ($o->{"owning_lib"}) {
+ push @{$id_query->{"where"}->{"-and"}},
+ {"+brsrc" => {"owner" => $o->{"owning_lib"}}};
+ }
+
+ foreach (@$rows) {
+ $id_query->{"where"}->{"-and"}->[0]->{"current_resource"} =
+ $_->{"current_resource"};
+ $id_query->{"where"}->{"-and"}->[1]->{"start_time"} =
+ $_->{"start_time"};
+
+ my $results = $e->json_query($id_query);
+ if ($results && @$results) {
+ $current_resource_bresv_map->{$_->{"current_resource"}} =
+ [map { $_->{"id"} } @$results];
+ }
+ }
+ }
+ return $current_resource_bresv_map;
+}
+
+sub get_pull_list {
+ my ($self, $client, $auth, $range, $interval_secs, $owning_lib) = @_;
+
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("RETRIEVE_RESERVATION_PULL_LIST");
+ return $e->die_event unless (
+ ref($range) eq "ARRAY" or
+ ($interval_secs = int($interval_secs)) > 0
+ );
+
+ $owning_lib = $e->requestor->ws_ou if not $owning_lib;
+ $range = [ naive_ts_string(time), naive_ts_string(time + $interval_secs) ]
+ if not $range;
+
+ my $uncaptured = get_uncaptured_bresv_for_brsrc(
+ $e, {"range" => $range, "owning_lib" => $owning_lib}
+ );
+
+ if (keys(%$uncaptured)) {
+ my @all_bresv_ids = map { @{$_} } values %$uncaptured;
+ my %bresv_lookup = (
+ map { $_->id => $_ } @{
+ $e->search_booking_reservation([{"id" => [@all_bresv_ids]}, {
+ flesh => 1,
+ flesh_fields => { bresv => [
+ "usr", "target_resource_type", "current_resource"
+ ]}
+ }])
+ }
+ );
+ $e->disconnect;
+ return [ map {
+ my $key = $_;
+ my $one = $bresv_lookup{$uncaptured->{$key}->[0]};
+ my $result = {
+ "current_resource" => $one->current_resource,
+ "target_resource_type" => $one->target_resource_type,
+ "reservations" => [
+ map { $bresv_lookup{$_} } @{$uncaptured->{$key}}
+ ]
+ };
+ foreach (@{$result->{"reservations"}}) { # deflesh
+ $_->current_resource($_->current_resource->id);
+ $_->target_resource_type($_->target_resource_type->id);
+ }
+ $result;
+ } keys %$uncaptured ];
+ } else {
+ $e->disconnect;
+ return [];
+ }
+}
+__PACKAGE__->register_method(
+ method => "get_pull_list",
+ api_name => "open-ils.booking.reservations.get_pull_list",
+ argc => 4,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "array", desc =>
+ "range: Date/time range for reservations (opt)"},
+ {type => "int", desc =>
+ "interval: Seconds from now (instead of range)"},
+ {type => "number", desc => "(Optional) Owning library"}
+ ],
+ return => { desc => "An array of hashes, each containing key/value " .
+ "pairs describing resource, resource type, and a list of " .
+ "reservations that claim the given resource." }
+ }
+);
+
+
+sub could_capture {
+ my ($self, $client, $auth, $barcode) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("COPY_CHECKIN");
+
+ my $dt_parser = new DateTime::Format::ISO8601;
+ my $now = now DateTime; # sic
+ my $res = get_uncaptured_bresv_for_brsrc($e, {"barcode" => $barcode});
+
+ if ($res and keys %$res) {
+ my $id;
+ while ((undef, $id) = each %$res) {
+ my $bresv = $e->retrieve_booking_reservation([
+ $id, {
+ "flesh" => 1, "flesh_fields" => {
+ "bresv" => [qw(
+ usr target_resource_type
+ target_resource current_resource
+ )]
+ }
+ }
+ ]);
+ my $elbow_room = interval_to_seconds(
+ $bresv->target_resource_type->elbow_room ||
+ $U->ou_ancestor_setting_value(
+ $bresv->pickup_lib,
+ "circ.booking_reservation.default_elbow_room"
+ ) ||
+ "0 seconds"
+ );
+
+ unless ($elbow_room) {
+ $client->respond($bresv);
+ } else {
+ my $start_time = $dt_parser->parse_datetime(
+ clense_ISO8601($bresv->start_time)
+ );
+
+ if ($now >= $start_time->subtract("seconds" => $elbow_room)) {
+ $client->respond($bresv);
+ } else {
+ $logger->info(
+ "not within elbow room: $elbow_room, " .
+ "else would have returned bresv " . $bresv->id
+ );
+ }
+ }
+ }
+ }
+ $e->disconnect;
+ undef;
+}
+__PACKAGE__->register_method(
+ method => "could_capture",
+ api_name => "open-ils.booking.reservations.could_capture",
+ argc => 2,
+ streaming=> 1,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "string", desc => "Resource barcode"}
+ ],
+ return => {desc => "One or zero reservations; event on error."}
+ }
+);
+
+
+sub get_copy_fleshed_just_right {
+ my ($self, $client, $auth, $barcode) = @_;
+
+ return undef if not defined $barcode;
+ return {} if ref($barcode) eq "ARRAY" and not @$barcode;
+
+ my $e = new_editor(authtoken => $auth);
+ my $results = $e->search_asset_copy([
+ {"barcode" => $barcode},
+ {
+ "flesh" => 1,
+ "flesh_fields" => {"acp" => [qw/call_number location/]}
+ }
+ ]);
+
+ if (ref($results) eq "ARRAY") {
+ $e->disconnect;
+ return $results->[0] unless ref $barcode;
+ return +{ map { $_->barcode => $_ } @$results };
+ } else {
+ return $e->die_event;
+ }
+}
+__PACKAGE__->register_method(
+ method => "get_copy_fleshed_just_right",
+ api_name => "open-ils.booking.asset.get_copy_fleshed_just_right",
+ argc => 2,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "mixed", desc => "One barcode or an array of them"},
+ ],
+ return => { desc =>
+ "A copy, or a hash of copies keyed by barcode if an array of " .
+ "barcodes was given"
+ }
+ }
+);
+
+
+sub best_bresv_candidate {
+ my ($e, $id_list) = @_;
+
+ # This will almost always be the case.
+ if (@$id_list == 1) {
+ $logger->info("best_bresv_candidate (only) " . $id_list->[0]);
+ return $id_list->[0];
+ }
+
+ my @here = ();
+ my $this_ou = $e->requestor->ws_ou;
+ my $results = $e->json_query({
+ "select" => {"brsrc" => ["pickup_lib"], "bresv" => ["id"]},
+ "from" => {
+ "bresv" => {
+ "brsrc" => {"field" => "id", "fkey" => "current_resource"}
+ }
+ },
+ "where" => {
+ {"+bresv" => {"id" => $id_list}}
+ }
+ });
+
+ foreach (@$results) {
+ push @here, $_->{"id"} if $_->{"pickup_lib"} == $this_ou;
+ }
+
+ my $result;
+ if (@here > 0) {
+ $result = @here == 1 ? pop @here : (sort @here)[0];
+ } else {
+ $result = (sort @$id_list)[0];
+ }
+ $logger->info(
+ "best_bresv_candidate from " . join(",", @$id_list) . ": $result"
+ );
+ return $result;
+}
+
+
+sub capture_resource_for_reservation {
+ my ($self, $client, $auth, $barcode, $no_update_copy) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("COPY_CHECKIN");
+
+ my $uncaptured = get_uncaptured_bresv_for_brsrc(
+ $e, {"barcode" => $barcode}
+ );
+
+ if (keys %$uncaptured) {
+ # Note this will only capture one reservation at a time, even in
+ # cases with overbooking (multiple "soonest" bresv's on a resource).
+ my $bresv = best_bresv_candidate(
+ $e, $uncaptured->{
+ (sort(keys %$uncaptured))[0]
+ }
+ );
+ $e->disconnect;
+ return capture_reservation(
+ $self, $client, $auth, $bresv, $no_update_copy
+ );
+ } else {
+ return new OpenILS::Event(
+ "RESERVATION_NOT_FOUND",
+ "desc" => "No capturable reservation found pertaining " .
+ "to a resource with barcode $barcode",
+ "payload" => {"fail_cause" => "no-reservation", "captured" => 0}
+ );
+ }
+}
+__PACKAGE__->register_method(
+ method => "capture_resource_for_reservation",
+ api_name => "open-ils.booking.resources.capture_for_reservation",
+ argc => 3,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "string", desc => "Barcode of booked & targeted resource"},
+ {type => "number", desc => "(optional) 1 to not update copy"}
+ ],
+ return => { desc => "An OpenILS event describing the capture outcome" }
+ }
+);
+
+
+sub capture_reservation {
+ my ($self, $client, $auth, $res_id, $no_update_copy) = @_;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("COPY_CHECKIN");
+ my $here = $e->requestor->ws_ou;
+
+ my $reservation = $e->retrieve_booking_reservation([
+ $res_id, {
+ "flesh" => 2, "flesh_fields" => {
+ "bresv" => [qw/usr current_resource type/],
+ "au" => ["card"],
+ "brsrc" => ["type"]
+ }
+ }
+ ]);
+
+ return new OpenILS::Event("RESERVATION_NOT_FOUND") unless $reservation;
+ return new OpenILS::Event(
+ "RESERVATION_CAPTURE_FAILED",
+ payload => {"captured" => 0, "fail_cause" => "no-resource"}
+ ) unless $reservation->current_resource;
+
+ return new OpenILS::Event(
+ "RESERVATION_CAPTURE_FAILED",
+ "payload" => {"captured" => 0, "fail_cause" => "cancelled"}
+ ) if $reservation->cancel_time;
+
+ $reservation->capture_staff($e->requestor->id);
+ $reservation->capture_time("now");
+
+ $e->update_booking_reservation($reservation) or return $e->die_event;
+
+ my $ret = {"captured" => 1, "reservation" => $reservation};
+
+ my $search_acp_like_this = [
+ {
+ "barcode" => $reservation->current_resource->barcode,
+ "deleted" => "f"
+ },
+ {"flesh" => 1, "flesh_fields" => {"acp" => ["call_number"]}}
+ ];
+
+ if ($here != $reservation->pickup_lib) {
+ $logger->info("resource isn't at the reservation's pickup lib...");
+ return new OpenILS::Event(
+ "RESERVATION_CAPTURE_FAILED",
+ "payload" => {"captured" => 0, "fail_cause" => "not-transferable"}
+ ) unless $U->is_true(
+ $reservation->current_resource->type->transferable
+ );
+
+ # need to transit the item ... is it already in transit?
+ my $transit = $e->search_action_reservation_transit_copy(
+ {"reservation" => $res_id, "dest_recv_time" => undef}
+ )->[0];
+
+ if (!$transit) { # not yet in transit
+ $transit = new Fieldmapper::action::reservation_transit_copy;
+
+ $transit->reservation($reservation->id);
+ $transit->target_copy($reservation->current_resource->id);
+ $transit->copy_status(15);
+ $transit->source_send_time("now");
+ $transit->source($here);
+ $transit->dest($reservation->pickup_lib);
+
+ $e->create_action_reservation_transit_copy($transit);
+
+ if ($U->is_true(
+ $reservation->current_resource->type->catalog_item
+ )) {
+ my $copy = $e->search_asset_copy($search_acp_like_this)->[0];
+
+ if ($copy) {
+ return new OpenILS::Event(
+ "OPEN_CIRCULATION_EXISTS",
+ "payload" => {"captured" => 0, "copy" => $copy}
+ ) if $copy->status == 1 and not $no_update_copy;
+
+ $ret->{"mvr"} = get_mvr($copy->call_number->record);
+ if ($no_update_copy) {
+ $ret->{"new_copy_status"} = 6;
+ } else {
+ $copy->status(6);
+ $e->update_asset_copy($copy) or return $e->die_event;
+ }
+ }
+ }
+ }
+
+ $ret->{"transit"} = $transit;
+ } elsif ($U->is_true($reservation->current_resource->type->catalog_item)) {
+ $logger->info("resource is a catalog item...");
+ my $copy = $e->search_asset_copy($search_acp_like_this)->[0];
+
+ if ($copy) {
+ return new OpenILS::Event(
+ "OPEN_CIRCULATION_EXISTS",
+ "payload" => {"captured" => 0, "copy" => $copy}
+ ) if $copy->status == 1 and not $no_update_copy;
+
+ $ret->{"mvr"} = get_mvr($copy->call_number->record);
+ if ($no_update_copy) {
+ $ret->{"new_copy_status"} = 15;
+ } else {
+ $copy->status(15);
+ $e->update_asset_copy($copy) or return $e->die_event;
+ }
+ }
+ }
+
+ $e->commit or return $e->die_event;
+
+ # XXX I'm not sure whether these last two elements of the payload
+ # actually get used anywhere.
+ $ret->{"resource"} = $reservation->current_resource;
+ $ret->{"type"} = $reservation->current_resource->type;
+ return new OpenILS::Event("SUCCESS", "payload" => $ret);
+}
+__PACKAGE__->register_method(
+ method => "capture_reservation",
+ api_name => "open-ils.booking.reservations.capture",
+ argc => 2,
+ signature=> {
+ params => [
+ {type => 'string', desc => 'Authentication token'},
+ {type => 'mixed', desc =>
+ 'Reservation ID (number) or array of resource barcodes'}
+ ],
+ return => { desc => "An OpenILS Event object describing the outcome of the capture, with relevant payload." },
+ }
+);
+
+
+sub cancel_reservation {
+ my ($self, $client, $auth, $id_list) = @_;
+
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ # Should the following permission really be checked as relates to each
+ # individual reservation's request_lib? Hrmm...
+ return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
+
+ my $bresv_list = $e->search_booking_reservation([
+ {"id" => $id_list},
+ {"flesh" => 1, "flesh_fields" => {"bresv" => [
+ "current_resource", "target_resource_type"
+ ]}}
+ ]);
+ return $e->die_event if not $bresv_list;
+
+ my @results = ();
+ my $circ = OpenSRF::AppSession->connect("open-ils.circ") or
+ return $e->die_event;
+ foreach my $bresv (@$bresv_list) {
+ $bresv->cancel_time("now");
+ $e->update_booking_reservation($bresv) or do {
+ $circ->disconnect;
+ return $e->die_event;
+ };
+ $e->xact_commit;
+ $e->xact_begin;
+
+ if (
+ $bresv->target_resource_type->catalog_item == "t" &&
+ $bresv->current_resource
+ ) {
+ $logger->info("result of no-op checkin (upon cxl bresv) is " .
+ $circ->request(
+ "open-ils.circ.checkin", $auth,
+ {"barcode" => $bresv->current_resource->barcode,
+ "noop" => 1}
+ )->gather(1)->{"textcode"});
+ }
+ push @results, $bresv->id;
+ }
+
+ $e->disconnect;
+ $circ->disconnect;
+
+ return \@results;
+}
+__PACKAGE__->register_method(
+ method => "cancel_reservation",
+ api_name => "open-ils.booking.reservations.cancel",
+ argc => 2,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "array", desc => "List of reservation IDs"}
+ ],
+ return => { desc => "A list of canceled reservation IDs" },
+ }
+);
+
+
+sub get_captured_reservations {
+ my ($self, $client, $auth, $barcode, $which) = @_;
+
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("VIEW_USER");
+ return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
+
+ # fetch the patron for our uses in any case...
+ my $patron = $U->fetch_user_by_barcode($barcode);
+ return $patron if ref($patron) eq "HASH" and exists $patron->{"ilsevent"};
+
+ my $bresv_flesh = {
+ "flesh" => 1,
+ "flesh_fields" => {"bresv" => [
+ qw/target_resource_type current_resource/
+ ]}
+ };
+
+ my $dispatch = {
+ "patron" => sub {
+ return $patron;
+ },
+ "ready" => sub {
+ return $e->search_booking_reservation([
+ {
+ "usr" => $patron->id,
+ "capture_time" => {"!=" => undef},
+ "pickup_time" => undef,
+ "start_time" => {">=" => naive_start_of_day()},
+ "cancel_time" => undef
+ },
+ $bresv_flesh
+ ]) or $e->die_event;
+ },
+ "out" => sub {
+ return $e->search_booking_reservation([
+ {
+ "usr" => $patron->id,
+ "pickup_time" => {"!=" => undef},
+ "return_time" => undef,
+ "cancel_time" => undef
+ },
+ $bresv_flesh
+ ]) or $e->die_event;
+ },
+ "in" => sub {
+ return $e->search_booking_reservation([
+ {
+ "usr" => $patron->id,
+ "return_time" => {">=" => naive_start_of_day()},
+ "cancel_time" => undef
+ },
+ $bresv_flesh
+ ]) or $e->die_event;
+ }
+ };
+
+ my $result = {};
+ foreach (@$which) {
+ my $f = $dispatch->{$_};
+ if ($f) {
+ my $r = &{$f}();
+ return $r if (ref($r) eq "HASH" and exists $r->{"ilsevent"});
+ $result->{$_} = $r;
+ }
+ }
+
+ return $result;
+}
+__PACKAGE__->register_method(
+ method => "get_captured_reservations",
+ api_name => "open-ils.booking.reservations.get_captured",
+ argc => 3,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "string", desc => "Patron barcode"},
+ {type => "array", desc => "Parts wanted (patron, ready, out, in?)"}
+ ],
+ return => { desc => "A hash of parts." } # XXX describe more fully
+ }
+);
+
+
+sub get_bresv_by_returnable_resource_barcode {
+ my ($self, $client, $auth, $barcode) = @_;
+
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("VIEW_USER");
+# return $e->die_event unless $e->allowed("ADMIN_BOOKING_RESERVATION");
+
+ my $rows = $e->json_query({
+ "select" => {"bresv" => ["id"]},
+ "from" => {
+ "bresv" => {
+ "brsrc" => {"field" => "id", "fkey" => "current_resource"}
+ }
+ },
+ "where" => {
+ "+brsrc" => {"barcode" => $barcode},
+ "-and" => {
+ "pickup_time" => {"!=" => undef},
+ "cancel_time" => undef,
+ "return_time" => undef
+ }
+ }
+ }) or return $e->die_event;
+
+ if (@$rows < 1) {
+ $e->rollback;
+ return $rows;
+ } else {
+ # More than one result might be possible, but we don't want to return
+ # more than one at this time.
+ my $id = $rows->[0]->{"id"};
+ my $resp =$e->retrieve_booking_reservation([
+ $id, {
+ "flesh" => 2,
+ "flesh_fields" => {
+ "bresv" => [qw/usr target_resource_type current_resource/],
+ "au" => ["card"]
+ }
+ }
+ ]) or $e->die_event;
+ $e->rollback;
+ return $resp;
+ }
+}
+
+__PACKAGE__->register_method(
+ method => "get_bresv_by_returnable_resource_barcode",
+ api_name => "open-ils.booking.reservations.by_returnable_resource_barcode",
+ argc => 2,
+ signature=> {
+ params => [
+ {type => "string", desc => "Authentication token"},
+ {type => "string", desc => "Resource barcode"},
+ ],
+ return => { desc => "A fleshed bresv or an ilsevent on error" }
+ }
+);
+
+
+1;
--- /dev/null
+use strict; use warnings;
+package OpenILS::Application::Cat;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application;
+use OpenILS::Application::Cat::Merge;
+use OpenILS::Application::Cat::Authority;
+use OpenILS::Application::Cat::BibCommon;
+use OpenILS::Application::Cat::AssetCommon;
+use base qw/OpenILS::Application/;
+use Time::HiRes qw(time);
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::JSON;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Event;
+use OpenILS::Const qw/:const/;
+
+use XML::LibXML;
+use Unicode::Normalize;
+use Data::Dumper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Perm;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw($logger);
+use OpenSRF::AppSession;
+
+my $U = "OpenILS::Application::AppUtils";
+my $conf;
+my %marctemplates;
+
+__PACKAGE__->register_method(
+ method => "retrieve_marc_template",
+ api_name => "open-ils.cat.biblio.marc_template.retrieve",
+ notes => <<" NOTES");
+ Returns a MARC 'record tree' based on a set of pre-defined templates.
+ Templates include : book
+ NOTES
+
+sub retrieve_marc_template {
+ my( $self, $client, $type ) = @_;
+ return $marctemplates{$type} if defined($marctemplates{$type});
+ $marctemplates{$type} = _load_marc_template($type);
+ return $marctemplates{$type};
+}
+
+__PACKAGE__->register_method(
+ method => 'fetch_marc_template_types',
+ api_name => 'open-ils.cat.marc_template.types.retrieve'
+);
+
+my $marc_template_files;
+
+sub fetch_marc_template_types {
+ my( $self, $conn ) = @_;
+ __load_marc_templates();
+ return [ keys %$marc_template_files ];
+}
+
+sub __load_marc_templates {
+ return if $marc_template_files;
+ if(!$conf) { $conf = OpenSRF::Utils::SettingsClient->new; }
+
+ $marc_template_files = $conf->config_value(
+ "apps", "open-ils.cat","app_settings", "marctemplates" );
+
+ $logger->info("Loaded marc templates: " . Dumper($marc_template_files));
+}
+
+sub _load_marc_template {
+ my $type = shift;
+
+ __load_marc_templates();
+
+ my $template = $$marc_template_files{$type};
+ open( F, $template ) or
+ throw OpenSRF::EX::ERROR ("Unable to open MARC template file: $template : $@");
+
+ my @xml = <F>;
+ close(F);
+ my $xml = join('', @xml);
+
+ return XML::LibXML->new->parse_string($xml)->documentElement->toString;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_bib_sources',
+ api_name => 'open-ils.cat.bib_sources.retrieve.all');
+
+sub fetch_bib_sources {
+ return OpenILS::Application::Cat::BibCommon->fetch_bib_sources();
+}
+
+__PACKAGE__->register_method(
+ method => "create_record_xml",
+ api_name => "open-ils.cat.biblio.record.xml.create.override",
+ signature => q/@see open-ils.cat.biblio.record.xml.create/);
+
+__PACKAGE__->register_method(
+ method => "create_record_xml",
+ api_name => "open-ils.cat.biblio.record.xml.create",
+ signature => q/
+ Inserts a new biblio with the given XML
+ /
+);
+
+sub create_record_xml {
+ my( $self, $client, $login, $xml, $source ) = @_;
+
+ my $override = 1 if $self->api_name =~ /override/;
+
+ my( $user_obj, $evt ) = $U->checksesperm($login, 'CREATE_MARC');
+ return $evt if $evt;
+
+ $logger->activity("user ".$user_obj->id." creating new MARC record");
+
+ my $meth = $self->method_lookup("open-ils.cat.biblio.record.xml.import");
+
+ $meth = $self->method_lookup(
+ "open-ils.cat.biblio.record.xml.import.override") if $override;
+
+ my ($s) = $meth->run($login, $xml, $source);
+ return $s;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "biblio_record_replace_marc",
+ api_name => "open-ils.cat.biblio.record.xml.update",
+ argc => 3,
+ signature => q/
+ Updates the XML for a given biblio record.
+ This does not change any other aspect of the record entry
+ exception the XML, the editor, and the edit date.
+ @return The update record object
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'biblio_record_replace_marc',
+ api_name => 'open-ils.cat.biblio.record.marc.replace',
+ signature => q/
+ @param auth The authtoken
+ @param recid The record whose MARC we're replacing
+ @param newxml The new xml to use
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'biblio_record_replace_marc',
+ api_name => 'open-ils.cat.biblio.record.marc.replace.override',
+ signature => q/@see open-ils.cat.biblio.record.marc.replace/
+);
+
+sub biblio_record_replace_marc {
+ my( $self, $conn, $auth, $recid, $newxml, $source ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_MARC', $e->requestor->ws_ou);
+
+ my $fix_tcn = $self->api_name =~ /replace/o;
+ my $override = $self->api_name =~ /override/o;
+
+ my $res = OpenILS::Application::Cat::BibCommon->biblio_record_replace_marc(
+ $e, $recid, $newxml, $source, $fix_tcn, $override);
+
+ $e->commit unless $U->event_code($res);
+
+ #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
+ #$ses->request('open-ils.ingest.full.biblio.record', $recid);
+
+ return $res;
+}
+
+__PACKAGE__->register_method(
+ method => "template_overlay_biblio_record_entry",
+ api_name => "open-ils.cat.biblio.record_entry.template_overlay",
+ stream => 1,
+ signature => q#
+ Overlays biblio.record_entry MARC values
+ @param auth The authtoken
+ @param records The record ids to be updated by the template
+ @param template The overlay template
+ @return Stream of hashes record id in the key "record" and t or f for the success of the overlay operation in key "success"
+ #
+);
+
+sub template_overlay_biblio_record_entry {
+ my($self, $conn, $auth, $records, $template) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ $records = [$records] if (!ref($records));
+
+ for my $rid ( @$records ) {
+ my $rec = $e->retrieve_biblio_record_entry($rid);
+ next unless $rec;
+
+ unless ($e->allowed('UPDATE_RECORD', $rec->owner, $rec)) {
+ $conn->respond({ record => $rid, success => 'f' });
+ next;
+ }
+
+ my $success = $e->json_query(
+ { from => [ 'vandelay.template_overlay_bib_record', $template, $rid ] }
+ )->[0]->{'vandelay.template_overlay_bib_record'};
+
+ $conn->respond({ record => $rid, success => $success });
+ }
+
+ $e->commit;
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "template_overlay_container",
+ api_name => "open-ils.cat.container.template_overlay",
+ stream => 1,
+ signature => q#
+ Overlays biblio.record_entry MARC values
+ @param auth The authtoken
+ @param container The container, um, containing the records to be updated by the template
+ @param template The overlay template, or nothing and the method will look for a negative bib id in the container
+ @return Stream of hashes record id in the key "record" and t or f for the success of the overlay operation in key "success"
+ #
+);
+
+__PACKAGE__->register_method(
+ method => "template_overlay_container",
+ api_name => "open-ils.cat.container.template_overlay.background",
+ stream => 1,
+ signature => q#
+ Overlays biblio.record_entry MARC values
+ @param auth The authtoken
+ @param container The container, um, containing the records to be updated by the template
+ @param template The overlay template, or nothing and the method will look for a negative bib id in the container
+ @return Cache key to check for status of the container overlay
+ #
+);
+
+sub template_overlay_container {
+ my($self, $conn, $auth, $container, $template) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $actor = OpenSRF::AppSession->create('open-ils.actor') if ($self->api_name =~ /background$/);
+
+ my $items = $e->search_container_biblio_record_entry_bucket_item({ bucket => $container });
+
+ my $titem;
+ if (!$template) {
+ ($titem) = grep { $_->target_biblio_record_entry < 0 } @$items;
+ if (!$titem) {
+ $e->rollback;
+ return undef;
+ }
+ $items = [grep { $_->target_biblio_record_entry > 0 } @$items];
+
+ $template = $e->retrieve_biblio_record_entry( $titem->target_biblio_record_entry )->marc;
+ }
+
+ my $responses = [];
+ my $some_failed = 0;
+
+ $self->respond_complete(
+ $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses)->gather(1)
+ ) if ($actor);
+
+ for my $item ( @$items ) {
+ my $rec = $e->retrieve_biblio_record_entry($item->target_biblio_record_entry);
+ next unless $rec;
+
+ my $success = 'f';
+ if ($e->allowed('UPDATE_RECORD', $rec->owner, $rec)) {
+ $success = $e->json_query(
+ { from => [ 'vandelay.template_overlay_bib_record', $template, $rec->id ] }
+ )->[0]->{'vandelay.template_overlay_bib_record'};
+ }
+
+ $some_failed++ if ($success eq 'f');
+
+ if ($actor) {
+ push @$responses, { record => $rec->id, success => $success };
+ $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
+ } else {
+ $conn->respond({ record => $rec->id, success => $success });
+ }
+
+ if ($success eq 't') {
+ unless ($e->delete_container_biblio_record_entry_bucket_item($item)) {
+ $e->rollback;
+ if ($actor) {
+ push @$responses, { complete => 1, success => 'f' };
+ $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
+ return undef;
+ } else {
+ return { complete => 1, success => 'f' };
+ }
+ }
+ }
+ }
+
+ if ($titem && !$some_failed) {
+ return $e->die_event unless ($e->delete_container_biblio_record_entry_bucket_item($titem));
+ }
+
+ if ($e->commit) {
+ if ($actor) {
+ push @$responses, { complete => 1, success => 't' };
+ $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
+ } else {
+ return { complete => 1, success => 't' };
+ }
+ } else {
+ if ($actor) {
+ push @$responses, { complete => 1, success => 'f' };
+ $actor->request('open-ils.actor.anon_cache.set_value', $auth, res_list => $responses);
+ } else {
+ return { complete => 1, success => 'f' };
+ }
+ }
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "update_biblio_record_entry",
+ api_name => "open-ils.cat.biblio.record_entry.update",
+ signature => q/
+ Updates a biblio.record_entry
+ @param auth The authtoken
+ @param record The record with updated values
+ @return 1 on success, Event on error.
+ /
+);
+
+sub update_biblio_record_entry {
+ my($self, $conn, $auth, $record) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('UPDATE_RECORD');
+ $e->update_biblio_record_entry($record) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "undelete_biblio_record_entry",
+ api_name => "open-ils.cat.biblio.record_entry.undelete",
+ signature => q/
+ Un-deletes a record and sets active=true
+ @param auth The authtoken
+ @param record The record_id to ressurect
+ @return 1 on success, Event on error.
+ /
+);
+sub undelete_biblio_record_entry {
+ my($self, $conn, $auth, $record_id) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('UPDATE_RECORD');
+
+ my $record = $e->retrieve_biblio_record_entry($record_id)
+ or return $e->die_event;
+ $record->deleted('f');
+ $record->active('t');
+
+ # Set the leader/05 to indicate that the record has been corrected/revised
+ my $marc = $record->marc();
+ $marc =~ s{(<leader>.{5}).}{$1c};
+ $record->marc($marc);
+
+ # no 2 non-deleted records can have the same tcn_value
+ my $existing = $e->search_biblio_record_entry(
+ { deleted => 'f',
+ tcn_value => $record->tcn_value,
+ id => {'!=' => $record_id}
+ }, {idlist => 1});
+ return OpenILS::Event->new('TCN_EXISTS') if @$existing;
+
+ $e->update_biblio_record_entry($record) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_record_xml_import",
+ api_name => "open-ils.cat.biblio.record.xml.import.override",
+ signature => q/@see open-ils.cat.biblio.record.xml.import/);
+
+__PACKAGE__->register_method(
+ method => "biblio_record_xml_import",
+ api_name => "open-ils.cat.biblio.record.xml.import",
+ notes => <<" NOTES");
+ Takes a marcxml record and imports the record into the database. In this
+ case, the marcxml record is assumed to be a complete record (i.e. valid
+ MARC). The title control number is taken from (whichever comes first)
+ tags 001, 039[ab], 020a, 022a, 010, 035a and whichever does not already exist
+ in the database.
+ user_session must have IMPORT_MARC permissions
+ NOTES
+
+
+sub biblio_record_xml_import {
+ my( $self, $client, $authtoken, $xml, $source, $auto_tcn) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('IMPORT_MARC', $e->requestor->ws_ou);
+
+ my $override = $self->api_name =~ /override/;
+ my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
+ $e, $xml, $source, $auto_tcn, $override);
+
+ return $record if $U->event_code($record);
+
+ $e->commit;
+
+ #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
+ #$ses->request('open-ils.ingest.full.biblio.record', $record->id);
+
+ return $record;
+}
+
+__PACKAGE__->register_method(
+ method => "biblio_record_record_metadata",
+ api_name => "open-ils.cat.biblio.record.metadata.retrieve",
+ authoritative => 1,
+ argc => 1, #(session_id, biblio_tree )
+ notes => "Walks the tree and commits any changed nodes " .
+ "adds any new nodes, and deletes any deleted nodes",
+);
+
+sub biblio_record_record_metadata {
+ my( $self, $client, $authtoken, $ids ) = @_;
+
+ return [] unless $ids and @$ids;
+
+ my $editor = new_editor(authtoken => $authtoken);
+ return $editor->event unless $editor->checkauth;
+ return $editor->event unless $editor->allowed('VIEW_USER');
+
+ my @results;
+
+ for(@$ids) {
+ return $editor->event unless
+ my $rec = $editor->retrieve_biblio_record_entry($_);
+ $rec->creator($editor->retrieve_actor_user($rec->creator));
+ $rec->editor($editor->retrieve_actor_user($rec->editor));
+ $rec->clear_marc; # slim the record down
+ push( @results, $rec );
+ }
+
+ return \@results;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "biblio_record_marc_cn",
+ api_name => "open-ils.cat.biblio.record.marc_cn.retrieve",
+ argc => 1, #(bib id )
+ signature => {
+ desc => 'Extracts call number candidates from a bibliographic record',
+ params => [
+ {desc => 'Record ID', type => 'number'},
+ {desc => '(Optional) Classification scheme ID', type => 'number'},
+ ]
+ },
+ return => {desc => 'Hash of candidate call numbers identified by tag' }
+);
+
+sub biblio_record_marc_cn {
+ my( $self, $client, $id, $class ) = @_;
+
+ my $e = new_editor();
+ my $marc = $e->retrieve_biblio_record_entry($id)->marc;
+
+ my $doc = XML::LibXML->new->parse_string($marc);
+ $doc->documentElement->setNamespace( "http://www.loc.gov/MARC21/slim", "marc", 1 );
+
+ my @fields;
+ my @res;
+ if ($class) {
+ @fields = split(/,/, $e->retrieve_asset_call_number_class($class)->field);
+ } else {
+ @fields = qw/050ab 055ab 060ab 070ab 080ab 082ab 086ab 088ab 090 092 096 098 099/;
+ }
+
+ # Get field/subfield combos based on acnc value; for example "050ab,055ab"
+
+ foreach my $field (@fields) {
+ my $tag = substr($field, 0, 3);
+ $logger->debug("Tag = $tag");
+ my @node = $doc->findnodes("//marc:datafield[\@tag='$tag']");
+
+ # Now parse the subfields and build up the subfield XPath
+ my @subfields = split(//, substr($field, 3));
+
+ # If they give us no subfields to parse, default to just the 'a'
+ if (!@subfields) {
+ @subfields = ('a');
+ }
+ my $subxpath;
+ foreach my $sf (@subfields) {
+ $subxpath .= "\@code='$sf' or ";
+ }
+ $subxpath = substr($subxpath, 0, -4);
+ $logger->debug("subxpath = $subxpath");
+
+ # Find the contents of the specified subfields
+ foreach my $x (@node) {
+ my $cn = $x->findvalue("marc:subfield[$subxpath]");
+ push @res, {$tag => $cn} if ($cn);
+ }
+ }
+
+ return \@res;
+}
+
+__PACKAGE__->register_method(
+ method => 'autogen_barcodes',
+ api_name => "open-ils.cat.item.barcode.autogen",
+ signature => {
+ desc => 'Returns N generated barcodes following a specified barcode.',
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Barcode which the sequence should follow from', type => 'string'},
+ {desc => 'Number of barcodes to generate', type => 'number'},
+ {desc => 'Options hash. Currently you can pass in checkdigit : false to disable the use of checkdigits.'}
+ ],
+ return => {desc => 'Array of generated barcodes'}
+ }
+);
+
+sub autogen_barcodes {
+ my( $self, $client, $auth, $barcode, $num_of_barcodes, $options ) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('UPDATE_COPY', $e->requestor->ws_ou);
+ $options ||= {};
+
+ my $barcode_text = '';
+ my $barcode_number = 0;
+
+ if ($barcode =~ /^(\D+)/) { $barcode_text = $1; }
+ if ($barcode =~ /(\d+)$/) { $barcode_number = $1; }
+
+ my @res;
+ for (my $i = 1; $i <= $num_of_barcodes; $i++) {
+ my $calculated_barcode;
+
+ # default is to use checkdigits, so looking for an explicit false here
+ if (defined $$options{'checkdigit'} && ! $$options{'checkdigit'}) {
+ $calculated_barcode = $barcode_number + $i;
+ } else {
+ if ($barcode_number =~ /^\d{8}$/) {
+ $calculated_barcode = add_codabar_checkdigit($barcode_number + $i, 0);
+ } elsif ($barcode_number =~ /^\d{9}$/) {
+ $calculated_barcode = add_codabar_checkdigit($barcode_number + $i*10, 1); # strip last digit
+ } elsif ($barcode_number =~ /^\d{13}$/) {
+ $calculated_barcode = add_codabar_checkdigit($barcode_number + $i, 0);
+ } elsif ($barcode_number =~ /^\d{14}$/) {
+ $calculated_barcode = add_codabar_checkdigit($barcode_number + $i*10, 1); # strip last digit
+ } else {
+ $calculated_barcode = $barcode_number + $i;
+ }
+ }
+ push @res, $barcode_text . $calculated_barcode;
+ }
+ return \@res
+}
+
+# Codabar doesn't define a checkdigit algorithm, but this one is typically used by libraries. gmcharlt++
+sub add_codabar_checkdigit {
+ my $barcode = shift;
+ my $strip_last_digit = shift;
+
+ return $barcode if $barcode =~ /\D/;
+ $barcode = substr($barcode, 0, length($barcode)-1) if $strip_last_digit;
+ my @digits = split //, $barcode;
+ my $total = 0;
+ for (my $i = 1; $i < length($barcode); $i+=2) { # for a 13/14 digit barcode, would expect 1,3,5,7,9,11
+ $total += $digits[$i];
+ }
+ for (my $i = 0; $i < length($barcode); $i+=2) { # for a 13/14 digit barcode, would expect 0,2,4,6,8,10,12
+ $total += (2 * $digits[$i] >= 10) ? (2 * $digits[$i] - 9) : (2 * $digits[$i]);
+ }
+ my $remainder = $total % 10;
+ my $checkdigit = ($remainder == 0) ? $remainder : 10 - $remainder;
+ return $barcode . $checkdigit;
+}
+
+__PACKAGE__->register_method(
+ method => "orgs_for_title",
+ authoritative => 1,
+ api_name => "open-ils.cat.actor.org_unit.retrieve_by_title"
+);
+
+sub orgs_for_title {
+ my( $self, $client, $record_id ) = @_;
+
+ my $vols = $U->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.asset.call_number.search.atomic",
+ { record => $record_id, deleted => 'f' });
+
+ my $orgs = { map {$_->owning_lib => 1 } @$vols };
+ return [ keys %$orgs ];
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_copies",
+ authoritative => 1,
+ api_name => "open-ils.cat.asset.copy_tree.retrieve");
+
+__PACKAGE__->register_method(
+ method => "retrieve_copies",
+ api_name => "open-ils.cat.asset.copy_tree.global.retrieve");
+
+# user_session may be null/undef
+sub retrieve_copies {
+
+ my( $self, $client, $user_session, $docid, @org_ids ) = @_;
+
+ if(ref($org_ids[0])) { @org_ids = @{$org_ids[0]}; }
+
+ $docid = "$docid";
+
+ # grabbing copy trees should be available for everyone..
+ if(!@org_ids and $user_session) {
+ my($user_obj, $evt) = OpenILS::Application::AppUtils->checkses($user_session);
+ return $evt if $evt;
+ @org_ids = ($user_obj->home_ou);
+ }
+
+ if( $self->api_name =~ /global/ ) {
+ return _build_volume_list( { record => $docid, deleted => 'f', label => { '<>' => '##URI##' } } );
+
+ } else {
+
+ my @all_vols;
+ for my $orgid (@org_ids) {
+ my $vols = _build_volume_list(
+ { record => $docid, owning_lib => $orgid, deleted => 'f', label => { '<>' => '##URI##' } } );
+ push( @all_vols, @$vols );
+ }
+
+ return \@all_vols;
+ }
+
+ return undef;
+}
+
+
+sub _build_volume_list {
+ my $search_hash = shift;
+
+ $search_hash->{deleted} = 'f';
+ my $e = new_editor();
+
+ my $vols = $e->search_asset_call_number([$search_hash, { 'order_by' => {
+ 'acn' => 'oils_text_as_bytea(label_sortkey), oils_text_as_bytea(label), id, owning_lib'
+ } } ] );
+
+ my @volumes;
+
+ for my $volume (@$vols) {
+
+ my $copies = $e->search_asset_copy(
+ { call_number => $volume->id , deleted => 'f' });
+
+ $copies = [ sort { $a->barcode cmp $b->barcode } @$copies ];
+
+ for my $c (@$copies) {
+ if( $c->status == OILS_COPY_STATUS_CHECKED_OUT ) {
+ $c->circulations(
+ $e->search_action_circulation(
+ [
+ { target_copy => $c->id },
+ {
+ order_by => { circ => 'xact_start desc' },
+ limit => 1
+ }
+ ]
+ )
+ )
+ }
+ }
+
+ $volume->copies($copies);
+ push( @volumes, $volume );
+ }
+
+ #$session->disconnect();
+ return \@volumes;
+
+}
+
+
+__PACKAGE__->register_method(
+ method => "fleshed_copy_update",
+ api_name => "open-ils.cat.asset.copy.fleshed.batch.update",);
+
+__PACKAGE__->register_method(
+ method => "fleshed_copy_update",
+ api_name => "open-ils.cat.asset.copy.fleshed.batch.update.override",);
+
+
+sub fleshed_copy_update {
+ my( $self, $conn, $auth, $copies, $delete_stats ) = @_;
+ return 1 unless ref $copies;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+ my $retarget_holds = [];
+ $evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
+ $editor, $override, undef, $copies, $delete_stats, $retarget_holds, undef);
+
+ if( $evt ) {
+ $logger->info("fleshed copy update failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+
+ $editor->commit;
+ $logger->info("fleshed copy update successfully updated ".scalar(@$copies)." copies");
+ reset_hold_list($auth, $retarget_holds);
+
+ return 1;
+}
+
+sub reset_hold_list {
+ my($auth, $hold_ids) = @_;
+ return unless @$hold_ids;
+ $logger->info("reseting holds after copy status change: @$hold_ids");
+ my $ses = OpenSRF::AppSession->create('open-ils.circ');
+ $ses->request('open-ils.circ.hold.reset.batch', $auth, $hold_ids);
+}
+
+
+__PACKAGE__->register_method(
+ method => 'in_db_merge',
+ api_name => 'open-ils.cat.biblio.records.merge',
+ signature => q/
+ Merges a group of records
+ @param auth The login session key
+ @param master The id of the record all other records should be merged into
+ @param records Array of records to be merged into the master record
+ @return 1 on success, Event on error.
+ /
+);
+
+sub in_db_merge {
+ my( $self, $conn, $auth, $master, $records ) = @_;
+
+ my $editor = new_editor( authtoken => $auth, xact => 1 );
+ return $editor->die_event unless $editor->checkauth;
+ return $editor->die_event unless $editor->allowed('MERGE_BIB_RECORDS'); # TODO see below about record ownership
+
+ my $count = 0;
+ for my $source ( @$records ) {
+ #XXX we actually /will/ want to check perms for master and sources after record ownership exists
+
+ # This stored proc (asset.merge_record_assets(target,source)) has the side effects of
+ # moving call_number, title-type (and some volume-type) hold_request and uri-mapping
+ # objects from the source record to the target record, so must be called from within
+ # a transaction.
+
+ $count += $editor->json_query({
+ select => {
+ bre => [{
+ alias => 'count',
+ transform => 'asset.merge_record_assets',
+ column => 'id',
+ params => [$source]
+ }]
+ },
+ from => 'bre',
+ where => { id => $master }
+ })->[0]->{count}; # count of objects moved, of all types
+
+ }
+
+ $editor->commit;
+ return $count;
+}
+
+__PACKAGE__->register_method(
+ method => 'in_db_auth_merge',
+ api_name => 'open-ils.cat.authority.records.merge',
+ signature => q/
+ Merges a group of authority records
+ @param auth The login session key
+ @param master The id of the record all other records should be merged into
+ @param records Array of records to be merged into the master record
+ @return 1 on success, Event on error.
+ /
+);
+
+sub in_db_auth_merge {
+ my( $self, $conn, $auth, $master, $records ) = @_;
+
+ my $editor = new_editor( authtoken => $auth, xact => 1 );
+ return $editor->die_event unless $editor->checkauth;
+ return $editor->die_event unless $editor->allowed('MERGE_AUTH_RECORDS'); # TODO see below about record ownership
+
+ my $count = 0;
+ for my $source ( @$records ) {
+ $count += $editor->json_query({
+ select => {
+ are => [{
+ alias => 'count',
+ transform => 'authority.merge_records',
+ column => 'id',
+ params => [$source]
+ }]
+ },
+ from => 'are',
+ where => { id => $master }
+ })->[0]->{count}; # count of objects moved, of all types
+ }
+
+ $editor->commit;
+ return $count;
+}
+
+__PACKAGE__->register_method(
+ method => "fleshed_volume_update",
+ api_name => "open-ils.cat.asset.volume.fleshed.batch.update",);
+
+__PACKAGE__->register_method(
+ method => "fleshed_volume_update",
+ api_name => "open-ils.cat.asset.volume.fleshed.batch.update.override",);
+
+sub fleshed_volume_update {
+ my( $self, $conn, $auth, $volumes, $delete_stats, $options ) = @_;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ $options ||= {};
+
+ my $override = ($self->api_name =~ /override/);
+ my $editor = new_editor( requestor => $reqr, xact => 1 );
+ my $retarget_holds = [];
+ my $auto_merge_vols = $options->{auto_merge_vols};
+
+ for my $vol (@$volumes) {
+ $logger->info("vol-update: investigating volume ".$vol->id);
+
+ $vol->editor($reqr->id);
+ $vol->edit_date('now');
+
+ my $copies = $vol->copies;
+ $vol->clear_copies;
+
+ $vol->editor($editor->requestor->id);
+ $vol->edit_date('now');
+
+ if( $vol->isdeleted ) {
+
+ $logger->info("vol-update: deleting volume");
+ my $cs = $editor->search_asset_copy(
+ { call_number => $vol->id, deleted => 'f' } );
+ return OpenILS::Event->new(
+ 'VOLUME_NOT_EMPTY', payload => $vol->id ) if @$cs;
+
+ $vol->deleted('t');
+ return $editor->event unless
+ $editor->update_asset_call_number($vol);
+
+
+ } elsif( $vol->isnew ) {
+ $logger->info("vol-update: creating volume");
+ $evt = OpenILS::Application::Cat::AssetCommon->create_volume( $override, $editor, $vol );
+ return $evt if $evt;
+
+ } elsif( $vol->ischanged ) {
+ $logger->info("vol-update: update volume");
+ my $resp = update_volume($vol, $editor, ($override or $auto_merge_vols));
+ return $resp->{evt} if $resp->{evt};
+ $vol = $resp->{merge_vol};
+ }
+
+ # now update any attached copies
+ if( $copies and @$copies and !$vol->isdeleted ) {
+ $_->call_number($vol->id) for @$copies;
+ $evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
+ $editor, $override, $vol, $copies, $delete_stats, $retarget_holds, undef);
+ return $evt if $evt;
+ }
+ }
+
+ $editor->finish;
+ reset_hold_list($auth, $retarget_holds);
+ return scalar(@$volumes);
+}
+
+
+sub update_volume {
+ my $vol = shift;
+ my $editor = shift;
+ my $auto_merge = shift;
+ my $evt;
+ my $merge_vol;
+
+ return {evt => $evt}
+ if ( $evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($editor, $vol->owning_lib) );
+
+ my $vols = $editor->search_asset_call_number({
+ owning_lib => $vol->owning_lib,
+ record => $vol->record,
+ label => $vol->label,
+ deleted => 'f',
+ id => {'!=' => $vol->id}
+ });
+
+ if(@$vols) {
+
+ if($auto_merge) {
+
+ # If the auto-merge option is on, merge our updated volume into the existing
+ # volume with the same record + owner + label.
+ ($merge_vol, $evt) = OpenILS::Application::Cat::Merge::merge_volumes($editor, [$vol], $vols->[0]);
+ return {evt => $evt, merge_vol => $merge_vol};
+
+ } else {
+ return {evt => OpenILS::Event->new('VOLUME_LABEL_EXISTS', payload => $vol->id)};
+ }
+ }
+
+ return {evt => $editor->die_event} unless $editor->update_asset_call_number($vol);
+ return {};
+}
+
+
+
+__PACKAGE__->register_method (
+ method => 'delete_bib_record',
+ api_name => 'open-ils.cat.biblio.record_entry.delete');
+
+sub delete_bib_record {
+ my($self, $conn, $auth, $rec_id) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('DELETE_RECORD', $e->requestor->ws_ou);
+ my $vols = $e->search_asset_call_number({record=>$rec_id, deleted=>'f'});
+ return OpenILS::Event->new('RECORD_NOT_EMPTY', payload=>$rec_id) if @$vols;
+ my $evt = OpenILS::Application::Cat::BibCommon->delete_rec($e, $rec_id);
+ if($evt) { $e->rollback; return $evt; }
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method (
+ method => 'batch_volume_transfer',
+ api_name => 'open-ils.cat.asset.volume.batch.transfer',
+);
+
+__PACKAGE__->register_method (
+ method => 'batch_volume_transfer',
+ api_name => 'open-ils.cat.asset.volume.batch.transfer.override',
+);
+
+
+sub batch_volume_transfer {
+ my( $self, $conn, $auth, $args ) = @_;
+
+ my $evt;
+ my $rec = $$args{docid};
+ my $o_lib = $$args{lib};
+ my $vol_ids = $$args{volumes};
+
+ my $override = 1 if $self->api_name =~ /override/;
+
+ $logger->info("merge: transferring volumes to lib=$o_lib and record=$rec");
+
+ my $e = new_editor(authtoken => $auth, xact =>1);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('UPDATE_VOLUME', $o_lib);
+
+ my $dorg = $e->retrieve_actor_org_unit($o_lib)
+ or return $e->event;
+
+ my $ou_type = $e->retrieve_actor_org_unit_type($dorg->ou_type)
+ or return $e->event;
+
+ return $evt if ( $evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($e, $o_lib) );
+
+ my $vols = $e->batch_retrieve_asset_call_number($vol_ids);
+ my @seen;
+
+ my @rec_ids;
+
+ for my $vol (@$vols) {
+
+ # if we've already looked at this volume, go to the next
+ next if !$vol or grep { $vol->id == $_ } @seen;
+
+ # grab all of the volumes in the list that have
+ # the same label so they can be merged
+ my @all = grep { $_->label eq $vol->label } @$vols;
+
+ # take note of the fact that we've looked at this set of volumes
+ push( @seen, $_->id ) for @all;
+ push( @rec_ids, $_->record ) for @all;
+
+ # for each volume, see if there are any copies that have a
+ # remote circ_lib (circ_lib != vol->owning_lib and != $o_lib ).
+ # if so, warn them
+ unless( $override ) {
+ for my $v (@all) {
+
+ $logger->debug("merge: searching for copies with remote circ_lib for volume ".$v->id);
+ my $args = {
+ call_number => $v->id,
+ circ_lib => { "not in" => [ $o_lib, $v->owning_lib ] },
+ deleted => 'f'
+ };
+
+ my $copies = $e->search_asset_copy($args, {idlist=>1});
+
+ # if the copy's circ_lib matches the destination lib,
+ # that's ok too
+ return OpenILS::Event->new('COPY_REMOTE_CIRC_LIB') if @$copies;
+ }
+ }
+
+ # see if there is a volume at the destination lib that
+ # already has the requested label
+ my $existing_vol = $e->search_asset_call_number(
+ {
+ label => $vol->label,
+ record => $rec,
+ owning_lib => $o_lib,
+ deleted => 'f'
+ }
+ )->[0];
+
+ if( $existing_vol ) {
+
+ if( grep { $_->id == $existing_vol->id } @all ) {
+ # this volume is already accounted for in our list of volumes to merge
+ $existing_vol = undef;
+
+ } else {
+ # this volume exists on the destination record/owning_lib and must
+ # be used as the destination for merging
+ $logger->debug("merge: volume already exists at destination record: ".
+ $existing_vol->id.' : '.$existing_vol->label) if $existing_vol;
+ }
+ }
+
+ if( @all > 1 || $existing_vol ) {
+ $logger->info("merge: found collisions in volume transfer");
+ my @args = ($e, \@all);
+ @args = ($e, \@all, $existing_vol) if $existing_vol;
+ ($vol, $evt) = OpenILS::Application::Cat::Merge::merge_volumes(@args);
+ return $evt if $evt;
+ }
+
+ if( !$existing_vol ) {
+
+ $vol->owning_lib($o_lib);
+ $vol->record($rec);
+ $vol->editor($e->requestor->id);
+ $vol->edit_date('now');
+
+ $logger->info("merge: updating volume ".$vol->id);
+ $e->update_asset_call_number($vol) or return $e->event;
+
+ } else {
+ $logger->info("merge: bypassing volume update because existing volume used as target");
+ }
+
+ # regardless of what volume was used as the destination,
+ # update any copies that have moved over to the new lib
+ my $copies = $e->search_asset_copy({call_number=>$vol->id, deleted => 'f'});
+
+ # update circ lib on the copies - make this a method flag?
+ for my $copy (@$copies) {
+ next if $copy->circ_lib == $o_lib;
+ $logger->info("merge: transfer moving circ lib on copy ".$copy->id);
+ $copy->circ_lib($o_lib);
+ $copy->editor($e->requestor->id);
+ $copy->edit_date('now');
+ $e->update_asset_copy($copy) or return $e->event;
+ }
+
+ # Now see if any empty records need to be deleted after all of this
+
+ for(@rec_ids) {
+ $logger->debug("merge: seeing if we should delete record $_...");
+ $evt = OpenILS::Application::Cat::BibCommon->delete_rec($e, $_)
+ if OpenILS::Application::Cat::BibCommon->title_is_empty($e, $_);
+ return $evt if $evt;
+ }
+ }
+
+ $logger->info("merge: transfer succeeded");
+ $e->commit;
+ return 1;
+}
+
+
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.cat.call_number.find_or_create',
+ method => 'find_or_create_volume',
+);
+
+sub find_or_create_volume {
+ my( $self, $conn, $auth, $label, $record_id, $org_id ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my ($vol, $evt, $exists) =
+ OpenILS::Application::Cat::AssetCommon->find_or_create_volume($e, $label, $record_id, $org_id);
+ return $evt if $evt;
+ $e->rollback if $exists;
+ $e->commit if $vol;
+ return $vol->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => "create_serial_record_xml",
+ api_name => "open-ils.cat.serial.record.xml.create.override",
+ signature => q/@see open-ils.cat.serial.record.xml.create/);
+
+__PACKAGE__->register_method(
+ method => "create_serial_record_xml",
+ api_name => "open-ils.cat.serial.record.xml.create",
+ signature => q/
+ Inserts a new serial record with the given XML
+ /
+);
+
+sub create_serial_record_xml {
+ my( $self, $client, $login, $source, $owning_lib, $record_id, $xml ) = @_;
+
+ my $override = 1 if $self->api_name =~ /override/; # not currently used
+
+ my $e = new_editor(xact=>1, authtoken=>$login);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_MFHD_RECORD', $owning_lib);
+
+ # Auto-populate the location field of a placeholder MFHD record with the library name
+ my $aou = $e->retrieve_actor_org_unit($owning_lib) or return $e->die_event;
+
+ my $mfhd = Fieldmapper::serial::record_entry->new;
+
+ $mfhd->source($source) if $source;
+ $mfhd->record($record_id);
+ $mfhd->creator($e->requestor->id);
+ $mfhd->editor($e->requestor->id);
+ $mfhd->create_date('now');
+ $mfhd->edit_date('now');
+ $mfhd->owning_lib($owning_lib);
+
+ # If the caller did not pass in MFHD XML, create a placeholder record.
+ # The placeholder will only contain the name of the owning library.
+ # The goal is to generate common patterns for the caller in the UI that
+ # then get passed in here.
+ if (!$xml) {
+ my $aou_name = $aou->name;
+ $xml = <<HERE;
+<record
+ xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
+ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+ xmlns="http://www.loc.gov/MARC21/slim">
+<leader>00307ny a22001094 4500</leader>
+<controlfield tag="001">42153</controlfield>
+<controlfield tag="005">20090601182414.0</controlfield>
+<controlfield tag="004">$record_id</controlfield>
+<controlfield tag="008"> 4u####8###l# 4 uueng1 </controlfield>
+<datafield tag="852" ind1=" " ind2=" "> <subfield code="b">$aou_name</subfield></datafield>
+</record>
+HERE
+ }
+ my $marcxml = XML::LibXML->new->parse_string($xml);
+ $marcxml->documentElement->setNamespace("http://www.loc.gov/MARC21/slim", "marc", 1 );
+ $marcxml->documentElement->setNamespace("http://www.loc.gov/MARC21/slim");
+
+ $mfhd->marc($U->entityize($marcxml->documentElement->toString));
+
+ $e->create_serial_record_entry($mfhd) or return $e->die_event;
+
+ $e->commit;
+ return $mfhd->id;
+}
+
+__PACKAGE__->register_method(
+ method => "create_update_asset_copy_template",
+ api_name => "open-ils.cat.asset.copy_template.create_or_update"
+);
+
+sub create_update_asset_copy_template {
+ my ($self, $client, $authtoken, $act) = @_;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $authtoken);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed(
+ "ADMIN_ASSET_COPY_TEMPLATE", $act->owning_lib
+ );
+
+ $act->editor($e->requestor->id);
+ $act->edit_date("now");
+
+ my $retval;
+ if (!$act->id) {
+ $act->creator($e->requestor->id);
+ $act->create_date("now");
+
+ $e->create_asset_copy_template($act) or return $e->die_event;
+ $retval = $e->data;
+ } else {
+ $e->update_asset_copy_template($act) or return $e->die_event;
+ $retval = $e->retrieve_asset_copy_template($e->data);
+ }
+ $e->commit and return $retval;
+}
+
+1;
+
+# vi:et:ts=4:sw=4
--- /dev/null
+package OpenILS::Application::Cat::AssetCommon;
+use strict; use warnings;
+use OpenILS::Application::Cat::BibCommon;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger qw($logger);
+use OpenILS::Application::Cat::Merge;
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Const qw/:const/;
+use OpenSRF::AppSession;
+use OpenILS::Event;
+use OpenILS::Application::Circ::CircCommon;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+# ---------------------------------------------------------------------------
+# Shared copy mangling code. Do not publish methods from here.
+# ---------------------------------------------------------------------------
+
+sub org_cannot_have_vols {
+ my($class, $e, $org_id) = @_;
+ my $org = $e->retrieve_actor_org_unit([
+ $org_id,
+ { flesh => 1,
+ flesh_fields => {aou => ['ou_type']}
+ }]) or return $e->event;
+
+ return OpenILS::Event->new('ORG_CANNOT_HAVE_VOLS')
+ unless $U->is_true($org->ou_type->can_have_vols);
+
+ return 0;
+}
+
+sub fix_copy_price {
+ my $class = shift;
+ my $copy = shift;
+
+ if(defined $copy->price) {
+ my $p = $copy->price || 0;
+ $p =~ s/\$//og;
+ $copy->price($p);
+ }
+
+ my $d = $copy->deposit_amount || 0;
+ $d =~ s/\$//og;
+ $copy->deposit_amount($d);
+}
+
+sub create_copy {
+ my($class, $editor, $vol, $copy) = @_;
+
+ my $existing = $editor->search_asset_copy(
+ { barcode => $copy->barcode, deleted => 'f' } );
+
+ return OpenILS::Event->new('ITEM_BARCODE_EXISTS') if @$existing;
+
+ # see if the volume this copy references is marked as deleted
+ return OpenILS::Event->new('VOLUME_DELETED', vol => $vol->id)
+ if $U->is_true($vol->deleted);
+
+ my $evt;
+ my $org = (ref $copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
+ return $evt if ($evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($editor, $org));
+
+ $copy->clear_id;
+ $copy->editor($editor->requestor->id);
+ $copy->creator($editor->requestor->id);
+ $copy->create_date('now');
+ $copy->call_number($vol->id);
+ $class->fix_copy_price($copy);
+
+ $editor->create_asset_copy($copy) or return $editor->die_event;
+ return undef;
+}
+
+
+# if 'delete_stats' is true, the copy->stat_cat_entries data is
+# treated as the authoritative list for the copy. existing entries
+# that are not in said list will be deleted from the DB
+sub update_copy_stat_entries {
+ my($class, $editor, $copy, $delete_stats) = @_;
+
+ return undef if $copy->isdeleted;
+ return undef unless $copy->ischanged or $copy->isnew;
+
+ my $evt;
+ my $entries = $copy->stat_cat_entries;
+
+ if( $delete_stats ) {
+ $entries = ($entries and @$entries) ? $entries : [];
+ } else {
+ return undef unless ($entries and @$entries);
+ }
+
+ my $maps = $editor->search_asset_stat_cat_entry_copy_map({owning_copy=>$copy->id});
+
+ if(!$copy->isnew) {
+ # if there is no stat cat entry on the copy who's id matches the
+ # current map's id, remove the map from the database
+ for my $map (@$maps) {
+ if(! grep { $_->id == $map->stat_cat_entry } @$entries ) {
+
+ $logger->info("copy update found stale ".
+ "stat cat entry map ".$map->id. " on copy ".$copy->id);
+
+ $editor->delete_asset_stat_cat_entry_copy_map($map)
+ or return $editor->event;
+ }
+ }
+ }
+
+ # go through the stat cat update/create process
+ for my $entry (@$entries) {
+ next unless $entry;
+
+ # if this link already exists in the DB, don't attempt to re-create it
+ next if( grep{$_->stat_cat_entry == $entry->id} @$maps );
+
+ my $new_map = Fieldmapper::asset::stat_cat_entry_copy_map->new();
+
+ my $sc = ref($entry->stat_cat) ? $entry->stat_cat->id : $entry->stat_cat;
+
+ $new_map->stat_cat( $sc );
+ $new_map->stat_cat_entry( $entry->id );
+ $new_map->owning_copy( $copy->id );
+
+ $editor->create_asset_stat_cat_entry_copy_map($new_map)
+ or return $editor->event;
+
+ $logger->info("copy update created new stat cat entry map ".$editor->data);
+ }
+
+ return undef;
+}
+
+
+sub update_copy {
+ my($class, $editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib) = @_;
+
+ my $evt;
+ my $org = (ref $copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
+ return $evt if ( $evt = OpenILS::Application::Cat::AssetCommon->org_cannot_have_vols($editor, $org) );
+
+ $logger->info("vol-update: updating copy ".$copy->id);
+ my $orig_copy = $editor->retrieve_asset_copy($copy->id);
+ my $orig_vol = $editor->retrieve_asset_call_number($copy->call_number);
+
+ $copy->editor($editor->requestor->id);
+ $copy->edit_date('now');
+
+ $copy->age_protect( $copy->age_protect->id )
+ if ref $copy->age_protect;
+
+ $class->fix_copy_price($copy);
+ $class->check_hold_retarget($editor, $copy, $orig_copy, $retarget_holds);
+
+ return $editor->event unless $editor->update_asset_copy($copy);
+ return $class->remove_empty_objects($editor, $override, $orig_vol, $force_delete_empty_bib);
+}
+
+sub check_hold_retarget {
+ my($class, $editor, $copy, $orig_copy, $retarget_holds) = @_;
+ return unless $retarget_holds;
+
+ if( !($copy->isdeleted or $U->is_true($copy->deleted)) ) {
+ # see if a status change warrants a retarget
+
+ $orig_copy = $editor->retrieve_asset_copy($copy->id) unless $orig_copy;
+
+ if($orig_copy->status == $copy->status) {
+ # no status change, no retarget
+ return;
+ }
+
+ my $stat = $editor->retrieve_config_copy_status($copy->status);
+
+ # new status is holdable, no retarget. Later add logic to find potential
+ # holds and retarget those to pick up the newly available copy
+ return if $U->is_true($stat->holdable);
+ }
+
+ my $hold_ids = $editor->search_action_hold_request(
+ { current_copy => $copy->id,
+ cancel_time => undef,
+ fulfillment_time => undef
+ }, {idlist => 1}
+ );
+
+ push(@$retarget_holds, @$hold_ids);
+}
+
+
+# this does the actual work
+sub update_fleshed_copies {
+ my($class, $editor, $override, $vol, $copies, $delete_stats, $retarget_holds, $force_delete_empty_bib) = @_;
+
+ my $evt;
+ my $fetchvol = ($vol) ? 0 : 1;
+
+ my %cache;
+ $cache{$vol->id} = $vol if $vol;
+
+ for my $copy (@$copies) {
+
+ my $copyid = $copy->id;
+ $logger->info("vol-update: inspecting copy $copyid");
+
+ if( !($vol = $cache{$copy->call_number}) ) {
+ $vol = $cache{$copy->call_number} =
+ $editor->retrieve_asset_call_number($copy->call_number);
+ return $editor->event unless $vol;
+ }
+
+ return $editor->event unless
+ $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ $copy->editor($editor->requestor->id);
+ $copy->edit_date('now');
+
+ $copy->status( $copy->status->id ) if ref($copy->status);
+ $copy->location( $copy->location->id ) if ref($copy->location);
+ $copy->circ_lib( $copy->circ_lib->id ) if ref($copy->circ_lib);
+
+ my $sc_entries = $copy->stat_cat_entries;
+ $copy->clear_stat_cat_entries;
+
+ if( $copy->isdeleted ) {
+ $evt = $class->delete_copy($editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib);
+ return $evt if $evt;
+
+ } elsif( $copy->isnew ) {
+ $evt = $class->create_copy( $editor, $vol, $copy );
+ return $evt if $evt;
+
+ } elsif( $copy->ischanged ) {
+
+ $evt = $class->update_copy( $editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib);
+ return $evt if $evt;
+ }
+
+ $copy->stat_cat_entries( $sc_entries );
+ $evt = $class->update_copy_stat_entries($editor, $copy, $delete_stats);
+ return $evt if $evt;
+ }
+
+ $logger->debug("vol-update: done updating copy batch");
+
+ return undef;
+}
+
+
+sub delete_copy {
+ my($class, $editor, $override, $vol, $copy, $retarget_holds, $force_delete_empty_bib) = @_;
+
+ return $editor->event unless
+ $editor->allowed('DELETE_COPY', $class->copy_perm_org($vol, $copy));
+
+ my $stat = $U->copy_status($copy->status)->id;
+
+ unless($override) {
+ return OpenILS::Event->new('COPY_DELETE_WARNING', payload => $copy->id )
+ if $stat == OILS_COPY_STATUS_CHECKED_OUT or
+ $stat == OILS_COPY_STATUS_IN_TRANSIT or
+ $stat == OILS_COPY_STATUS_ON_HOLDS_SHELF or
+ $stat == OILS_COPY_STATUS_ILL;
+ }
+
+ $logger->info("vol-update: deleting copy ".$copy->id);
+ $copy->deleted('t');
+
+ $copy->editor($editor->requestor->id);
+ $copy->edit_date('now');
+ $editor->update_asset_copy($copy) or return $editor->event;
+
+ # Delete any open transits for this copy
+ my $transits = $editor->search_action_transit_copy(
+ { target_copy=>$copy->id, dest_recv_time => undef } );
+
+ for my $t (@$transits) {
+ $editor->delete_action_transit_copy($t)
+ or return $editor->event;
+ }
+
+ $class->check_hold_retarget($editor, $copy, undef, $retarget_holds);
+
+ return $class->remove_empty_objects($editor, $override, $vol, $force_delete_empty_bib);
+}
+
+
+
+sub create_volume {
+ my($class, $override, $editor, $vol) = @_;
+ my $evt;
+
+ return $evt if ( $evt = $class->org_cannot_have_vols($editor, $vol->owning_lib) );
+
+ # see if the record this volume references is marked as deleted
+ my $rec = $editor->retrieve_biblio_record_entry($vol->record)
+ or return $editor->die_event;
+ return OpenILS::Event->new('BIB_RECORD_DELETED', rec => $rec->id)
+ if $U->is_true($rec->deleted);
+
+ # first lets see if there are any collisions
+ my $vols = $editor->search_asset_call_number( {
+ owning_lib => $vol->owning_lib,
+ record => $vol->record,
+ label => $vol->label,
+ deleted => 'f'
+ }
+ );
+
+ my $label = undef;
+ if(@$vols) {
+ # we've found an exising volume
+ if($override) {
+ $label = $vol->label;
+ } else {
+ return OpenILS::Event->new(
+ 'VOLUME_LABEL_EXISTS', payload => $vol->id);
+ }
+ }
+
+ # create a temp label so we can create the new volume,
+ # then de-dup it with the existing volume
+ $vol->label( "__SYSTEM_TMP_$$".time) if $label;
+
+ $vol->creator($editor->requestor->id);
+ $vol->create_date('now');
+ $vol->editor($editor->requestor->id);
+ $vol->edit_date('now');
+ $vol->clear_id;
+
+ $editor->create_asset_call_number($vol) or return $editor->die_event;
+
+ if($label) {
+ # now restore the label and merge into the existing record
+ $vol->label($label);
+ (undef, $evt) =
+ OpenILS::Application::Cat::Merge::merge_volumes($editor, [$vol], $$vols[0]);
+ return $evt if $evt;
+ }
+
+ return undef;
+}
+
+# returns the volume if it exists
+sub volume_exists {
+ my($class, $e, $rec_id, $label, $owning_lib) = @_;
+ return $e->search_asset_call_number(
+ {label => $label, record => $rec_id, owning_lib => $owning_lib, deleted => 'f'})->[0];
+}
+
+sub find_or_create_volume {
+ my($class, $e, $label, $record_id, $org_id) = @_;
+
+ my $vol;
+
+ if($record_id == OILS_PRECAT_RECORD) {
+ $vol = $e->retrieve_asset_call_number(OILS_PRECAT_CALL_NUMBER)
+ or return (undef, $e->die_event);
+
+ } else {
+ $vol = $class->volume_exists($e, $record_id, $label, $org_id);
+ }
+
+ # If the volume exists, return the ID
+ return ($vol, undef, 1) if $vol;
+
+ # -----------------------------------------------------------------
+ # Otherwise, create a new volume with the given attributes
+ # -----------------------------------------------------------------
+ return (undef, $e->die_event) unless $e->allowed('UPDATE_VOLUME', $org_id);
+
+ $vol = Fieldmapper::asset::call_number->new;
+ $vol->owning_lib($org_id);
+ $vol->label($label);
+ $vol->record($record_id);
+
+ my $evt = OpenILS::Application::Cat::AssetCommon->create_volume(0, $e, $vol);
+ return (undef, $evt) if $evt;
+
+ return ($vol);
+}
+
+
+sub create_copy_note {
+ my($class, $e, $copy, $title, $value, $pub) = @_;
+ my $note = Fieldmapper::asset::copy_note->new;
+ $note->owning_copy($copy->id);
+ $note->creator($e->requestor->id);
+ $note->pub('t');
+ $note->value($value);
+ $note->title($title);
+ $e->create_asset_copy_note($note) or return $e->die_event;
+ return undef;
+}
+
+
+sub remove_empty_objects {
+ my($class, $editor, $override, $vol, $force_delete_empty_bib) = @_;
+
+ my $koe = $U->ou_ancestor_setting_value(
+ $editor->requestor->ws_ou, 'cat.bib.keep_on_empty', $editor);
+ my $aoe = $U->ou_ancestor_setting_value(
+ $editor->requestor->ws_ou, 'cat.bib.alert_on_empty', $editor);
+
+ if( OpenILS::Application::Cat::BibCommon->title_is_empty($editor, $vol->record, $vol->id) ) {
+
+ # delete this volume if it's not already marked as deleted
+ unless( $U->is_true($vol->deleted) || $vol->isdeleted ) {
+ $vol->deleted('t');
+ $vol->editor($editor->requestor->id);
+ $vol->edit_date('now');
+ $editor->update_asset_call_number($vol) or return $editor->event;
+ }
+
+ return OpenILS::Event->new('TITLE_LAST_COPY', payload => $vol->record )
+ if $aoe and not $override and not $force_delete_empty_bib;
+
+ unless($koe and not $force_delete_empty_bib) {
+ # delete the bib record if the keep-on-empty setting is not set (and we're not otherwise forcing things, say through acq settings)
+ my $evt = OpenILS::Application::Cat::BibCommon->delete_rec($editor, $vol->record);
+ return $evt if $evt;
+ }
+ }
+
+ return undef;
+}
+
+
+sub copy_perm_org {
+ my($class, $vol, $copy) = @_;
+ my $org = $vol->owning_lib;
+ if( $vol->id == OILS_PRECAT_CALL_NUMBER ) {
+ $org = ref($copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
+ }
+ $logger->debug("using copy perm org $org");
+ return $org;
+}
+
+
+sub set_item_lost {
+ my($class, $e, $copy_id) = @_;
+
+ my $copy = $e->retrieve_asset_copy([
+ $copy_id,
+ {flesh => 1, flesh_fields => {'acp' => ['call_number']}}])
+ or return $e->die_event;
+
+ my $owning_lib =
+ ($copy->call_number->id == OILS_PRECAT_CALL_NUMBER) ?
+ $copy->circ_lib : $copy->call_number->owning_lib;
+
+ my $circ = $e->search_action_circulation(
+ {checkin_time => undef, target_copy => $copy->id} )->[0]
+ or return $e->die_event;
+
+ $e->allowed('SET_CIRC_LOST', $circ->circ_lib) or return $e->die_event;
+
+ return $e->die_event(OpenILS::Event->new('COPY_MARKED_LOST'))
+ if $copy->status == OILS_COPY_STATUS_LOST;
+
+ # ---------------------------------------------------------------------
+ # fetch the related org settings
+ my $proc_fee = $U->ou_ancestor_setting_value(
+ $owning_lib, OILS_SETTING_LOST_PROCESSING_FEE, $e) || 0;
+ my $void_overdue = $U->ou_ancestor_setting_value(
+ $owning_lib, OILS_SETTING_VOID_OVERDUE_ON_LOST, $e) || 0;
+
+ # ---------------------------------------------------------------------
+ # move the copy into LOST status
+ $copy->status(OILS_COPY_STATUS_LOST);
+ $copy->editor($e->requestor->id);
+ $copy->edit_date('now');
+ $e->update_asset_copy($copy) or return $e->die_event;
+
+ my $price = $U->get_copy_price($e, $copy, $copy->call_number);
+
+ if( $price > 0 ) {
+ my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
+ $e, $price, 3, 'Lost Materials', $circ->id);
+ return $evt if $evt;
+ }
+
+ # ---------------------------------------------------------------------
+ # if there is a processing fee, charge that too
+ if( $proc_fee > 0 ) {
+ my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
+ $e, $proc_fee, 4, 'Lost Materials Processing Fee', $circ->id);
+ return $evt if $evt;
+ }
+
+ # ---------------------------------------------------------------------
+ # mark the circ as lost and stop the fines
+ $circ->stop_fines(OILS_STOP_FINES_LOST);
+ $circ->stop_fines_time('now') unless $circ->stop_fines_time;
+ $e->update_action_circulation($circ) or return $e->die_event;
+
+ # ---------------------------------------------------------------------
+ # void all overdue fines on this circ if configured
+ if( $void_overdue ) {
+ my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ);
+ return $evt if $evt;
+ }
+
+ my $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($e, $circ->id);
+ return $evt if $evt;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'lost', $circ, $circ->circ_lib);
+
+ return undef;
+}
--- /dev/null
+package OpenILS::Application::Cat::AuthCommon;
+use strict; use warnings;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger qw($logger);
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Const qw/:const/;
+use OpenSRF::AppSession;
+use OpenILS::Event;
+my $U = 'OpenILS::Application::AppUtils';
+my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
+
+
+# ---------------------------------------------------------------------------
+# Shared authority mangling code. Do not publish methods from here.
+# ---------------------------------------------------------------------------
+
+# generate a MARC XML document from a MARC XML string
+sub marc_xml_to_doc {
+ my $xml = shift;
+ my $marc_doc = XML::LibXML->new->parse_string($xml);
+ $marc_doc->documentElement->setNamespace($MARC_NAMESPACE, 'marc', 1);
+ $marc_doc->documentElement->setNamespace($MARC_NAMESPACE);
+ return $marc_doc;
+}
+
+
+sub import_authority_record {
+ my($class, $e, $marc_xml, $source) = @_;
+
+ my $marc_doc = marc_xml_to_doc($marc_xml);
+ my $rec = Fieldmapper::authority::record_entry->new;
+ $rec->creator($e->requestor->id);
+ $rec->editor($e->requestor->id);
+ $rec->create_date('now');
+ $rec->edit_date('now');
+ $rec->marc($U->entityize($marc_doc->documentElement->toString));
+
+ $rec = $e->create_authority_record_entry($rec) or return $e->die_event;
+
+ # we don't care about the result, just fire off the request
+ #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
+ #$ses->request('open-ils.ingest.full.authority.record', $recid);
+
+ return $rec;
+}
+
+
+sub overlay_authority_record {
+ my($class, $e, $rec_id, $marc_xml, $source) = @_;
+
+ my $marc_doc = marc_xml_to_doc($marc_xml);
+ my $rec = $e->retrieve_authority_record_entry($rec_id) or return $e->die_event;
+ $rec->editor($e->requestor->id);
+ $rec->edit_date('now');
+ $rec->marc($U->entityize($marc_doc->documentElement->toString));
+
+ $rec = $e->update_authority_record_entry($rec) or return $e->die_event;
+
+ # we don't care about the result, just fire off the request
+ #my $ses = OpenSRF::AppSession->create('open-ils.ingest');
+ #$ses->request('open-ils.ingest.full.authority.record', $recid);
+
+ return $rec;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Cat::Authority;
+use strict; use warnings;
+use base qw/OpenILS::Application/;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::Cat::AuthCommon;
+use OpenSRF::Utils::Logger qw($logger);
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Const qw/:const/;
+use OpenILS::Event;
+my $U = 'OpenILS::Application::AppUtils';
+my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
+
+
+# generate a MARC XML document from a MARC XML string
+sub marc_xml_to_doc {
+ my $xml = shift;
+ my $marc_doc = XML::LibXML->new->parse_string($xml);
+ $marc_doc->documentElement->setNamespace($MARC_NAMESPACE, 'marc', 1);
+ $marc_doc->documentElement->setNamespace($MARC_NAMESPACE);
+ return $marc_doc;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'import_authority_record',
+ api_name => 'open-ils.cat.authority.record.import',
+);
+
+sub import_authority_record {
+ my($self, $conn, $auth, $marc_xml, $source) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_AUTHORITY_RECORD');
+ my $rec = OpenILS::Application::Cat::AuthCommon->import_authority_record($marc_xml, $source);
+ $e->commit unless $U->event_code($rec);
+ return $rec;
+}
+
+__PACKAGE__->register_method(
+ method => 'create_authority_record_from_bib_field',
+ api_name => 'open-ils.cat.authority.record.create_from_bib',
+ signature => {
+ desc => q/Create an authority record entry from a field in a bibliographic record/,
+ params => q/
+ @param field A hash representing the field to control, consisting of: { tag: string, ind1: string, ind2: string, subfields: [ [code, value] ... ] }
+ @param identifier A MARC control number identifier
+ @param authtoken A valid authentication token
+ @returns The new record object
+ /}
+);
+
+__PACKAGE__->register_method(
+ method => 'create_authority_record_from_bib_field',
+ api_name => 'open-ils.cat.authority.record.create_from_bib.readonly',
+ signature => {
+ desc => q/Creates MARCXML for an authority record entry from a field in a bibliographic record/,
+ params => q/
+ @param field A hash representing the field to control, consisting of: { tag: string, ind1: string, ind2: string, subfields: [ [code, value] ... ] }
+ @param identifier A MARC control number identifier
+ @returns The MARCXML for the authority record
+ /}
+);
+
+sub create_authority_record_from_bib_field {
+ my($self, $conn, $field, $cni, $auth) = @_;
+
+ # Control number identifier should have been passed in
+ if (!$cni) {
+ $cni = 'UNSET';
+ }
+
+ # Change the first character of the incoming bib field tag to a '1'
+ # for use in our authority record; close enough for now?
+ my $tag = $field->{'tag'};
+ $tag =~ s/^./1/;
+
+ my $ind1 = $field->{ind1} || ' ';
+ my $ind2 = $field->{ind2} || ' ';
+
+ my $control = qq{<datafield tag="$tag" ind1="$ind1" ind2="$ind2">};
+ foreach my $sf (@{$field->{subfields}}) {
+ my $code = $sf->[0];
+ my $val = $U->entityize($sf->[1]);
+ $control .= qq{<subfield code="$code">$val</subfield>};
+ }
+ $control .= '</datafield>';
+
+ # ARN, or "authority record number", used to need to be unique across the database.
+ # Of course, we have no idea what's in the database, and if the
+ # cat.maintain_control_numbers flag is set to "TRUE" then the 001 will
+ # be reset to the record ID anyway.
+ my $arn = 'AUTOGEN-' . time();
+
+ # Placeholder MARCXML;
+ # 001/003 can be be properly filled in via database triggers
+ # 005 will be filled in automatically at creation time
+ # 008 needs to be set by a cataloguer (could be some OU settings, I suppose)
+ # 040 should come from OU settings / OU shortname
+ #
+ my $marc_xml = <<MARCXML;
+<record xmlns:marc="http://www.loc.gov/MARC21/slim" xmlns="http://www.loc.gov/MARC21/slim"><leader> nz a22 o 4500</leader>
+<controlfield tag="001">$arn</controlfield>
+<controlfield tag="008"> ||||||||||||||||||||||||||||||||||</controlfield>
+<datafield tag="040" ind1=" " ind2=" "><subfield code="a">$cni</subfield><subfield code="c">$cni</subfield></datafield>
+$control
+</record>
+MARCXML
+
+ if ($self->api_name =~ m/readonly$/) {
+ return $marc_xml;
+ } else {
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_AUTHORITY_RECORD');
+ my $rec = OpenILS::Application::Cat::AuthCommon->import_authority_record($e, $marc_xml);
+ $e->commit unless $U->event_code($rec);
+ return $rec;
+ }
+}
+
+__PACKAGE__->register_method(
+ method => 'overlay_authority_record',
+ api_name => 'open-ils.cat.authority.record.overlay',
+);
+
+sub overlay_authority_record {
+ my($self, $conn, $auth, $rec_id, $marc_xml, $source) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('UPDATE_AUTHORITY_RECORD');
+ my $rec = OpenILS::Application::Cat::AuthCommon->overlay_authority_record($rec_id, $marc_xml, $source);
+ $e->commit unless $U->event_code($rec);
+ return $rec;
+
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_authority_record',
+ api_name => 'open-ils.cat.authority.record.retrieve',
+ signature => {
+ desc => q/Retrieve an authority record entry/,
+ params => [
+ {desc => q/hash of options. Options include "clear_marc" which clears
+ the MARC xml from the record before it is returned/}
+ ]
+ }
+);
+sub retrieve_authority_record {
+ my($self, $conn, $auth, $rec_id, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $rec = $e->retrieve_authority_record($rec_id) or return $e->event;
+ $rec->clear_marc if $$options{clear_marc};
+ return $rec;
+}
+
+__PACKAGE__->register_method(
+ method => 'batch_retrieve_authority_record',
+ api_name => 'open-ils.cat.authority.record.batch.retrieve',
+ stream => 1,
+ signature => {
+ desc => q/Retrieve a set of authority record entry objects/,
+ params => [
+ {desc => q/hash of options. Options include "clear_marc" which clears
+ the MARC xml from the record before it is returned/}
+ ]
+ }
+);
+sub batch_retrieve_authority_record {
+ my($self, $conn, $auth, $rec_id_list, $options) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ for my $rec_id (@$rec_id_list) {
+ my $rec = $e->retrieve_authority_record($rec_id) or return $e->event;
+ $rec->clear_marc if $$options{clear_marc};
+ $conn->respond($rec);
+ }
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'count_linked_bibs',
+ api_name => 'open-ils.cat.authority.records.count_linked_bibs',
+ signature => q/
+ Counts the number of bib records linked to each authority record in the input list
+ @param records Array of authority records to return counts
+ @return A list of hashes containing the authority record ID ("id") and linked bib count ("bibs")
+ /
+);
+
+sub count_linked_bibs {
+ my( $self, $conn, $records ) = @_;
+
+ my $editor = new_editor();
+
+ my $link_count;
+ my @clean_records;
+ for my $auth ( @$records ) {
+ # Protection against SQL injection? Might be overkill.
+ my $intauth = int($auth);
+ if ($intauth) {
+ push(@clean_records, $intauth);
+ }
+ }
+ return $link_count if !@clean_records;
+
+ $link_count = $editor->json_query({
+ "select" => {
+ "abl" => [
+ {
+ "column" => "authority"
+ },
+ {
+ "alias" => "bibs",
+ "transform" => "count",
+ "column" => "bib",
+ "aggregate" => 1
+ }
+ ]
+ },
+ "from" => "abl",
+ "where" => { "authority" => \@clean_records }
+ });
+
+ return $link_count;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Cat::BibCommon;
+use strict; use warnings;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger qw($logger);
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Const qw/:const/;
+use OpenSRF::AppSession;
+use OpenILS::Event;
+my $U = 'OpenILS::Application::AppUtils';
+my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
+
+
+# ---------------------------------------------------------------------------
+# Shared bib mangling code. Do not publish methods from here.
+# ---------------------------------------------------------------------------
+
+my $__bib_sources;
+sub bib_source_from_name {
+ my $name = shift;
+ $logger->debug("searching for bib source: $name");
+
+ fetch_bib_sources();
+
+ my ($s) = grep { lc($_->source) eq lc($name) } @$__bib_sources;
+
+ return $s->id if $s;
+ return undef;
+}
+
+sub fetch_bib_sources {
+ $__bib_sources = new_editor()->retrieve_all_config_bib_source()
+ unless $__bib_sources;
+ return $__bib_sources;
+}
+
+
+sub biblio_record_replace_marc {
+ my($class, $e, $recid, $newxml, $source, $fixtcn, $override) = @_;
+
+ my $rec = $e->retrieve_biblio_record_entry($recid)
+ or return $e->die_event;
+
+ # See if there is a different record in the database that has our TCN value
+ # If we're not updating the TCN, all we care about it the marcdoc
+ # XXX should .update even bother with the tcn_info if it's not going to replace it?
+ # there is the potential for returning a TCN_EXISTS event, even though no replacement happens
+
+ my( $tcn, $tsource, $marcdoc, $evt);
+
+ if($fixtcn or $override) {
+
+ ($tcn, $tsource, $marcdoc, $evt) =
+ _find_tcn_info($e, $newxml, $override, $recid);
+
+ return $evt if $evt;
+
+ $rec->tcn_value($tcn) if ($tcn);
+ $rec->tcn_source($tsource);
+
+ } else {
+
+ $marcdoc = __make_marc_doc($newxml);
+ }
+
+
+ $rec->source(bib_source_from_name($source)) if $source;
+ $rec->editor($e->requestor->id);
+ $rec->edit_date('now');
+ $rec->marc( $U->entityize( $marcdoc->documentElement->toString ) );
+ $e->update_biblio_record_entry($rec) or return $e->die_event;
+
+ return $rec;
+}
+
+sub biblio_record_xml_import {
+ my($class, $e, $xml, $source, $auto_tcn, $override) = @_;
+
+ my( $evt, $tcn, $tcn_source, $marcdoc );
+
+ my $use_id = $e->retrieve_config_global_flag('cat.bib.use_id_for_tcn');
+ $use_id = ($use_id and $U->is_true($use_id->enabled));
+
+ if( $auto_tcn or $use_id ) {
+ # auto_tcn forces a blank TCN value so the DB will have to generate one for us
+ $marcdoc = __make_marc_doc($xml);
+ } else {
+ ( $tcn, $tcn_source, $marcdoc, $evt ) = _find_tcn_info($e, $xml, $override);
+ return $evt if $evt;
+ }
+
+ # Silence warnings when _find_tcn_info() fails
+ $tcn ||= '';
+ $tcn_source ||= '';
+ $logger->info("user ".$e->requestor->id.
+ " creating new biblio entry with tcn=$tcn and tcn_source $tcn_source");
+
+ my $record = Fieldmapper::biblio::record_entry->new;
+
+ $record->source(bib_source_from_name($source)) if $source;
+ $record->tcn_source($tcn_source);
+ $record->tcn_value($tcn) if ($tcn);
+ $record->creator($e->requestor->id);
+ $record->editor($e->requestor->id);
+ $record->create_date('now');
+ $record->edit_date('now');
+ $record->marc($U->entityize($marcdoc->documentElement->toString));
+
+ $record = $e->create_biblio_record_entry($record) or return $e->die_event;
+
+ if($use_id) {
+ my $existing = $e->search_biblio_record_entry(
+ {
+ tcn_value => $record->id,
+ deleted => 'f'
+ }, {
+ idlist => 1
+ }
+ );
+
+ if(@$existing) {
+ # leave the auto-generated tcn_value in place
+ $logger->warn("Collision using internal ID as tcn_value for record " . $record->id);
+ } else {
+ $record->tcn_value($record->id);
+ $e->update_biblio_record_entry($record) or return $e->die_event;
+ }
+ }
+
+ $logger->info("marc create/import created new record ".$record->id);
+ return $record;
+}
+
+sub __make_marc_doc {
+ my $xml = shift;
+ my $marcxml = XML::LibXML->new->parse_string($xml);
+ $marcxml->documentElement->setNamespace($MARC_NAMESPACE, "marc", 1 );
+ $marcxml->documentElement->setNamespace($MARC_NAMESPACE);
+ __remove_empty_marc_nodes($marcxml);
+ return $marcxml;
+}
+
+# remove empty control fields, subfields, and variable data fields, which
+# can creep in via less-than-correct imported MARC records or issues
+# with templates
+sub __remove_empty_marc_nodes {
+ my $marcxml = shift;
+
+ __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'controlfield');
+ __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'subfield');
+ __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'datafield');
+}
+
+sub __remove_if_childless {
+ my $node = shift;
+ my @children = $node->childNodes();
+ my $has_nonblank_children = 0;
+ # can do this more concisely by requiring XML::LibXML >= 1.70 and using nonBlankChildNodes()
+ foreach my $node ($node->childNodes()) {
+ if ($node->nodeType != XML::LibXML::XML_TEXT_NODE || $node->nodeValue !~ /^\s*$/) {
+ $has_nonblank_children = 1;
+ last;
+ }
+ }
+ $node->parentNode->removeChild($node) unless $has_nonblank_children;
+}
+
+sub _find_tcn_info {
+ my $editor = shift;
+ my $xml = shift;
+ my $override = shift;
+ my $existing_rec = shift || 0;
+
+ # parse the XML
+ my $marcxml = __make_marc_doc($xml);
+
+ my $xpath = '//marc:controlfield[@tag="001"]';
+ my $tcn = $marcxml->documentElement->findvalue($xpath);
+ $logger->info("biblio import located 001 (tcn) value of $tcn");
+
+ $xpath = '//marc:controlfield[@tag="003"]';
+ my $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
+
+ if(my $rec = _tcn_exists($editor, $tcn, $tcn_source, $existing_rec) ) {
+
+ my $origtcn = $tcn;
+ $tcn = find_free_tcn( $marcxml, $editor, $existing_rec );
+
+ # if we're overriding, try to find a different TCN to use
+ if( $override ) {
+
+ # XXX Create ALLOW_ALT_TCN permission check support
+
+ $logger->info("tcn value $tcn already exists, attempting to override");
+
+ if(!$tcn) {
+ return (
+ undef,
+ undef,
+ undef,
+ OpenILS::Event->new(
+ 'OPEN_TCN_NOT_FOUND',
+ payload => $marcxml->toString())
+ );
+ }
+
+ } else {
+
+ $logger->warn("tcn value $origtcn already exists in import/create");
+
+ # otherwise, return event
+ return (
+ undef,
+ undef,
+ undef,
+ OpenILS::Event->new(
+ 'TCN_EXISTS', payload => {
+ dup_record => $rec,
+ tcn => $origtcn,
+ new_tcn => $tcn
+ }
+ )
+ );
+ }
+ }
+
+ return ($tcn, $tcn_source, $marcxml);
+}
+
+sub find_free_tcn {
+
+ my $marcxml = shift;
+ my $editor = shift;
+ my $existing_rec = shift;
+
+ my $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="a"]';
+ my ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
+
+ if (!$tcn) {
+ $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="a"]';
+ ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
+ }
+
+ $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="b"]';
+ my ($tcn_source) = $marcxml->documentElement->findvalue($xpath);
+ if (!$tcn_source) {
+ $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="b"]';
+ $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
+ }
+
+ if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {
+ $tcn = undef;
+ }
+
+
+ if(!$tcn) {
+ $xpath = '//marc:datafield[@tag="020"]/marc:subfield[@code="a"]';
+ ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
+ $tcn_source = "ISBN";
+ if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
+ }
+
+ if(!$tcn) {
+ $xpath = '//marc:datafield[@tag="022"]/marc:subfield[@code="a"]';
+ ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
+ $tcn_source = "ISSN";
+ if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
+ }
+
+ if(!$tcn) {
+ $xpath = '//marc:datafield[@tag="010"]';
+ ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
+ $tcn_source = "LCCN";
+ if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
+ }
+
+ if(!$tcn) {
+ $xpath = '//marc:datafield[@tag="035"]/marc:subfield[@code="a"]';
+ ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
+ $tcn_source = "System Legacy";
+ if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
+
+ if($tcn) {
+ $marcxml->documentElement->removeChild(
+ $marcxml->documentElement->findnodes( '//marc:datafield[@tag="035"]' )
+ );
+ }
+ }
+
+ return undef unless $tcn;
+ return $tcn;
+}
+
+
+
+sub _tcn_exists {
+ my $editor = shift;
+ my $tcn = shift;
+ my $source = shift;
+ my $existing_rec = shift || 0;
+
+ if(!$tcn) {return 0;}
+
+ $logger->debug("tcn_exists search for tcn $tcn and source $source and id $existing_rec");
+
+ # XXX why does the source matter?
+# my $req = $session->request(
+# { tcn_value => $tcn, tcn_source => $source, deleted => 'f' } );
+
+ my $recs = $editor->search_biblio_record_entry(
+ {tcn_value => $tcn, deleted => 'f', id => {'!=' => $existing_rec}}, {idlist =>1});
+
+ if(@$recs) {
+ $logger->debug("_tcn_exists is true for tcn : $tcn ($source)");
+ return $recs->[0];
+ }
+
+ $logger->debug("_tcn_exists is false for tcn : $tcn ($source)");
+ return 0;
+}
+
+
+sub delete_rec {
+ my($class, $editor, $rec_id ) = @_;
+
+ my $rec = $editor->retrieve_biblio_record_entry($rec_id)
+ or return $editor->event;
+
+ return undef if $U->is_true($rec->deleted);
+
+ $rec->deleted('t');
+ $rec->active('f');
+ $rec->editor( $editor->requestor->id );
+ $rec->edit_date('now');
+
+ # Set the leader/05 to indicate that the record has been deleted
+ my $marc = $rec->marc();
+ $marc =~ s{(<leader>.{5}).}{$1d};
+ $rec->marc($marc);
+
+ $editor->update_biblio_record_entry($rec) or return $editor->event;
+
+ return undef;
+}
+
+
+# ---------------------------------------------------------------------------
+# returns true if the given title (id) has no un-deleted volumes or
+# copies attached. If a context volume is defined, a record
+# is considered empty only if the context volume is the only
+# remaining volume on the record.
+# ---------------------------------------------------------------------------
+sub title_is_empty {
+ my($class, $editor, $rid, $vol_id) = @_;
+
+ return 0 if $rid == OILS_PRECAT_RECORD;
+
+ my $cnlist = $editor->search_asset_call_number(
+ { record => $rid, deleted => 'f' }, { idlist => 1 } );
+
+ return 1 unless @$cnlist; # no attached volumes
+ return 0 if @$cnlist > 1; # multiple attached volumes
+ return 0 unless $$cnlist[0] == $vol_id; # attached volume is not the context vol.
+
+ # see if the sole remaining context volume has any attached copies
+ for my $cn (@$cnlist) {
+ my $copylist = $editor->search_asset_copy(
+ [
+ { call_number => $cn, deleted => 'f' },
+ { limit => 1 },
+ ], { idlist => 1 });
+ return 0 if @$copylist; # false if we find any copies
+ }
+
+ return 1;
+}
+1;
--- /dev/null
+use strict; use warnings;
+package OpenILS::Application::Cat::Merge;
+use base qw/OpenILS::Application/;
+use OpenSRF::Application;
+use OpenILS::Application::AppUtils;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Event;
+use OpenSRF::Utils::Logger qw($logger);
+use Data::Dumper;
+my $U = "OpenILS::Application::AppUtils";
+
+my $storage;
+
+
+# removes items from an array and returns the removed items
+# example : my @d = rgrep(sub { $_ =~ /o/ }, \@a);
+# there's surely a smarter way to do this
+sub rgrep {
+ my( $sub, $arr ) = @_;
+ my @del;
+ for( my $i = 0; $i < @$arr; $i++ ) {
+ my $a = $$arr[$i];
+ local $_ = $a;
+ if($sub->()) {
+ splice(@$arr, $i--, 1);
+ push( @del, $a );
+ }
+ }
+ return @del;
+}
+
+
+
+# takes a master record and a list of
+# sub-records to merge into the master record
+sub merge_records {
+ my( $editor, $master, $records ) = @_;
+
+ # bib records are global objects, so no org context required.
+ return (undef, $editor->die_event)
+ unless $editor->allowed('MERGE_BIB_RECORDS');
+
+ my $vol;
+ my $evt;
+
+ my %r = map { $_ => 1 } ($master, @$records); # unique the ids
+ my @recs = keys %r;
+
+ my $reqr = $editor->requestor;
+ $logger->activity("merge: user ".$reqr->id." merging bib records: @recs with master = $master");
+
+ # -----------------------------------------------------------
+ # collect all of the volumes, merge any with duplicate
+ # labels, then move all of the volumes to the master record
+ # -----------------------------------------------------------
+ my @volumes;
+ for (@recs) {
+ my $vs = $editor->search_asset_call_number({record => $_, deleted=>'f'});
+ push( @volumes, @$vs );
+ }
+
+ $logger->info("merge: merge recovered ".scalar(@volumes)." total volumes");
+
+ my @trimmed;
+ # de-duplicate any volumes with the same label and owning_lib
+
+ my %seen_vols;
+
+ for my $v (@volumes) {
+ my $l = $v->label;
+ my $o = $v->owning_lib;
+
+ if($seen_vols{$v->id}) {
+ $logger->debug("merge: skipping ".$v->id." since it's already been merged");
+ next;
+ }
+
+ $seen_vols{$v->id} = 1;
+
+ $logger->debug("merge: [".$v->id."] looking for dupes with label $l and owning_lib $o");
+
+ my @dups;
+ for my $vv (@volumes) {
+ if( $vv->label eq $v->label and $vv->owning_lib == $v->owning_lib ) {
+ $logger->debug("merge: pushing dupe volume ".$vv->id) if @dups;
+ push( @dups, $vv );
+ $seen_vols{$vv->id} = 1;
+ }
+ }
+
+ if( @dups == 1 ) {
+ $logger->debug("merge: pushing unique volume into trimmed volume set: ".$v->id);
+ push( @trimmed, @dups );
+
+ } else {
+ my($vol, $e) = merge_volumes($editor, \@dups);
+ return $e if $e;
+ $logger->debug("merge: pushing vol-merged volume into trimmed volume set: ".$vol->id);
+ push(@trimmed, $vol);
+ }
+ }
+
+ my $s = 'merge: trimmed volume set contains the following vols: ';
+ $s .= 'id = '.$_->id .' : record = '.$_->record.' | ' for @trimmed;
+ $logger->debug($s);
+
+ # make all the volumes point to the master record
+ my $stat;
+ for $vol (@trimmed) {
+ if( $vol->record ne $master ) {
+
+ $logger->debug("merge: moving volume ".
+ $vol->id." from record ".$vol->record. " to $master");
+
+ $vol->editor( $editor->requestor->id );
+ $vol->edit_date('now');
+ $vol->record( $master );
+ $editor->update_asset_call_number($vol)
+ or return $editor->die_event;
+ }
+ }
+
+ # cycle through and delete the non-master records
+ for my $rec (@recs) {
+
+ my $record = $editor->retrieve_biblio_record_entry($rec)
+ or return $editor->die_event;
+
+ $logger->debug("merge: seeing if record $rec needs to be deleted or un-deleted");
+
+ if( $rec == $master ) {
+ # make sure the master record is not deleted
+ if( $U->is_true($record->deleted) ) {
+ $logger->info("merge: master record is marked as deleted...un-deleting.");
+ $record->deleted('f');
+ $record->editor($reqr->id);
+ $record->edit_date('now');
+ $editor->update_biblio_record_entry($record)
+ or return $editor->die_event;
+ }
+
+ } else {
+ $logger->info("merge: deleting record $rec");
+ $record->deleted('t');
+ $record->editor($reqr->id);
+ $record->edit_date('now');
+ $editor->update_biblio_record_entry($record)
+ or return $editor->die_event;
+ }
+ }
+
+ return undef;
+}
+
+
+
+# takes a list of volume objects, picks the volume with most
+# copies and moves all copies attached to the other volumes
+# into said volume. all other volumes are deleted
+sub merge_volumes {
+ my( $editor, $volumes, $master ) = @_;
+ my %copies;
+ my $evt;
+
+ return ($$volumes[0]) if !$master and @$volumes == 1;
+
+ return ($$volumes[0]) if
+ $master and @$volumes == 1
+ and $master->id == $$volumes[0]->id;
+
+ $logger->debug("merge: fetching copies for volume list of size ".scalar(@$volumes));
+
+ # collect all of the copies attached to the selected volumes
+ for( @$volumes ) {
+ $copies{$_->id} = $editor->search_asset_copy({call_number=>$_->id, deleted=>'f'});
+ $logger->debug("merge: found ".scalar(@{$copies{$_->id}})." copies for volume ".$_->id);
+ }
+
+ my $bigcn;
+ if( $master ) {
+
+ # the caller has chosen the master record
+ $bigcn = $master->id;
+ push( @$volumes, $master );
+
+ } else {
+
+ # find the CN with the most copies and make it the master CN
+ my $big = 0;
+ for my $cn (keys %copies) {
+ my $count = scalar(@{$copies{$cn}});
+ if( $count > $big ) {
+ $big = $count;
+ $bigcn = $cn;
+ }
+ }
+ }
+
+ $bigcn = $$volumes[0]->id unless $bigcn;
+
+ $logger->info("merge: merge using volume $bigcn as the master");
+
+ # now move all of the copies to the new volume
+ for my $cn (keys %copies) {
+ next if $cn == $bigcn;
+ for my $copy (@{$copies{$cn}}) {
+ $logger->debug("merge: setting call_number to $bigcn for copy ".$copy->id);
+ $copy->call_number($bigcn);
+ $copy->editor($editor->requestor->id);
+ $copy->edit_date('now');
+ $editor->update_asset_copy($copy) or return (undef, $editor->die_event);
+ }
+ }
+
+ for( @$volumes ) {
+ next if $_->id == $bigcn;
+ $logger->debug("merge: marking call_number as deleted: ".$_->id);
+ $_->deleted('t');
+ $_->editor($editor->requestor->id);
+ $_->edit_date('now');
+ $editor->update_asset_call_number($_) or return (undef, $editor->die_event);
+ merge_volume_holds($editor, $bigcn, $_->id);
+ }
+
+ my ($mvol) = grep { $_->id == $bigcn } @$volumes;
+ $logger->debug("merge: returning master volume ".$mvol->id);
+ return ($mvol);
+}
+
+sub merge_volume_holds {
+ my($e, $master_id, $vol_id) = @_;
+
+ my $holds = $e->search_action_hold_request(
+ { cancel_time => undef,
+ fulfillment_time => undef,
+ hold_type => 'V',
+ target => $vol_id
+ }
+ );
+
+ for my $hold (@$holds) {
+
+ $logger->info("Changing hold ".$hold->id.
+ " target from ".$hold->target." to $master_id in volume merge");
+
+ $hold->target($master_id);
+ unless($e->update_action_hold_request($hold)) {
+ my $evt = $e->event;
+ $logger->error("Error updating hold ". $evt->textcode .":". $evt->desc .":". $evt->stacktrace);
+ }
+ }
+
+ return undef;
+}
+
+
+1;
+
+
--- /dev/null
+package OpenILS::Application::Circ;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenILS::Application::Circ::Circulate;
+use OpenILS::Application::Circ::Survey;
+use OpenILS::Application::Circ::StatCat;
+use OpenILS::Application::Circ::Holds;
+use OpenILS::Application::Circ::HoldNotify;
+use OpenILS::Application::Circ::CreditCard;
+use OpenILS::Application::Circ::Money;
+use OpenILS::Application::Circ::NonCat;
+use OpenILS::Application::Circ::CopyLocations;
+use OpenILS::Application::Circ::CircCommon;
+
+use DateTime;
+use DateTime::Format::ISO8601;
+
+use OpenILS::Application::AppUtils;
+
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::AppSession;
+use OpenILS::Utils::ModsParser;
+use OpenILS::Event;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::Editor;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Const qw/:const/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::Cat::AssetCommon;
+
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+
+my $holdcode = "OpenILS::Application::Circ::Holds";
+
+# ------------------------------------------------------------------------
+# Top level Circ package;
+# ------------------------------------------------------------------------
+
+sub initialize {
+ my $self = shift;
+ OpenILS::Application::Circ::Circulate->initialize();
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_circ',
+ authoritative => 1,
+ api_name => 'open-ils.circ.retrieve',
+ signature => q/
+ Retrieve a circ object by id
+ @param authtoken Login session key
+ @pararm circid The id of the circ object
+ /
+);
+sub retrieve_circ {
+ my( $s, $c, $a, $i ) = @_;
+ my $e = new_editor(authtoken => $a);
+ return $e->event unless $e->checkauth;
+ my $circ = $e->retrieve_action_circulation($i) or return $e->event;
+ if( $e->requestor->id ne $circ->usr ) {
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
+ }
+ return $circ;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_circ_mods',
+ api_name => 'open-ils.circ.circ_modifier.retrieve.all');
+sub fetch_circ_mods {
+ my($self, $conn, $args) = @_;
+ my $mods = new_editor()->retrieve_all_config_circ_modifier;
+ return [ map {$_->code} @$mods ] unless $$args{full};
+ return $mods;
+}
+
+__PACKAGE__->register_method(
+ method => 'fetch_bill_types',
+ api_name => 'open-ils.circ.billing_type.retrieve.all');
+sub fetch_bill_types {
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ return $conf->config_value(
+ 'apps', 'open-ils.circ', 'app_settings', 'billing_types', 'type' );
+}
+
+
+__PACKAGE__->register_method(
+ method => 'ranged_billing_types',
+ api_name => 'open-ils.circ.billing_type.ranged.retrieve.all');
+
+sub ranged_billing_types {
+ my($self, $conn, $auth, $org_id, $depth) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_BILLING_TYPE', $org_id);
+ return $e->search_config_billing_type(
+ {owner => $U->get_org_full_path($org_id, $depth)});
+}
+
+
+
+# ------------------------------------------------------------------------
+# Returns an array of {circ, record} hashes checked out by the user.
+# ------------------------------------------------------------------------
+__PACKAGE__->register_method(
+ method => "checkouts_by_user",
+ api_name => "open-ils.circ.actor.user.checked_out",
+ stream => 1,
+ NOTES => <<" NOTES");
+ Returns a list of open circulations as a pile of objects. Each object
+ contains the relevant copy, circ, and record
+ NOTES
+
+sub checkouts_by_user {
+ my($self, $client, $auth, $user_id) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $circ_ids = $e->search_action_circulation(
+ { usr => $user_id,
+ checkin_time => undef,
+ '-or' => [
+ {stop_fines => undef},
+ {stop_fines => ['MAXFINES','LONGOVERDUE']}
+ ]
+ },
+ {idlist => 1}
+ );
+
+ for my $id (@$circ_ids) {
+ my $circ = $e->retrieve_action_circulation([
+ $id,
+ { flesh => 3,
+ flesh_fields => {
+ circ => ['target_copy'],
+ acp => ['call_number'],
+ acn => ['record']
+ }
+ }
+ ]);
+
+ # un-flesh for consistency
+ my $c = $circ->target_copy;
+ $circ->target_copy($c->id);
+
+ my $cn = $c->call_number;
+ $c->call_number($cn->id);
+
+ my $t = $cn->record;
+ $cn->record($t->id);
+
+ $client->respond(
+ { circ => $circ,
+ copy => $c,
+ record => $U->record_to_mvr($t)
+ }
+ );
+ }
+
+ return undef;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "checkouts_by_user_slim",
+ api_name => "open-ils.circ.actor.user.checked_out.slim",
+ NOTES => <<" NOTES");
+ Returns a list of open circulation objects
+ NOTES
+
+# DEPRECAT ME?? XXX
+sub checkouts_by_user_slim {
+ my( $self, $client, $user_session, $user_id ) = @_;
+
+ my( $requestor, $target, $copy, $record, $evt );
+
+ ( $requestor, $target, $evt ) =
+ $apputils->checkses_requestor( $user_session, $user_id, 'VIEW_CIRCULATIONS');
+ return $evt if $evt;
+
+ $logger->debug( 'User ' . $requestor->id .
+ " retrieving checked out items for user " . $target->id );
+
+ # XXX Make the call correct..
+ return $apputils->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.action.open_circulation.search.atomic",
+ { usr => $target->id, checkin_time => undef } );
+# { usr => $target->id } );
+}
+
+
+__PACKAGE__->register_method(
+ method => "checkouts_by_user_opac",
+ api_name => "open-ils.circ.actor.user.checked_out.opac",);
+
+# XXX Deprecate Me
+sub checkouts_by_user_opac {
+ my( $self, $client, $auth, $user_id ) = @_;
+
+ my $e = OpenILS::Utils::Editor->new( authtoken => $auth );
+ return $e->event unless $e->checkauth;
+ $user_id ||= $e->requestor->id;
+ return $e->event unless
+ my $patron = $e->retrieve_actor_user($user_id);
+
+ my $data;
+ my $search = {usr => $user_id, stop_fines => undef};
+
+ if( $user_id ne $e->requestor->id ) {
+ $data = $e->search_action_circulation(
+ $search, {checkperm=>1, permorg=>$patron->home_ou})
+ or return $e->event;
+
+ } else {
+ $data = $e->search_action_circulation($search);
+ }
+
+ return $data;
+}
+
+
+__PACKAGE__->register_method(
+ method => "title_from_transaction",
+ api_name => "open-ils.circ.circ_transaction.find_title",
+ NOTES => <<" NOTES");
+ Returns a mods object for the title that is linked to from the
+ copy from the hold that created the given transaction
+ NOTES
+
+sub title_from_transaction {
+ my( $self, $client, $login_session, $transactionid ) = @_;
+
+ my( $user, $circ, $title, $evt );
+
+ ( $user, $evt ) = $apputils->checkses( $login_session );
+ return $evt if $evt;
+
+ ( $circ, $evt ) = $apputils->fetch_circulation($transactionid);
+ return $evt if $evt;
+
+ ($title, $evt) = $apputils->fetch_record_by_copy($circ->target_copy);
+ return $evt if $evt;
+
+ return $apputils->record_to_mvr($title);
+}
+
+__PACKAGE__->register_method(
+ method => "staff_age_to_lost",
+ api_name => "open-ils.circ.circulation.age_to_lost",
+ stream => 1,
+ signature => q/
+ This fires a circ.staff_age_to_lost Action-Trigger event against all
+ overdue circulations in scope of the specified context library and
+ user profile, which effectively marks the associated items as Lost.
+ This is likely to be done at the end of a semester in an academic
+ library, etc.
+ @param auth
+ @param args : circ_lib, user_profile
+ /
+);
+
+sub staff_age_to_lost {
+ my( $self, $conn, $auth, $args ) = @_;
+
+ my $orgs = $U->get_org_descendants($args->{'circ_lib'});
+ my $profiles = $U->fetch_permission_group_descendants($args->{'user_profile'});
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+
+ my $method = 'open-ils.trigger.passive.event.autocreate.batch';
+ my $hook = 'circ.staff_age_to_lost';
+ my $context_org = 'circ_lib';
+ my $opt_granularity = undef;
+ my $filter = {
+ "checkin_time" => undef,
+ "due_date" => { "<" => "now" },
+ "-or" => [
+ { "stop_fines" => ["MAXFINES", "LONGOVERDUE"] }, # FIXME: CLAIMSRETURNED also?
+ { "stop_fines" => undef }
+ ],
+ "-and" => [
+ {"-exists" => {
+ "select" => {"au" => ["id"]},
+ "from" => "au",
+ "where" => {
+ "profile" => $profiles,
+ "id" => { "=" => {"+circ" => "usr"} }
+ }
+ }},
+ {"-exists" => {
+ "select" => {"aou" => ["id"]},
+ "from" => "aou",
+ "where" => {
+ "-and" => [
+ {"id" => { "=" => {"+circ" => "circ_lib"} }},
+ {"id" => $orgs}
+ ]
+ }
+ }}
+ ]
+ };
+ my $req_timeout = 10800;
+ my $chunk_size = 100;
+ my $progress = 1;
+
+ my $req = $ses->request($method, $hook, $context_org, $filter, $opt_granularity);
+ my @event_ids; my @chunked_ids;
+ while (my $resp = $req->recv(timeout => $req_timeout)) {
+ push(@event_ids, $resp->content);
+ push(@chunked_ids, $resp->content);
+ if (scalar(@chunked_ids) > $chunk_size) {
+ $conn->respond({'progress'=>$progress++}); # 'event_ids'=>@chunked_ids
+ @chunked_ids = ();
+ }
+ }
+ if (scalar(@chunked_ids) > 0) {
+ $conn->respond({'progress'=>$progress++}); # 'event_ids'=>@chunked_ids
+ }
+
+ if(@event_ids) {
+ $logger->info("staff_age_to_lost: created ".scalar(@event_ids)." events for circ.staff_age_to_lost");
+ $conn->respond_complete({'total_progress'=>$progress-1,'created'=>scalar(@event_ids)});
+ } elsif($req->complete) {
+ $logger->info("staff_age_to_lost: no events to create for circ.staff_age_to_lost");
+ $conn->respond_complete({'total_progress'=>$progress-1,'created'=>0});
+ } else {
+ $logger->warn("staff_age_to_lost: timeout occurred during event creation for circ.staff_age_to_lost");
+ $conn->respond_complete({'total_progress'=>$progress-1,'error'=>'timeout'});
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "new_set_circ_lost",
+ api_name => "open-ils.circ.circulation.set_lost",
+ signature => q/
+ Sets the copy and related open circulation to lost
+ @param auth
+ @param args : barcode
+ /
+);
+
+
+# ---------------------------------------------------------------------
+# Sets a circulation to lost. updates copy status to lost
+# applies copy and/or prcoessing fees depending on org settings
+# ---------------------------------------------------------------------
+sub new_set_circ_lost {
+ my( $self, $conn, $auth, $args ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $copy = $e->search_asset_copy({barcode=>$$args{barcode}, deleted=>'f'})->[0]
+ or return $e->die_event;
+
+ my $evt = OpenILS::Application::Cat::AssetCommon->set_item_lost($e, $copy->id);
+ return $evt if $evt;
+
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "set_circ_claims_returned",
+ api_name => "open-ils.circ.circulation.set_claims_returned",
+ signature => {
+ desc => q/Sets the circ for a given item as claims returned
+ If a backdate is provided, overdue fines will be voided
+ back to the backdate/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Arguments, including "barcode" and optional "backdate"', type => 'object'}
+ ],
+ return => {desc => q/1 on success, failure event on error, and
+ PATRON_EXCEEDS_CLAIMS_RETURN_COUNT if the patron exceeds the
+ configured claims return maximum/}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "set_circ_claims_returned",
+ api_name => "open-ils.circ.circulation.set_claims_returned.override",
+ signature => {
+ desc => q/This adds support for overrideing the configured max
+ claims returned amount.
+ @see open-ils.circ.circulation.set_claims_returned./,
+ }
+);
+
+sub set_circ_claims_returned {
+ my( $self, $conn, $auth, $args ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $barcode = $$args{barcode};
+ my $backdate = $$args{backdate};
+
+ my $copy = $e->search_asset_copy({barcode=>$barcode, deleted=>'f'})->[0]
+ or return $e->die_event;
+
+ my $circ = $e->search_action_circulation(
+ {checkin_time => undef, target_copy => $copy->id})->[0]
+ or return $e->die_event;
+
+ $backdate = $circ->due_date if $$args{use_due_date};
+
+ $logger->info("marking circ for item $barcode as claims returned".
+ (($backdate) ? " with backdate $backdate" : ''));
+
+ my $patron = $e->retrieve_actor_user($circ->usr);
+ my $max_count = $U->ou_ancestor_setting_value(
+ $circ->circ_lib, 'circ.max_patron_claim_return_count', $e);
+
+ # If the patron has too instances of many claims returned,
+ # require an override to continue. A configured max of
+ # 0 means all attempts require an override
+ if(defined $max_count and $patron->claims_returned_count >= $max_count) {
+
+ if($self->api_name =~ /override/) {
+
+ # see if we're allowed to override
+ return $e->die_event unless
+ $e->allowed('SET_CIRC_CLAIMS_RETURNED.override', $circ->circ_lib);
+
+ } else {
+
+ # exit early and return the max claims return event
+ $e->rollback;
+ return OpenILS::Event->new(
+ 'PATRON_EXCEEDS_CLAIMS_RETURN_COUNT',
+ payload => {
+ patron_count => $patron->claims_returned_count,
+ max_count => $max_count
+ }
+ );
+ }
+ }
+
+ $e->allowed('SET_CIRC_CLAIMS_RETURNED', $circ->circ_lib)
+ or return $e->die_event;
+
+ $circ->stop_fines(OILS_STOP_FINES_CLAIMSRETURNED);
+ $circ->stop_fines_time('now') unless $circ->stop_fines_time;
+
+ if( $backdate ) {
+ $backdate = cleanse_ISO8601($backdate);
+
+ my $original_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($circ->due_date));
+ my $new_date = DateTime::Format::ISO8601->new->parse_datetime($backdate);
+ $backdate = $new_date->ymd . 'T' . $original_date->strftime('%T%z');
+
+ # clean it up once again; need a : in the timezone offset. E.g. -06:00 not -0600
+ $backdate = cleanse_ISO8601($backdate);
+
+ # make it look like the circ stopped at the cliams returned time
+ $circ->stop_fines_time($backdate);
+ my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ, $backdate);
+ return $evt if $evt;
+ }
+
+ $e->update_action_circulation($circ) or return $e->die_event;
+
+ # see if there is a configured post-claims-return copy status
+ if(my $stat = $U->ou_ancestor_setting_value($circ->circ_lib, 'circ.claim_return.copy_status')) {
+ $copy->status($stat);
+ $copy->edit_date('now');
+ $copy->editor($e->requestor->id);
+ $e->update_asset_copy($copy) or return $e->die_event;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "post_checkin_backdate_circ",
+ api_name => "open-ils.circ.post_checkin_backdate",
+ signature => {
+ desc => q/Back-date an already checked in circulation/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Circ ID', type => 'number'},
+ {desc => 'ISO8601 backdate', type => 'string'},
+ ],
+ return => {desc => q/1 on success, failure event on error/}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "post_checkin_backdate_circ",
+ api_name => "open-ils.circ.post_checkin_backdate.batch",
+ stream => 1,
+ signature => {
+ desc => q/@see open-ils.circ.post_checkin_backdate. Batch mode/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'List of Circ ID', type => 'array'},
+ {desc => 'ISO8601 backdate', type => 'string'},
+ ],
+ return => {desc => q/Set of: 1 on success, failure event on error/}
+ }
+);
+
+
+sub post_checkin_backdate_circ {
+ my( $self, $conn, $auth, $circ_id, $backdate ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ if($self->api_name =~ /batch/) {
+ foreach my $c (@$circ_id) {
+ $conn->respond(post_checkin_backdate_circ_impl($e, $c, $backdate));
+ }
+ } else {
+ $conn->respond_complete(post_checkin_backdate_circ_impl($e, $circ_id, $backdate));
+ }
+
+ $e->disconnect;
+ return undef;
+}
+
+
+sub post_checkin_backdate_circ_impl {
+ my($e, $circ_id, $backdate) = @_;
+
+ $e->xact_begin;
+
+ my $circ = $e->retrieve_action_circulation($circ_id)
+ or return $e->die_event;
+
+ # anyone with checkin perms can backdate (more restrictive?)
+ return $e->die_event unless $e->allowed('COPY_CHECKIN', $circ->circ_lib);
+
+ # don't allow back-dating an open circulation
+ return OpenILS::Event->new('BAD_PARAMS') unless
+ $backdate and $circ->checkin_time;
+
+ # update the checkin and stop_fines times to reflect the new backdate
+ $circ->stop_fines_time(cleanse_ISO8601($backdate));
+ $circ->checkin_time(cleanse_ISO8601($backdate));
+ $e->update_action_circulation($circ) or return $e->die_event;
+
+ # now void the overdues "erased" by the back-dating
+ my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ, $backdate);
+ return $evt if $evt;
+
+ # If the circ was closed before and the balance owned !=0, re-open the transaction
+ $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($e, $circ->id);
+ return $evt if $evt;
+
+ $e->xact_commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method (
+ method => 'set_circ_due_date',
+ api_name => 'open-ils.circ.circulation.due_date.update',
+ signature => q/
+ Updates the due_date on the given circ
+ @param authtoken
+ @param circid The id of the circ to update
+ @param date The timestamp of the new due date
+ /
+);
+
+sub set_circ_due_date {
+ my( $self, $conn, $auth, $circ_id, $date ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ my $circ = $e->retrieve_action_circulation($circ_id)
+ or return $e->die_event;
+
+ return $e->die_event unless $e->allowed('CIRC_OVERRIDE_DUE_DATE', $circ->circ_lib);
+ $date = cleanse_ISO8601($date);
+
+ if (!(interval_to_seconds($circ->duration) % 86400)) { # duration is divisible by days
+ my $original_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($circ->due_date));
+ my $new_date = DateTime::Format::ISO8601->new->parse_datetime($date);
+ $date = cleanse_ISO8601( $new_date->ymd . 'T' . $original_date->strftime('%T%z') );
+ }
+
+ $circ->due_date($date);
+ $e->update_action_circulation($circ) or return $e->die_event;
+ $e->commit;
+
+ return $circ;
+}
+
+
+__PACKAGE__->register_method(
+ method => "create_in_house_use",
+ api_name => 'open-ils.circ.in_house_use.create',
+ signature => q/
+ Creates an in-house use action.
+ @param $authtoken The login session key
+ @param params A hash of params including
+ 'location' The org unit id where the in-house use occurs
+ 'copyid' The copy in question
+ 'count' The number of in-house uses to apply to this copy
+ @return An array of id's representing the id's of the newly created
+ in-house use objects or an event on an error
+ /);
+
+__PACKAGE__->register_method(
+ method => "create_in_house_use",
+ api_name => 'open-ils.circ.non_cat_in_house_use.create',
+);
+
+
+sub create_in_house_use {
+ my( $self, $client, $auth, $params ) = @_;
+
+ my( $evt, $copy );
+ my $org = $params->{location};
+ my $copyid = $params->{copyid};
+ my $count = $params->{count} || 1;
+ my $nc_type = $params->{non_cat_type};
+ my $use_time = $params->{use_time} || 'now';
+
+ my $e = new_editor(xact=>1,authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('CREATE_IN_HOUSE_USE');
+
+ my $non_cat = 1 if $self->api_name =~ /non_cat/;
+
+ unless( $non_cat ) {
+ if( $copyid ) {
+ $copy = $e->retrieve_asset_copy($copyid) or return $e->event;
+ } else {
+ $copy = $e->search_asset_copy({barcode=>$params->{barcode}, deleted => 'f'})->[0]
+ or return $e->event;
+ $copyid = $copy->id;
+ }
+ }
+
+ if( $use_time ne 'now' ) {
+ $use_time = cleanse_ISO8601($use_time);
+ $logger->debug("in_house_use setting use time to $use_time");
+ }
+
+ my @ids;
+ for(1..$count) {
+
+ my $ihu;
+ my $method;
+ my $cmeth;
+
+ if($non_cat) {
+ $ihu = Fieldmapper::action::non_cat_in_house_use->new;
+ $ihu->item_type($nc_type);
+ $method = 'open-ils.storage.direct.action.non_cat_in_house_use.create';
+ $cmeth = "create_action_non_cat_in_house_use";
+
+ } else {
+ $ihu = Fieldmapper::action::in_house_use->new;
+ $ihu->item($copyid);
+ $method = 'open-ils.storage.direct.action.in_house_use.create';
+ $cmeth = "create_action_in_house_use";
+ }
+
+ $ihu->staff($e->requestor->id);
+ $ihu->org_unit($org);
+ $ihu->use_time($use_time);
+
+ $ihu = $e->$cmeth($ihu) or return $e->event;
+ push( @ids, $ihu->id );
+ }
+
+ $e->commit;
+ return \@ids;
+}
+
+
+
+
+
+__PACKAGE__->register_method(
+ method => "view_circs",
+ api_name => "open-ils.circ.copy_checkout_history.retrieve",
+ notes => q/
+ Retrieves the last X circs for a given copy
+ @param authtoken The login session key
+ @param copyid The copy to check
+ @param count How far to go back in the item history
+ @return An array of circ ids
+ /);
+
+# ----------------------------------------------------------------------
+# Returns $count most recent circs. If count exceeds the configured
+# max, use the configured max instead
+# ----------------------------------------------------------------------
+sub view_circs {
+ my( $self, $client, $authtoken, $copyid, $count ) = @_;
+
+ my $e = new_editor(authtoken => $authtoken);
+ return $e->event unless $e->checkauth;
+
+ my $copy = $e->retrieve_asset_copy([
+ $copyid,
+ { flesh => 1,
+ flesh_fields => {acp => ['call_number']}
+ }
+ ]) or return $e->event;
+
+ return $e->event unless $e->allowed(
+ 'VIEW_COPY_CHECKOUT_HISTORY',
+ ($copy->call_number == OILS_PRECAT_CALL_NUMBER) ?
+ $copy->circ_lib : $copy->call_number->owning_lib);
+
+ my $max_history = $U->ou_ancestor_setting_value(
+ $e->requestor->ws_ou, 'circ.item_checkout_history.max', $e);
+
+ if(defined $max_history) {
+ $count = $max_history unless defined $count and $count < $max_history;
+ } else {
+ $count = 4 unless defined $count;
+ }
+
+ return $e->search_action_circulation([
+ {target_copy => $copyid},
+ {limit => $count, order_by => { circ => "xact_start DESC" }}
+ ]);
+}
+
+
+__PACKAGE__->register_method(
+ method => "circ_count",
+ api_name => "open-ils.circ.circulation.count",
+ notes => q/
+ Returns the number of times the item has circulated
+ @param copyid The copy to check
+ /);
+
+sub circ_count {
+ my( $self, $client, $copyid, $range ) = @_;
+ my $e = OpenILS::Utils::Editor->new;
+ return $e->request('open-ils.storage.asset.copy.circ_count', $copyid, $range);
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_notes',
+ authoritative => 1,
+ api_name => 'open-ils.circ.copy_note.retrieve.all',
+ signature => q/
+ Returns an array of copy note objects.
+ @param args A named hash of parameters including:
+ authtoken : Required if viewing non-public notes
+ itemid : The id of the item whose notes we want to retrieve
+ pub : True if all the caller wants are public notes
+ @return An array of note objects
+ /);
+
+__PACKAGE__->register_method(
+ method => 'fetch_notes',
+ api_name => 'open-ils.circ.call_number_note.retrieve.all',
+ signature => q/@see open-ils.circ.copy_note.retrieve.all/);
+
+__PACKAGE__->register_method(
+ method => 'fetch_notes',
+ api_name => 'open-ils.circ.title_note.retrieve.all',
+ signature => q/@see open-ils.circ.copy_note.retrieve.all/);
+
+
+# NOTE: VIEW_COPY/VOLUME/TITLE_NOTES perms should always be global
+sub fetch_notes {
+ my( $self, $connection, $args ) = @_;
+
+ my $id = $$args{itemid};
+ my $authtoken = $$args{authtoken};
+ my( $r, $evt);
+
+ if( $self->api_name =~ /copy/ ) {
+ if( $$args{pub} ) {
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.asset.copy_note.search.atomic',
+ { owning_copy => $id, pub => 't' } );
+ } else {
+ ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_COPY_NOTES');
+ return $evt if $evt;
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.asset.copy_note.search.atomic', {owning_copy => $id} );
+ }
+
+ } elsif( $self->api_name =~ /call_number/ ) {
+ if( $$args{pub} ) {
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.asset.call_number_note.search.atomic',
+ { call_number => $id, pub => 't' } );
+ } else {
+ ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_VOLUME_NOTES');
+ return $evt if $evt;
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.asset.call_number_note.search.atomic', { call_number => $id } );
+ }
+
+ } elsif( $self->api_name =~ /title/ ) {
+ if( $$args{pub} ) {
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.bilbio.record_note.search.atomic',
+ { record => $id, pub => 't' } );
+ } else {
+ ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_TITLE_NOTES');
+ return $evt if $evt;
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.biblio.record_note.search.atomic', { record => $id } );
+ }
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'has_notes',
+ api_name => 'open-ils.circ.copy.has_notes');
+__PACKAGE__->register_method(
+ method => 'has_notes',
+ api_name => 'open-ils.circ.call_number.has_notes');
+__PACKAGE__->register_method(
+ method => 'has_notes',
+ api_name => 'open-ils.circ.title.has_notes');
+
+
+sub has_notes {
+ my( $self, $conn, $authtoken, $id ) = @_;
+ my $editor = OpenILS::Utils::Editor->new(authtoken => $authtoken);
+ return $editor->event unless $editor->checkauth;
+
+ my $n = $editor->search_asset_copy_note(
+ {owning_copy=>$id}, {idlist=>1}) if $self->api_name =~ /copy/;
+
+ $n = $editor->search_asset_call_number_note(
+ {call_number=>$id}, {idlist=>1}) if $self->api_name =~ /call_number/;
+
+ $n = $editor->search_biblio_record_note(
+ {record=>$id}, {idlist=>1}) if $self->api_name =~ /title/;
+
+ return scalar @$n;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'create_copy_note',
+ api_name => 'open-ils.circ.copy_note.create',
+ signature => q/
+ Creates a new copy note
+ @param authtoken The login session key
+ @param note The note object to create
+ @return The id of the new note object
+ /);
+
+sub create_copy_note {
+ my( $self, $connection, $authtoken, $note ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+ my $copy = $e->retrieve_asset_copy(
+ [
+ $note->owning_copy,
+ { flesh => 1,
+ flesh_fields => { 'acp' => ['call_number'] }
+ }
+ ]
+ );
+
+ return $e->event unless
+ $e->allowed('CREATE_COPY_NOTE', $copy->call_number->owning_lib);
+
+ $note->create_date('now');
+ $note->creator($e->requestor->id);
+ $note->pub( ($U->is_true($note->pub)) ? 't' : 'f' );
+ $note->clear_id;
+
+ $e->create_asset_copy_note($note) or return $e->event;
+ $e->commit;
+ return $note->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_copy_note',
+ api_name => 'open-ils.circ.copy_note.delete',
+ signature => q/
+ Deletes an existing copy note
+ @param authtoken The login session key
+ @param noteid The id of the note to delete
+ @return 1 on success - Event otherwise.
+ /);
+sub delete_copy_note {
+ my( $self, $conn, $authtoken, $noteid ) = @_;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+
+ my $note = $e->retrieve_asset_copy_note([
+ $noteid,
+ { flesh => 2,
+ flesh_fields => {
+ 'acpn' => [ 'owning_copy' ],
+ 'acp' => [ 'call_number' ],
+ }
+ }
+ ]) or return $e->die_event;
+
+ if( $note->creator ne $e->requestor->id ) {
+ return $e->die_event unless
+ $e->allowed('DELETE_COPY_NOTE', $note->owning_copy->call_number->owning_lib);
+ }
+
+ $e->delete_asset_copy_note($note) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'age_hold_rules',
+ api_name => 'open-ils.circ.config.rules.age_hold_protect.retrieve.all',
+);
+
+sub age_hold_rules {
+ my( $self, $conn ) = @_;
+ return new_editor()->retrieve_all_config_rules_age_hold_protect();
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'copy_details_barcode',
+ authoritative => 1,
+ api_name => 'open-ils.circ.copy_details.retrieve.barcode');
+sub copy_details_barcode {
+ my( $self, $conn, $auth, $barcode ) = @_;
+ my $e = new_editor();
+ my $cid = $e->search_asset_copy({barcode=>$barcode, deleted=>'f'}, {idlist=>1})->[0];
+ return $e->event unless $cid;
+ return copy_details( $self, $conn, $auth, $cid );
+}
+
+
+__PACKAGE__->register_method(
+ method => 'copy_details',
+ api_name => 'open-ils.circ.copy_details.retrieve');
+
+sub copy_details {
+ my( $self, $conn, $auth, $copy_id ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ my $flesh = { flesh => 1 };
+
+ my $copy = $e->retrieve_asset_copy(
+ [
+ $copy_id,
+ {
+ flesh => 2,
+ flesh_fields => {
+ acp => ['call_number'],
+ acn => ['record']
+ }
+ }
+ ]) or return $e->event;
+
+
+ # De-flesh the copy for backwards compatibility
+ my $mvr;
+ my $vol = $copy->call_number;
+ if( ref $vol ) {
+ $copy->call_number($vol->id);
+ my $record = $vol->record;
+ if( ref $record ) {
+ $vol->record($record->id);
+ $mvr = $U->record_to_mvr($record);
+ }
+ }
+
+
+ my $hold = $e->search_action_hold_request(
+ {
+ current_copy => $copy_id,
+ capture_time => { "!=" => undef },
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ )->[0];
+
+ OpenILS::Application::Circ::Holds::flesh_hold_transits([$hold]) if $hold;
+
+ my $transit = $e->search_action_transit_copy(
+ { target_copy => $copy_id, dest_recv_time => undef } )->[0];
+
+ # find the latest circ, open or closed
+ my $circ = $e->search_action_circulation(
+ [
+ { target_copy => $copy_id },
+ {
+ flesh => 1,
+ flesh_fields => {
+ circ => [
+ 'workstation',
+ 'checkin_workstation',
+ 'duration_rule',
+ 'max_fine_rule',
+ 'recurring_fine_rule'
+ ]
+ },
+ order_by => { circ => 'xact_start desc' },
+ limit => 1
+ }
+ ]
+ )->[0];
+
+
+ return {
+ copy => $copy,
+ hold => $hold,
+ transit => $transit,
+ circ => $circ,
+ volume => $vol,
+ mvr => $mvr,
+ };
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_damaged',
+ signature => q/
+ Changes the status of a copy to "damaged". Requires MARK_ITEM_DAMAGED permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as damaged
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_missing',
+ signature => q/
+ Changes the status of a copy to "missing". Requires MARK_ITEM_MISSING permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as missing
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_bindery',
+ signature => q/
+ Changes the status of a copy to "bindery". Requires MARK_ITEM_BINDERY permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as bindery
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_on_order',
+ signature => q/
+ Changes the status of a copy to "on order". Requires MARK_ITEM_ON_ORDER permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as on order
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_ill',
+ signature => q/
+ Changes the status of a copy to "inter-library loan". Requires MARK_ITEM_ILL permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as inter-library loan
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_cataloging',
+ signature => q/
+ Changes the status of a copy to "cataloging". Requires MARK_ITEM_CATALOGING permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as cataloging
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_reserves',
+ signature => q/
+ Changes the status of a copy to "reserves". Requires MARK_ITEM_RESERVES permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as reserves
+ @return 1 on success - Event otherwise.
+ /
+);
+__PACKAGE__->register_method(
+ method => 'mark_item',
+ api_name => 'open-ils.circ.mark_item_discard',
+ signature => q/
+ Changes the status of a copy to "discard". Requires MARK_ITEM_DISCARD permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as discard
+ @return 1 on success - Event otherwise.
+ /
+);
+
+sub mark_item {
+ my( $self, $conn, $auth, $copy_id, $args ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact =>1);
+ return $e->die_event unless $e->checkauth;
+ $args ||= {};
+
+ my $copy = $e->retrieve_asset_copy([
+ $copy_id,
+ {flesh => 1, flesh_fields => {'acp' => ['call_number']}}])
+ or return $e->die_event;
+
+ my $owning_lib =
+ ($copy->call_number->id == OILS_PRECAT_CALL_NUMBER) ?
+ $copy->circ_lib : $copy->call_number->owning_lib;
+
+ return $e->die_event unless $e->allowed('UPDATE_COPY', $owning_lib);
+
+
+ my $perm = 'MARK_ITEM_MISSING';
+ my $stat = OILS_COPY_STATUS_MISSING;
+
+ if( $self->api_name =~ /damaged/ ) {
+ $perm = 'MARK_ITEM_DAMAGED';
+ $stat = OILS_COPY_STATUS_DAMAGED;
+ my $evt = handle_mark_damaged($e, $copy, $owning_lib, $args);
+ return $evt if $evt;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'damaged', $copy, $owning_lib);
+
+ } elsif ( $self->api_name =~ /bindery/ ) {
+ $perm = 'MARK_ITEM_BINDERY';
+ $stat = OILS_COPY_STATUS_BINDERY;
+ } elsif ( $self->api_name =~ /on_order/ ) {
+ $perm = 'MARK_ITEM_ON_ORDER';
+ $stat = OILS_COPY_STATUS_ON_ORDER;
+ } elsif ( $self->api_name =~ /ill/ ) {
+ $perm = 'MARK_ITEM_ILL';
+ $stat = OILS_COPY_STATUS_ILL;
+ } elsif ( $self->api_name =~ /cataloging/ ) {
+ $perm = 'MARK_ITEM_CATALOGING';
+ $stat = OILS_COPY_STATUS_CATALOGING;
+ } elsif ( $self->api_name =~ /reserves/ ) {
+ $perm = 'MARK_ITEM_RESERVES';
+ $stat = OILS_COPY_STATUS_RESERVES;
+ } elsif ( $self->api_name =~ /discard/ ) {
+ $perm = 'MARK_ITEM_DISCARD';
+ $stat = OILS_COPY_STATUS_DISCARD;
+ }
+
+
+ $copy->status($stat);
+ $copy->edit_date('now');
+ $copy->editor($e->requestor->id);
+
+ $e->update_asset_copy($copy) or return $e->die_event;
+
+ my $holds = $e->search_action_hold_request(
+ {
+ current_copy => $copy->id,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ );
+
+ $e->commit;
+
+ $logger->debug("resetting holds that target the marked copy");
+ OpenILS::Application::Circ::Holds->_reset_hold($e->requestor, $_) for @$holds;
+
+ return 1;
+}
+
+sub handle_mark_damaged {
+ my($e, $copy, $owning_lib, $args) = @_;
+
+ my $apply = $args->{apply_fines} || '';
+ return undef if $apply eq 'noapply';
+
+ my $new_amount = $args->{override_amount};
+ my $new_btype = $args->{override_btype};
+ my $new_note = $args->{override_note};
+
+ # grab the last circulation
+ my $circ = $e->search_action_circulation([
+ { target_copy => $copy->id},
+ { limit => 1,
+ order_by => {circ => "xact_start DESC"},
+ flesh => 2,
+ flesh_fields => {circ => ['target_copy', 'usr'], au => ['card']}
+ }
+ ])->[0];
+
+ return undef unless $circ;
+
+ my $charge_price = $U->ou_ancestor_setting_value(
+ $owning_lib, 'circ.charge_on_damaged', $e);
+
+ my $proc_fee = $U->ou_ancestor_setting_value(
+ $owning_lib, 'circ.damaged_item_processing_fee', $e) || 0;
+
+ my $void_overdue = $U->ou_ancestor_setting_value(
+ $owning_lib, 'circ.damaged.void_ovedue', $e) || 0;
+
+ return undef unless $charge_price or $proc_fee;
+
+ my $copy_price = ($charge_price) ? $U->get_copy_price($e, $copy) : 0;
+ my $total = $copy_price + $proc_fee;
+
+ if($apply) {
+
+ if($new_amount and $new_btype) {
+
+ # Allow staff to override the amount to charge for a damaged item
+ # Consider the case where the item is only partially damaged
+ # This value is meant to take the place of the item price and
+ # optional processing fee.
+
+ my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
+ $e, $new_amount, $new_btype, 'Damaged Item Override', $circ->id, $new_note);
+ return $evt if $evt;
+
+ } else {
+
+ if($charge_price and $copy_price) {
+ my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
+ $e, $copy_price, 7, 'Damaged Item', $circ->id);
+ return $evt if $evt;
+ }
+
+ if($proc_fee) {
+ my $evt = OpenILS::Application::Circ::CircCommon->create_bill(
+ $e, $proc_fee, 8, 'Damaged Item Processing Fee', $circ->id);
+ return $evt if $evt;
+ }
+ }
+
+ # the assumption is that you would not void the overdues unless you
+ # were also charging for the item and/or applying a processing fee
+ if($void_overdue) {
+ my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($e, $circ);
+ return $evt if $evt;
+ }
+
+ my $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($e, $circ->id);
+ return $evt if $evt;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'checkout.damaged', $circ, $circ->circ_lib);
+
+ return undef;
+
+ } else {
+ return OpenILS::Event->new('DAMAGE_CHARGE',
+ payload => {
+ circ => $circ,
+ charge => $total
+ }
+ );
+ }
+}
+
+
+
+# ----------------------------------------------------------------------
+__PACKAGE__->register_method(
+ method => 'mark_item_missing_pieces',
+ api_name => 'open-ils.circ.mark_item_missing_pieces',
+ signature => q/
+ Changes the status of a copy to "damaged" or to a custom status based on the
+ circ.missing_pieces.copy_status org unit setting. Requires MARK_ITEM_MISSING_PIECES
+ permission.
+ @param authtoken The login session key
+ @param copy_id The ID of the copy to mark as damaged
+ @return Success event with circ and copy objects in the payload, or error Event otherwise.
+ /
+);
+
+sub mark_item_missing_pieces {
+ my( $self, $conn, $auth, $copy_id, $args ) = @_;
+ ### FIXME: We're starting a transaction here, but we're doing a lot of things outside of the transaction
+ my $e = new_editor(authtoken=>$auth, xact =>1);
+ return $e->die_event unless $e->checkauth;
+ $args ||= {};
+
+ my $copy = $e->retrieve_asset_copy([
+ $copy_id,
+ {flesh => 1, flesh_fields => {'acp' => ['call_number']}}])
+ or return $e->die_event;
+
+ my $owning_lib =
+ ($copy->call_number->id == OILS_PRECAT_CALL_NUMBER) ?
+ $copy->circ_lib : $copy->call_number->owning_lib;
+
+ return $e->die_event unless $e->allowed('MARK_ITEM_MISSING_PIECES', $owning_lib);
+
+ #### grab the last circulation
+ my $circ = $e->search_action_circulation([
+ { target_copy => $copy->id},
+ { limit => 1,
+ order_by => {circ => "xact_start DESC"}
+ }
+ ])->[0];
+
+ if ($circ) {
+ if (! $circ->checkin_time) { # if circ active, attempt renew
+ my ($res) = $self->method_lookup('open-ils.circ.renew')->run($e->authtoken,{'copy_id'=>$circ->target_copy});
+ if (ref $res ne 'ARRAY') { $res = [ $res ]; }
+ if ( $res->[0]->{textcode} eq 'SUCCESS' ) {
+ $circ = $res->[0]->{payload}{'circ'};
+ $circ->target_copy( $copy->id );
+ $logger->info('open-ils.circ.mark_item_missing_pieces: successful renewal');
+ } else {
+ $logger->info('open-ils.circ.mark_item_missing_pieces: non-successful renewal');
+ }
+ } else {
+
+ my $co_params = {
+ 'copy_id'=>$circ->target_copy,
+ 'patron_id'=>$circ->usr,
+ 'skip_deposit_fee'=>1,
+ 'skip_rental_fee'=>1
+ };
+
+ if ($U->ou_ancestor_setting_value($e->requestor->ws_ou, 'circ.block_renews_for_holds')) {
+
+ my ($hold, undef, $retarget) = $holdcode->find_nearest_permitted_hold(
+ $e, $copy, $e->requestor, 1 );
+
+ if ($hold) { # needed for hold? then due now
+
+ $logger->info('open-ils.circ.mark_item_missing_pieces: item needed for hold, shortening due date');
+ my $due_date = DateTime->now(time_zone => 'local');
+ $co_params->{'due_date'} = cleanse_ISO8601( $due_date->strftime('%FT%T%z') );
+ } else {
+ $logger->info('open-ils.circ.mark_item_missing_pieces: item not needed for hold');
+ }
+ }
+
+ my ($res) = $self->method_lookup('open-ils.circ.checkout.full.override')->run($e->authtoken,$co_params);
+ if (ref $res ne 'ARRAY') { $res = [ $res ]; }
+ if ( $res->[0]->{textcode} eq 'SUCCESS' ) {
+ $logger->info('open-ils.circ.mark_item_missing_pieces: successful checkout');
+ $circ = $res->[0]->{payload}{'circ'};
+ } else {
+ $logger->info('open-ils.circ.mark_item_missing_pieces: non-successful checkout');
+ $e->rollback;
+ return $res;
+ }
+ }
+ } else {
+ $logger->info('open-ils.circ.mark_item_missing_pieces: no previous checkout');
+ $e->rollback;
+ return OpenILS::Event->new('ACTION_CIRCULATION_NOT_FOUND',{'copy'=>$copy});
+ }
+
+ ### Update the item status
+
+ my $custom_stat = $U->ou_ancestor_setting_value(
+ $owning_lib, 'circ.missing_pieces.copy_status', $e);
+ my $stat = $custom_stat || OILS_COPY_STATUS_DAMAGED;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'missing_pieces', $copy, $owning_lib);
+
+ $copy->status($stat);
+ $copy->edit_date('now');
+ $copy->editor($e->requestor->id);
+
+ $e->update_asset_copy($copy) or return $e->die_event;
+
+ my $holds = $e->search_action_hold_request(
+ {
+ current_copy => $copy->id,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ );
+
+ $logger->debug("resetting holds that target the marked copy");
+ OpenILS::Application::Circ::Holds->_reset_hold($e->requestor, $_) for @$holds;
+
+ if ($e->commit) {
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'circ.missing_pieces', $circ, $circ->circ_lib);
+
+ return OpenILS::Event->new('SUCCESS',
+ payload => {
+ circ => $circ,
+ copy => $copy,
+ slip => $U->fire_object_event(undef, 'circ.format.missing_pieces.slip.print', $circ, $circ->circ_lib),
+ letter => $U->fire_object_event(undef, 'circ.format.missing_pieces.letter.print', $circ, $circ->circ_lib)
+ }
+ );
+
+ } else {
+ return $e->die_event;
+ }
+}
+
+
+
+
+
+# ----------------------------------------------------------------------
+__PACKAGE__->register_method(
+ method => 'magic_fetch',
+ api_name => 'open-ils.agent.fetch'
+);
+
+my @FETCH_ALLOWED = qw/ aou aout acp acn bre /;
+
+sub magic_fetch {
+ my( $self, $conn, $auth, $args ) = @_;
+ my $e = new_editor( authtoken => $auth );
+ return $e->event unless $e->checkauth;
+
+ my $hint = $$args{hint};
+ my $id = $$args{id};
+
+ # Is the call allowed to fetch this type of object?
+ return undef unless grep { $_ eq $hint } @FETCH_ALLOWED;
+
+ # Find the class the implements the given hint
+ my ($class) = grep {
+ $Fieldmapper::fieldmap->{$_}{hint} eq $hint } Fieldmapper->classes;
+
+ $class =~ s/Fieldmapper:://og;
+ $class =~ s/::/_/og;
+ my $method = "retrieve_$class";
+
+ my $obj = $e->$method($id) or return $e->event;
+ return $obj;
+}
+# ----------------------------------------------------------------------
+
+
+__PACKAGE__->register_method(
+ method => "fleshed_circ_retrieve",
+ authoritative => 1,
+ api_name => "open-ils.circ.fleshed.retrieve",);
+
+sub fleshed_circ_retrieve {
+ my( $self, $client, $id ) = @_;
+ my $e = new_editor();
+ my $circ = $e->retrieve_action_circulation(
+ [
+ $id,
+ {
+ flesh => 4,
+ flesh_fields => {
+ circ => [ qw/ target_copy / ],
+ acp => [ qw/ location status stat_cat_entry_copy_maps notes age_protect call_number / ],
+ ascecm => [ qw/ stat_cat stat_cat_entry / ],
+ acn => [ qw/ record / ],
+ }
+ }
+ ]
+ ) or return $e->event;
+
+ my $copy = $circ->target_copy;
+ my $vol = $copy->call_number;
+ my $rec = $circ->target_copy->call_number->record;
+
+ $vol->record($rec->id);
+ $copy->call_number($vol->id);
+ $circ->target_copy($copy->id);
+
+ my $mvr;
+
+ if( $rec->id == OILS_PRECAT_RECORD ) {
+ $rec = undef;
+ $vol = undef;
+ } else {
+ $mvr = $U->record_to_mvr($rec);
+ $rec->marc(''); # drop the bulky marc data
+ }
+
+ return {
+ circ => $circ,
+ copy => $copy,
+ volume => $vol,
+ record => $rec,
+ mvr => $mvr,
+ };
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "test_batch_circ_events",
+ api_name => "open-ils.circ.trigger_event_by_def_and_barcode.fire"
+);
+
+# method for testing the behavior of a given event definition
+sub test_batch_circ_events {
+ my($self, $conn, $auth, $event_def, $barcode) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
+
+ my $copy = $e->search_asset_copy({barcode => $barcode, deleted => 'f'})->[0]
+ or return $e->event;
+
+ my $circ = $e->search_action_circulation(
+ {target_copy => $copy->id, checkin_time => undef})->[0]
+ or return $e->event;
+
+ return undef unless $circ;
+
+ return $U->fire_object_event($event_def, undef, $circ, $e->requestor->ws_ou)
+}
+
+
+__PACKAGE__->register_method(
+ method => "fire_circ_events",
+ api_name => "open-ils.circ.fire_circ_trigger_events",
+ signature => q/
+ General event def runner for circ objects. If no event def ID
+ is provided, the hook will be used to find the best event_def
+ match based on the context org unit
+ /
+);
+
+__PACKAGE__->register_method(
+ method => "fire_circ_events",
+ api_name => "open-ils.circ.fire_hold_trigger_events",
+ signature => q/
+ General event def runner for hold objects. If no event def ID
+ is provided, the hook will be used to find the best event_def
+ match based on the context org unit
+ /
+);
+
+__PACKAGE__->register_method(
+ method => "fire_circ_events",
+ api_name => "open-ils.circ.fire_user_trigger_events",
+ signature => q/
+ General event def runner for user objects. If no event def ID
+ is provided, the hook will be used to find the best event_def
+ match based on the context org unit
+ /
+);
+
+
+sub fire_circ_events {
+ my($self, $conn, $auth, $org_id, $event_def, $hook, $granularity, $target_ids, $user_data) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->event unless $e->checkauth;
+
+ my $targets;
+
+ if($self->api_name =~ /hold/) {
+ return $e->event unless $e->allowed('VIEW_HOLD', $org_id);
+ $targets = $e->batch_retrieve_action_hold_request($target_ids);
+ } elsif($self->api_name =~ /user/) {
+ return $e->event unless $e->allowed('VIEW_USER', $org_id);
+ $targets = $e->batch_retrieve_actor_user($target_ids);
+ } else {
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS', $org_id);
+ $targets = $e->batch_retrieve_action_circulation($target_ids);
+ }
+ $e->rollback; # FIXME using transaction because of pgpool/slony setups, but not
+ # simply making this method authoritative because of weirdness
+ # with transaction handling in A/T code that causes rollback
+ # failure down the line if handling many targets
+
+ return undef unless @$targets;
+ return $U->fire_object_event($event_def, $hook, $targets, $org_id, $granularity, $user_data);
+}
+
+__PACKAGE__->register_method(
+ method => "user_payments_list",
+ api_name => "open-ils.circ.user_payments.filtered.batch",
+ stream => 1,
+ signature => {
+ desc => q/Returns a fleshed, date-limited set of all payments a user
+ has made. By default, ordered by payment date. Optionally
+ ordered by other columns in the top-level "mp" object/,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'User ID', type => 'number'},
+ {desc => 'Order by column(s), optional. Array of "mp" class columns', type => 'array'}
+ ],
+ return => {desc => q/List of "mp" objects, fleshed with the billable transaction
+ and the related fully-realized payment object (e.g money.cash_payment)/}
+ }
+);
+
+sub user_payments_list {
+ my($self, $conn, $auth, $user_id, $start_date, $end_date, $order_by) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS', $user->home_ou);
+
+ $order_by ||= ['payment_ts'];
+
+ # all payments by user, between start_date and end_date
+ my $payments = $e->json_query({
+ select => {mp => ['id']},
+ from => {
+ mp => {
+ mbt => {
+ fkey => 'xact', field => 'id'}
+ }
+ },
+ where => {
+ '+mbt' => {usr => $user_id},
+ '+mp' => {payment_ts => {between => [$start_date, $end_date]}}
+ },
+ order_by => {mp => $order_by}
+ });
+
+ for my $payment_id (@$payments) {
+ my $payment = $e->retrieve_money_payment([
+ $payment_id->{id},
+ {
+ flesh => 2,
+ flesh_fields => {
+ mp => [
+ 'xact',
+ 'cash_payment',
+ 'credit_card_payment',
+ 'credit_payment',
+ 'check_payment',
+ 'work_payment',
+ 'forgive_payment',
+ 'goods_payment'
+ ],
+ mbt => [
+ 'circulation',
+ 'grocery',
+ 'reservation'
+ ]
+ }
+ }
+ ]);
+ $conn->respond($payment);
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_circ_chain",
+ api_name => "open-ils.circ.renewal_chain.retrieve_by_circ",
+ stream => 1,
+ signature => {
+ desc => q/Given a circulation, this returns all circulation objects
+ that are part of the same chain of renewals./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Circ ID', type => 'number'},
+ ],
+ return => {desc => q/List of circ objects, orderd by oldest circ first/}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_circ_chain",
+ api_name => "open-ils.circ.renewal_chain.retrieve_by_circ.summary",
+ signature => {
+ desc => q/Given a circulation, this returns a summary of the circulation objects
+ that are part of the same chain of renewals./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Circ ID', type => 'number'},
+ ],
+ return => {desc => q/Circulation Chain Summary/}
+ }
+);
+
+sub retrieve_circ_chain {
+ my($self, $conn, $auth, $circ_id) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
+
+ if($self->api_name =~ /summary/) {
+ return $U->create_circ_chain_summary($e, $circ_id);
+
+ } else {
+
+ my $chain = $e->json_query({from => ['action.circ_chain', $circ_id]});
+
+ for my $circ_info (@$chain) {
+ my $circ = Fieldmapper::action::circulation->new;
+ $circ->$_($circ_info->{$_}) for keys %$circ_info;
+ $conn->respond($circ);
+ }
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_prev_circ_chain",
+ api_name => "open-ils.circ.prev_renewal_chain.retrieve_by_circ",
+ stream => 1,
+ signature => {
+ desc => q/Given a circulation, this returns all circulation objects
+ that are part of the previous chain of renewals./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Circ ID', type => 'number'},
+ ],
+ return => {desc => q/List of circ objects, orderd by oldest circ first/}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_prev_circ_chain",
+ api_name => "open-ils.circ.prev_renewal_chain.retrieve_by_circ.summary",
+ signature => {
+ desc => q/Given a circulation, this returns a summary of the circulation objects
+ that are part of the previous chain of renewals./,
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Circ ID', type => 'number'},
+ ],
+ return => {desc => q/Object containing Circulation Chain Summary and User Id/}
+ }
+);
+
+sub retrieve_prev_circ_chain {
+ my($self, $conn, $auth, $circ_id) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS');
+
+ if($self->api_name =~ /summary/) {
+ my $first_circ = $e->json_query({from => ['action.circ_chain', $circ_id]})->[0];
+ my $target_copy = $$first_circ{'target_copy'};
+ my $usr = $$first_circ{'usr'};
+ my $last_circ_from_prev_chain = $e->json_query({
+ 'select' => { 'circ' => ['id','usr'] },
+ 'from' => 'circ',
+ 'where' => {
+ target_copy => $target_copy,
+ xact_start => { '<' => $$first_circ{'xact_start'} }
+ },
+ 'order_by' => [{ 'class'=>'circ', 'field'=>'xact_start', 'direction'=>'desc' }],
+ 'limit' => 1
+ })->[0];
+ return undef unless $last_circ_from_prev_chain;
+ return undef unless $$last_circ_from_prev_chain{'id'};
+ my $sum = $e->json_query({from => ['action.summarize_circ_chain', $$last_circ_from_prev_chain{'id'}]})->[0];
+ return undef unless $sum;
+ my $obj = Fieldmapper::action::circ_chain_summary->new;
+ $obj->$_($sum->{$_}) for keys %$sum;
+ return { 'summary' => $obj, 'usr' => $$last_circ_from_prev_chain{'usr'} };
+
+ } else {
+
+ my $first_circ = $e->json_query({from => ['action.circ_chain', $circ_id]})->[0];
+ my $target_copy = $$first_circ{'target_copy'};
+ my $last_circ_from_prev_chain = $e->json_query({
+ 'select' => { 'circ' => ['id'] },
+ 'from' => 'circ',
+ 'where' => {
+ target_copy => $target_copy,
+ xact_start => { '<' => $$first_circ{'xact_start'} }
+ },
+ 'order_by' => [{ 'class'=>'circ', 'field'=>'xact_start', 'direction'=>'desc' }],
+ 'limit' => 1
+ })->[0];
+ return undef unless $last_circ_from_prev_chain;
+ return undef unless $$last_circ_from_prev_chain{'id'};
+ my $chain = $e->json_query({from => ['action.circ_chain', $$last_circ_from_prev_chain{'id'}]});
+
+ for my $circ_info (@$chain) {
+ my $circ = Fieldmapper::action::circulation->new;
+ $circ->$_($circ_info->{$_}) for keys %$circ_info;
+ $conn->respond($circ);
+ }
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_copy_due_date",
+ api_name => "open-ils.circ.copy.due_date.retrieve",
+ signature => {
+ desc => q/
+ Given a copy ID, returns the due date for the copy if it's
+ currently circulating. Otherwise, returns null. Note, this is a public
+ method requiring no authentication. Only the due date is exposed.
+ /,
+ params => [
+ {desc => 'Copy ID', type => 'number'}
+ ],
+ return => {desc => q/
+ Due date (ISO date stamp) if the copy is circulating, null otherwise.
+ /}
+ }
+);
+
+sub get_copy_due_date {
+ my($self, $conn, $copy_id) = @_;
+ my $e = new_editor();
+
+ my $circ = $e->json_query({
+ select => {circ => ['due_date']},
+ from => 'circ',
+ where => {
+ target_copy => $copy_id,
+ checkin_time => undef,
+ '-or' => [
+ {stop_fines => ["MAXFINES","LONGOVERDUE"]},
+ {stop_fines => undef}
+ ],
+ },
+ limit => 1
+ })->[0] or return undef;
+
+ return $circ->{due_date};
+}
+
+
+
+
+
+# {"select":{"acp":["id"],"circ":[{"aggregate":true,"transform":"count","alias":"count","column":"id"}]},"from":{"acp":{"circ":{"field":"target_copy","fkey":"id","type":"left"},"acn"{"field":"id","fkey":"call_number"}}},"where":{"+acn":{"record":200057}}
+
+
+1;
--- /dev/null
+package OpenILS::Application::Circ::CircCommon;
+use strict; use warnings;
+use DateTime;
+use DateTime::Format::ISO8601;
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils qw/:datetime/;
+use OpenILS::Event;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Const qw/:const/;
+
+my $U = "OpenILS::Application::AppUtils";
+
+# -----------------------------------------------------------------
+# Do not publish methods here. This code is shared across apps.
+# -----------------------------------------------------------------
+
+
+# -----------------------------------------------------------------
+# Voids overdue fines on the given circ. if a backdate is
+# provided, then we only void back to the backdate
+# -----------------------------------------------------------------
+sub void_overdues {
+ my($class, $e, $circ, $backdate, $note) = @_;
+
+ my $bill_search = {
+ xact => $circ->id,
+ btype => 1
+ };
+
+ if( $backdate ) {
+ # ------------------------------------------------------------------
+ # Fines for overdue materials are assessed up to, but not including,
+ # one fine interval after the fines are applicable. Here, we add
+ # one fine interval to the backdate to ensure that we are not
+ # voiding fines that were applicable before the backdate.
+ # ------------------------------------------------------------------
+
+ # if there is a raw time component (e.g. from postgres),
+ # turn it into an interval that interval_to_seconds can parse
+ my $duration = $circ->fine_interval;
+ $duration =~ s/(\d{2}):(\d{2}):(\d{2})/$1 h $2 m $3 s/o;
+ my $interval = OpenSRF::Utils->interval_to_seconds($duration);
+
+ my $date = DateTime::Format::ISO8601->parse_datetime($backdate);
+ $backdate = $U->epoch2ISO8601($date->epoch + $interval);
+ $logger->info("applying backdate $backdate in overdue voiding");
+ $$bill_search{billing_ts} = {'>=' => $backdate};
+ }
+
+ my $bills = $e->search_money_billing($bill_search);
+
+ for my $bill (@$bills) {
+ next if $U->is_true($bill->voided);
+ $logger->info("voiding overdue bill ".$bill->id);
+ $bill->voided('t');
+ $bill->void_time('now');
+ $bill->voider($e->requestor->id);
+ my $n = ($bill->note) ? sprintf("%s\n", $bill->note) : "";
+ $bill->note(sprintf("$n%s", ($note) ? $note : "System: VOIDED FOR BACKDATE"));
+ $e->update_money_billing($bill) or return $e->die_event;
+ }
+
+ return undef;
+}
+
+
+sub reopen_xact {
+ my($class, $e, $xactid) = @_;
+
+ # -----------------------------------------------------------------
+ # make sure the transaction is not closed
+ my $xact = $e->retrieve_money_billable_transaction($xactid)
+ or return $e->die_event;
+
+ if( $xact->xact_finish ) {
+ my ($mbts) = $U->fetch_mbts($xactid, $e);
+ if( $mbts->balance_owed != 0 ) {
+ $logger->info("* re-opening xact $xactid, orig xact_finish is ".$xact->xact_finish);
+ $xact->clear_xact_finish;
+ $e->update_money_billable_transaction($xact)
+ or return $e->die_event;
+ }
+ }
+
+ return undef;
+}
+
+
+sub create_bill {
+ my($class, $e, $amount, $btype, $type, $xactid, $note) = @_;
+
+ $logger->info("The system is charging $amount [$type] on xact $xactid");
+ $note ||= 'SYSTEM GENERATED';
+
+ # -----------------------------------------------------------------
+ # now create the billing
+ my $bill = Fieldmapper::money::billing->new;
+ $bill->xact($xactid);
+ $bill->amount($amount);
+ $bill->billing_type($type);
+ $bill->btype($btype);
+ $bill->note($note);
+ $e->create_money_billing($bill) or return $e->die_event;
+
+ return undef;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Circ::Circulate;
+use strict; use warnings;
+use base 'OpenILS::Application';
+use OpenSRF::EX qw(:try);
+use OpenSRF::AppSession;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Const qw/:const/;
+use OpenILS::Application::AppUtils;
+use DateTime;
+my $U = "OpenILS::Application::AppUtils";
+
+my %scripts;
+my $script_libs;
+my $legacy_script_support = 0;
+my $booking_status;
+
+sub determine_booking_status {
+ unless (defined $booking_status) {
+ my $ses = create OpenSRF::AppSession("router");
+ $booking_status = grep {$_ eq "open-ils.booking"} @{
+ $ses->request("opensrf.router.info.class.list")->gather(1)
+ };
+ $ses->disconnect;
+ $logger->info("booking status: " . ($booking_status ? "on" : "off"));
+ }
+
+ return $booking_status;
+}
+
+
+my $MK_ENV_FLESH = {
+ flesh => 2,
+ flesh_fields => {acp => ['call_number'], acn => ['record']}
+};
+
+sub initialize {
+
+ my $self = shift;
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my @pfx2 = ( "apps", "open-ils.circ","app_settings" );
+
+ $legacy_script_support = $conf->config_value(@pfx2, 'legacy_script_support');
+ $legacy_script_support = ($legacy_script_support and $legacy_script_support =~ /true/i);
+
+ my $lb = $conf->config_value( @pfx2, 'script_path' );
+ $lb = [ $lb ] unless ref($lb);
+ $script_libs = $lb;
+
+ return unless $legacy_script_support;
+
+ my @pfx = ( @pfx2, "scripts" );
+ my $p = $conf->config_value( @pfx, 'circ_permit_patron' );
+ my $c = $conf->config_value( @pfx, 'circ_permit_copy' );
+ my $d = $conf->config_value( @pfx, 'circ_duration' );
+ my $f = $conf->config_value( @pfx, 'circ_recurring_fines' );
+ my $m = $conf->config_value( @pfx, 'circ_max_fines' );
+ my $pr = $conf->config_value( @pfx, 'circ_permit_renew' );
+
+ $logger->error( "Missing circ script(s)" )
+ unless( $p and $c and $d and $f and $m and $pr );
+
+ $scripts{circ_permit_patron} = $p;
+ $scripts{circ_permit_copy} = $c;
+ $scripts{circ_duration} = $d;
+ $scripts{circ_recurring_fines} = $f;
+ $scripts{circ_max_fines} = $m;
+ $scripts{circ_permit_renew} = $pr;
+
+ $logger->debug(
+ "circulator: Loaded rules scripts for circ: " .
+ "circ permit patron = $p, ".
+ "circ permit copy = $c, ".
+ "circ duration = $d, ".
+ "circ recurring fines = $f, " .
+ "circ max fines = $m, ".
+ "circ renew permit = $pr. ".
+ "lib paths = @$lb. ".
+ "legacy script support = ". ($legacy_script_support) ? 'yes' : 'no'
+ );
+}
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkout.permit",
+ notes => q/
+ Determines if the given checkout can occur
+ @param authtoken The login session key
+ @param params A trailing hash of named params including
+ barcode : The copy barcode,
+ patron : The patron the checkout is occurring for,
+ renew : true or false - whether or not this is a renewal
+ @return The event that occurred during the permit check.
+ /);
+
+
+__PACKAGE__->register_method (
+ method => 'run_method',
+ api_name => 'open-ils.circ.checkout.permit.override',
+ signature => q/@see open-ils.circ.checkout.permit/,
+);
+
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkout",
+ notes => q/
+ Checks out an item
+ @param authtoken The login session key
+ @param params A named hash of params including:
+ copy The copy object
+ barcode If no copy is provided, the copy is retrieved via barcode
+ copyid If no copy or barcode is provide, the copy id will be use
+ patron The patron's id
+ noncat True if this is a circulation for a non-cataloted item
+ noncat_type The non-cataloged type id
+ noncat_circ_lib The location for the noncat circ.
+ precat The item has yet to be cataloged
+ dummy_title The temporary title of the pre-cataloded item
+ dummy_author The temporary authr of the pre-cataloded item
+ Default is the home org of the staff member
+ @return The SUCCESS event on success, any other event depending on the error
+ /);
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkin",
+ argc => 2,
+ signature => q/
+ Generic super-method for handling all copies
+ @param authtoken The login session key
+ @param params Hash of named parameters including:
+ barcode - The copy barcode
+ force - If true, copies in bad statuses will be checked in and give good statuses
+ noop - don't capture holds or put items into transit
+ void_overdues - void all overdues for the circulation (aka amnesty)
+ ...
+ /
+);
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkin.override",
+ signature => q/@see open-ils.circ.checkin/
+);
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.renew.override",
+ signature => q/@see open-ils.circ.renew/,
+);
+
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.renew",
+ notes => <<" NOTES");
+ PARAMS( authtoken, circ => circ_id );
+ open-ils.circ.renew(login_session, circ_object);
+ Renews the provided circulation. login_session is the requestor of the
+ renewal and if the logged in user is not the same as circ->usr, then
+ the logged in user must have RENEW_CIRC permissions.
+ NOTES
+
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkout.full"
+);
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkout.full.override"
+);
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.reservation.pickup"
+);
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.reservation.return"
+);
+__PACKAGE__->register_method(
+ method => "run_method",
+ api_name => "open-ils.circ.checkout.inspect",
+ desc => q/Returns the circ matrix test result and, on success, the rule set and matrix test object/
+);
+
+
+sub run_method {
+ my( $self, $conn, $auth, $args ) = @_;
+ translate_legacy_args($args);
+ my $api = $self->api_name;
+
+ my $circulator =
+ OpenILS::Application::Circ::Circulator->new($auth, %$args);
+
+ return circ_events($circulator) if $circulator->bail_out;
+
+ $circulator->use_booking(determine_booking_status());
+
+ # --------------------------------------------------------------------------
+ # First, check for a booking transit, as the barcode may not be a copy
+ # barcode, but a resource barcode, and nothing else in here will work
+ # --------------------------------------------------------------------------
+
+ if ($circulator->use_booking && (my $bc = $circulator->copy_barcode) && $api !~ /checkout|inspect/) { # do we have a barcode?
+ my $resources = $circulator->editor->search_booking_resource( { barcode => $bc } ); # any resources by this barcode?
+ if (@$resources) { # yes!
+
+ my $res_id_list = [ map { $_->id } @$resources ];
+ my $transit = $circulator->editor->search_action_reservation_transit_copy(
+ [
+ { target_copy => $res_id_list, dest => $circulator->circ_lib, dest_recv_time => undef },
+ { order_by => { artc => 'source_send_time' }, limit => 1 }
+ ]
+ )->[0]; # Any transit for this barcode?
+
+ if ($transit) { # yes! unwrap it.
+
+ my $reservation = $circulator->editor->retrieve_booking_reservation( $transit->reservation );
+ my $res_type = $circulator->editor->retrieve_booking_resource_type( $reservation->target_resource_type );
+
+ my $success_event = new OpenILS::Event(
+ "SUCCESS", "payload" => {"reservation" => $reservation}
+ );
+ if ($U->is_true($res_type->catalog_item)) { # is there a copy to be had here?
+ if (my $copy = $circulator->editor->search_asset_copy([
+ { barcode => $bc, deleted => 'f' }, $MK_ENV_FLESH
+ ])->[0]) { # got a copy
+ $copy->status( $transit->copy_status );
+ $copy->editor($circulator->editor->requestor->id);
+ $copy->edit_date('now');
+ $circulator->editor->update_asset_copy($copy);
+ $success_event->{"payload"}->{"record"} =
+ $U->record_to_mvr($copy->call_number->record);
+ $copy->call_number($copy->call_number->id);
+ $success_event->{"payload"}->{"copy"} = $copy;
+ }
+ }
+
+ $transit->dest_recv_time('now');
+ $circulator->editor->update_action_reservation_transit_copy( $transit );
+
+ $circulator->editor->commit;
+ # Formerly this branch just stopped here. Argh!
+ $conn->respond_complete($success_event);
+ return;
+ }
+ }
+ }
+
+
+
+ # --------------------------------------------------------------------------
+ # Go ahead and load the script runner to make sure we have all
+ # of the objects we need
+ # --------------------------------------------------------------------------
+
+ if ($circulator->use_booking) {
+ $circulator->is_res_checkin($circulator->is_checkin(1))
+ if $api =~ /reservation.return/ or (
+ $api =~ /checkin/ and $circulator->seems_like_reservation()
+ );
+
+ $circulator->is_res_checkout(1) if $api =~ /reservation.pickup/;
+ }
+
+ $circulator->is_renewal(1) if $api =~ /renew/;
+ $circulator->is_checkin(1) if $api =~ /checkin/;
+
+ $circulator->mk_env();
+ $circulator->noop(1) if $circulator->claims_never_checked_out;
+
+ if($legacy_script_support and not $circulator->is_checkin) {
+ $circulator->mk_script_runner();
+ $circulator->legacy_script_support(1);
+ $circulator->circ_permit_patron($scripts{circ_permit_patron});
+ $circulator->circ_permit_copy($scripts{circ_permit_copy});
+ $circulator->circ_duration($scripts{circ_duration});
+ $circulator->circ_permit_renew($scripts{circ_permit_renew});
+ }
+ return circ_events($circulator) if $circulator->bail_out;
+
+
+ $circulator->override(1) if $api =~ /override/o;
+
+ if( $api =~ /checkout\.permit/ ) {
+ $circulator->do_permit();
+
+ } elsif( $api =~ /checkout.full/ ) {
+
+ # requesting a precat checkout implies that any required
+ # overrides have been performed. Go ahead and re-override.
+ $circulator->skip_permit_key(1);
+ $circulator->override(1) if $circulator->request_precat;
+ $circulator->do_permit();
+ $circulator->is_checkout(1);
+ unless( $circulator->bail_out ) {
+ $circulator->events([]);
+ $circulator->do_checkout();
+ }
+
+ } elsif( $circulator->is_res_checkout ) {
+ $circulator->do_reservation_pickup();
+
+ } elsif( $api =~ /inspect/ ) {
+ my $data = $circulator->do_inspect();
+ $circulator->editor->rollback;
+ return $data;
+
+ } elsif( $api =~ /checkout/ ) {
+ $circulator->is_checkout(1);
+ $circulator->do_checkout();
+
+ } elsif( $circulator->is_res_checkin ) {
+ $circulator->do_reservation_return();
+ $circulator->do_checkin() if ($circulator->copy());
+ } elsif( $api =~ /checkin/ ) {
+ $circulator->do_checkin();
+
+ } elsif( $api =~ /renew/ ) {
+ $circulator->is_renewal(1);
+ $circulator->do_renew();
+ }
+
+ if( $circulator->bail_out ) {
+
+ my @ee;
+ # make sure no success event accidentally slip in
+ $circulator->events(
+ [ grep { $_->{textcode} ne 'SUCCESS' } @{$circulator->events} ]);
+
+ # Log the events
+ my @e = @{$circulator->events};
+ push( @ee, $_->{textcode} ) for @e;
+ $logger->info("circulator: bailing out with events: " . (join ", ", @ee));
+
+ $circulator->editor->rollback;
+
+ } else {
+ $circulator->editor->commit;
+ }
+
+ $circulator->script_runner->cleanup if $circulator->script_runner;
+
+ $conn->respond_complete(circ_events($circulator));
+
+ unless($circulator->bail_out) {
+ $circulator->do_hold_notify($circulator->notify_hold)
+ if $circulator->notify_hold;
+ $circulator->retarget_holds if $circulator->retarget;
+ $circulator->append_reading_list;
+ $circulator->make_trigger_events;
+ }
+}
+
+sub circ_events {
+ my $circ = shift;
+ my @e = @{$circ->events};
+ # if we have multiple events, SUCCESS should not be one of them;
+ @e = grep { $_->{textcode} ne 'SUCCESS' } @e if @e > 1;
+ return (@e == 1) ? $e[0] : \@e;
+}
+
+
+sub translate_legacy_args {
+ my $args = shift;
+
+ if( $$args{barcode} ) {
+ $$args{copy_barcode} = $$args{barcode};
+ delete $$args{barcode};
+ }
+
+ if( $$args{copyid} ) {
+ $$args{copy_id} = $$args{copyid};
+ delete $$args{copyid};
+ }
+
+ if( $$args{patronid} ) {
+ $$args{patron_id} = $$args{patronid};
+ delete $$args{patronid};
+ }
+
+ if( $$args{patron} and !ref($$args{patron}) ) {
+ $$args{patron_id} = $$args{patron};
+ delete $$args{patron};
+ }
+
+
+ if( $$args{noncat} ) {
+ $$args{is_noncat} = $$args{noncat};
+ delete $$args{noncat};
+ }
+
+ if( $$args{precat} ) {
+ $$args{is_precat} = $$args{request_precat} = $$args{precat};
+ delete $$args{precat};
+ }
+}
+
+
+
+# --------------------------------------------------------------------------
+# This package actually manages all of the circulation logic
+# --------------------------------------------------------------------------
+package OpenILS::Application::Circ::Circulator;
+use strict; use warnings;
+use vars q/$AUTOLOAD/;
+use DateTime;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Cache;
+use Digest::MD5 qw(md5_hex);
+use DateTime::Format::ISO8601;
+use OpenILS::Utils::PermitHold;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::Circ::Holds;
+use OpenILS::Application::Circ::Transit;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Application::Circ::ScriptBuilder;
+use OpenILS::Const qw/:const/;
+use OpenILS::Utils::Penalty;
+use OpenILS::Application::Circ::CircCommon;
+use Time::Local;
+
+my $holdcode = "OpenILS::Application::Circ::Holds";
+my $transcode = "OpenILS::Application::Circ::Transit";
+my %user_groups;
+
+sub DESTROY { }
+
+
+# --------------------------------------------------------------------------
+# Add a pile of automagic getter/setter methods
+# --------------------------------------------------------------------------
+my @AUTOLOAD_FIELDS = qw/
+ notify_hold
+ remote_hold
+ backdate
+ reservation
+ copy
+ copy_id
+ copy_barcode
+ patron
+ patron_id
+ patron_barcode
+ script_runner
+ volume
+ title
+ is_renewal
+ is_checkout
+ is_res_checkout
+ is_precat
+ is_noncat
+ request_precat
+ is_checkin
+ is_res_checkin
+ noncat_type
+ editor
+ events
+ cache_handle
+ override
+ circ_permit_patron
+ circ_permit_copy
+ circ_duration
+ circ_recurring_fines
+ circ_max_fines
+ circ_permit_renew
+ circ
+ transit
+ hold
+ permit_key
+ noncat_circ_lib
+ noncat_count
+ checkout_time
+ dummy_title
+ dummy_author
+ dummy_isbn
+ circ_modifier
+ circ_lib
+ barcode
+ duration_level
+ recurring_fines_level
+ duration_rule
+ recurring_fines_rule
+ max_fine_rule
+ renewal_remaining
+ hard_due_date
+ due_date
+ fulfilled_holds
+ transit
+ checkin_changed
+ force
+ permit_override
+ pending_checkouts
+ cancelled_hold_transit
+ opac_renewal
+ phone_renewal
+ desk_renewal
+ sip_renewal
+ retarget
+ matrix_test_result
+ circ_matrix_matchpoint
+ circ_test_success
+ legacy_script_support
+ is_deposit
+ is_rental
+ deposit_billing
+ rental_billing
+ capture
+ noop
+ void_overdues
+ parent_circ
+ return_patron
+ claims_never_checked_out
+ skip_permit_key
+ skip_deposit_fee
+ skip_rental_fee
+ use_booking
+/;
+
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $type = ref($self) or die "$self is not an object";
+ my $data = shift;
+ my $name = $AUTOLOAD;
+ $name =~ s/.*://o;
+
+ unless (grep { $_ eq $name } @AUTOLOAD_FIELDS) {
+ $logger->error("circulator: $type: invalid autoload field: $name");
+ die "$type: invalid autoload field: $name\n"
+ }
+
+ {
+ no strict 'refs';
+ *{"${type}::${name}"} = sub {
+ my $s = shift;
+ my $v = shift;
+ $s->{$name} = $v if defined $v;
+ return $s->{$name};
+ }
+ }
+ return $self->$name($data);
+}
+
+
+sub new {
+ my( $class, $auth, %args ) = @_;
+ $class = ref($class) || $class;
+ my $self = bless( {}, $class );
+
+ $self->events([]);
+ $self->editor(new_editor(xact => 1, authtoken => $auth));
+
+ unless( $self->editor->checkauth ) {
+ $self->bail_on_events($self->editor->event);
+ return $self;
+ }
+
+ $self->cache_handle(OpenSRF::Utils::Cache->new('global'));
+
+ $self->$_($args{$_}) for keys %args;
+
+ $self->circ_lib(
+ ($self->circ_lib) ? $self->circ_lib : $self->editor->requestor->ws_ou);
+
+ # if this is a renewal, default to desk_renewal
+ $self->desk_renewal(1) unless
+ $self->opac_renewal or $self->phone_renewal or $self->sip_renewal;
+
+ $self->capture('') unless $self->capture;
+
+ unless(%user_groups) {
+ my $gps = $self->editor->retrieve_all_permission_grp_tree;
+ %user_groups = map { $_->id => $_ } @$gps;
+ }
+
+ return $self;
+}
+
+
+# --------------------------------------------------------------------------
+# True if we should discontinue processing
+# --------------------------------------------------------------------------
+sub bail_out {
+ my( $self, $bool ) = @_;
+ if( defined $bool ) {
+ $logger->info("circulator: BAILING OUT") if $bool;
+ $self->{bail_out} = $bool;
+ }
+ return $self->{bail_out};
+}
+
+
+sub push_events {
+ my( $self, @evts ) = @_;
+ for my $e (@evts) {
+ next unless $e;
+ $e->{payload} = $self->copy if
+ ($e->{textcode} eq 'COPY_NOT_AVAILABLE');
+
+ $logger->info("circulator: pushing event ".$e->{textcode});
+ push( @{$self->events}, $e ) unless
+ grep { $_->{textcode} eq $e->{textcode} } @{$self->events};
+ }
+}
+
+sub mk_permit_key {
+ my $self = shift;
+ return '' if $self->skip_permit_key;
+ my $key = md5_hex( time() . rand() . "$$" );
+ $self->cache_handle->put_cache( "oils_permit_key_$key", 1, 300 );
+ return $self->permit_key($key);
+}
+
+sub check_permit_key {
+ my $self = shift;
+ return 1 if $self->skip_permit_key;
+ my $key = $self->permit_key;
+ return 0 unless $key;
+ my $k = "oils_permit_key_$key";
+ my $one = $self->cache_handle->get_cache($k);
+ $self->cache_handle->delete_cache($k);
+ return ($one) ? 1 : 0;
+}
+
+sub seems_like_reservation {
+ my $self = shift;
+
+ # Some words about the following method:
+ # 1) It requires the VIEW_USER permission, but that's not an
+ # issue, right, since all staff should have that?
+ # 2) It returns only one reservation at a time, even if an item can be
+ # and is currently overbooked. Hmmm....
+ my $booking_ses = create OpenSRF::AppSession("open-ils.booking");
+ my $result = $booking_ses->request(
+ "open-ils.booking.reservations.by_returnable_resource_barcode",
+ $self->editor->authtoken,
+ $self->copy_barcode
+ )->gather(1);
+ $booking_ses->disconnect;
+
+ return $self->bail_on_events($result) if defined $U->event_code($result);
+
+ if (@$result > 0) {
+ $self->reservation(shift @$result);
+ return 1;
+ } else {
+ return 0;
+ }
+
+}
+
+# save_trimmed_copy() used just to be a block in mk_env(), but was separated for re-use
+sub save_trimmed_copy {
+ my ($self, $copy) = @_;
+
+ $self->copy($copy);
+ $self->volume($copy->call_number);
+ $self->title($self->volume->record);
+ $self->copy->call_number($self->volume->id);
+ $self->volume->record($self->title->id);
+ $self->is_precat(1) if $self->volume->id == OILS_PRECAT_CALL_NUMBER;
+ if($self->copy->deposit_amount and $self->copy->deposit_amount > 0) {
+ $self->is_deposit(1) if $U->is_true($self->copy->deposit);
+ $self->is_rental(1) unless $U->is_true($self->copy->deposit);
+ }
+}
+
+sub mk_env {
+ my $self = shift;
+ my $e = $self->editor;
+
+ # --------------------------------------------------------------------------
+ # Grab the fleshed copy
+ # --------------------------------------------------------------------------
+ unless($self->is_noncat) {
+ my $copy;
+ if($self->copy_id) {
+ $copy = $e->retrieve_asset_copy(
+ [$self->copy_id, $MK_ENV_FLESH ]) or return $e->event;
+
+ } elsif( $self->copy_barcode ) {
+
+ $copy = $e->search_asset_copy(
+ [{barcode => $self->copy_barcode, deleted => 'f'}, $MK_ENV_FLESH ])->[0];
+ } elsif( $self->reservation ) {
+ my $res = $e->json_query(
+ {
+ "select" => {"acp" => ["id"]},
+ "from" => {
+ "acp" => {
+ "brsrc" => {
+ "fkey" => "barcode",
+ "field" => "barcode",
+ "join" => {
+ "bresv" => {
+ "fkey" => "id",
+ "field" => "current_resource"
+ }
+ }
+ }
+ }
+ },
+ "where" => {
+ "+bresv" => {
+ "id" => (ref $self->reservation) ?
+ $self->reservation->id : $self->reservation
+ }
+ }
+ }
+ );
+ if (ref $res eq "ARRAY" and scalar @$res) {
+ $logger->info("circulator: mapped reservation " .
+ $self->reservation . " to copy " . $res->[0]->{"id"});
+ $copy = $e->retrieve_asset_copy([$res->[0]->{"id"}, $MK_ENV_FLESH]);
+ }
+ }
+
+ if($copy) {
+ $self->save_trimmed_copy($copy);
+ } else {
+ # We can't renew if there is no copy
+ return $self->bail_on_events(OpenILS::Event->new('ASSET_COPY_NOT_FOUND'))
+ if $self->is_renewal;
+ $self->is_precat(1);
+ }
+ }
+
+ # --------------------------------------------------------------------------
+ # Grab the patron
+ # --------------------------------------------------------------------------
+ my $patron;
+ my $flesh = {
+ flesh => 1,
+ flesh_fields => {au => [ qw/ card / ]}
+ };
+
+ if( $self->patron_id ) {
+ $patron = $e->retrieve_actor_user([$self->patron_id, $flesh])
+ or return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'));
+
+ } elsif( $self->patron_barcode ) {
+
+ # note: throwing ACTOR_USER_NOT_FOUND instead of ACTOR_CARD_NOT_FOUND is intentional
+ my $card = $e->search_actor_card({barcode => $self->patron_barcode})->[0]
+ or return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'));
+
+ $patron = $e->search_actor_user([{card => $card->id}, $flesh])->[0]
+ or return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'));
+
+ } else {
+ if( my $copy = $self->copy ) {
+
+ $flesh->{flesh} = 2;
+ $flesh->{flesh_fields}->{circ} = ['usr'];
+
+ my $circ = $e->search_action_circulation([
+ {target_copy => $copy->id, checkin_time => undef}, $flesh
+ ])->[0];
+
+ if($circ) {
+ $patron = $circ->usr;
+ $circ->usr($patron->id); # de-flesh for consistency
+ $self->circ($circ);
+ }
+ }
+ }
+
+ return $self->bail_on_events(OpenILS::Event->new('ACTOR_USER_NOT_FOUND'))
+ unless $self->patron($patron) or $self->is_checkin;
+
+ unless($self->is_checkin) {
+
+ # Check for inactivity and patron reg. expiration
+
+ $self->bail_on_events(OpenILS::Event->new('PATRON_INACTIVE'))
+ unless $U->is_true($patron->active);
+
+ $self->bail_on_events(OpenILS::Event->new('PATRON_CARD_INACTIVE'))
+ unless $U->is_true($patron->card->active);
+
+ my $expire = DateTime::Format::ISO8601->new->parse_datetime(
+ cleanse_ISO8601($patron->expire_date));
+
+ $self->bail_on_events(OpenILS::Event->new('PATRON_ACCOUNT_EXPIRED'))
+ if( CORE::time > $expire->epoch ) ;
+ }
+}
+
+# --------------------------------------------------------------------------
+# This builds the script runner environment and fetches most of the
+# objects we need
+# --------------------------------------------------------------------------
+sub mk_script_runner {
+ my $self = shift;
+ my $args = {};
+
+
+ my @fields =
+ qw/copy copy_barcode copy_id patron
+ patron_id patron_barcode volume title editor/;
+
+ # Translate our objects into the ScriptBuilder args hash
+ $$args{$_} = $self->$_() for @fields;
+
+ $args->{ignore_user_status} = 1 if $self->is_checkin;
+ $$args{fetch_patron_by_circ_copy} = 1;
+ $$args{fetch_patron_circ_info} = 1 unless $self->is_checkin;
+
+ if( my $pco = $self->pending_checkouts ) {
+ $logger->info("circulator: we were given a pending checkouts number of $pco");
+ $$args{patronItemsOut} = $pco;
+ }
+
+ # This fetches most of the objects we need
+ $self->script_runner(
+ OpenILS::Application::Circ::ScriptBuilder->build($args));
+
+ # Now we translate the ScriptBuilder objects back into self
+ $self->$_($$args{$_}) for @fields;
+
+ my @evts = @{$args->{_events}} if $args->{_events};
+
+ $logger->debug("circulator: script builder returned events: @evts") if @evts;
+
+
+ if(@evts) {
+ # Anything besides ASSET_COPY_NOT_FOUND will stop processing
+ if(!$self->is_noncat and
+ @evts == 1 and
+ $evts[0]->{textcode} eq 'ASSET_COPY_NOT_FOUND') {
+ $self->is_precat(1);
+
+ } else {
+ my @e = grep { $_->{textcode} ne 'ASSET_COPY_NOT_FOUND' } @evts;
+ return $self->bail_on_events(@e);
+ }
+ }
+
+ if($self->copy) {
+ $self->is_precat(1) if $self->copy->call_number == OILS_PRECAT_CALL_NUMBER;
+ if($self->copy->deposit_amount and $self->copy->deposit_amount > 0) {
+ $self->is_deposit(1) if $U->is_true($self->copy->deposit);
+ $self->is_rental(1) unless $U->is_true($self->copy->deposit);
+ }
+ }
+
+ # We can't renew if there is no copy
+ return $self->bail_on_events(@evts) if
+ $self->is_renewal and !$self->copy;
+
+ # Set some circ-specific flags in the script environment
+ my $evt = "environment";
+ $self->script_runner->insert("$evt.isRenewal", ($self->is_renewal) ? 1 : undef);
+
+ if( $self->is_noncat ) {
+ $self->script_runner->insert("$evt.isNonCat", 1);
+ $self->script_runner->insert("$evt.nonCatType", $self->noncat_type);
+ }
+
+ if( $self->is_precat ) {
+ $self->script_runner->insert("environment.isPrecat", 1, 1);
+ }
+
+ $self->script_runner->add_path( $_ ) for @$script_libs;
+
+ return 1;
+}
+
+# --------------------------------------------------------------------------
+# Does the circ permit work
+# --------------------------------------------------------------------------
+sub do_permit {
+ my $self = shift;
+
+ $self->log_me("do_permit()");
+
+ unless( $self->editor->requestor->id == $self->patron->id ) {
+ return $self->bail_on_events($self->editor->event)
+ unless( $self->editor->allowed('VIEW_PERMIT_CHECKOUT') );
+ }
+
+ $self->check_captured_holds();
+ $self->do_copy_checks();
+ return if $self->bail_out;
+ $self->run_patron_permit_scripts();
+ $self->run_copy_permit_scripts()
+ unless $self->is_precat or $self->is_noncat;
+ $self->check_item_deposit_events();
+ $self->override_events();
+ return if $self->bail_out;
+
+ if($self->is_precat and not $self->request_precat) {
+ $self->push_events(
+ OpenILS::Event->new(
+ 'ITEM_NOT_CATALOGED', payload => $self->mk_permit_key));
+ return $self->bail_out(1) unless $self->is_renewal;
+ }
+
+ $self->push_events(
+ OpenILS::Event->new('SUCCESS', payload => $self->mk_permit_key));
+}
+
+sub check_item_deposit_events {
+ my $self = shift;
+ $self->push_events(OpenILS::Event->new('ITEM_DEPOSIT_REQUIRED', payload => $self->copy))
+ if $self->is_deposit and not $self->is_deposit_exempt;
+ $self->push_events(OpenILS::Event->new('ITEM_RENTAL_FEE_REQUIRED', payload => $self->copy))
+ if $self->is_rental and not $self->is_rental_exempt;
+}
+
+# returns true if the user is not required to pay deposits
+sub is_deposit_exempt {
+ my $self = shift;
+ my $pid = (ref $self->patron->profile) ?
+ $self->patron->profile->id : $self->patron->profile;
+ my $groups = $U->ou_ancestor_setting_value(
+ $self->circ_lib, 'circ.deposit.exempt_groups', $self->editor);
+ for my $grp (@$groups) {
+ return 1 if $self->is_group_descendant($grp, $pid);
+ }
+ return 0;
+}
+
+# returns true if the user is not required to pay rental fees
+sub is_rental_exempt {
+ my $self = shift;
+ my $pid = (ref $self->patron->profile) ?
+ $self->patron->profile->id : $self->patron->profile;
+ my $groups = $U->ou_ancestor_setting_value(
+ $self->circ_lib, 'circ.rental.exempt_groups', $self->editor);
+ for my $grp (@$groups) {
+ return 1 if $self->is_group_descendant($grp, $pid);
+ }
+ return 0;
+}
+
+sub is_group_descendant {
+ my($self, $p_id, $c_id) = @_;
+ return 0 unless defined $p_id and defined $c_id;
+ return 1 if $c_id == $p_id;
+ while(my $grp = $user_groups{$c_id}) {
+ $c_id = $grp->parent;
+ return 0 unless defined $c_id;
+ return 1 if $c_id == $p_id;
+ }
+ return 0;
+}
+
+sub check_captured_holds {
+ my $self = shift;
+ my $copy = $self->copy;
+ my $patron = $self->patron;
+
+ return undef unless $copy;
+
+ my $s = $U->copy_status($copy->status)->id;
+ return unless $s == OILS_COPY_STATUS_ON_HOLDS_SHELF;
+ $logger->info("circulator: copy is on holds shelf, searching for the correct hold");
+
+ # Item is on the holds shelf, make sure it's going to the right person
+ my $holds = $self->editor->search_action_hold_request(
+ [
+ {
+ current_copy => $copy->id ,
+ capture_time => { '!=' => undef },
+ cancel_time => undef,
+ fulfillment_time => undef
+ },
+ { limit => 1 }
+ ]
+ );
+
+ if( $holds and $$holds[0] ) {
+ return undef if $$holds[0]->usr == $patron->id;
+ }
+
+ $logger->info("circulator: this copy is needed by a different patron to fulfill a hold");
+
+ $self->push_events(OpenILS::Event->new('ITEM_ON_HOLDS_SHELF'));
+}
+
+
+sub do_copy_checks {
+ my $self = shift;
+ my $copy = $self->copy;
+ return unless $copy;
+
+ my $stat = $U->copy_status($copy->status)->id;
+
+ # We cannot check out a copy if it is in-transit
+ if( $stat == OILS_COPY_STATUS_IN_TRANSIT ) {
+ return $self->bail_on_events(OpenILS::Event->new('COPY_IN_TRANSIT'));
+ }
+
+ $self->handle_claims_returned();
+ return if $self->bail_out;
+
+ # no claims returned circ was found, check if there is any open circ
+ unless( $self->is_renewal ) {
+
+ my $circs = $self->editor->search_action_circulation(
+ { target_copy => $copy->id, checkin_time => undef }
+ );
+
+ if(my $old_circ = $circs->[0]) { # an open circ was found
+
+ my $payload = {copy => $copy};
+
+ if($old_circ->usr == $self->patron->id) {
+
+ $payload->{old_circ} = $old_circ;
+
+ # If there is an open circulation on the checkout item and an auto-renew
+ # interval is defined, inform the caller that they should go
+ # ahead and renew the item instead of warning about open circulations.
+
+ my $auto_renew_intvl = $U->ou_ancestor_setting_value(
+ $self->circ_lib,
+ 'circ.checkout_auto_renew_age',
+ $self->editor
+ );
+
+ if($auto_renew_intvl) {
+ my $intvl_seconds = OpenSRF::Utils->interval_to_seconds($auto_renew_intvl);
+ my $checkout_time = DateTime::Format::ISO8601->new->parse_datetime( cleanse_ISO8601($old_circ->xact_start) );
+
+ if(DateTime->now > $checkout_time->add(seconds => $intvl_seconds)) {
+ $payload->{auto_renew} = 1;
+ }
+ }
+ }
+
+ return $self->bail_on_events(
+ OpenILS::Event->new('OPEN_CIRCULATION_EXISTS', payload => $payload)
+ );
+ }
+ }
+}
+
+my $LEGACY_CIRC_EVENT_MAP = {
+ 'no_item' => 'ITEM_NOT_CATALOGED',
+ 'actor.usr.barred' => 'PATRON_BARRED',
+ 'asset.copy.circulate' => 'COPY_CIRC_NOT_ALLOWED',
+ 'asset.copy.status' => 'COPY_NOT_AVAILABLE',
+ 'asset.copy_location.circulate' => 'COPY_CIRC_NOT_ALLOWED',
+ 'config.circ_matrix_test.circulate' => 'COPY_CIRC_NOT_ALLOWED',
+ 'config.circ_matrix_test.max_items_out' => 'PATRON_EXCEEDS_CHECKOUT_COUNT',
+ 'config.circ_matrix_test.max_overdue' => 'PATRON_EXCEEDS_OVERDUE_COUNT',
+ 'config.circ_matrix_test.max_fines' => 'PATRON_EXCEEDS_FINES',
+ 'config.circ_matrix_circ_mod_test' => 'PATRON_EXCEEDS_CHECKOUT_COUNT',
+};
+
+
+# ---------------------------------------------------------------------
+# This pushes any patron-related events into the list but does not
+# set bail_out for any events
+# ---------------------------------------------------------------------
+sub run_patron_permit_scripts {
+ my $self = shift;
+ my $runner = $self->script_runner;
+ my $patronid = $self->patron->id;
+
+ my @allevents;
+
+ if(!$self->legacy_script_support) {
+
+ my $results = $self->run_indb_circ_test;
+ unless($self->circ_test_success) {
+ # no_item result is OK during noncat checkout
+ unless(@$results == 1 && $results->[0]->{fail_part} eq 'no_item' and $self->is_noncat) {
+ push @allevents, $self->matrix_test_result_events;
+ }
+ }
+
+ } else {
+
+ # ---------------------------------------------------------------------
+ # # Now run the patron permit script
+ # ---------------------------------------------------------------------
+ $runner->load($self->circ_permit_patron);
+ my $result = $runner->run or
+ throw OpenSRF::EX::ERROR ("Circ Permit Patron Script Died: $@");
+
+ my $patron_events = $result->{events};
+
+ OpenILS::Utils::Penalty->calculate_penalties($self->editor, $self->patron->id, $self->circ_lib);
+ my $mask = ($self->is_renewal) ? 'RENEW' : 'CIRC';
+ my $penalties = OpenILS::Utils::Penalty->retrieve_penalties($self->editor, $patronid, $self->circ_lib, $mask);
+ $penalties = $penalties->{fatal_penalties};
+
+ for my $pen (@$penalties) {
+ my $event = OpenILS::Event->new($pen->name);
+ $event->{desc} = $pen->label;
+ push(@allevents, $event);
+ }
+
+ push(@allevents, OpenILS::Event->new($_)) for (@$patron_events);
+ }
+
+ for (@allevents) {
+ $_->{payload} = $self->copy if
+ ($_->{textcode} eq 'COPY_NOT_AVAILABLE');
+ }
+
+ $logger->info("circulator: permit_patron script returned events: @allevents") if @allevents;
+
+ $self->push_events(@allevents);
+}
+
+sub matrix_test_result_codes {
+ my $self = shift;
+ map { $_->{"fail_part"} } @{$self->matrix_test_result};
+}
+
+sub matrix_test_result_events {
+ my $self = shift;
+ map {
+ my $event = new OpenILS::Event(
+ $LEGACY_CIRC_EVENT_MAP->{$_->{"fail_part"}} || $_->{"fail_part"}
+ );
+ $event->{"payload"} = {"fail_part" => $_->{"fail_part"}};
+ $event;
+ } (@{$self->matrix_test_result});
+}
+
+sub run_indb_circ_test {
+ my $self = shift;
+ return $self->matrix_test_result if $self->matrix_test_result;
+
+ my $dbfunc = ($self->is_renewal) ?
+ 'action.item_user_renew_test' : 'action.item_user_circ_test';
+
+ if( $self->is_precat && $self->request_precat) {
+ $self->make_precat_copy;
+ return if $self->bail_out;
+ }
+
+ my $results = $self->editor->json_query(
+ { from => [
+ $dbfunc,
+ $self->circ_lib,
+ ($self->is_noncat or ($self->is_precat and !$self->override and !$self->is_renewal)) ? undef : $self->copy->id,
+ $self->patron->id,
+ ]
+ }
+ );
+
+ $self->circ_test_success($U->is_true($results->[0]->{success}));
+
+ if(my $mp = $results->[0]->{matchpoint}) {
+ $logger->info("circulator: circ policy test found matchpoint $mp");
+ $self->circ_matrix_matchpoint(
+ $self->editor->retrieve_config_circ_matrix_matchpoint([
+ $mp,
+ { flesh => 1,
+ flesh_fields => {ccmm =>
+ ['duration_rule', 'recurring_fine_rule', 'max_fine_rule', 'hard_due_date']}
+ }
+ ])
+ );
+ }
+
+ return $self->matrix_test_result($results);
+}
+
+# ---------------------------------------------------------------------
+# given a use and copy, this will calculate the circulation policy
+# parameters. Only works with in-db circ.
+# ---------------------------------------------------------------------
+sub do_inspect {
+ my $self = shift;
+
+ return OpenILS::Event->new('ASSET_COPY_NOT_FOUND') unless $self->copy;
+
+ $self->run_indb_circ_test;
+
+ my $results = {
+ circ_test_success => $self->circ_test_success,
+ failure_events => [],
+ failure_codes => [],
+ matchpoint => $self->circ_matrix_matchpoint
+ };
+
+ unless($self->circ_test_success) {
+ $results->{"failure_codes"} = [ $self->matrix_test_result_codes ];
+ $results->{"failure_events"} = [ $self->matrix_test_result_events ];
+ }
+
+ if($self->circ_matrix_matchpoint) {
+ my $duration_rule = $self->circ_matrix_matchpoint->duration_rule;
+ my $recurring_fine_rule = $self->circ_matrix_matchpoint->recurring_fine_rule;
+ my $max_fine_rule = $self->circ_matrix_matchpoint->max_fine_rule;
+ my $hard_due_date = $self->circ_matrix_matchpoint->hard_due_date;
+
+ my $policy = $self->get_circ_policy(
+ $duration_rule, $recurring_fine_rule, $max_fine_rule, $hard_due_date);
+
+ $$results{$_} = $$policy{$_} for keys %$policy;
+ }
+
+ return $results;
+}
+
+# ---------------------------------------------------------------------
+# Loads the circ policy info for duration, recurring fine, and max
+# fine based on the current copy
+# ---------------------------------------------------------------------
+sub get_circ_policy {
+ my($self, $duration_rule, $recurring_fine_rule, $max_fine_rule, $hard_due_date) = @_;
+
+ my $policy = {
+ duration_rule => $duration_rule->name,
+ recurring_fine_rule => $recurring_fine_rule->name,
+ max_fine_rule => $max_fine_rule->name,
+ max_fine => $self->get_max_fine_amount($max_fine_rule),
+ fine_interval => $recurring_fine_rule->recurrence_interval,
+ renewal_remaining => $duration_rule->max_renewals
+ };
+
+ if($hard_due_date) {
+ $policy->{duration_date_ceiling} = $hard_due_date->ceiling_date;
+ $policy->{duration_date_ceiling_force} = $hard_due_date->forceto;
+ }
+ else {
+ $policy->{duration_date_ceiling} = undef;
+ $policy->{duration_date_ceiling_force} = undef;
+ }
+
+ $policy->{duration} = $duration_rule->shrt
+ if $self->copy->loan_duration == OILS_CIRC_DURATION_SHORT;
+ $policy->{duration} = $duration_rule->normal
+ if $self->copy->loan_duration == OILS_CIRC_DURATION_NORMAL;
+ $policy->{duration} = $duration_rule->extended
+ if $self->copy->loan_duration == OILS_CIRC_DURATION_EXTENDED;
+
+ $policy->{recurring_fine} = $recurring_fine_rule->low
+ if $self->copy->fine_level == OILS_REC_FINE_LEVEL_LOW;
+ $policy->{recurring_fine} = $recurring_fine_rule->normal
+ if $self->copy->fine_level == OILS_REC_FINE_LEVEL_NORMAL;
+ $policy->{recurring_fine} = $recurring_fine_rule->high
+ if $self->copy->fine_level == OILS_REC_FINE_LEVEL_HIGH;
+
+ return $policy;
+}
+
+sub get_max_fine_amount {
+ my $self = shift;
+ my $max_fine_rule = shift;
+ my $max_amount = $max_fine_rule->amount;
+
+ # if is_percent is true then the max->amount is
+ # use as a percentage of the copy price
+ if ($U->is_true($max_fine_rule->is_percent)) {
+ my $price = $U->get_copy_price($self->editor, $self->copy, $self->volume);
+ $max_amount = $price * $max_fine_rule->amount / 100;
+ } elsif (
+ $U->ou_ancestor_setting_value(
+ $self->circ_lib,
+ 'circ.max_fine.cap_at_price',
+ $self->editor
+ )
+ ) {
+ my $price = $U->get_copy_price($self->editor, $self->copy, $self->volume);
+ $max_amount = ( $price && $max_amount > $price ) ? $price : $max_amount;
+ }
+
+ return $max_amount;
+}
+
+
+
+sub run_copy_permit_scripts {
+ my $self = shift;
+ my $copy = $self->copy || return;
+ my $runner = $self->script_runner;
+
+ my @allevents;
+
+ if(!$self->legacy_script_support) {
+ my $results = $self->run_indb_circ_test;
+ push @allevents, $self->matrix_test_result_events
+ unless $self->circ_test_success;
+ } else {
+
+ # ---------------------------------------------------------------------
+ # Capture all of the copy permit events
+ # ---------------------------------------------------------------------
+ $runner->load($self->circ_permit_copy);
+ my $result = $runner->run or
+ throw OpenSRF::EX::ERROR ("Circ Permit Copy Script Died: $@");
+ my $copy_events = $result->{events};
+
+ # ---------------------------------------------------------------------
+ # Now collect all of the events together
+ # ---------------------------------------------------------------------
+ push( @allevents, OpenILS::Event->new($_)) for @$copy_events;
+ }
+
+ # See if this copy has an alert message
+ my $ae = $self->check_copy_alert();
+ push( @allevents, $ae ) if $ae;
+
+ # uniquify the events
+ my %hash = map { ($_->{ilsevent} => $_) } @allevents;
+ @allevents = values %hash;
+
+ $logger->info("circulator: permit_copy script returned events: @allevents") if @allevents;
+
+ $self->push_events(@allevents);
+}
+
+
+sub check_copy_alert {
+ my $self = shift;
+ return undef if $self->is_renewal;
+ return OpenILS::Event->new(
+ 'COPY_ALERT_MESSAGE', payload => $self->copy->alert_message)
+ if $self->copy and $self->copy->alert_message;
+ return undef;
+}
+
+
+
+# --------------------------------------------------------------------------
+# If the call is overriding and has permissions to override every collected
+# event, the are cleared. Any event that the caller does not have
+# permission to override, will be left in the event list and bail_out will
+# be set
+# XXX We need code in here to cancel any holds/transits on copies
+# that are being force-checked out
+# --------------------------------------------------------------------------
+sub override_events {
+ my $self = shift;
+ my @events = @{$self->events};
+ return unless @events;
+
+ if(!$self->override) {
+ return $self->bail_out(1)
+ if( @events > 1 or $events[0]->{textcode} ne 'SUCCESS' );
+ }
+
+ $self->events([]);
+
+ for my $e (@events) {
+ my $tc = $e->{textcode};
+ next if $tc eq 'SUCCESS';
+ my $ov = "$tc.override";
+ $logger->info("circulator: attempting to override event: $ov");
+
+ return $self->bail_on_events($self->editor->event)
+ unless( $self->editor->allowed($ov) );
+ }
+}
+
+
+# --------------------------------------------------------------------------
+# If there is an open claimsreturn circ on the requested copy, close the
+# circ if overriding, otherwise bail out
+# --------------------------------------------------------------------------
+sub handle_claims_returned {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ my $CR = $self->editor->search_action_circulation(
+ {
+ target_copy => $copy->id,
+ stop_fines => OILS_STOP_FINES_CLAIMSRETURNED,
+ checkin_time => undef,
+ }
+ );
+
+ return unless ($CR = $CR->[0]);
+
+ my $evt;
+
+ # - If the caller has set the override flag, we will check the item in
+ if($self->override) {
+
+ $CR->checkin_time('now');
+ $CR->checkin_scan_time('now');
+ $CR->checkin_lib($self->circ_lib);
+ $CR->checkin_workstation($self->editor->requestor->wsid);
+ $CR->checkin_staff($self->editor->requestor->id);
+
+ $evt = $self->editor->event
+ unless $self->editor->update_action_circulation($CR);
+
+ } else {
+ $evt = OpenILS::Event->new('CIRC_CLAIMS_RETURNED');
+ }
+
+ $self->bail_on_events($evt) if $evt;
+ return;
+}
+
+
+# --------------------------------------------------------------------------
+# This performs the checkout
+# --------------------------------------------------------------------------
+sub do_checkout {
+ my $self = shift;
+
+ $self->log_me("do_checkout()");
+
+ # make sure perms are good if this isn't a renewal
+ unless( $self->is_renewal ) {
+ return $self->bail_on_events($self->editor->event)
+ unless( $self->editor->allowed('COPY_CHECKOUT') );
+ }
+
+ # verify the permit key
+ unless( $self->check_permit_key ) {
+ if( $self->permit_override ) {
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->allowed('CIRC_PERMIT_OVERRIDE');
+ } else {
+ return $self->bail_on_events(OpenILS::Event->new('CIRC_PERMIT_BAD_KEY'))
+ }
+ }
+
+ # if this is a non-cataloged circ, build the circ and finish
+ if( $self->is_noncat ) {
+ $self->checkout_noncat;
+ $self->push_events(
+ OpenILS::Event->new('SUCCESS',
+ payload => { noncat_circ => $self->circ }));
+ return;
+ }
+
+ if( $self->is_precat ) {
+ $self->make_precat_copy;
+ return if $self->bail_out;
+
+ } elsif( $self->copy->call_number == OILS_PRECAT_CALL_NUMBER ) {
+ return $self->bail_on_events(OpenILS::Event->new('ITEM_NOT_CATALOGED'));
+ }
+
+ $self->do_copy_checks;
+ return if $self->bail_out;
+
+ $self->run_checkout_scripts();
+ return if $self->bail_out;
+
+ $self->build_checkout_circ_object();
+ return if $self->bail_out;
+
+ my $modify_to_start = $self->booking_adjusted_due_date();
+ return if $self->bail_out;
+
+ $self->apply_modified_due_date($modify_to_start);
+ return if $self->bail_out;
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->create_action_circulation($self->circ);
+
+ # refresh the circ to force local time zone for now
+ $self->circ($self->editor->retrieve_action_circulation($self->circ->id));
+
+ $self->copy->status(OILS_COPY_STATUS_CHECKED_OUT);
+ $self->update_copy;
+ return if $self->bail_out;
+
+ $self->apply_deposit_fee();
+ return if $self->bail_out;
+
+ $self->handle_checkout_holds();
+ return if $self->bail_out;
+
+ # ------------------------------------------------------------------------------
+ # Update the patron penalty info in the DB. Run it for permit-overrides
+ # since the penalties are not updated during the permit phase
+ # ------------------------------------------------------------------------------
+ OpenILS::Utils::Penalty->calculate_penalties($self->editor, $self->patron->id, $self->circ_lib);
+
+ my $record = $U->record_to_mvr($self->title) unless $self->is_precat;
+
+ my $pcirc;
+ if($self->is_renewal) {
+ # flesh the billing summary for the checked-in circ
+ $pcirc = $self->editor->retrieve_action_circulation([
+ $self->parent_circ,
+ {flesh => 2, flesh_fields => {circ => ['billable_transaction'], mbt => ['summary']}}
+ ]);
+ }
+
+ $self->push_events(
+ OpenILS::Event->new('SUCCESS',
+ payload => {
+ copy => $U->unflesh_copy($self->copy),
+ circ => $self->circ,
+ record => $record,
+ holds_fulfilled => $self->fulfilled_holds,
+ deposit_billing => $self->deposit_billing,
+ rental_billing => $self->rental_billing,
+ parent_circ => $pcirc,
+ patron => ($self->return_patron) ? $self->patron : undef,
+ patron_money => $self->editor->retrieve_money_user_summary($self->patron->id)
+ }
+ )
+ );
+}
+
+sub apply_deposit_fee {
+ my $self = shift;
+ my $copy = $self->copy;
+ return unless
+ ($self->is_deposit and not $self->is_deposit_exempt) or
+ ($self->is_rental and not $self->is_rental_exempt);
+
+ return if $self->is_deposit and $self->skip_deposit_fee;
+ return if $self->is_rental and $self->skip_rental_fee;
+
+ my $bill = Fieldmapper::money::billing->new;
+ my $amount = $copy->deposit_amount;
+ my $billing_type;
+ my $btype;
+
+ if($self->is_deposit) {
+ $billing_type = OILS_BILLING_TYPE_DEPOSIT;
+ $btype = 5;
+ $self->deposit_billing($bill);
+ } else {
+ $billing_type = OILS_BILLING_TYPE_RENTAL;
+ $btype = 6;
+ $self->rental_billing($bill);
+ }
+
+ $bill->xact($self->circ->id);
+ $bill->amount($amount);
+ $bill->note(OILS_BILLING_NOTE_SYSTEM);
+ $bill->billing_type($billing_type);
+ $bill->btype($btype);
+ $self->editor->create_money_billing($bill) or $self->bail_on_events($self->editor->event);
+
+ $logger->info("circulator: charged $amount on checkout with billing type $billing_type");
+}
+
+sub update_copy {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ my $stat = $copy->status if ref $copy->status;
+ my $loc = $copy->location if ref $copy->location;
+ my $circ_lib = $copy->circ_lib if ref $copy->circ_lib;
+
+ $copy->status($stat->id) if $stat;
+ $copy->location($loc->id) if $loc;
+ $copy->circ_lib($circ_lib->id) if $circ_lib;
+ $copy->editor($self->editor->requestor->id);
+ $copy->edit_date('now');
+ $copy->age_protect($copy->age_protect->id) if ref $copy->age_protect;
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_asset_copy($self->copy);
+
+ $copy->status($U->copy_status($copy->status));
+ $copy->location($loc) if $loc;
+ $copy->circ_lib($circ_lib) if $circ_lib;
+}
+
+sub update_reservation {
+ my $self = shift;
+ my $reservation = $self->reservation;
+
+ my $usr = $reservation->usr;
+ my $target_rt = $reservation->target_resource_type;
+ my $target_r = $reservation->target_resource;
+ my $current_r = $reservation->current_resource;
+
+ $reservation->usr($usr->id) if ref $usr;
+ $reservation->target_resource_type($target_rt->id) if ref $target_rt;
+ $reservation->target_resource($target_r->id) if ref $target_r;
+ $reservation->current_resource($current_r->id) if ref $current_r;
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_booking_reservation($self->reservation);
+
+ my $evt;
+ ($reservation, $evt) = $U->fetch_booking_reservation($reservation->id);
+ $self->reservation($reservation);
+}
+
+
+sub bail_on_events {
+ my( $self, @evts ) = @_;
+ $self->push_events(@evts);
+ $self->bail_out(1);
+}
+
+
+# ------------------------------------------------------------------------------
+# When an item is checked out, see if we can fulfill a hold for this patron
+# ------------------------------------------------------------------------------
+sub handle_checkout_holds {
+ my $self = shift;
+ my $copy = $self->copy;
+ my $patron = $self->patron;
+
+ my $e = $self->editor;
+ $self->fulfilled_holds([]);
+
+ # pre/non-cats can't fulfill a hold
+ return if $self->is_precat or $self->is_noncat;
+
+ my $hold = $e->search_action_hold_request({
+ current_copy => $copy->id ,
+ cancel_time => undef,
+ fulfillment_time => undef,
+ '-or' => [
+ {expire_time => undef},
+ {expire_time => {'>' => 'now'}}
+ ]
+ })->[0];
+
+ if($hold and $hold->usr != $patron->id) {
+ # reset the hold since the copy is now checked out
+
+ $logger->info("circulator: un-targeting hold ".$hold->id.
+ " because copy ".$copy->id." is getting checked out");
+
+ $hold->clear_prev_check_time;
+ $hold->clear_current_copy;
+ $hold->clear_capture_time;
+
+ return $self->bail_on_event($e->event)
+ unless $e->update_action_hold_request($hold);
+
+ $hold = undef;
+ }
+
+ unless($hold) {
+ $hold = $self->find_related_user_hold($copy, $patron) or return;
+ $logger->info("circulator: found related hold to fulfill in checkout");
+ }
+
+ $logger->debug("circulator: checkout fulfilling hold " . $hold->id);
+
+ # if the hold was never officially captured, capture it.
+ $hold->current_copy($copy->id);
+ $hold->capture_time('now') unless $hold->capture_time;
+ $hold->fulfillment_time('now');
+ $hold->fulfillment_staff($e->requestor->id);
+ $hold->fulfillment_lib($self->circ_lib);
+
+ return $self->bail_on_events($e->event)
+ unless $e->update_action_hold_request($hold);
+
+ $holdcode->delete_hold_copy_maps($e, $hold->id);
+ return $self->fulfilled_holds([$hold->id]);
+}
+
+
+# ------------------------------------------------------------------------------
+# If the circ.checkout_fill_related_hold setting is turned on and no hold for
+# the patron directly targets the checked out item, see if there is another hold
+# (with hold_type T or V) for the patron that could be fulfilled by the checked
+# out item. Fulfill the oldest hold and only fulfill 1 of them.
+# ------------------------------------------------------------------------------
+sub find_related_user_hold {
+ my($self, $copy, $patron) = @_;
+ my $e = $self->editor;
+
+ return undef if $self->volume->id == OILS_PRECAT_CALL_NUMBER;
+
+ return undef unless $U->ou_ancestor_setting_value(
+ $self->circ_lib, 'circ.checkout_fills_related_hold', $e);
+
+ # find the oldest unfulfilled hold that has not yet hit the holds shelf.
+ my $args = {
+ select => {ahr => ['id']},
+ from => {
+ ahr => {
+ acp => {
+ field => 'id',
+ fkey => 'current_copy',
+ type => 'left' # there may be no current_copy
+ }
+ }
+ },
+ where => {
+ '+ahr' => {
+ usr => $patron->id,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ '-or' => [
+ {expire_time => undef},
+ {expire_time => {'>' => 'now'}}
+ ]
+ },
+ '-or' => [
+ {
+ '+ahr' => {
+ hold_type => 'V',
+ target => $self->volume->id
+ }
+ },
+ {
+ '+ahr' => {
+ hold_type => 'T',
+ target => $self->title->id
+ }
+ },
+ ],
+ '+acp' => {
+ '-or' => [
+ {id => undef}, # left-join copy may be nonexistent
+ {status => {'!=' => OILS_COPY_STATUS_ON_HOLDS_SHELF}},
+ ]
+ }
+ },
+ order_by => {ahr => {request_time => {direction => 'asc'}}},
+ limit => 1
+ };
+
+ my $hold_info = $e->json_query($args)->[0];
+ return $e->retrieve_action_hold_request($hold_info->{id}) if $hold_info;
+ return undef;
+}
+
+
+sub run_checkout_scripts {
+ my $self = shift;
+ my $nobail = shift;
+
+ my $evt;
+ my $runner = $self->script_runner;
+
+ my $duration;
+ my $recurring;
+ my $max_fine;
+ my $hard_due_date;
+ my $duration_name;
+ my $recurring_name;
+ my $max_fine_name;
+ my $hard_due_date_name;
+
+ if(!$self->legacy_script_support) {
+ $self->run_indb_circ_test();
+ $duration = $self->circ_matrix_matchpoint->duration_rule;
+ $recurring = $self->circ_matrix_matchpoint->recurring_fine_rule;
+ $max_fine = $self->circ_matrix_matchpoint->max_fine_rule;
+ $hard_due_date = $self->circ_matrix_matchpoint->hard_due_date;
+
+ } else {
+
+ $runner->load($self->circ_duration);
+
+ my $result = $runner->run or
+ throw OpenSRF::EX::ERROR ("Circ Duration Script Died: $@");
+
+ $duration_name = $result->{durationRule};
+ $recurring_name = $result->{recurringFinesRule};
+ $max_fine_name = $result->{maxFine};
+ $hard_due_date_name = $result->{hardDueDate};
+ }
+
+ $duration_name = $duration->name if $duration;
+ if( $duration_name ne OILS_UNLIMITED_CIRC_DURATION ) {
+
+ unless($duration) {
+ ($duration, $evt) = $U->fetch_circ_duration_by_name($duration_name);
+ return $self->bail_on_events($evt) if ($evt && !$nobail);
+
+ ($recurring, $evt) = $U->fetch_recurring_fine_by_name($recurring_name);
+ return $self->bail_on_events($evt) if ($evt && !$nobail);
+
+ ($max_fine, $evt) = $U->fetch_max_fine_by_name($max_fine_name);
+ return $self->bail_on_events($evt) if ($evt && !$nobail);
+
+ if($hard_due_date_name) {
+ ($hard_due_date, $evt) = $U->fetch_hard_due_date_by_name($hard_due_date_name);
+ return $self->bail_on_events($evt) if ($evt && !$nobail);
+ }
+ }
+
+ } else {
+
+ # The item circulates with an unlimited duration
+ $duration = undef;
+ $recurring = undef;
+ $max_fine = undef;
+ $hard_due_date = undef;
+ }
+
+ $self->duration_rule($duration);
+ $self->recurring_fines_rule($recurring);
+ $self->max_fine_rule($max_fine);
+ $self->hard_due_date($hard_due_date);
+}
+
+
+sub build_checkout_circ_object {
+ my $self = shift;
+
+ my $circ = Fieldmapper::action::circulation->new;
+ my $duration = $self->duration_rule;
+ my $max = $self->max_fine_rule;
+ my $recurring = $self->recurring_fines_rule;
+ my $hard_due_date = $self->hard_due_date;
+ my $copy = $self->copy;
+ my $patron = $self->patron;
+ my $duration_date_ceiling;
+ my $duration_date_ceiling_force;
+
+ if( $duration ) {
+
+ my $policy = $self->get_circ_policy($duration, $recurring, $max, $hard_due_date);
+ $duration_date_ceiling = $policy->{duration_date_ceiling};
+ $duration_date_ceiling_force = $policy->{duration_date_ceiling_force};
+
+ my $dname = $duration->name;
+ my $mname = $max->name;
+ my $rname = $recurring->name;
+ my $hdname = '';
+ if($hard_due_date) {
+ $hdname = $hard_due_date->name;
+ }
+
+ $logger->debug("circulator: building circulation ".
+ "with duration=$dname, maxfine=$mname, recurring=$rname, hard due date=$hdname");
+
+ $circ->duration($policy->{duration});
+ $circ->recurring_fine($policy->{recurring_fine});
+ $circ->duration_rule($duration->name);
+ $circ->recurring_fine_rule($recurring->name);
+ $circ->max_fine_rule($max->name);
+ $circ->max_fine($policy->{max_fine});
+ $circ->fine_interval($recurring->recurrence_interval);
+ $circ->renewal_remaining($duration->max_renewals);
+
+ } else {
+
+ $logger->info("circulator: copy found with an unlimited circ duration");
+ $circ->duration_rule(OILS_UNLIMITED_CIRC_DURATION);
+ $circ->recurring_fine_rule(OILS_UNLIMITED_CIRC_DURATION);
+ $circ->max_fine_rule(OILS_UNLIMITED_CIRC_DURATION);
+ $circ->renewal_remaining(0);
+ }
+
+ $circ->target_copy( $copy->id );
+ $circ->usr( $patron->id );
+ $circ->circ_lib( $self->circ_lib );
+ $circ->workstation($self->editor->requestor->wsid)
+ if defined $self->editor->requestor->wsid;
+
+ # renewals maintain a link to the parent circulation
+ $circ->parent_circ($self->parent_circ);
+
+ if( $self->is_renewal ) {
+ $circ->opac_renewal('t') if $self->opac_renewal;
+ $circ->phone_renewal('t') if $self->phone_renewal;
+ $circ->desk_renewal('t') if $self->desk_renewal;
+ $circ->renewal_remaining($self->renewal_remaining);
+ $circ->circ_staff($self->editor->requestor->id);
+ }
+
+
+ # if the user provided an overiding checkout time,
+ # (e.g. the checkout really happened several hours ago), then
+ # we apply that here. Does this need a perm??
+ $circ->xact_start(cleanse_ISO8601($self->checkout_time))
+ if $self->checkout_time;
+
+ # if a patron is renewing, 'requestor' will be the patron
+ $circ->circ_staff($self->editor->requestor->id);
+ $circ->due_date( $self->create_due_date($circ->duration, $duration_date_ceiling, $duration_date_ceiling_force) ) if $circ->duration;
+
+ $self->circ($circ);
+}
+
+sub do_reservation_pickup {
+ my $self = shift;
+
+ $self->log_me("do_reservation_pickup()");
+
+ $self->reservation->pickup_time('now');
+
+ if (
+ $self->reservation->current_resource &&
+ $U->is_true($self->reservation->target_resource_type->catalog_item)
+ ) {
+ # We used to try to set $self->copy and $self->patron here,
+ # but that should already be done.
+
+ $self->run_checkout_scripts(1);
+
+ my $duration = $self->duration_rule;
+ my $max = $self->max_fine_rule;
+ my $recurring = $self->recurring_fines_rule;
+
+ if ($duration && $max && $recurring) {
+ my $policy = $self->get_circ_policy($duration, $recurring, $max);
+
+ my $dname = $duration->name;
+ my $mname = $max->name;
+ my $rname = $recurring->name;
+
+ $logger->debug("circulator: updating reservation ".
+ "with duration=$dname, maxfine=$mname, recurring=$rname");
+
+ $self->reservation->fine_amount($policy->{recurring_fine});
+ $self->reservation->max_fine($policy->{max_fine});
+ $self->reservation->fine_interval($recurring->recurrence_interval);
+ }
+
+ $self->copy->status(OILS_COPY_STATUS_CHECKED_OUT);
+ $self->update_copy();
+
+ } else {
+ $self->reservation->fine_amount(
+ $self->reservation->target_resource_type->fine_amount
+ );
+ $self->reservation->max_fine(
+ $self->reservation->target_resource_type->max_fine
+ );
+ $self->reservation->fine_interval(
+ $self->reservation->target_resource_type->fine_interval
+ );
+ }
+
+ $self->update_reservation();
+}
+
+sub do_reservation_return {
+ my $self = shift;
+ my $request = shift;
+
+ $self->log_me("do_reservation_return()");
+
+ if (not ref $self->reservation) {
+ my ($reservation, $evt) =
+ $U->fetch_booking_reservation($self->reservation);
+ return $self->bail_on_events($evt) if $evt;
+ $self->reservation($reservation);
+ }
+
+ $self->generate_fines(1);
+ $self->reservation->return_time('now');
+ $self->update_reservation();
+ $self->reshelve_copy if $self->copy;
+
+ if ( $self->reservation->current_resource && $self->reservation->current_resource->catalog_item ) {
+ $self->copy( $self->reservation->current_resource->catalog_item );
+ }
+}
+
+sub booking_adjusted_due_date {
+ my $self = shift;
+ my $circ = $self->circ;
+ my $copy = $self->copy;
+
+ return undef unless $self->use_booking;
+
+ my $changed;
+
+ if( $self->due_date ) {
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->allowed('CIRC_OVERRIDE_DUE_DATE', $self->circ_lib);
+
+ $circ->due_date(cleanse_ISO8601($self->due_date));
+
+ } else {
+
+ return unless $copy and $circ->due_date;
+ }
+
+ my $booking_items = $self->editor->search_booking_resource( { barcode => $copy->barcode } );
+ if (@$booking_items) {
+ my $booking_item = $booking_items->[0];
+ my $resource_type = $self->editor->retrieve_booking_resource_type( $booking_item->type );
+
+ my $stop_circ_setting = $U->ou_ancestor_setting_value( $self->circ_lib, 'circ.booking_reservation.stop_circ', $self->editor );
+ my $shorten_circ_setting = $resource_type->elbow_room ||
+ $U->ou_ancestor_setting_value( $self->circ_lib, 'circ.booking_reservation.default_elbow_room', $self->editor ) ||
+ '0 seconds';
+
+ my $booking_ses = OpenSRF::AppSession->create( 'open-ils.booking' );
+ my $bookings = $booking_ses->request(
+ 'open-ils.booking.reservations.filtered_id_list', $self->editor->authtoken,
+ { resource => $booking_item->id, search_start => 'now', search_end => $circ->due_date, fields => { cancel_time => undef }}
+ )->gather(1);
+ $booking_ses->disconnect;
+
+ my $dt_parser = DateTime::Format::ISO8601->new;
+ my $due_date = $dt_parser->parse_datetime( cleanse_ISO8601($circ->due_date) );
+
+ for my $bid (@$bookings) {
+
+ my $booking = $self->editor->retrieve_booking_reservation( $bid );
+
+ my $booking_start = $dt_parser->parse_datetime( cleanse_ISO8601($booking->start_time) );
+ my $booking_end = $dt_parser->parse_datetime( cleanse_ISO8601($booking->end_time) );
+
+ return $self->bail_on_events( OpenILS::Event->new('COPY_RESERVED') )
+ if ($booking_start < DateTime->now);
+
+
+ if ($U->is_true($stop_circ_setting)) {
+ $self->bail_on_events( OpenILS::Event->new('COPY_RESERVED') );
+ } else {
+ $due_date = $booking_start->subtract( seconds => interval_to_seconds($shorten_circ_setting) );
+ $self->bail_on_events( OpenILS::Event->new('COPY_RESERVED') ) if ($due_date < DateTime->now);
+ }
+
+ # We set the circ duration here only to affect the logic that will
+ # later (in a DB trigger) mangle the time part of the due date to
+ # 11:59pm. Having any circ duration that is not a whole number of
+ # days is enough to prevent the "correction."
+ my $new_circ_duration = $due_date->epoch - time;
+ $new_circ_duration++ if $new_circ_duration % 86400 == 0;
+ $circ->duration("$new_circ_duration seconds");
+
+ $circ->due_date(cleanse_ISO8601($due_date->strftime('%FT%T%z')));
+ $changed = 1;
+ }
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->allowed('CIRC_OVERRIDE_DUE_DATE', $self->circ_lib);
+ }
+
+ return $changed;
+}
+
+sub apply_modified_due_date {
+ my $self = shift;
+ my $shift_earlier = shift;
+ my $circ = $self->circ;
+ my $copy = $self->copy;
+
+ if( $self->due_date ) {
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->allowed('CIRC_OVERRIDE_DUE_DATE', $self->circ_lib);
+
+ $circ->due_date(cleanse_ISO8601($self->due_date));
+
+ } else {
+
+ # if the due_date lands on a day when the location is closed
+ return unless $copy and $circ->due_date;
+
+ #my $org = (ref $copy->circ_lib) ? $copy->circ_lib->id : $copy->circ_lib;
+
+ # due-date overlap should be determined by the location the item
+ # is checked out from, not the owning or circ lib of the item
+ my $org = $self->circ_lib;
+
+ $logger->info("circulator: circ searching for closed date overlap on lib $org".
+ " with an item due date of ".$circ->due_date );
+
+ my $dateinfo = $U->storagereq(
+ 'open-ils.storage.actor.org_unit.closed_date.overlap',
+ $org, $circ->due_date );
+
+ if($dateinfo) {
+ $logger->info("circulator: $dateinfo : circ due data / close date overlap found : due_date=".
+ $circ->due_date." start=". $dateinfo->{start}.", end=".$dateinfo->{end});
+
+ # XXX make the behavior more dynamic
+ # for now, we just push the due date to after the close date
+ if ($shift_earlier) {
+ $circ->due_date($dateinfo->{start});
+ } else {
+ $circ->due_date($dateinfo->{end});
+ }
+ }
+ }
+}
+
+
+
+sub create_due_date {
+ my( $self, $duration, $date_ceiling, $force_date ) = @_;
+
+ # if there is a raw time component (e.g. from postgres),
+ # turn it into an interval that interval_to_seconds can parse
+ $duration =~ s/(\d{2}):(\d{2}):(\d{2})/$1 h $2 m $3 s/o;
+
+ # for now, use the server timezone. TODO: use workstation org timezone
+ my $due_date = DateTime->now(time_zone => 'local');
+
+ # add the circ duration
+ $due_date->add(seconds => OpenSRF::Utils->interval_to_seconds($duration));
+
+ if($date_ceiling) {
+ my $cdate = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($date_ceiling));
+ if ($cdate > DateTime->now and ($cdate < $due_date or $U->is_true( $force_date ))) {
+ $logger->info("circulator: overriding due date with date ceiling: $date_ceiling");
+ $due_date = $cdate;
+ }
+ }
+
+ # return ISO8601 time with timezone
+ return $due_date->strftime('%FT%T%z');
+}
+
+
+
+sub make_precat_copy {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ if($copy) {
+ $logger->debug("circulator: Pre-cat copy already exists in checkout: ID=" . $copy->id);
+
+ $copy->editor($self->editor->requestor->id);
+ $copy->edit_date('now');
+ $copy->dummy_title($self->dummy_title || $copy->dummy_title || '');
+ $copy->dummy_isbn($self->dummy_isbn || $copy->dummy_isbn || '');
+ $copy->dummy_author($self->dummy_author || $copy->dummy_author || '');
+ $copy->circ_modifier($self->circ_modifier || $copy->circ_modifier);
+ $self->update_copy();
+ return;
+ }
+
+ $logger->info("circulator: Creating a new precataloged ".
+ "copy in checkout with barcode " . $self->copy_barcode);
+
+ $copy = Fieldmapper::asset::copy->new;
+ $copy->circ_lib($self->circ_lib);
+ $copy->creator($self->editor->requestor->id);
+ $copy->editor($self->editor->requestor->id);
+ $copy->barcode($self->copy_barcode);
+ $copy->call_number(OILS_PRECAT_CALL_NUMBER);
+ $copy->loan_duration(OILS_PRECAT_COPY_LOAN_DURATION);
+ $copy->fine_level(OILS_PRECAT_COPY_FINE_LEVEL);
+
+ $copy->dummy_title($self->dummy_title || "");
+ $copy->dummy_author($self->dummy_author || "");
+ $copy->dummy_isbn($self->dummy_isbn || "");
+ $copy->circ_modifier($self->circ_modifier);
+
+
+ # See if we need to override the circ_lib for the copy with a configured circ_lib
+ # Setting is shortname of the org unit
+ my $precat_circ_lib = $U->ou_ancestor_setting_value(
+ $self->circ_lib, 'circ.pre_cat_copy_circ_lib', $self->editor);
+
+ if($precat_circ_lib) {
+ my $org = $self->editor->search_actor_org_unit({shortname => $precat_circ_lib})->[0];
+
+ if(!$org) {
+ $self->bail_on_events($self->editor->event);
+ return;
+ }
+
+ $copy->circ_lib($org->id);
+ }
+
+
+ unless( $self->copy($self->editor->create_asset_copy($copy)) ) {
+ $self->bail_out(1);
+ $self->push_events($self->editor->event);
+ return;
+ }
+
+ # this is a little bit of a hack, but we need to
+ # get the copy into the script runner
+ $self->script_runner->insert("environment.copy", $copy, 1) if $self->script_runner;
+}
+
+
+sub checkout_noncat {
+ my $self = shift;
+
+ my $circ;
+ my $evt;
+
+ my $lib = $self->noncat_circ_lib || $self->circ_lib;
+ my $count = $self->noncat_count || 1;
+ my $cotime = cleanse_ISO8601($self->checkout_time) || "";
+
+ $logger->info("circulator: circ creating $count noncat circs with checkout time $cotime");
+
+ for(1..$count) {
+
+ ( $circ, $evt ) = OpenILS::Application::Circ::NonCat::create_non_cat_circ(
+ $self->editor->requestor->id,
+ $self->patron->id,
+ $lib,
+ $self->noncat_type,
+ $cotime,
+ $self->editor );
+
+ if( $evt ) {
+ $self->push_events($evt);
+ $self->bail_out(1);
+ return;
+ }
+ $self->circ($circ);
+ }
+}
+
+
+sub do_checkin {
+ my $self = shift;
+ $self->log_me("do_checkin()");
+
+ return $self->bail_on_events(
+ OpenILS::Event->new('ASSET_COPY_NOT_FOUND'))
+ unless $self->copy;
+
+ # the renew code and mk_env should have already found our circulation object
+ unless( $self->circ ) {
+
+ my $circs = $self->editor->search_action_circulation(
+ { target_copy => $self->copy->id, checkin_time => undef });
+
+ $self->circ($$circs[0]);
+
+ # for now, just warn if there are multiple open circs on a copy
+ $logger->warn("circulator: we have ".scalar(@$circs).
+ " open circs for copy " .$self->copy->id."!!") if @$circs > 1;
+ }
+
+ # run the fine generator against this circ, if this circ is there
+ $self->generate_fines_start if $self->circ;
+
+
+ if( $self->checkin_check_holds_shelf() ) {
+ $self->bail_on_events(OpenILS::Event->new('NO_CHANGE'));
+ $self->hold($U->fetch_open_hold_by_copy($self->copy->id));
+ $self->checkin_flesh_events;
+ return;
+ }
+
+ unless( $self->is_renewal ) {
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->allowed('COPY_CHECKIN');
+ }
+
+ $self->push_events($self->check_copy_alert());
+ $self->push_events($self->check_checkin_copy_status());
+
+ # if the circ is marked as 'claims returned', add the event to the list
+ $self->push_events(OpenILS::Event->new('CIRC_CLAIMS_RETURNED'))
+ if ($self->circ and $self->circ->stop_fines
+ and $self->circ->stop_fines eq OILS_STOP_FINES_CLAIMSRETURNED);
+
+ $self->check_circ_deposit();
+
+ # handle the overridable events
+ $self->override_events unless $self->is_renewal;
+ return if $self->bail_out;
+
+ if( $self->copy ) {
+ $self->transit(
+ $self->editor->search_action_transit_copy(
+ { target_copy => $self->copy->id, dest_recv_time => undef }
+ )->[0]
+ );
+ }
+
+ if( $self->circ ) {
+ $self->checkin_handle_circ;
+ return if $self->bail_out;
+ $self->checkin_changed(1);
+
+ } elsif( $self->transit ) {
+ my $hold_transit = $self->process_received_transit;
+ $self->checkin_changed(1);
+
+ if( $self->bail_out ) {
+ $self->checkin_flesh_events;
+ return;
+ }
+
+ if( my $e = $self->check_checkin_copy_status() ) {
+ # If the original copy status is special, alert the caller
+ my $ev = $self->events;
+ $self->events([$e]);
+ $self->override_events;
+ return if $self->bail_out;
+ $self->events($ev);
+ }
+
+ if( $hold_transit or
+ $U->copy_status($self->copy->status)->id
+ == OILS_COPY_STATUS_ON_HOLDS_SHELF ) {
+
+ my $hold;
+ if( $hold_transit ) {
+ $hold = $self->editor->retrieve_action_hold_request($hold_transit->hold);
+ } else {
+ ($hold) = $U->fetch_open_hold_by_copy($self->copy->id);
+ }
+
+ $self->hold($hold);
+
+ if( $hold and $hold->cancel_time ) { # this transited hold was cancelled mid-transit
+
+ $logger->info("circulator: we received a transit on a cancelled hold " . $hold->id);
+ $self->reshelve_copy(1);
+ $self->cancelled_hold_transit(1);
+ $self->notify_hold(0); # don't notify for cancelled holds
+ return if $self->bail_out;
+
+ } else {
+
+ # hold transited to correct location
+ $self->checkin_flesh_events;
+ return;
+ }
+ }
+
+ } elsif( $U->copy_status($self->copy->status)->id == OILS_COPY_STATUS_IN_TRANSIT ) {
+
+ $logger->warn("circulator: we have a copy ".$self->copy->barcode.
+ " that is in-transit, but there is no transit.. repairing");
+ $self->reshelve_copy(1);
+ return if $self->bail_out;
+ }
+
+ if( $self->is_renewal ) {
+ $self->push_events(OpenILS::Event->new('SUCCESS'));
+ return;
+ }
+
+ # ------------------------------------------------------------------------------
+ # Circulations and transits are now closed where necessary. Now go on to see if
+ # this copy can fulfill a hold or needs to be routed to a different location
+ # ------------------------------------------------------------------------------
+
+ my $needed_for_something = 0; # formerly "needed_for_hold"
+
+ if(!$self->noop) { # /not/ a no-op checkin, capture for hold or put item into transit
+
+ if (!$self->remote_hold) {
+ if ($self->use_booking) {
+ my $potential_hold = $self->hold_capture_is_possible;
+ my $potential_reservation = $self->reservation_capture_is_possible;
+
+ if ($potential_hold and $potential_reservation) {
+ $logger->info("circulator: item could fulfill either hold or reservation");
+ $self->push_events(new OpenILS::Event(
+ "HOLD_RESERVATION_CONFLICT",
+ "hold" => $potential_hold,
+ "reservation" => $potential_reservation
+ ));
+ return if $self->bail_out;
+ } elsif ($potential_hold) {
+ $needed_for_something =
+ $self->attempt_checkin_hold_capture;
+ } elsif ($potential_reservation) {
+ $needed_for_something =
+ $self->attempt_checkin_reservation_capture;
+ }
+ } else {
+ $needed_for_something = $self->attempt_checkin_hold_capture;
+ }
+ }
+ return if $self->bail_out;
+
+ unless($needed_for_something) {
+ my $circ_lib = (ref $self->copy->circ_lib) ?
+ $self->copy->circ_lib->id : $self->copy->circ_lib;
+
+ if( $self->remote_hold ) {
+ $circ_lib = $self->remote_hold->pickup_lib;
+ $logger->warn("circulator: Copy ".$self->copy->barcode.
+ " is on a remote hold's shelf, sending to $circ_lib");
+ }
+
+ $logger->debug("circulator: circlib=$circ_lib, workstation=".$self->circ_lib);
+
+ if( $circ_lib == $self->circ_lib) {
+ # copy is where it needs to be, either for hold or reshelving
+
+ $self->checkin_handle_precat();
+ return if $self->bail_out;
+
+ } else {
+ # copy needs to transit "home", or stick here if it's a floating copy
+
+ if ($U->is_true( $self->copy->floating ) && !$self->remote_hold) { # copy is floating, stick here
+ $self->checkin_changed(1);
+ $self->copy->circ_lib( $self->circ_lib );
+ $self->update_copy;
+ } else {
+ my $bc = $self->copy->barcode;
+ $logger->info("circulator: copy $bc at the wrong location, sending to $circ_lib");
+ $self->checkin_build_copy_transit($circ_lib);
+ return if $self->bail_out;
+ $self->push_events(OpenILS::Event->new('ROUTE_ITEM', org => $circ_lib));
+ }
+ }
+ }
+ } else { # no-op checkin
+ if ($U->is_true( $self->copy->floating )) { # XXX floating items still stick where they are even with no-op checkin?
+ $self->checkin_changed(1);
+ $self->copy->circ_lib( $self->circ_lib );
+ $self->update_copy;
+ }
+ }
+
+ if($self->claims_never_checked_out and
+ $U->ou_ancestor_setting_value($self->circ->circ_lib, 'circ.claim_never_checked_out.mark_missing')) {
+
+ # the item was not supposed to be checked out to the user and should now be marked as missing
+ $self->copy->status(OILS_COPY_STATUS_MISSING);
+ $self->update_copy;
+
+ } else {
+ $self->reshelve_copy unless $needed_for_something;
+ }
+
+ return if $self->bail_out;
+
+ unless($self->checkin_changed) {
+
+ $self->push_events(OpenILS::Event->new('NO_CHANGE'));
+ my $stat = $U->copy_status($self->copy->status)->id;
+
+ $self->hold($U->fetch_open_hold_by_copy($self->copy->id))
+ if( $stat == OILS_COPY_STATUS_ON_HOLDS_SHELF );
+ $self->bail_out(1); # no need to commit anything
+
+ } else {
+
+ $self->push_events(OpenILS::Event->new('SUCCESS'))
+ unless @{$self->events};
+ }
+
+ # gather any updates to the circ after fine generation, if there was a circ
+ $self->generate_fines_finish if ($self->circ);
+
+ OpenILS::Utils::Penalty->calculate_penalties(
+ $self->editor, $self->patron->id, $self->circ_lib) if $self->patron;
+
+ $self->checkin_flesh_events;
+ return;
+}
+
+# if a deposit was payed for this item, push the event
+sub check_circ_deposit {
+ my $self = shift;
+ return unless $self->circ;
+ my $deposit = $self->editor->search_money_billing(
+ { btype => 5,
+ xact => $self->circ->id,
+ voided => 'f'
+ }, {idlist => 1})->[0];
+
+ $self->push_events(OpenILS::Event->new(
+ 'ITEM_DEPOSIT_PAID', payload => $deposit)) if $deposit;
+}
+
+sub reshelve_copy {
+ my $self = shift;
+ my $force = $self->force || shift;
+ my $copy = $self->copy;
+
+ my $stat = $U->copy_status($copy->status)->id;
+
+ if($force || (
+ $stat != OILS_COPY_STATUS_ON_HOLDS_SHELF and
+ $stat != OILS_COPY_STATUS_CATALOGING and
+ $stat != OILS_COPY_STATUS_IN_TRANSIT and
+ $stat != OILS_COPY_STATUS_RESHELVING )) {
+
+ $copy->status( OILS_COPY_STATUS_RESHELVING );
+ $self->update_copy;
+ $self->checkin_changed(1);
+ }
+}
+
+
+# Returns true if the item is at the current location
+# because it was transited there for a hold and the
+# hold has not been fulfilled
+sub checkin_check_holds_shelf {
+ my $self = shift;
+ return 0 unless $self->copy;
+
+ return 0 unless
+ $U->copy_status($self->copy->status)->id ==
+ OILS_COPY_STATUS_ON_HOLDS_SHELF;
+
+ # find the hold that put us on the holds shelf
+ my $holds = $self->editor->search_action_hold_request(
+ {
+ current_copy => $self->copy->id,
+ capture_time => { '!=' => undef },
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ );
+
+ unless(@$holds) {
+ $logger->warn("circulator: copy is on-holds-shelf, but there is no hold - reshelving");
+ $self->reshelve_copy(1);
+ return 0;
+ }
+
+ my $hold = $$holds[0];
+
+ $logger->info("circulator: we found a captured, un-fulfilled hold [".
+ $hold->id. "] for copy ".$self->copy->barcode);
+
+ if( $hold->pickup_lib == $self->circ_lib ) {
+ $logger->info("circulator: hold is for here .. we're done: ".$self->copy->barcode);
+ return 1;
+ }
+
+ $logger->info("circulator: hold is not for here..");
+ $self->remote_hold($hold);
+ return 0;
+}
+
+
+sub checkin_handle_precat {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ if( $self->is_precat and ($copy->status != OILS_COPY_STATUS_CATALOGING) ) {
+ $copy->status(OILS_COPY_STATUS_CATALOGING);
+ $self->update_copy();
+ $self->checkin_changed(1);
+ $self->push_events(OpenILS::Event->new('ITEM_NOT_CATALOGED'));
+ }
+}
+
+
+sub checkin_build_copy_transit {
+ my $self = shift;
+ my $dest = shift;
+ my $copy = $self->copy;
+ my $transit = Fieldmapper::action::transit_copy->new;
+
+ #$dest ||= (ref($copy->circ_lib)) ? $copy->circ_lib->id : $copy->circ_lib;
+ $logger->info("circulator: transiting copy to $dest");
+
+ $transit->source($self->circ_lib);
+ $transit->dest($dest);
+ $transit->target_copy($copy->id);
+ $transit->source_send_time('now');
+ $transit->copy_status( $U->copy_status($copy->status)->id );
+
+ $logger->debug("circulator: setting copy status on transit: ".$transit->copy_status);
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->create_action_transit_copy($transit);
+
+ $copy->status(OILS_COPY_STATUS_IN_TRANSIT);
+ $self->update_copy;
+ $self->checkin_changed(1);
+}
+
+
+sub hold_capture_is_possible {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ # we've been explicitly told not to capture any holds
+ return 0 if $self->capture eq 'nocapture';
+
+ # See if this copy can fulfill any holds
+ my $hold = $holdcode->find_nearest_permitted_hold(
+ $self->editor, $copy, $self->editor->requestor, 1 # check_only
+ );
+ return undef if ref $hold eq "HASH" and
+ $hold->{"textcode"} eq "ACTION_HOLD_REQUEST_NOT_FOUND";
+ return $hold;
+}
+
+sub reservation_capture_is_possible {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ # we've been explicitly told not to capture any holds
+ return 0 if $self->capture eq 'nocapture';
+
+ my $booking_ses = OpenSRF::AppSession->connect("open-ils.booking");
+ my $resv = $booking_ses->request(
+ "open-ils.booking.reservations.could_capture",
+ $self->editor->authtoken, $copy->barcode
+ )->gather(1);
+ $booking_ses->disconnect;
+ if (ref($resv) eq "HASH" and exists $resv->{"textcode"}) {
+ $self->push_events($resv);
+ } else {
+ return $resv;
+ }
+}
+
+# returns true if the item was used (or may potentially be used
+# in subsequent calls) to capture a hold.
+sub attempt_checkin_hold_capture {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ # we've been explicitly told not to capture any holds
+ return 0 if $self->capture eq 'nocapture';
+
+ # See if this copy can fulfill any holds
+ my ($hold, undef, $retarget) = $holdcode->find_nearest_permitted_hold(
+ $self->editor, $copy, $self->editor->requestor );
+
+ if(!$hold) {
+ $logger->debug("circulator: no potential permitted".
+ "holds found for copy ".$copy->barcode);
+ return 0;
+ }
+
+ if($self->capture ne 'capture') {
+ # see if this item is in a hold-capture-delay location
+ my $location = $self->editor->retrieve_asset_copy_location($self->copy->location);
+ if($U->is_true($location->hold_verify)) {
+ $self->bail_on_events(
+ OpenILS::Event->new('HOLD_CAPTURE_DELAYED', copy_location => $location));
+ return 1;
+ }
+ }
+
+ $self->retarget($retarget);
+
+ $logger->info("circulator: found permitted hold ".$hold->id." for copy, capturing...");
+
+ $hold->current_copy($copy->id);
+ $hold->capture_time('now');
+ $self->put_hold_on_shelf($hold)
+ if $hold->pickup_lib == $self->circ_lib;
+
+ # prevent DB errors caused by fetching
+ # holds from storage, and updating through cstore
+ $hold->clear_fulfillment_time;
+ $hold->clear_fulfillment_staff;
+ $hold->clear_fulfillment_lib;
+ $hold->clear_expire_time;
+ $hold->clear_cancel_time;
+ $hold->clear_prev_check_time unless $hold->prev_check_time;
+
+ $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_action_hold_request($hold);
+ $self->hold($hold);
+ $self->checkin_changed(1);
+
+ return 0 if $self->bail_out;
+
+ if( $hold->pickup_lib == $self->circ_lib ) {
+
+ # This hold was captured in the correct location
+ $copy->status(OILS_COPY_STATUS_ON_HOLDS_SHELF);
+ $self->push_events(OpenILS::Event->new('SUCCESS'));
+
+ #$self->do_hold_notify($hold->id);
+ $self->notify_hold($hold->id);
+
+ } else {
+
+ # Hold needs to be picked up elsewhere. Build a hold
+ # transit and route the item.
+ $self->checkin_build_hold_transit();
+ $copy->status(OILS_COPY_STATUS_IN_TRANSIT);
+ return 0 if $self->bail_out;
+ $self->push_events(OpenILS::Event->new('ROUTE_ITEM', org => $hold->pickup_lib));
+ }
+
+ # make sure we save the copy status
+ $self->update_copy;
+ return 1;
+}
+
+sub attempt_checkin_reservation_capture {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ # we've been explicitly told not to capture any holds
+ return 0 if $self->capture eq 'nocapture';
+
+ my $booking_ses = OpenSRF::AppSession->connect("open-ils.booking");
+ my $evt = $booking_ses->request(
+ "open-ils.booking.resources.capture_for_reservation",
+ $self->editor->authtoken,
+ $copy->barcode,
+ 1 # don't update copy - we probably have it locked
+ )->gather(1);
+ $booking_ses->disconnect;
+
+ if (ref($evt) ne "HASH" or not exists $evt->{"textcode"}) {
+ $logger->warn(
+ "open-ils.booking.resources.capture_for_reservation " .
+ "didn't return an event!"
+ );
+ } else {
+ if (
+ $evt->{"textcode"} eq "RESERVATION_NOT_FOUND" and
+ $evt->{"payload"}->{"fail_cause"} eq "not-transferable"
+ ) {
+ # not-transferable is an error event we'll pass on the user
+ $logger->warn("reservation capture attempted against non-transferable item");
+ $self->push_events($evt);
+ return 0;
+ } elsif ($evt->{"textcode"} eq "SUCCESS") {
+ # Re-retrieve copy as reservation capture may have changed
+ # its status and whatnot.
+ $logger->info(
+ "circulator: booking capture win on copy " . $self->copy->id
+ );
+ if (my $new_copy_status = $evt->{"payload"}->{"new_copy_status"}) {
+ $logger->info(
+ "circulator: changing copy " . $self->copy->id .
+ "'s status from " . $self->copy->status . " to " .
+ $new_copy_status
+ );
+ $self->copy->status($new_copy_status);
+ $self->update_copy;
+ }
+ $self->reservation($evt->{"payload"}->{"reservation"});
+
+ if (exists $evt->{"payload"}->{"transit"}) {
+ $self->push_events(
+ new OpenILS::Event(
+ "ROUTE_ITEM",
+ "org" => $evt->{"payload"}->{"transit"}->dest
+ )
+ );
+ }
+ $self->checkin_changed(1);
+ return 1;
+ }
+ }
+ # other results are treated as "nothing to capture"
+ return 0;
+}
+
+sub do_hold_notify {
+ my( $self, $holdid ) = @_;
+
+ my $e = new_editor(xact => 1);
+ my $hold = $e->retrieve_action_hold_request($holdid) or return $e->die_event;
+ $e->rollback;
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'hold.available', $hold, $hold->pickup_lib);
+
+ $logger->info("circulator: running delayed hold notify process");
+
+# my $notifier = OpenILS::Application::Circ::HoldNotify->new(
+# hold_id => $holdid, editor => new_editor(requestor=>$self->editor->requestor));
+
+ my $notifier = OpenILS::Application::Circ::HoldNotify->new(
+ hold_id => $holdid, requestor => $self->editor->requestor);
+
+ $logger->debug("circulator: built hold notifier");
+
+ if(!$notifier->event) {
+
+ $logger->info("circulator: attempt at sending hold notification for hold $holdid");
+
+ my $stat = $notifier->send_email_notify;
+ if( $stat == '1' ) {
+ $logger->info("circulator: hold notify succeeded for hold $holdid");
+ return;
+ }
+
+ $logger->debug("circulator: * hold notify cancelled or failed for hold $holdid");
+
+ } else {
+ $logger->info("circulator: Not sending hold notification since the patron has no email address");
+ }
+}
+
+sub retarget_holds {
+ my $self = shift;
+ $logger->info("circulator: retargeting holds @{$self->retarget} after opportunistic capture");
+ my $ses = OpenSRF::AppSession->create('open-ils.storage');
+ $ses->request('open-ils.storage.action.hold_request.copy_targeter', undef, $self->retarget);
+ # no reason to wait for the return value
+ return;
+}
+
+sub checkin_build_hold_transit {
+ my $self = shift;
+
+ my $copy = $self->copy;
+ my $hold = $self->hold;
+ my $trans = Fieldmapper::action::hold_transit_copy->new;
+
+ $logger->debug("circulator: building hold transit for ".$copy->barcode);
+
+ $trans->hold($hold->id);
+ $trans->source($self->circ_lib);
+ $trans->dest($hold->pickup_lib);
+ $trans->source_send_time("now");
+ $trans->target_copy($copy->id);
+
+ # when the copy gets to its destination, it will recover
+ # this status - put it onto the holds shelf
+ $trans->copy_status(OILS_COPY_STATUS_ON_HOLDS_SHELF);
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->create_action_hold_transit_copy($trans);
+}
+
+
+
+sub process_received_transit {
+ my $self = shift;
+ my $copy = $self->copy;
+ my $copyid = $self->copy->id;
+
+ my $status_name = $U->copy_status($copy->status)->name;
+ $logger->debug("circulator: attempting transit receive on ".
+ "copy $copyid. Copy status is $status_name");
+
+ my $transit = $self->transit;
+
+ if( $transit->dest != $self->circ_lib ) {
+ # - this item is in-transit to a different location
+
+ my $tid = $transit->id;
+ my $loc = $self->circ_lib;
+ my $dest = $transit->dest;
+
+ $logger->info("circulator: Fowarding transit on copy which is destined ".
+ "for a different location. transit=$tid, copy=$copyid, current ".
+ "location=$loc, destination location=$dest");
+
+ my $evt = OpenILS::Event->new('ROUTE_ITEM', org => $dest, payload => {});
+
+ # grab the associated hold object if available
+ my $ht = $self->editor->retrieve_action_hold_transit_copy($tid);
+ $self->hold($self->editor->retrieve_action_hold_request($ht->hold)) if $ht;
+
+ return $self->bail_on_events($evt);
+ }
+
+ # The transit is received, set the receive time
+ $transit->dest_recv_time('now');
+ $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_action_transit_copy($transit);
+
+ my $hold_transit = $self->editor->retrieve_action_hold_transit_copy($transit->id);
+
+ $logger->info("circulator: Recovering original copy status in transit: ".$transit->copy_status);
+ $copy->status( $transit->copy_status );
+ $self->update_copy();
+ return if $self->bail_out;
+
+ my $ishold = 0;
+ if($hold_transit) {
+ my $hold = $self->editor->retrieve_action_hold_request($hold_transit->hold);
+
+ # hold has arrived at destination, set shelf time
+ $self->put_hold_on_shelf($hold);
+ $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_action_hold_request($hold);
+ return if $self->bail_out;
+
+ $self->notify_hold($hold_transit->hold);
+ $ishold = 1;
+ }
+
+ $self->push_events(
+ OpenILS::Event->new(
+ 'SUCCESS',
+ ishold => $ishold,
+ payload => { transit => $transit, holdtransit => $hold_transit } ));
+
+ return $hold_transit;
+}
+
+
+# ------------------------------------------------------------------
+# Sets the shelf_time and shelf_expire_time for a newly shelved hold
+# ------------------------------------------------------------------
+sub put_hold_on_shelf {
+ my($self, $hold) = @_;
+
+ $hold->shelf_time('now');
+
+ my $shelf_expire = $U->ou_ancestor_setting_value(
+ $self->circ_lib, 'circ.holds.default_shelf_expire_interval', $self->editor);
+
+ if($shelf_expire) {
+ my $seconds = OpenSRF::Utils->interval_to_seconds($shelf_expire);
+ my $expire_time = DateTime->now->add(seconds => $seconds);
+ $hold->shelf_expire_time($expire_time->strftime('%FT%T%z'));
+ }
+
+ return undef;
+}
+
+
+
+sub generate_fines {
+ my $self = shift;
+ my $reservation = shift;
+
+ $self->generate_fines_start($reservation);
+ $self->generate_fines_finish($reservation);
+
+ return undef;
+}
+
+sub generate_fines_start {
+ my $self = shift;
+ my $reservation = shift;
+
+ my $id = $reservation ? $self->reservation->id : $self->circ->id;
+
+ if (!exists($self->{_gen_fines_req})) {
+ $self->{_gen_fines_req} = OpenSRF::AppSession->create('open-ils.storage')
+ ->request(
+ 'open-ils.storage.action.circulation.overdue.generate_fines',
+ undef,
+ $id
+ );
+ }
+
+ return undef;
+}
+
+sub generate_fines_finish {
+ my $self = shift;
+ my $reservation = shift;
+
+ my $id = $reservation ? $self->reservation->id : $self->circ->id;
+
+ $self->{_gen_fines_req}->wait_complete;
+ delete($self->{_gen_fines_req});
+
+ # refresh the circ in case the fine generator set the stop_fines field
+ $self->reservation($self->editor->retrieve_booking_reservation($id)) if $reservation;
+ $self->circ($self->editor->retrieve_action_circulation($id)) if !$reservation;
+
+ return undef;
+}
+
+sub checkin_handle_circ {
+ my $self = shift;
+ my $circ = $self->circ;
+ my $copy = $self->copy;
+ my $evt;
+ my $obt;
+
+ $self->backdate($circ->xact_start) if $self->claims_never_checked_out;
+
+ # backdate the circ if necessary
+ if($self->backdate) {
+ my $evt = $self->checkin_handle_backdate;
+ return $self->bail_on_events($evt) if $evt;
+ }
+
+ if($self->void_overdues) {
+ my $evt = OpenILS::Application::Circ::CircCommon->void_overdues(
+ $self->editor, $circ, undef, 'System: Amnesty Checkin'); # TODO i18n for system-generated notes
+ return $self->bail_on_events($evt) if $evt;
+ }
+
+ if(!$circ->stop_fines) {
+ $circ->stop_fines(OILS_STOP_FINES_CHECKIN);
+ $circ->stop_fines(OILS_STOP_FINES_RENEW) if $self->is_renewal;
+ $circ->stop_fines(OILS_STOP_FINES_CLAIMS_NEVERCHECKEDOUT) if $self->claims_never_checked_out;
+ $circ->stop_fines_time('now');
+ $circ->stop_fines_time($self->backdate) if $self->backdate;
+ }
+
+ # Set the checkin vars since we have the item
+ $circ->checkin_time( ($self->backdate) ? $self->backdate : 'now' );
+
+ # capture the true scan time for back-dated checkins
+ $circ->checkin_scan_time('now');
+
+ $circ->checkin_staff($self->editor->requestor->id);
+ $circ->checkin_lib($self->circ_lib);
+ $circ->checkin_workstation($self->editor->requestor->wsid);
+
+ my $circ_lib = (ref $self->copy->circ_lib) ?
+ $self->copy->circ_lib->id : $self->copy->circ_lib;
+ my $stat = $U->copy_status($self->copy->status)->id;
+
+ # immediately available keeps items lost or missing items from going home before being handled
+ my $lost_immediately_available = $U->ou_ancestor_setting_value(
+ $circ_lib, OILS_SETTING_LOST_IMMEDIATELY_AVAILABLE, $self->editor) || 0;
+
+
+ if ( (!$lost_immediately_available) && ($circ_lib != $self->circ_lib) ) {
+
+ if( ($stat == OILS_COPY_STATUS_LOST or $stat == OILS_COPY_STATUS_MISSING) ) {
+ $logger->info("circulator: not updating copy status on checkin because copy is lost/missing");
+ } else {
+ $self->copy->status($U->copy_status(OILS_COPY_STATUS_RESHELVING));
+ $self->update_copy;
+ }
+
+ } elsif ($stat == OILS_COPY_STATUS_LOST) {
+
+ $self->checkin_handle_lost($circ_lib);
+
+ } else {
+
+ $self->copy->status($U->copy_status(OILS_COPY_STATUS_RESHELVING));
+ $self->update_copy;
+ }
+
+
+ # see if there are any fines owed on this circ. if not, close it
+ ($obt) = $U->fetch_mbts($circ->id, $self->editor);
+ $circ->xact_finish('now') if( $obt and $obt->balance_owed == 0 );
+
+ $logger->debug("circulator: ".$obt->balance_owed." is owed on this circulation");
+
+ return $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_action_circulation($circ);
+
+ # make sure the circ isn't closed if we just voided some fines
+ $evt = OpenILS::Application::Circ::CircCommon->reopen_xact($self->editor, $circ->id);
+ return $self->bail_on_events($evt) if $evt;
+
+ return undef;
+}
+
+
+# ------------------------------------------------------------------
+# See if we need to void billings for lost checkin
+# ------------------------------------------------------------------
+sub checkin_handle_lost {
+ my $self = shift;
+ my $circ_lib = shift;
+ my $circ = $self->circ;
+
+ my $max_return = $U->ou_ancestor_setting_value(
+ $circ_lib, OILS_SETTING_MAX_ACCEPT_RETURN_OF_LOST, $self->editor) || 0;
+
+ if ($max_return) {
+
+ my $today = time();
+ my @tm = reverse($circ->due_date =~ /([\d\.]+)/og);
+ $tm[5] -= 1 if $tm[5] > 0;
+ my $due = timelocal(int($tm[1]), int($tm[2]), int($tm[3]), int($tm[4]), int($tm[5]), int($tm[6]));
+
+ my $last_chance = OpenSRF::Utils->interval_to_seconds($max_return) + int($due);
+ $logger->info("MAX OD: ".$max_return." DUEDATE: ".$circ->due_date." TODAY: ".$today." DUE: ".$due." LAST: ".$last_chance);
+
+ $max_return = 0 if $today < $last_chance;
+ }
+
+ if (!$max_return){ # there's either no max time to accept returns defined or we're within that time
+
+ my $void_lost = $U->ou_ancestor_setting_value(
+ $circ_lib, OILS_SETTING_VOID_LOST_ON_CHECKIN, $self->editor) || 0;
+ my $void_lost_fee = $U->ou_ancestor_setting_value(
+ $circ_lib, OILS_SETTING_VOID_LOST_PROCESS_FEE_ON_CHECKIN, $self->editor) || 0;
+ my $restore_od = $U->ou_ancestor_setting_value(
+ $circ_lib, OILS_SETTING_RESTORE_OVERDUE_ON_LOST_RETURN, $self->editor) || 0;
+
+ $self->checkin_handle_lost_now_found(3) if $void_lost;
+ $self->checkin_handle_lost_now_found(4) if $void_lost_fee;
+ $self->checkin_handle_lost_now_found_restore_od() if $restore_od && ! $self->void_overdues;
+ }
+
+ $self->copy->status($U->copy_status(OILS_COPY_STATUS_RESHELVING));
+ $self->update_copy;
+}
+
+
+sub checkin_handle_backdate {
+ my $self = shift;
+
+ # ------------------------------------------------------------------
+ # clean up the backdate for date comparison
+ # XXX We are currently taking the due-time from the original due-date,
+ # not the input. Do we need to do this? This certainly interferes with
+ # backdating of hourly checkouts, but that is likely a very rare case.
+ # ------------------------------------------------------------------
+ my $bd = cleanse_ISO8601($self->backdate);
+ my $original_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($self->circ->due_date));
+ my $new_date = DateTime::Format::ISO8601->new->parse_datetime($bd);
+ $bd = cleanse_ISO8601($new_date->ymd . 'T' . $original_date->strftime('%T%z'));
+
+ $self->backdate($bd);
+
+ my $evt = OpenILS::Application::Circ::CircCommon->void_overdues($self->editor, $self->circ, $bd);
+ return $evt if $evt;
+
+ return undef;
+}
+
+
+sub check_checkin_copy_status {
+ my $self = shift;
+ my $copy = $self->copy;
+
+ my $status = $U->copy_status($copy->status)->id;
+
+ return undef
+ if( $status == OILS_COPY_STATUS_AVAILABLE ||
+ $status == OILS_COPY_STATUS_CHECKED_OUT ||
+ $status == OILS_COPY_STATUS_IN_PROCESS ||
+ $status == OILS_COPY_STATUS_ON_HOLDS_SHELF ||
+ $status == OILS_COPY_STATUS_IN_TRANSIT ||
+ $status == OILS_COPY_STATUS_CATALOGING ||
+ $status == OILS_COPY_STATUS_ON_RESV_SHELF ||
+ $status == OILS_COPY_STATUS_RESHELVING );
+
+ return OpenILS::Event->new('COPY_STATUS_LOST', payload => $copy )
+ if( $status == OILS_COPY_STATUS_LOST );
+
+ return OpenILS::Event->new('COPY_STATUS_MISSING', payload => $copy )
+ if( $status == OILS_COPY_STATUS_MISSING );
+
+ return OpenILS::Event->new('COPY_BAD_STATUS', payload => $copy );
+}
+
+
+
+# --------------------------------------------------------------------------
+# On checkin, we need to return as many relevant objects as we can
+# --------------------------------------------------------------------------
+sub checkin_flesh_events {
+ my $self = shift;
+
+ if( grep { $_->{textcode} eq 'SUCCESS' } @{$self->events}
+ and grep { $_->{textcode} eq 'ITEM_NOT_CATALOGED' } @{$self->events} ) {
+ $self->events([grep { $_->{textcode} eq 'ITEM_NOT_CATALOGED' } @{$self->events}]);
+ }
+
+ my $record = $U->record_to_mvr($self->title) if($self->title and !$self->is_precat);
+
+ my $hold;
+ if($self->hold and !$self->hold->cancel_time) {
+ $hold = $self->hold;
+ $hold->notes($self->editor->search_action_hold_request_note({hold => $hold->id}));
+ }
+
+ if($self->circ) {
+ # if we checked in a circulation, flesh the billing summary data
+ $self->circ->billable_transaction(
+ $self->editor->retrieve_money_billable_transaction([
+ $self->circ->id,
+ {flesh => 1, flesh_fields => {mbt => ['summary']}}
+ ])
+ );
+ }
+
+ if($self->patron) {
+ # flesh some patron fields before returning
+ $self->patron(
+ $self->editor->retrieve_actor_user([
+ $self->patron->id,
+ {
+ flesh => 1,
+ flesh_fields => {
+ au => ['card', 'billing_address', 'mailing_address']
+ }
+ }
+ ])
+ );
+ }
+
+ for my $evt (@{$self->events}) {
+
+ my $payload = {};
+ $payload->{copy} = $U->unflesh_copy($self->copy);
+ $payload->{record} = $record,
+ $payload->{circ} = $self->circ;
+ $payload->{transit} = $self->transit;
+ $payload->{cancelled_hold_transit} = 1 if $self->cancelled_hold_transit;
+ $payload->{hold} = $hold;
+ $payload->{patron} = $self->patron;
+ $payload->{reservation} = $self->reservation
+ unless (not $self->reservation or $self->reservation->cancel_time);
+
+ $evt->{payload} = $payload;
+ }
+}
+
+sub log_me {
+ my( $self, $msg ) = @_;
+ my $bc = ($self->copy) ? $self->copy->barcode :
+ $self->barcode;
+ $bc ||= "";
+ my $usr = ($self->patron) ? $self->patron->id : "";
+ $logger->info("circulator: $msg requestor=".$self->editor->requestor->id.
+ ", recipient=$usr, copy=$bc");
+}
+
+
+sub do_renew {
+ my $self = shift;
+ $self->log_me("do_renew()");
+
+ # Make sure there is an open circ to renew that is not
+ # marked as LOST, CLAIMSRETURNED, or LONGOVERDUE
+ my $usrid = $self->patron->id if $self->patron;
+ my $circ = $self->editor->search_action_circulation({
+ target_copy => $self->copy->id,
+ xact_finish => undef,
+ ($usrid ? (usr => $usrid) : ()),
+ '-or' => [
+ {stop_fines => undef},
+ {stop_fines => OILS_STOP_FINES_MAX_FINES}
+ ]
+ })->[0];
+
+ return $self->bail_on_events($self->editor->event) unless $circ;
+
+ # A user is not allowed to renew another user's items without permission
+ unless( $circ->usr eq $self->editor->requestor->id ) {
+ return $self->bail_on_events($self->editor->events)
+ unless $self->editor->allowed('RENEW_CIRC', $circ->circ_lib);
+ }
+
+ $self->push_events(OpenILS::Event->new('MAX_RENEWALS_REACHED'))
+ if $circ->renewal_remaining < 1;
+
+ # -----------------------------------------------------------------
+
+ $self->parent_circ($circ->id);
+ $self->renewal_remaining( $circ->renewal_remaining - 1 );
+ $self->circ($circ);
+
+ # Run the fine generator against the old circ
+ $self->generate_fines_start;
+
+ $self->run_renew_permit;
+
+ # Check the item in
+ $self->do_checkin();
+ return if $self->bail_out;
+
+ unless( $self->permit_override ) {
+ $self->do_permit();
+ return if $self->bail_out;
+ $self->is_precat(1) if $self->have_event('ITEM_NOT_CATALOGED');
+ $self->remove_event('ITEM_NOT_CATALOGED');
+ }
+
+ $self->override_events;
+ return if $self->bail_out;
+
+ $self->events([]);
+ $self->do_checkout();
+}
+
+
+sub remove_event {
+ my( $self, $evt ) = @_;
+ $evt = (ref $evt) ? $evt->{textcode} : $evt;
+ $logger->debug("circulator: removing event from list: $evt");
+ my @events = @{$self->events};
+ $self->events( [ grep { $_->{textcode} ne $evt } @events ] );
+}
+
+
+sub have_event {
+ my( $self, $evt ) = @_;
+ $evt = (ref $evt) ? $evt->{textcode} : $evt;
+ return grep { $_->{textcode} eq $evt } @{$self->events};
+}
+
+
+
+sub run_renew_permit {
+ my $self = shift;
+
+ if ($U->ou_ancestor_setting_value($self->circ_lib, 'circ.block_renews_for_holds')) {
+ my ($hold, undef, $retarget) = $holdcode->find_nearest_permitted_hold(
+ $self->editor, $self->copy, $self->editor->requestor, 1
+ );
+ $self->push_events(new OpenILS::Event("COPY_NEEDED_FOR_HOLD")) if $hold;
+ }
+
+ if(!$self->legacy_script_support) {
+ my $results = $self->run_indb_circ_test;
+ $self->push_events($self->matrix_test_result_events)
+ unless $self->circ_test_success;
+ } else {
+
+ my $runner = $self->script_runner;
+
+ $runner->load($self->circ_permit_renew);
+ my $result = $runner->run or
+ throw OpenSRF::EX::ERROR ("Circ Permit Renew Script Died: $@");
+ if ($result->{"events"}) {
+ $self->push_events(
+ map { new OpenILS::Event($_) } @{$result->{"events"}}
+ );
+ $logger->activity(
+ "circulator: circ_permit_renew for user " .
+ $self->patron->id . " returned " .
+ scalar(@{$result->{"events"}}) . " event(s)"
+ );
+ }
+
+ $self->mk_script_runner;
+ }
+
+ $logger->debug("circulator: re-creating script runner to be safe");
+}
+
+
+# XXX: The primary mechanism for storing circ history is now handled
+# by tracking real circulation objects instead of bibs in a bucket.
+# However, this code is disabled by default and could be useful
+# some day, so may as well leave it for now.
+sub append_reading_list {
+ my $self = shift;
+
+ return undef unless
+ $self->is_checkout and
+ $self->patron and
+ $self->copy and
+ !$self->is_noncat;
+
+
+ # verify history is globally enabled and uses the bucket mechanism
+ my $htype = OpenSRF::Utils::SettingsClient->new->config_value(
+ apps => 'open-ils.circ' => app_settings => 'checkout_history_mechanism');
+
+ return undef unless $htype and $htype eq 'bucket';
+
+ my $e = new_editor(xact => 1, requestor => $self->editor->requestor);
+
+ # verify the patron wants to retain the hisory
+ my $setting = $e->search_actor_user_setting(
+ {usr => $self->patron->id, name => 'circ.keep_checkout_history'})->[0];
+
+ unless($setting and $setting->value) {
+ $e->rollback;
+ return undef;
+ }
+
+ my $bkt = $e->search_container_copy_bucket(
+ {owner => $self->patron->id, btype => 'circ_history'})->[0];
+
+ my $pos = 1;
+
+ if($bkt) {
+ # find the next item position
+ my $last_item = $e->search_container_copy_bucket_item(
+ {bucket => $bkt->id}, {order_by => {ccbi => 'pos desc'}, limit => 1})->[0];
+ $pos = $last_item->pos + 1 if $last_item;
+
+ } else {
+ # create the history bucket if necessary
+ $bkt = Fieldmapper::container::copy_bucket->new;
+ $bkt->owner($self->patron->id);
+ $bkt->name('');
+ $bkt->btype('circ_history');
+ $bkt->pub('f');
+ $e->create_container_copy_bucket($bkt) or return $e->die_event;
+ }
+
+ my $item = Fieldmapper::container::copy_bucket_item->new;
+
+ $item->bucket($bkt->id);
+ $item->target_copy($self->copy->id);
+ $item->pos($pos);
+
+ $e->create_container_copy_bucket_item($item) or return $e->die_event;
+ $e->commit;
+
+ return undef;
+}
+
+
+sub make_trigger_events {
+ my $self = shift;
+ return unless $self->circ;
+ $U->create_events_for_hook('checkout', $self->circ, $self->circ_lib) if $self->is_checkout;
+ $U->create_events_for_hook('checkin', $self->circ, $self->circ_lib) if $self->is_checkin;
+ $U->create_events_for_hook('renewal', $self->circ, $self->circ_lib) if $self->is_renewal;
+}
+
+
+
+sub checkin_handle_lost_now_found {
+ my ($self, $bill_type) = @_;
+
+ # ------------------------------------------------------------------
+ # remove charge from patron's account if lost item is returned
+ # ------------------------------------------------------------------
+
+ my $bills = $self->editor->search_money_billing(
+ {
+ xact => $self->circ->id,
+ btype => $bill_type
+ }
+ );
+
+ $logger->debug("voiding lost item charge of ".scalar(@$bills));
+ for my $bill (@$bills) {
+ if( !$U->is_true($bill->voided) ) {
+ $logger->info("lost item returned - voiding bill ".$bill->id);
+ $bill->voided('t');
+ $bill->void_time('now');
+ $bill->voider($self->editor->requestor->id);
+ my $note = ($bill->note) ? $bill->note . "\n" : '';
+ $bill->note("${note}System: VOIDED FOR LOST ITEM RETURNED");
+
+ $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_money_billing($bill);
+ }
+ }
+}
+
+sub checkin_handle_lost_now_found_restore_od {
+ my $self = shift;
+
+ # ------------------------------------------------------------------
+ # restore those overdue charges voided when item was set to lost
+ # ------------------------------------------------------------------
+
+ my $ods = $self->editor->search_money_billing(
+ {
+ xact => $self->circ->id,
+ btype => 1
+ }
+ );
+
+ $logger->debug("returning overdue charges pre-lost ".scalar(@$ods));
+ for my $bill (@$ods) {
+ if( $U->is_true($bill->voided) ) {
+ $logger->info("lost item returned - restoring overdue ".$bill->id);
+ $bill->voided('f');
+ $bill->clear_void_time;
+ $bill->voider($self->editor->requestor->id);
+ my $note = ($bill->note) ? $bill->note . "\n" : '';
+ $bill->note("${note}System: LOST RETURNED - OVERDUES REINSTATED");
+
+ $self->bail_on_events($self->editor->event)
+ unless $self->editor->update_money_billing($bill);
+ }
+ }
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Circ::CopyLocations;
+use base 'OpenILS::Application';
+use strict; use warnings;
+use Data::Dumper;
+$Data::Dumper::Indent = 0;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+my $U = "OpenILS::Application::AppUtils";
+
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.circ.copy_location.retrieve.all",
+ method => 'cl_retrieve_all',
+ argc => 2,
+ signature => q/
+ Retrieves the ranged set of copy locations for the requested org.
+ If no org is provided, all copy locations are returned
+ @param orgId The org location id
+ @param noi18n No i18n in result
+ @param flesh_owning_lib Flesh owning lib in results
+ @return An array of copy location objects
+ /);
+
+sub cl_retrieve_all {
+ my ($self, $client, $org_id, $no_i18n, $flesh_owning_lib) = @_;
+
+ if(!$org_id) {
+ my $otree = $U->get_org_tree();
+ $org_id = $otree->id;
+ }
+
+ my $second_cstore_arg = {"no_i18n" => scalar($no_i18n)};
+ if ($flesh_owning_lib) {
+ $second_cstore_arg->{"flesh"} = 1;
+ $second_cstore_arg->{"flesh_fields"} = {"acpl" => ["owning_lib"]};
+ }
+
+ return new_editor()->search_asset_copy_location([{
+ owning_lib => $U->get_org_full_path($org_id)
+ }, $second_cstore_arg]);
+}
+
+__PACKAGE__->register_method(
+ "api_name" => "open-ils.circ.copy_location.retrieve.distinct",
+ "method" => "cl_retrieve_distinct",
+ "stream" => 1,
+ "argc" => 0,
+ "signature" => q/Retrieve copy locations with distinct names globally/
+);
+
+sub cl_retrieve_distinct {
+ my ($self, $client) = @_;
+
+ my $e = new_editor();
+ my $names = $e->json_query({
+ "select" => {
+ "acpl" => [{"transform" => "distinct", "column" => "name"}]
+ },
+ "from" => {"acpl" => {}}
+ }) or return $e->die_event;
+ $e->disconnect;
+
+ $client->respond($_->{"name"}) for @$names;
+ undef;
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.circ.copy_location.create',
+ method => 'cl_create',
+ argc => 2,
+ signature => q/
+ Creates a new copy location. Requestor must have the CREATE_COPY_LOCATION
+ permission at the location specified on the new location object
+ @param authtoken The login session key
+ @param copyLoc The new copy location object
+ @return The if of the new location object on success, event on error
+ /);
+
+
+sub cl_create {
+ my( $self, $conn, $auth, $location ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless
+ $e->allowed('CREATE_COPY_LOCATION', $location->owning_lib);
+
+ # make sure there is no copy_location with the same name in the same place
+ my $existing = $e->search_asset_copy_location(
+ {owning_lib => $location->owning_lib, name => $location->name}, {idlist=>1});
+ return OpenILS::Event->new('COPY_LOCATION_EXISTS') if @$existing;
+
+ $e->create_asset_copy_location($location) or return $e->die_event;
+ $e->commit;
+ return $location->id;
+}
+
+
+
+__PACKAGE__->register_method (
+ api_name => 'open-ils.circ.copy_location.delete',
+ method => 'cl_delete',
+ argc => 2,
+ signature => q/
+ Deletes a copy location. Requestor must have the
+ DELETE_COPY_LOCATION permission.
+ @param authtoken The login session key
+ @param id The copy location object id
+ @return 1 on success, event on error
+ /);
+
+
+sub cl_delete {
+ my( $self, $conn, $auth, $id ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $cloc = $e->retrieve_asset_copy_location($id)
+ or return $e->die_event;
+ return $e->die_event unless
+ $e->allowed('DELETE_COPY_LOCATION', $cloc->owning_lib);
+
+ $e->delete_asset_copy_location($cloc) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method (
+ api_name => 'open-ils.circ.copy_location.update',
+ method => 'cl_update',
+ argc => 2,
+ signature => q/
+ Updates a copy location object. Requestor must have
+ the UPDATE_COPY_LOCATION permission
+ @param authtoken The login session key
+ @param copyLoc The copy location object
+ @return 1 on success, event on error
+ /);
+
+
+sub cl_update {
+ my( $self, $conn, $auth, $location ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ # check permissions against the original copy location
+ my $orig_loc = $e->retrieve_asset_copy_location($location->id)
+ or return $e->die_event;
+
+ return $e->die_event unless
+ $e->allowed('UPDATE_COPY_LOCATION', $orig_loc->owning_lib);
+
+ # disallow hijacking of the location
+ $location->owning_lib($orig_loc->owning_lib);
+
+ $e->update_asset_copy_location($location)
+ or return $e->die_event;
+
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_loc',
+ authoritative => 1,
+ api_name => 'open-ils.circ.copy_location.retrieve',
+);
+
+sub fetch_loc {
+ my( $self, $con, $id ) = @_;
+ my $e = new_editor();
+ my $cl = $e->retrieve_asset_copy_location($id)
+ or return $e->event;
+ return $cl;
+}
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.circ.copy_location_order.update",
+ method => 'update_clo',
+ argc => 2,
+);
+
+sub update_clo {
+ my($self, $client, $auth, $orders) = @_;
+ return [] unless $orders and @$orders;
+
+ my $e = new_editor(authtoken => $auth, xact =>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $org = $$orders[0]->org;
+ return $e->die_event unless $e->allowed('ADMIN_COPY_LOCATION_ORDER', $org);
+
+ # clear out the previous order entries
+ my $existing = $e->search_asset_copy_location_order({org => $org});
+ $e->delete_asset_copy_location_order($_) or return $e->die_event for @$existing;
+
+ # create the new order entries
+ my $progress = 0;
+ for my $order (@$orders) {
+ return $e->die_event(OpenILS::Event->new('BAD_PARAMS')) unless $order->org == $org;
+ $e->create_asset_copy_location_order($order) or return $e->die_event;
+ $client->respond({maximum => scalar(@$orders), progress => $progress}) unless ($progress++ % 10);
+ }
+
+ # fetch the new entries
+ $orders = $e->search_asset_copy_location_order({org => $org});
+ $e->commit;
+ return {orders => $orders};
+}
+
+
+1;
--- /dev/null
+# --------------------------------------------------------------------
+# Copyright (C) 2008 Niles Ingalls
+# Niles Ingalls <nilesi@zionsville.lib.in.us>
+# Bill Erickson <erickson@esilibrary.com>
+# Joe Atzberger <jatzberger@esilibrary.com>
+# Lebbeous Fogle-Weekley <lebbeous@esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# --------------------------------------------------------------------
+package OpenILS::Application::Circ::CreditCard;
+use base qw/OpenSRF::Application/;
+use strict; use warnings;
+
+use Business::CreditCard;
+use Business::OnlinePayment;
+use UUID::Tiny qw/:std/;
+use Locale::Country;
+
+use OpenILS::Event;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Application::AppUtils;
+my $U = "OpenILS::Application::AppUtils";
+
+use constant CREDIT_NS => "credit";
+
+# Given the argshash from process_payment(), this helper function just finds
+# a function in the current namespace named "bop_args_{processor}" and calls
+# it with $argshash as an argument, returning the result, or returning an
+# empty hash if it can't find such a function.
+sub get_bop_args_filler {
+ no strict 'refs';
+
+ my $argshash = shift;
+ my $funcname = "bop_args_" . $argshash->{processor};
+ return &{$funcname}($argshash) if defined &{$funcname};
+ return ();
+}
+
+# Provide default arguments for calls using the AuthorizeNet processor
+sub bop_args_AuthorizeNet {
+ my $argshash = shift;
+ if ($argshash->{server}) {
+ return (
+ # One might provide "test.authorize.net" here.
+ Server => $argshash->{server},
+ );
+ }
+ else {
+ return ();
+ }
+}
+
+# Provide default arguments for calls using the PayPal processor
+sub bop_args_PayPal {
+ my $argshash = shift;
+ return (
+ Username => $argshash->{login},
+ Password => $argshash->{password},
+ Signature => $argshash->{signature}
+ );
+}
+
+# Provide default arguments for calls using the PayflowPro processor
+sub bop_args_PayflowPro {
+ my $argshash = shift;
+ return (
+ "vendor" => $argshash->{vendor},
+ "partner" => $argshash->{partner} || "PayPal" # reasonable default?
+ );
+}
+
+sub get_processor_settings {
+ my $org_unit = shift;
+ my $processor = lc shift;
+
+ # XXX TODO: make this one single cstore request instead of many
+ +{ map { ($_ =>
+ $U->ou_ancestor_setting_value(
+ $org_unit, CREDIT_NS . ".processor.${processor}.${_}"
+ )) } qw/enabled login password signature server testmode vendor partner/
+ };
+}
+
+# argshash (Hash of arguments with these keys):
+# patron_id: Not a barcode, but a patron's internal ID
+# ou: Org unit where transaction happens
+# processor: Payment processor to use
+# (AuthorizeNet/PayPal/PayflowPro)
+# cc: credit card number
+# cvv2: 3 or 4 digits from back of card
+# amount: transaction value
+# action: optional (default: Normal Authorization)
+# first_name: optional (default: patron's first_given_name field)
+# last_name: optional (default: patron's family_name field)
+# address: optional (default: patron's street1 field + street2)
+# city: optional (default: patron's city field)
+# state: optional (default: patron's state field)
+# zip: optional (default: patron's zip field)
+# country: optional (some processor APIs: 2 letter code.)
+# description: optional
+
+sub process_payment {
+ my ($argshash) = @_;
+
+ # Confirm some required arguments.
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless $argshash
+ and $argshash->{cc}
+ and $argshash->{amount}
+ and $argshash->{expiration}
+ and $argshash->{ou};
+
+ if (!$argshash->{processor}) {
+ if (!($argshash->{processor} =
+ $U->ou_ancestor_setting_value(
+ $argshash->{ou}, CREDIT_NS . '.processor.default'))) {
+ return OpenILS::Event->new('CREDIT_PROCESSOR_NOT_SPECIFIED');
+ }
+ }
+ # Basic sanity check on processor name.
+ if ($argshash->{processor} !~ /^[a-z0-9_\-]+$/i) {
+ return OpenILS::Event->new('CREDIT_PROCESSOR_NOT_ALLOWED');
+ }
+
+ # Get org unit settings related to our processor
+ my $psettings = get_processor_settings(
+ $argshash->{ou}, $argshash->{processor}
+ );
+
+ if (!$psettings->{enabled}) {
+ return OpenILS::Event->new('CREDIT_PROCESSOR_NOT_ENABLED');
+ }
+
+ # Add the org unit settings for the chosen processor to our argshash.
+ $argshash = +{ %{$argshash}, %{$psettings} };
+
+ # At least the following (derived from org unit settings) are required.
+ return OpenILS::Event->new('CREDIT_PROCESSOR_BAD_PARAMS')
+ unless $argshash->{login}
+ and $argshash->{password};
+
+ # A valid patron_id is also required.
+ my $e = new_editor();
+ my $patron = $e->retrieve_actor_user(
+ [
+ $argshash->{patron_id},
+ {
+ flesh => 1,
+ flesh_fields => { au => ["mailing_address"] }
+ }
+ ]
+ ) or return $e->event;
+
+ return dispatch($argshash, $patron);
+}
+
+sub prepare_bop_content {
+ my ($argshash, $patron, $cardtype) = @_;
+
+ my %content;
+ foreach (qw/
+ login
+ password
+ description
+ first_name
+ last_name
+ amount
+ expiration
+ cvv2
+ address
+ city
+ state
+ zip
+ country/) {
+ if (exists $argshash->{$_}) {
+ $content{$_} = $argshash->{$_};
+ }
+ }
+
+ $content{action} = $argshash->{action} || "Normal Authorization";
+ $content{type} = $cardtype; #'American Express', 'VISA', 'MasterCard'
+ $content{card_number} = $argshash->{cc};
+ $content{customer_id} = $patron->id;
+
+ $content{first_name} ||= $patron->first_given_name;
+ $content{last_name} ||= $patron->family_name;
+
+ $content{FirstName} = $content{first_name}; # kludge mcugly for PP
+ $content{LastName} = $content{last_name};
+
+
+ # Especially for the following fields, do we need to support different
+ # mapping of fields for different payment processors, particularly ones
+ # in other countries?
+ $content{address} ||= $patron->mailing_address->street1;
+ $content{address} .= ", " . $patron->mailing_address->street2
+ if $patron->mailing_address->street2;
+
+ $content{city} ||= $patron->mailing_address->city;
+ $content{state} ||= $patron->mailing_address->state;
+ $content{zip} ||= $patron->mailing_address->post_code;
+ $content{country} ||= $patron->mailing_address->country;
+
+ # Yet another fantastic kludge. country2code() comes from Locale::Country.
+ # PayPal must have 2 letter country field (ISO 3166) that's uppercase.
+ if (length($content{country}) > 2 && $argshash->{processor} eq 'PayPal') {
+ $content{country} = uc country2code($content{country});
+ } elsif($argshash->{processor} eq "PayflowPro") {
+ ($content{request_id} = create_uuid_as_string(UUID_V4)) =~ s/-//;
+ }
+
+ %content;
+}
+
+sub dispatch {
+ my ($argshash, $patron) = @_;
+
+ # The validate() sub is exported by Business::CreditCard.
+ if (!validate($argshash->{cc})) {
+ # Although it might help a troubleshooter, it's probably not a good
+ # idea to put the credit card number in the log file.
+ $logger->info("Credit card number invalid");
+
+ return new OpenILS::Event("CREDIT_PROCESSOR_INVALID_CC_NUMBER");
+ }
+
+ # cardtype() also comes from Business::CreditCard. It is not certain that
+ # a) the card type returned by this method will be suitable input for
+ # a payment processor, nor that
+ # b) it is even necessary to supply this argument to processors in all
+ # cases. Testing this with several processors would be a good idea.
+ (my $cardtype = cardtype($argshash->{cc})) =~ s/ card//i;
+
+ if (lc($cardtype) eq "unknown") {
+ $logger->info("Credit card number passed validate(), " .
+ "yet cardtype() returned $cardtype");
+ return new OpenILS::Event(
+ "CREDIT_PROCESSOR_INVALID_CC_NUMBER", "note" => "cardtype $cardtype"
+ );
+ }
+
+ $logger->debug(
+ "applying payment via processor '" . $argshash->{processor} . "'"
+ );
+
+ # Find B:OP constructor arguments specific to our payment processor.
+ my %bop_args = get_bop_args_filler($argshash);
+
+ # We're assuming that all B:OP processors accept this argument to the
+ # constructor.
+ $bop_args{test_transaction} = $argshash->{testmode};
+
+ my $transaction = new Business::OnlinePayment(
+ $argshash->{processor}, %bop_args
+ );
+
+ my %content = prepare_bop_content($argshash, $patron, $cardtype);
+ $transaction->content(%content);
+
+ # submit() does not return a value, although crashing is possible here
+ # with some bad input depending on the payment processor.
+ $transaction->submit;
+
+ my $payload = {
+ "processor" => $argshash->{"processor"}, "card_type" => $cardtype
+ };
+
+ # Put the values of any of these fields into the event payload, if present.
+ foreach (qw/authorization correlationid avs_code request_id
+ server_response cvv2_response cvv2_code error_message order_number/) {
+ $payload->{$_} = $transaction->$_ if $transaction->can($_);
+ }
+
+ my $event_name;
+
+ if ($transaction->is_success) {
+ $logger->info($argshash->{processor} . " payment succeeded");
+ $event_name = "SUCCESS";
+ } else {
+ $logger->info($argshash->{processor} . " payment failed");
+ $event_name = "CREDIT_PROCESSOR_DECLINED_TRANSACTION";
+ }
+
+ return new OpenILS::Event($event_name, "payload" => $payload);
+}
+
+
+1;
--- /dev/null
+# ---------------------------------------------------------------
+# Copyright (C) 2005 Georgia Public Library Service
+# Bill Erickson <billserickson@gmail.com>
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+
+package OpenILS::Application::Circ::HoldNotify;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use OpenSRF::EX qw(:try);
+use vars q/$AUTOLOAD/;
+use OpenILS::Event;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::AppUtils;
+use OpenILS::Const qw/:const/;
+use OpenILS::Utils::Fieldmapper;
+use Email::Send;
+use Data::Dumper;
+use OpenSRF::EX qw/:try/;
+my $U = 'OpenILS::Application::AppUtils';
+
+use open ':utf8';
+
+
+__PACKAGE__->register_method(
+ method => 'send_email_notify_pub',
+ api_name => 'open-ils.circ.send_hold_notify.email',
+);
+
+
+sub send_email_notify_pub {
+ my( $self, $conn, $auth, $hold_id ) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('CREATE_HOLD_NOTIFICATION');
+ my $notifier = __PACKAGE__->new(requestor => $e->requestor, hold_id => $hold_id);
+ return $notifier->event if $notifier->event;
+ my $stat = $notifier->send_email_notify;
+# $e->commit if $stat == '1';
+ return $stat;
+}
+
+
+
+
+
+# ---------------------------------------------------------------
+# Define the notifier object
+# ---------------------------------------------------------------
+
+my @AUTOLOAD_FIELDS = qw/
+ hold
+ copy
+ volume
+ title
+ editor
+ patron
+ event
+ pickup_lib
+ smtp_server
+ settings_client
+/;
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $type = ref($self) or die "$self is not an object";
+ my $data = shift;
+ my $name = $AUTOLOAD;
+ $name =~ s/.*://o;
+
+ unless (grep { $_ eq $name } @AUTOLOAD_FIELDS) {
+ $logger->error("hold_notify: $type: invalid autoload field: $name");
+ die "$type: invalid autoload field: $name\n"
+ }
+
+ {
+ no strict 'refs';
+ *{"${type}::${name}"} = sub {
+ my $s = shift;
+ my $v = shift;
+ $s->{$name} = $v if defined $v;
+ return $s->{$name};
+ }
+ }
+ return $self->$name($data);
+}
+
+
+sub new {
+ my( $class, %args ) = @_;
+ $class = ref($class) || $class;
+ my $self = bless( {}, $class );
+ $self->editor( new_editor( xact => 1, requestor => $args{requestor} ));
+ $logger->debug("circulator: creating new hold-notifier with requestor ".
+ $self->editor->requestor->id);
+ $self->fetch_data($args{hold_id});
+ return $self;
+}
+
+sub send_email_notify {
+ my $self = shift;
+
+ my $sc = OpenSRF::Utils::SettingsClient->new;
+ my $setting = $sc->config_value(
+ qw/ apps open-ils.circ app_settings notify_hold email / );
+
+ $logger->debug("hold_notify: email enabled setting = $setting");
+
+ if( !$setting or $setting ne 'true' ) {
+ $self->editor->rollback;
+ $logger->info("hold_notify: not sending hold notify - email notifications disabled");
+ return 0;
+ }
+
+ unless ($U->is_true($self->hold->email_notify)) {
+ $self->editor->rollback;
+ $logger->info("hold_notify: not sending hold notification because email_notify is false");
+ return 0;
+ }
+
+ unless( $self->patron->email and $self->patron->email =~ /.+\@.+/ ) { # see if it's remotely email-esque
+ $self->editor->rollback;
+ return OpenILS::Event->new('PATRON_NO_EMAIL_ADDRESS');
+ }
+
+ $logger->info("hold_notify: attempting email notify on hold ".$self->hold->id);
+
+ my $sclient = OpenSRF::Utils::SettingsClient->new;
+ $self->settings_client($sclient);
+ my $template = $sclient->config_value('email_notify', 'template');
+ my $str = $self->flesh_template($self->load_template($template));
+
+ unless( $str ) {
+ $self->editor->rollback;
+ $logger->error("hold_notify: No email notify template found - cannot notify");
+ return 0;
+ }
+
+ my $reqr = $self->editor->requestor;
+ $self->editor->rollback; # we're done with this transaction
+
+ return 0 unless $self->send_email($str);
+
+ # ------------------------------------------------------------------
+ # If the hold email takes too long to send, the existing editor
+ # transaction may have timed out. Create a one-off editor to write
+ # the notification to the DB.
+ # ------------------------------------------------------------------
+ my $we = new_editor(xact=>1, requestor=>$reqr);
+
+ my $notify = Fieldmapper::action::hold_notification->new;
+ $notify->hold($self->hold->id);
+ $notify->notify_staff($we->requestor->id);
+ $notify->notify_time('now');
+ $notify->method('email');
+
+ $we->create_action_hold_notification($notify)
+ or return $we->die_event;
+ $we->commit;
+
+ return 1;
+}
+
+sub send_email {
+ my( $self, $text ) = @_;
+
+ # !!! $self->editor xact has been rolled back before we get here
+
+ my $smtp = $self->settings_client->config_value('email_notify', 'smtp_server');
+
+ $logger->info("hold_notify: sending email notice to ".
+ $self->patron->email." with SMTP server $smtp");
+
+ my $sender = Email::Send->new({mailer => 'SMTP'});
+ $sender->mailer_args([Host => $smtp]);
+
+ my $stat;
+ my $err;
+
+ try {
+ $stat = $sender->send($text);
+ } catch Error with {
+ $err = $stat = shift;
+ $logger->error("hold_notify: Email notify failed with error: $err");
+ };
+
+ if( !$err and $stat and $stat->type eq 'success' ) {
+ $logger->info("hold_notify: successfully sent hold notification");
+ return 1;
+ } else {
+ $logger->warn("hold_notify: unable to send hold notification: ".Dumper($stat));
+ return 0;
+ }
+
+ return undef;
+}
+
+
+# -------------------------------------------------------------------------
+# Fetches all of the hold-related data
+# -------------------------------------------------------------------------
+sub fetch_data {
+ my $self = shift;
+ my $holdid = shift;
+ my $e = $self->editor;
+
+ $logger->debug("circulator: fetching hold notify data");
+
+ $self->hold($e->retrieve_action_hold_request($holdid)) or return $self->event($e->event);
+ $self->copy($e->retrieve_asset_copy($self->hold->current_copy)) or return $self->event($e->event);
+ $self->volume($e->retrieve_asset_call_number($self->copy->call_number)) or return $self->event($e->event);
+ $self->title($e->retrieve_biblio_record_entry($self->volume->record)) or return $self->event($e->event);
+ $self->patron($e->retrieve_actor_user($self->hold->usr)) or return $self->event($e->event);
+ $self->pickup_lib($e->retrieve_actor_org_unit($self->hold->pickup_lib)) or return $self->event($e->event);
+}
+
+
+sub extract_data {
+ my $self = shift;
+ my $e = $self->editor;
+
+ my $patron = $self->patron;
+ my $o_name = $self->pickup_lib->name;
+ my $p_name = $patron->first_given_name .' '.$patron->family_name;
+
+ # try to find a suitable address for the patron
+ my $p_addr;
+ my $p_addrs;
+ unless( $p_addr =
+ $e->retrieve_actor_user_address($patron->billing_address)) {
+ unless( $p_addr =
+ $e->retrieve_actor_user_address($patron->mailing_address)) {
+ $logger->warn("hold_notify: No address for user ".$patron->id);
+ $p_addrs = "";
+ }
+ }
+
+ unless( defined $p_addrs ) {
+ $p_addrs =
+ $p_addr->street1." ".
+ $p_addr->street2." ".
+ $p_addr->city." ".
+ $p_addr->state." ".
+ $p_addr->post_code;
+ }
+
+ my $l_addr = $e->retrieve_actor_org_address($self->pickup_lib->holds_address);
+ my $l_addrs = (!$l_addr) ? "" :
+ $l_addr->street1." ".
+ $l_addr->street2." ".
+ $l_addr->city." ".
+ $l_addr->state." ".
+ $l_addr->post_code;
+
+ my $title;
+ my $author;
+
+ if( $self->title->id == OILS_PRECAT_RECORD ) {
+ $title = ($self->copy->dummy_title) ?
+ $self->copy->dummy_title : "";
+ $author = ($self->copy->dummy_author) ?
+ $self->copy->dummy_author : "";
+ } else {
+ my $mods = $U->record_to_mvr($self->title);
+ $title = ($mods->title) ? $mods->title : "";
+ $author = ($mods->author) ? $mods->author : "";
+ }
+
+
+ return {
+ patron_email => $self->patron->email,
+ pickup_lib_name => $o_name,
+ pickup_lib_addr => $l_addrs,
+ patron_name => $p_name,
+ patron_addr => $p_addrs,
+ title => $title,
+ author => $author,
+ call_number => $self->volume->label,
+ copy_barcode => $self->copy->barcode,
+ copy_number => $self->copy->copy_number,
+ };
+}
+
+
+
+sub load_template {
+ my $self = shift;
+ my $template = shift;
+
+ unless( open(F, $template) ) {
+ $logger->error("hold_notify: Unable to open hold notification template file: $template");
+ return undef;
+ }
+
+ # load the template, strip comments
+ my @lines = <F>;
+ close(F);
+
+ my $str = '';
+ for(@lines) {
+ chomp $_;
+ next if $_ =~ /^\s*\#/o;
+ $_ =~ s/\#.*//og;
+ $str .= "$_\n";
+ }
+
+ return $str;
+}
+
+sub flesh_template {
+ my( $self, $str ) = @_;
+ return undef unless $str;
+
+ my @time = CORE::localtime();
+ my $day = $time[3];
+ my $month = $time[4] + 1;
+ my $year = $time[5] + 1900;
+
+ my $data = $self->extract_data;
+
+ my $email = $$data{patron_email};
+ my $p_name = $$data{patron_name};
+ my $p_addr = $$data{patron_addr};
+ my $o_name = $$data{pickup_lib_name};
+ my $o_addr = $$data{pickup_lib_addr};
+ my $title = $$data{title};
+ my $author = $$data{author};
+ my $cn = $$data{call_number};
+ my $barcode = $$data{copy_barcode};
+ my $copy_number = $$data{copy_number};
+
+ my $sender = $self->settings_client->config_value('email_notify', 'sender_address');
+ my $reply_to = $self->pickup_lib->email;
+ $reply_to ||= $sender;
+
+ # if they have an org setting for bounced emails, use that as the sender address
+ if( my $set = $self->editor->search_actor_org_unit_setting(
+ { name => OILS_SETTING_ORG_BOUNCED_EMAIL,
+ org_unit => $self->pickup_lib->id } )->[0] ) {
+
+ my $bemail = OpenSRF::Utils::JSON->JSON2perl($set->value);
+ $sender = $bemail if $bemail;
+ }
+
+ $str =~ s/\${EMAIL_SENDER}/$sender/;
+ $str =~ s/\${EMAIL_RECIPIENT}/$email/;
+ $str =~ s/\${EMAIL_REPLY_TO}/$reply_to/;
+ $str =~ s/\${EMAIL_HEADERS}//;
+
+ $str =~ s/\${DATE}/$year-$month-$day/;
+ $str =~ s/\${LIBRARY}/$o_name/;
+ $str =~ s/\${LIBRARY_ADDRESS}/$o_addr/;
+ $str =~ s/\${PATRON_NAME}/$p_name/;
+ $str =~ s/\${PATRON_ADDRESS}/$p_addr/;
+
+ $str =~ s/\${TITLE}/$title/;
+ $str =~ s/\${AUTHOR}/$author/;
+ $str =~ s/\${CALL_NUMBER}/$cn/;
+ $str =~ s/\${COPY_BARCODE}/$barcode/;
+ $str =~ s/\${COPY_NUMBER}/$copy_number/;
+
+ return $str;
+}
+
+
+
+
+
+1;
--- /dev/null
+# ---------------------------------------------------------------
+# Copyright (C) 2005 Georgia Public Library Service
+# Bill Erickson <highfalutin@gmail.com>
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+
+package OpenILS::Application::Circ::Holds;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use OpenILS::Application::AppUtils;
+use DateTime;
+use Data::Dumper;
+use OpenSRF::EX qw(:try);
+use OpenILS::Perm;
+use OpenILS::Event;
+use OpenSRF::Utils;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Utils::PermitHold;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Const qw/:const/;
+use OpenILS::Application::Circ::Transit;
+use OpenILS::Application::Actor::Friends;
+use DateTime;
+use DateTime::Format::ISO8601;
+use OpenSRF::Utils qw/:datetime/;
+use Digest::MD5 qw(md5_hex);
+use OpenSRF::Utils::Cache;
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+
+
+__PACKAGE__->register_method(
+ method => "create_hold_batch",
+ api_name => "open-ils.circ.holds.create.batch",
+ stream => 1,
+ signature => {
+ desc => q/@see open-ils.circ.holds.create.batch/,
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Array of hold objects', type => 'array' }
+ ],
+ return => {
+ desc => 'Array of hold ID on success, -1 on missing arg, event (or ref to array of events) on error(s)',
+ },
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "create_hold_batch",
+ api_name => "open-ils.circ.holds.create.override.batch",
+ stream => 1,
+ signature => {
+ desc => '@see open-ils.circ.holds.create.batch',
+ }
+);
+
+
+sub create_hold_batch {
+ my( $self, $conn, $auth, $hold_list ) = @_;
+ (my $method = $self->api_name) =~ s/\.batch//og;
+ foreach (@$hold_list) {
+ my ($res) = $self->method_lookup($method)->run($auth, $_);
+ $conn->respond($res);
+ }
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "create_hold",
+ api_name => "open-ils.circ.holds.create",
+ signature => {
+ desc => "Create a new hold for an item. From a permissions perspective, " .
+ "the login session is used as the 'requestor' of the hold. " .
+ "The hold recipient is determined by the 'usr' setting within the hold object. " .
+ 'First we verify the requestor has holds request permissions. ' .
+ 'Then we verify that the recipient is allowed to make the given hold. ' .
+ 'If not, we see if the requestor has "override" capabilities. If not, ' .
+ 'a permission exception is returned. If permissions allow, we cycle ' .
+ 'through the set of holds objects and create. ' .
+ 'If the recipient does not have permission to place multiple holds ' .
+ 'on a single title and said operation is attempted, a permission ' .
+ 'exception is returned',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Hold object for hold to be created',
+ type => 'object', class => 'ahr' }
+ ],
+ return => {
+ desc => 'New ahr ID on success, -1 on missing arg, event (or ref to array of events) on error(s)',
+ },
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "create_hold",
+ api_name => "open-ils.circ.holds.create.override",
+ notes => '@see open-ils.circ.holds.create',
+ signature => {
+ desc => "If the recipient is not allowed to receive the requested hold, " .
+ "call this method to attempt the override",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ {
+ desc => 'Hold object for hold to be created',
+ type => 'object', class => 'ahr'
+ }
+ ],
+ return => {
+ desc => 'New hold (ahr) ID on success, -1 on missing arg, event (or ref to array of events) on error(s)',
+ },
+ }
+);
+
+sub create_hold {
+ my( $self, $conn, $auth, $hold ) = @_;
+ return -1 unless $hold;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $override = 1 if $self->api_name =~ /override/;
+
+ my @events;
+
+ my $requestor = $e->requestor;
+ my $recipient = $requestor;
+
+ if( $requestor->id ne $hold->usr ) {
+ # Make sure the requestor is allowed to place holds for
+ # the recipient if they are not the same people
+ $recipient = $e->retrieve_actor_user($hold->usr) or return $e->die_event;
+ $e->allowed('REQUEST_HOLDS', $recipient->home_ou) or return $e->die_event;
+ }
+
+ # If the related org setting tells us to, block if patron privs have expired
+ my $expire_setting = $U->ou_ancestor_setting_value($recipient->home_ou, OILS_SETTING_BLOCK_HOLD_FOR_EXPIRED_PATRON);
+ if ($expire_setting) {
+ my $expire = DateTime::Format::ISO8601->new->parse_datetime(
+ cleanse_ISO8601($recipient->expire_date));
+
+ push( @events, OpenILS::Event->new(
+ 'PATRON_ACCOUNT_EXPIRED',
+ "payload" => {"fail_part" => "actor.usr.privs_expired"}
+ )) if( CORE::time > $expire->epoch ) ;
+ }
+
+ # Now make sure the recipient is allowed to receive the specified hold
+ my $porg = $recipient->home_ou;
+ my $rid = $e->requestor->id;
+ my $t = $hold->hold_type;
+
+ # See if a duplicate hold already exists
+ my $sargs = {
+ usr => $recipient->id,
+ hold_type => $t,
+ fulfillment_time => undef,
+ target => $hold->target,
+ cancel_time => undef,
+ };
+
+ $sargs->{holdable_formats} = $hold->holdable_formats if $t eq 'M';
+
+ my $existing = $e->search_action_hold_request($sargs);
+ push( @events, OpenILS::Event->new('HOLD_EXISTS')) if @$existing;
+
+ my $checked_out = hold_item_is_checked_out($e, $recipient->id, $hold->hold_type, $hold->target);
+ push( @events, OpenILS::Event->new('HOLD_ITEM_CHECKED_OUT')) if $checked_out;
+
+ if ( $t eq OILS_HOLD_TYPE_METARECORD ) {
+ return $e->die_event unless $e->allowed('MR_HOLDS', $porg);
+ } elsif ( $t eq OILS_HOLD_TYPE_TITLE ) {
+ return $e->die_event unless $e->allowed('TITLE_HOLDS', $porg);
+ } elsif ( $t eq OILS_HOLD_TYPE_VOLUME ) {
+ return $e->die_event unless $e->allowed('VOLUME_HOLDS', $porg);
+ } elsif ( $t eq OILS_HOLD_TYPE_ISSUANCE ) {
+ return $e->die_event unless $e->allowed('ISSUANCE_HOLDS', $porg);
+ } elsif ( $t eq OILS_HOLD_TYPE_COPY ) {
+ return $e->die_event unless $e->allowed('COPY_HOLDS', $porg);
+ } elsif ( $t eq OILS_HOLD_TYPE_FORCE ) {
+ return $e->die_event unless $e->allowed('COPY_HOLDS', $porg);
+ } elsif ( $t eq OILS_HOLD_TYPE_RECALL ) {
+ return $e->die_event unless $e->allowed('COPY_HOLDS', $porg);
+ }
+
+ if( @events ) {
+ if (!$override) {
+ $e->rollback;
+ return \@events;
+ }
+ for my $evt (@events) {
+ next unless $evt;
+ my $name = $evt->{textcode};
+ return $e->die_event unless $e->allowed("$name.override", $porg);
+ }
+ }
+
+ # set the configured expire time
+ unless($hold->expire_time) {
+ my $interval = $U->ou_ancestor_setting_value($recipient->home_ou, OILS_SETTING_HOLD_EXPIRE);
+ if($interval) {
+ my $date = DateTime->now->add(seconds => OpenSRF::Utils::interval_to_seconds($interval));
+ $hold->expire_time($U->epoch2ISO8601($date->epoch));
+ }
+ }
+
+ $hold->requestor($e->requestor->id);
+ $hold->request_lib($e->requestor->ws_ou);
+ $hold->selection_ou($hold->pickup_lib) unless $hold->selection_ou;
+ $hold = $e->create_action_hold_request($hold) or return $e->die_event;
+
+ $e->commit;
+
+ $conn->respond_complete($hold->id);
+
+ $U->storagereq(
+ 'open-ils.storage.action.hold_request.copy_targeter',
+ undef, $hold->id ) unless $U->is_true($hold->frozen);
+
+ return undef;
+}
+
+# makes sure that a user has permission to place the type of requested hold
+# returns the Perm exception if not allowed, returns undef if all is well
+sub _check_holds_perm {
+ my($type, $user_id, $org_id) = @_;
+
+ my $evt;
+ if ($type eq "M") {
+ $evt = $apputils->check_perms($user_id, $org_id, "MR_HOLDS" );
+ } elsif ($type eq "T") {
+ $evt = $apputils->check_perms($user_id, $org_id, "TITLE_HOLDS" );
+ } elsif($type eq "V") {
+ $evt = $apputils->check_perms($user_id, $org_id, "VOLUME_HOLDS");
+ } elsif($type eq "C") {
+ $evt = $apputils->check_perms($user_id, $org_id, "COPY_HOLDS" );
+ }
+
+ return $evt if $evt;
+ return undef;
+}
+
+# tests if the given user is allowed to place holds on another's behalf
+sub _check_request_holds_perm {
+ my $user_id = shift;
+ my $org_id = shift;
+ if (my $evt = $apputils->check_perms(
+ $user_id, $org_id, "REQUEST_HOLDS")) {
+ return $evt;
+ }
+}
+
+my $ses_is_req_note = 'The login session is the requestor. If the requestor is different from the user, ' .
+ 'then the requestor must have VIEW_HOLD permissions';
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds_by_id",
+ api_name => "open-ils.circ.holds.retrieve_by_id",
+ signature => {
+ desc => "Retrieve the hold, with hold transits attached, for the specified ID. $ses_is_req_note",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Hold ID', type => 'number' }
+ ],
+ return => {
+ desc => 'Hold object with transits attached, event on error',
+ }
+ }
+);
+
+
+sub retrieve_holds_by_id {
+ my($self, $client, $auth, $hold_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ $e->checkauth or return $e->event;
+ $e->allowed('VIEW_HOLD') or return $e->event;
+
+ my $holds = $e->search_action_hold_request(
+ [
+ { id => $hold_id , fulfillment_time => undef },
+ {
+ order_by => { ahr => "request_time" },
+ flesh => 1,
+ flesh_fields => {ahr => ['notes']}
+ }
+ ]
+ );
+
+ flesh_hold_transits($holds);
+ flesh_hold_notices($holds, $e);
+ return $holds;
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds",
+ api_name => "open-ils.circ.holds.retrieve",
+ signature => {
+ desc => "Retrieves all the holds, with hold transits attached, for the specified user. $ses_is_req_note",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User ID', type => 'integer' }
+ ],
+ return => {
+ desc => 'list of holds, event on error',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds",
+ api_name => "open-ils.circ.holds.id_list.retrieve",
+ authoritative => 1,
+ signature => {
+ desc => "Retrieves all the hold IDs, for the specified user. $ses_is_req_note",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User ID', type => 'integer' }
+ ],
+ return => {
+ desc => 'list of holds, event on error',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds",
+ api_name => "open-ils.circ.holds.canceled.retrieve",
+ authoritative => 1,
+ signature => {
+ desc => "Retrieves all the cancelled holds for the specified user. $ses_is_req_note",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User ID', type => 'integer' }
+ ],
+ return => {
+ desc => 'list of holds, event on error',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds",
+ api_name => "open-ils.circ.holds.canceled.id_list.retrieve",
+ authoritative => 1,
+ signature => {
+ desc => "Retrieves list of cancelled hold IDs for the specified user. $ses_is_req_note",
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User ID', type => 'integer' }
+ ],
+ return => {
+ desc => 'list of hold IDs, event on error',
+ }
+ }
+);
+
+
+sub retrieve_holds {
+ my ($self, $client, $auth, $user_id) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ $user_id = $e->requestor->id unless defined $user_id;
+
+ my $notes_filter = {staff => 'f'};
+ my $user = $e->retrieve_actor_user($user_id) or return $e->event;
+ unless($user_id == $e->requestor->id) {
+ if($e->allowed('VIEW_HOLD', $user->home_ou)) {
+ $notes_filter = {staff => 't'}
+ } else {
+ my $allowed = OpenILS::Application::Actor::Friends->friend_perm_allowed(
+ $e, $user_id, $e->requestor->id, 'hold.view');
+ return $e->event unless $allowed;
+ }
+ } else {
+ # staff member looking at his/her own holds can see staff and non-staff notes
+ $notes_filter = {} if $e->allowed('VIEW_HOLD', $user->home_ou);
+ }
+
+ my $holds_query = {
+ select => {ahr => ['id']},
+ from => 'ahr',
+ where => {usr => $user_id, fulfillment_time => undef}
+ };
+
+ if($self->api_name =~ /canceled/) {
+
+ # Fetch the canceled holds
+ # order cancelled holds by cancel time, most recent first
+
+ $holds_query->{order_by} = [{class => 'ahr', field => 'cancel_time', direction => 'desc'}];
+
+ my $cancel_age;
+ my $cancel_count = $U->ou_ancestor_setting_value(
+ $e->requestor->ws_ou, 'circ.holds.canceled.display_count', $e);
+
+ unless($cancel_count) {
+ $cancel_age = $U->ou_ancestor_setting_value(
+ $e->requestor->ws_ou, 'circ.holds.canceled.display_age', $e);
+
+ # if no settings are defined, default to last 10 cancelled holds
+ $cancel_count = 10 unless $cancel_age;
+ }
+
+ if($cancel_count) { # limit by count
+
+ $holds_query->{where}->{cancel_time} = {'!=' => undef};
+ $holds_query->{limit} = $cancel_count;
+
+ } elsif($cancel_age) { # limit by age
+
+ # find all of the canceled holds that were canceled within the configured time frame
+ my $date = DateTime->now->subtract(seconds => OpenSRF::Utils::interval_to_seconds($cancel_age));
+ $date = $U->epoch2ISO8601($date->epoch);
+ $holds_query->{where}->{cancel_time} = {'>=' => $date};
+ }
+
+ } else {
+
+ # order non-cancelled holds by ready-for-pickup, then active, followed by suspended
+ $holds_query->{order_by} = {ahr => ['shelf_time', 'frozen', 'request_time']};
+ $holds_query->{where}->{cancel_time} = undef;
+ }
+
+ my $hold_ids = $e->json_query($holds_query);
+ $hold_ids = [ map { $_->{id} } @$hold_ids ];
+
+ return $hold_ids if $self->api_name =~ /id_list/;
+
+ my @holds;
+ for my $hold_id ( @$hold_ids ) {
+
+ my $hold = $e->retrieve_action_hold_request($hold_id);
+ $hold->notes($e->search_action_hold_request_note({hold => $hold_id, %$notes_filter}));
+
+ $hold->transit(
+ $e->search_action_hold_transit_copy([
+ {hold => $hold->id},
+ {order_by => {ahtc => 'source_send_time desc'}, limit => 1}])->[0]
+ );
+
+ push(@holds, $hold);
+ }
+
+ return \@holds;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'user_hold_count',
+ api_name => 'open-ils.circ.hold.user.count'
+);
+
+sub user_hold_count {
+ my ( $self, $conn, $auth, $userid ) = @_;
+ my $e = new_editor( authtoken => $auth );
+ return $e->event unless $e->checkauth;
+ my $patron = $e->retrieve_actor_user($userid)
+ or return $e->event;
+ return $e->event unless $e->allowed( 'VIEW_HOLD', $patron->home_ou );
+ return __user_hold_count( $self, $e, $userid );
+}
+
+sub __user_hold_count {
+ my ( $self, $e, $userid ) = @_;
+ my $holds = $e->search_action_hold_request(
+ {
+ usr => $userid,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ },
+ { idlist => 1 }
+ );
+
+ return scalar(@$holds);
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds_by_pickup_lib",
+ api_name => "open-ils.circ.holds.retrieve_by_pickup_lib",
+ notes =>
+ "Retrieves all the holds, with hold transits attached, for the specified pickup_ou id."
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_holds_by_pickup_lib",
+ api_name => "open-ils.circ.holds.id_list.retrieve_by_pickup_lib",
+ notes => "Retrieves all the hold ids for the specified pickup_ou id. "
+);
+
+sub retrieve_holds_by_pickup_lib {
+ my ($self, $client, $login_session, $ou_id) = @_;
+
+ #FIXME -- put an appropriate permission check here
+ #my( $user, $target, $evt ) = $apputils->checkses_requestor(
+ # $login_session, $user_id, 'VIEW_HOLD' );
+ #return $evt if $evt;
+
+ my $holds = $apputils->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.action.hold_request.search.atomic",
+ {
+ pickup_lib => $ou_id ,
+ fulfillment_time => undef,
+ cancel_time => undef
+ },
+ { order_by => { ahr => "request_time" } }
+ );
+
+ if ( ! $self->api_name =~ /id_list/ ) {
+ flesh_hold_transits($holds);
+ return $holds;
+ }
+ # else id_list
+ return [ map { $_->id } @$holds ];
+}
+
+
+__PACKAGE__->register_method(
+ method => "uncancel_hold",
+ api_name => "open-ils.circ.hold.uncancel"
+);
+
+sub uncancel_hold {
+ my($self, $client, $auth, $hold_id) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $hold = $e->retrieve_action_hold_request($hold_id)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('CANCEL_HOLDS', $hold->request_lib);
+
+ if ($hold->fulfillment_time) {
+ $e->rollback;
+ return 0;
+ }
+ unless ($hold->cancel_time) {
+ $e->rollback;
+ return 1;
+ }
+
+ # if configured to reset the request time, also reset the expire time
+ if($U->ou_ancestor_setting_value(
+ $hold->request_lib, 'circ.holds.uncancel.reset_request_time', $e)) {
+
+ $hold->request_time('now');
+ my $interval = $U->ou_ancestor_setting_value($hold->request_lib, OILS_SETTING_HOLD_EXPIRE);
+ if($interval) {
+ my $date = DateTime->now->add(seconds => OpenSRF::Utils::interval_to_seconds($interval));
+ $hold->expire_time($U->epoch2ISO8601($date->epoch));
+ }
+ }
+
+ $hold->clear_cancel_time;
+ $hold->clear_cancel_cause;
+ $hold->clear_cancel_note;
+ $e->update_action_hold_request($hold) or return $e->die_event;
+ $e->commit;
+
+ $U->storagereq('open-ils.storage.action.hold_request.copy_targeter', undef, $hold_id);
+
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "cancel_hold",
+ api_name => "open-ils.circ.hold.cancel",
+ signature => {
+ desc => 'Cancels the specified hold. The login session is the requestor. If the requestor is different from the usr field ' .
+ 'on the hold, the requestor must have CANCEL_HOLDS permissions. The hold may be either the hold object or the hold id',
+ param => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Hold ID', type => 'number'},
+ {desc => 'Cause of Cancellation', type => 'string'},
+ {desc => 'Note', type => 'string'}
+ ],
+ return => {
+ desc => '1 on success, event on error'
+ }
+ }
+);
+
+sub cancel_hold {
+ my($self, $client, $auth, $holdid, $cause, $note) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $hold = $e->retrieve_action_hold_request($holdid)
+ or return $e->die_event;
+
+ if( $e->requestor->id ne $hold->usr ) {
+ return $e->die_event unless $e->allowed('CANCEL_HOLDS');
+ }
+
+ if ($hold->cancel_time) {
+ $e->rollback;
+ return 1;
+ }
+
+ # If the hold is captured, reset the copy status
+ if( $hold->capture_time and $hold->current_copy ) {
+
+ my $copy = $e->retrieve_asset_copy($hold->current_copy)
+ or return $e->die_event;
+
+ if( $copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF ) {
+ $logger->info("canceling hold $holdid whose item is on the holds shelf");
+# $logger->info("setting copy to status 'reshelving' on hold cancel");
+# $copy->status(OILS_COPY_STATUS_RESHELVING);
+# $copy->editor($e->requestor->id);
+# $copy->edit_date('now');
+# $e->update_asset_copy($copy) or return $e->event;
+
+ } elsif( $copy->status == OILS_COPY_STATUS_IN_TRANSIT ) {
+
+ my $hid = $hold->id;
+ $logger->warn("! canceling hold [$hid] that is in transit");
+ my $transid = $e->search_action_hold_transit_copy({hold=>$hold->id},{idlist=>1})->[0];
+
+ if( $transid ) {
+ my $trans = $e->retrieve_action_transit_copy($transid);
+ # Leave the transit alive, but set the copy status to
+ # reshelving so it will be properly reshelved when it gets back home
+ if( $trans ) {
+ $trans->copy_status( OILS_COPY_STATUS_RESHELVING );
+ $e->update_action_transit_copy($trans) or return $e->die_event;
+ }
+ }
+ }
+ }
+
+ $hold->cancel_time('now');
+ $hold->cancel_cause($cause);
+ $hold->cancel_note($note);
+ $e->update_action_hold_request($hold)
+ or return $e->die_event;
+
+ delete_hold_copy_maps($self, $e, $hold->id);
+
+ $e->commit;
+
+ $U->create_events_for_hook('hold_request.cancel.staff', $hold, $hold->pickup_lib)
+ if $e->requestor->id != $hold->usr;
+
+ return 1;
+}
+
+sub delete_hold_copy_maps {
+ my $class = shift;
+ my $editor = shift;
+ my $holdid = shift;
+
+ my $maps = $editor->search_action_hold_copy_map({hold=>$holdid});
+ for(@$maps) {
+ $editor->delete_action_hold_copy_map($_)
+ or return $editor->event;
+ }
+ return undef;
+}
+
+
+my $update_hold_desc = 'The login session is the requestor. ' .
+ 'If the requestor is different from the usr field on the hold, ' .
+ 'the requestor must have UPDATE_HOLDS permissions. ' .
+ 'If supplying a hash of hold data, "id" must be included. ' .
+ 'The hash is ignored if a hold object is supplied, ' .
+ 'so you should supply only one kind of hold data argument.' ;
+
+__PACKAGE__->register_method(
+ method => "update_hold",
+ api_name => "open-ils.circ.hold.update",
+ signature => {
+ desc => "Updates the specified hold. $update_hold_desc",
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Hold Object', type => 'object'},
+ {desc => 'Hash of values to be applied', type => 'object'}
+ ],
+ return => {
+ desc => 'Hold ID on success, event on error',
+ # type => 'number'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "batch_update_hold",
+ api_name => "open-ils.circ.hold.update.batch",
+ stream => 1,
+ signature => {
+ desc => "Updates the specified hold(s). $update_hold_desc",
+ params => [
+ {desc => 'Authentication token', type => 'string'},
+ {desc => 'Array of hold obejcts', type => 'array' },
+ {desc => 'Array of hashes of values to be applied', type => 'array' }
+ ],
+ return => {
+ desc => 'Hold ID per success, event per error',
+ }
+ }
+);
+
+sub update_hold {
+ my($self, $client, $auth, $hold, $values) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ my $resp = update_hold_impl($self, $e, $hold, $values);
+ if ($U->event_code($resp)) {
+ $e->rollback;
+ return $resp;
+ }
+ $e->commit; # FIXME: update_hold_impl already does $e->commit ??
+ return $resp;
+}
+
+sub batch_update_hold {
+ my($self, $client, $auth, $hold_list, $values_list) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $count = ($hold_list) ? scalar(@$hold_list) : scalar(@$values_list); # FIXME: we don't know for sure that we got $values_list. we could have neither list.
+ $hold_list ||= [];
+ $values_list ||= []; # FIXME: either move this above $count declaration, or send an event if both lists undef. Probably the latter.
+
+# FIXME: Failing over to [] guarantees warnings for "Use of unitialized value" in update_hold_impl call.
+# FIXME: We should be sure we only call update_hold_impl with hold object OR hash, not both.
+
+ for my $idx (0..$count-1) {
+ $e->xact_begin;
+ my $resp = update_hold_impl($self, $e, $hold_list->[$idx], $values_list->[$idx]);
+ $e->xact_commit unless $U->event_code($resp);
+ $client->respond($resp);
+ }
+
+ $e->disconnect;
+ return undef; # not in the register return type, assuming we should always have at least one list populated
+}
+
+sub update_hold_impl {
+ my($self, $e, $hold, $values) = @_;
+
+ unless($hold) {
+ $hold = $e->retrieve_action_hold_request($values->{id})
+ or return $e->die_event;
+ for my $k (keys %$values) {
+ if (defined $values->{$k}) {
+ $hold->$k($values->{$k});
+ } else {
+ my $f = "clear_$k"; $hold->$f();
+ }
+ }
+ }
+
+ my $orig_hold = $e->retrieve_action_hold_request($hold->id)
+ or return $e->die_event;
+
+ # don't allow the user to be changed
+ return OpenILS::Event->new('BAD_PARAMS') if $hold->usr != $orig_hold->usr;
+
+ if($hold->usr ne $e->requestor->id) {
+ # if the hold is for a different user, make sure the
+ # requestor has the appropriate permissions
+ my $usr = $e->retrieve_actor_user($hold->usr)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('UPDATE_HOLD', $usr->home_ou);
+ }
+
+
+ # --------------------------------------------------------------
+ # Changing the request time is like playing God
+ # --------------------------------------------------------------
+ if($hold->request_time ne $orig_hold->request_time) {
+ return OpenILS::Event->new('BAD_PARAMS') if $hold->fulfillment_time;
+ return $e->die_event unless $e->allowed('UPDATE_HOLD_REQUEST_TIME', $hold->pickup_lib);
+ }
+
+ # --------------------------------------------------------------
+ # if the hold is on the holds shelf or in transit and the pickup
+ # lib changes we need to create a new transit.
+ # --------------------------------------------------------------
+ if($orig_hold->pickup_lib ne $hold->pickup_lib) {
+
+ my $status = _hold_status($e, $hold);
+
+ if($status == 3) { # in transit
+
+ return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_TRANSIT', $orig_hold->pickup_lib);
+ return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_TRANSIT', $hold->pickup_lib);
+
+ $logger->info("updating pickup lib for hold ".$hold->id." while already in transit");
+
+ # update the transit to reflect the new pickup location
+ my $transit = $e->search_action_hold_transit_copy(
+ {hold=>$hold->id, dest_recv_time => undef})->[0]
+ or return $e->die_event;
+
+ $transit->prev_dest($transit->dest); # mark the previous destination on the transit
+ $transit->dest($hold->pickup_lib);
+ $e->update_action_hold_transit_copy($transit) or return $e->die_event;
+
+ } elsif($status == 4) { # on holds shelf
+
+ return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_HOLDS_SHELF', $orig_hold->pickup_lib);
+ return $e->die_event unless $e->allowed('UPDATE_PICKUP_LIB_FROM_HOLDS_SHELF', $hold->pickup_lib);
+
+ $logger->info("updating pickup lib for hold ".$hold->id." while on holds shelf");
+
+ # create the new transit
+ my $evt = transit_hold($e, $orig_hold, $hold, $e->retrieve_asset_copy($hold->current_copy));
+ return $evt if $evt;
+ }
+ }
+
+ update_hold_if_frozen($self, $e, $hold, $orig_hold);
+ $e->update_action_hold_request($hold) or return $e->die_event;
+ $e->commit;
+
+ # a change to mint-condition changes the set of potential copies, so retarget the hold;
+ if($U->is_true($hold->mint_condition) and !$U->is_true($orig_hold->mint_condition)) {
+ _reset_hold($self, $e->requestor, $hold)
+ }
+
+ return $hold->id;
+}
+
+sub transit_hold {
+ my($e, $orig_hold, $hold, $copy) = @_;
+ my $src = $orig_hold->pickup_lib;
+ my $dest = $hold->pickup_lib;
+
+ $logger->info("putting hold into transit on pickup_lib update");
+
+ my $transit = Fieldmapper::action::hold_transit_copy->new;
+ $transit->hold($hold->id);
+ $transit->source($src);
+ $transit->dest($dest);
+ $transit->target_copy($copy->id);
+ $transit->source_send_time('now');
+ $transit->copy_status(OILS_COPY_STATUS_ON_HOLDS_SHELF);
+
+ $copy->status(OILS_COPY_STATUS_IN_TRANSIT);
+ $copy->editor($e->requestor->id);
+ $copy->edit_date('now');
+
+ $e->create_action_hold_transit_copy($transit) or return $e->die_event;
+ $e->update_asset_copy($copy) or return $e->die_event;
+ return undef;
+}
+
+# if the hold is frozen, this method ensures that the hold is not "targeted",
+# that is, it clears the current_copy and prev_check_time to essentiallly
+# reset the hold. If it is being activated, it runs the targeter in the background
+sub update_hold_if_frozen {
+ my($self, $e, $hold, $orig_hold) = @_;
+ return if $hold->capture_time;
+
+ if($U->is_true($hold->frozen)) {
+ $logger->info("clearing current_copy and check_time for frozen hold ".$hold->id);
+ $hold->clear_current_copy;
+ $hold->clear_prev_check_time;
+
+ } else {
+ if($U->is_true($orig_hold->frozen)) {
+ $logger->info("Running targeter on activated hold ".$hold->id);
+ $U->storagereq( 'open-ils.storage.action.hold_request.copy_targeter', undef, $hold->id );
+ }
+ }
+}
+
+__PACKAGE__->register_method(
+ method => "hold_note_CUD",
+ api_name => "open-ils.circ.hold_request.note.cud",
+ signature => {
+ desc => 'Create, update or delete a hold request note. If the operator (from Auth. token) '
+ . 'is not the owner of the hold, the UPDATE_HOLD permission is required',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Hold note object', type => 'object' }
+ ],
+ return => {
+ desc => 'Returns the note ID, event on error'
+ },
+ }
+);
+
+sub hold_note_CUD {
+ my($self, $conn, $auth, $note) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $hold = $e->retrieve_action_hold_request($note->hold)
+ or return $e->die_event;
+
+ if($hold->usr ne $e->requestor->id) {
+ my $usr = $e->retrieve_actor_user($hold->usr);
+ return $e->die_event unless $e->allowed('UPDATE_HOLD', $usr->home_ou);
+ $note->staff('t') if $note->isnew;
+ }
+
+ if($note->isnew) {
+ $e->create_action_hold_request_note($note) or return $e->die_event;
+ } elsif($note->ischanged) {
+ $e->update_action_hold_request_note($note) or return $e->die_event;
+ } elsif($note->isdeleted) {
+ $e->delete_action_hold_request_note($note) or return $e->die_event;
+ }
+
+ $e->commit;
+ return $note->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_hold_status",
+ api_name => "open-ils.circ.hold.status.retrieve",
+ signature => {
+ desc => 'Calculates the current status of the hold. The requestor must have ' .
+ 'VIEW_HOLD permissions if the hold is for a user other than the requestor' ,
+ param => [
+ { desc => 'Hold ID', type => 'number' }
+ ],
+ return => {
+ # type => 'number', # event sometimes
+ desc => <<'END_OF_DESC'
+Returns event on error or:
+-1 on error (for now),
+ 1 for 'waiting for copy to become available',
+ 2 for 'waiting for copy capture',
+ 3 for 'in transit',
+ 4 for 'arrived',
+ 5 for 'hold-shelf-delay'
+ 6 for 'canceled'
+END_OF_DESC
+ }
+ }
+);
+
+sub retrieve_hold_status {
+ my($self, $client, $auth, $hold_id) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ my $hold = $e->retrieve_action_hold_request($hold_id)
+ or return $e->event;
+
+ if( $e->requestor->id != $hold->usr ) {
+ return $e->event unless $e->allowed('VIEW_HOLD');
+ }
+
+ return _hold_status($e, $hold);
+
+}
+
+sub _hold_status {
+ my($e, $hold) = @_;
+ if ($hold->cancel_time) {
+ return 6;
+ }
+ return 1 unless $hold->current_copy;
+ return 2 unless $hold->capture_time;
+
+ my $copy = $hold->current_copy;
+ unless( ref $copy ) {
+ $copy = $e->retrieve_asset_copy($hold->current_copy)
+ or return $e->event;
+ }
+
+ return 3 if $copy->status == OILS_COPY_STATUS_IN_TRANSIT;
+
+ if($copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF) {
+
+ my $hs_wait_interval = $U->ou_ancestor_setting_value($hold->pickup_lib, 'circ.hold_shelf_status_delay');
+ return 4 unless $hs_wait_interval;
+
+ # if a hold_shelf_status_delay interval is defined and start_time plus
+ # the interval is greater than now, consider the hold to be in the virtual
+ # "on its way to the holds shelf" status. Return 5.
+
+ my $transit = $e->search_action_hold_transit_copy({hold => $hold->id})->[0];
+ my $start_time = ($transit) ? $transit->dest_recv_time : $hold->capture_time;
+ $start_time = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($start_time));
+ my $end_time = $start_time->add(seconds => OpenSRF::Utils::interval_to_seconds($hs_wait_interval));
+
+ return 5 if $end_time > DateTime->now;
+ return 4;
+ }
+
+ return -1; # error
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_hold_queue_stats",
+ api_name => "open-ils.circ.hold.queue_stats.retrieve",
+ signature => {
+ desc => 'Returns summary data about the state of a hold',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Hold ID', type => 'number'},
+ ],
+ return => {
+ desc => q/Summary object with keys:
+ total_holds : total holds in queue
+ queue_position : current queue position
+ potential_copies : number of potential copies for this hold
+ estimated_wait : estimated wait time in days
+ status : hold status
+ -1 => error or unexpected state,
+ 1 => 'waiting for copy to become available',
+ 2 => 'waiting for copy capture',
+ 3 => 'in transit',
+ 4 => 'arrived',
+ 5 => 'hold-shelf-delay'
+ /,
+ type => 'object'
+ }
+ }
+);
+
+sub retrieve_hold_queue_stats {
+ my($self, $conn, $auth, $hold_id) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ my $hold = $e->retrieve_action_hold_request($hold_id) or return $e->event;
+ if($e->requestor->id != $hold->usr) {
+ return $e->event unless $e->allowed('VIEW_HOLD');
+ }
+ return retrieve_hold_queue_status_impl($e, $hold);
+}
+
+sub retrieve_hold_queue_status_impl {
+ my $e = shift;
+ my $hold = shift;
+
+ # The holds queue is defined as the distinct set of holds that share at
+ # least one potential copy with the context hold, plus any holds that
+ # share the same hold type and target. The latter part exists to
+ # accomodate holds that currently have no potential copies
+ my $q_holds = $e->json_query({
+
+ # fetch cut_in_line and request_time since they're in the order_by
+ # and we're asking for distinct values
+ select => {ahr => ['id', 'cut_in_line', 'request_time']},
+ from => { ahr => 'ahcm' },
+ order_by => [
+ {
+ "class" => "ahr",
+ "field" => "cut_in_line",
+ "transform" => "coalesce",
+ "params" => [ 0 ],
+ "direction" => "desc"
+ },
+ { "class" => "ahr", "field" => "request_time" }
+ ],
+ distinct => 1,
+ where => {
+ '+ahcm' => {
+ target_copy => {
+ in => {
+ select => {ahcm => ['target_copy']},
+ from => 'ahcm',
+ where => {hold => $hold->id}
+ }
+ }
+ }
+ }
+ });
+
+ if (!@$q_holds) { # none? maybe we don't have a map ...
+ $q_holds = $e->json_query({
+ select => {ahr => ['id', 'cut_in_line', 'request_time']},
+ from => 'ahr',
+ order_by => [
+ {
+ "class" => "ahr",
+ "field" => "cut_in_line",
+ "transform" => "coalesce",
+ "params" => [ 0 ],
+ "direction" => "desc"
+ },
+ { "class" => "ahr", "field" => "request_time" }
+ ],
+ where => {
+ hold_type => $hold->hold_type,
+ target => $hold->target
+ }
+ });
+ }
+
+
+ my $qpos = 1;
+ for my $h (@$q_holds) {
+ last if $h->{id} == $hold->id;
+ $qpos++;
+ }
+
+ my $hold_data = $e->json_query({
+ select => {
+ acp => [ {column => 'id', transform => 'count', aggregate => 1, alias => 'count'} ],
+ ccm => [ {column =>'avg_wait_time'} ]
+ },
+ from => {
+ ahcm => {
+ acp => {
+ join => {
+ ccm => {type => 'left'}
+ }
+ }
+ }
+ },
+ where => {'+ahcm' => {hold => $hold->id} }
+ });
+
+ my $user_org = $e->json_query({select => {au => ['home_ou']}, from => 'au', where => {id => $hold->usr}})->[0]->{home_ou};
+
+ my $default_wait = $U->ou_ancestor_setting_value($user_org, OILS_SETTING_HOLD_ESIMATE_WAIT_INTERVAL);
+ my $min_wait = $U->ou_ancestor_setting_value($user_org, 'circ.holds.min_estimated_wait_interval');
+ $min_wait = OpenSRF::Utils::interval_to_seconds($min_wait || '0 seconds');
+ $default_wait ||= '0 seconds';
+
+ # Estimated wait time is the average wait time across the set
+ # of potential copies, divided by the number of potential copies
+ # times the queue position.
+
+ my $combined_secs = 0;
+ my $num_potentials = 0;
+
+ for my $wait_data (@$hold_data) {
+ my $count += $wait_data->{count};
+ $combined_secs += $count *
+ OpenSRF::Utils::interval_to_seconds($wait_data->{avg_wait_time} || $default_wait);
+ $num_potentials += $count;
+ }
+
+ my $estimated_wait = -1;
+
+ if($num_potentials) {
+ my $avg_wait = $combined_secs / $num_potentials;
+ $estimated_wait = $qpos * ($avg_wait / $num_potentials);
+ $estimated_wait = $min_wait if $estimated_wait < $min_wait and $estimated_wait != -1;
+ }
+
+ return {
+ total_holds => scalar(@$q_holds),
+ queue_position => $qpos,
+ potential_copies => $num_potentials,
+ status => _hold_status( $e, $hold ),
+ estimated_wait => int($estimated_wait)
+ };
+}
+
+
+sub fetch_open_hold_by_current_copy {
+ my $class = shift;
+ my $copyid = shift;
+ my $hold = $apputils->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.action.hold_request.search.atomic',
+ { current_copy => $copyid , cancel_time => undef, fulfillment_time => undef });
+ return $hold->[0] if ref($hold);
+ return undef;
+}
+
+sub fetch_related_holds {
+ my $class = shift;
+ my $copyid = shift;
+ return $apputils->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.action.hold_request.search.atomic',
+ { current_copy => $copyid , cancel_time => undef, fulfillment_time => undef });
+}
+
+
+__PACKAGE__->register_method(
+ method => "hold_pull_list",
+ api_name => "open-ils.circ.hold_pull_list.retrieve",
+ signature => {
+ desc => 'Returns (reference to) a list of holds that need to be "pulled" by a given location. ' .
+ 'The location is determined by the login session.',
+ params => [
+ { desc => 'Limit (optional)', type => 'number'},
+ { desc => 'Offset (optional)', type => 'number'},
+ ],
+ return => {
+ desc => 'reference to a list of holds, or event on failure',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "hold_pull_list",
+ api_name => "open-ils.circ.hold_pull_list.id_list.retrieve",
+ signature => {
+ desc => 'Returns (reference to) a list of holds IDs that need to be "pulled" by a given location. ' .
+ 'The location is determined by the login session.',
+ params => [
+ { desc => 'Limit (optional)', type => 'number'},
+ { desc => 'Offset (optional)', type => 'number'},
+ ],
+ return => {
+ desc => 'reference to a list of holds, or event on failure',
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "hold_pull_list",
+ api_name => "open-ils.circ.hold_pull_list.retrieve.count",
+ signature => {
+ desc => 'Returns a count of holds that need to be "pulled" by a given location. ' .
+ 'The location is determined by the login session.',
+ params => [
+ { desc => 'Limit (optional)', type => 'number'},
+ { desc => 'Offset (optional)', type => 'number'},
+ ],
+ return => {
+ desc => 'Holds count (integer), or event on failure',
+ # type => 'number'
+ }
+ }
+);
+
+
+sub hold_pull_list {
+ my( $self, $conn, $authtoken, $limit, $offset ) = @_;
+ my( $reqr, $evt ) = $U->checkses($authtoken);
+ return $evt if $evt;
+
+ my $org = $reqr->ws_ou || $reqr->home_ou;
+ # the perm locaiton shouldn't really matter here since holds
+ # will exist all over and VIEW_HOLDS should be universal
+ $evt = $U->check_perms($reqr->id, $org, 'VIEW_HOLD');
+ return $evt if $evt;
+
+ if($self->api_name =~ /count/) {
+
+ my $count = $U->storagereq(
+ 'open-ils.storage.direct.action.hold_request.pull_list.current_copy_circ_lib.status_filtered.count',
+ $org, $limit, $offset );
+
+ $logger->info("Grabbing pull list for org unit $org with $count items");
+ return $count;
+
+ } elsif( $self->api_name =~ /id_list/ ) {
+ return $U->storagereq(
+ 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib.status_filtered.atomic',
+ $org, $limit, $offset );
+
+ } else {
+ return $U->storagereq(
+ 'open-ils.storage.direct.action.hold_request.pull_list.search.current_copy_circ_lib.status_filtered.atomic',
+ $org, $limit, $offset );
+ }
+}
+
+__PACKAGE__->register_method(
+ method => "print_hold_pull_list",
+ api_name => "open-ils.circ.hold_pull_list.print",
+ signature => {
+ desc => 'Returns an HTML-formatted holds pull list',
+ params => [
+ { desc => 'Authtoken', type => 'string'},
+ { desc => 'Org unit ID. Optional, defaults to workstation org unit', type => 'number'},
+ ],
+ return => {
+ desc => 'HTML string',
+ type => 'string'
+ }
+ }
+);
+
+sub print_hold_pull_list {
+ my($self, $client, $auth, $org_id) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+
+ $org_id = (defined $org_id) ? $org_id : $e->requestor->ws_ou;
+ return $e->event unless $e->allowed('VIEW_HOLD', $org_id);
+
+ my $hold_ids = $U->storagereq(
+ 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib.status_filtered.atomic',
+ $org_id, 10000);
+
+ return undef unless @$hold_ids;
+
+ $client->status(new OpenSRF::DomainObject::oilsContinueStatus);
+
+ # Holds will /NOT/ be in order after this ...
+ my $holds = $e->search_action_hold_request({id => $hold_ids}, {substream => 1});
+ $client->status(new OpenSRF::DomainObject::oilsContinueStatus);
+
+ # ... so we must resort.
+ my $hold_map = +{map { $_->id => $_ } @$holds};
+ my $sorted_holds = [];
+ push @$sorted_holds, $hold_map->{$_} foreach @$hold_ids;
+
+ return $U->fire_object_event(
+ undef, "ahr.format.pull_list", $sorted_holds,
+ $org_id, undef, undef, $client
+ );
+
+}
+
+__PACKAGE__->register_method(
+ method => "print_hold_pull_list_stream",
+ stream => 1,
+ api_name => "open-ils.circ.hold_pull_list.print.stream",
+ signature => {
+ desc => 'Returns a stream of fleshed holds',
+ params => [
+ { desc => 'Authtoken', type => 'string'},
+ { desc => 'Hash of optional param: Org unit ID (defaults to workstation org unit), limit, offset, sort (array of: acplo.position, call_number, request_time)',
+ type => 'object'
+ },
+ ],
+ return => {
+ desc => 'A stream of fleshed holds',
+ type => 'object'
+ }
+ }
+);
+
+sub print_hold_pull_list_stream {
+ my($self, $client, $auth, $params) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+
+ delete($$params{org_id}) unless (int($$params{org_id}));
+ delete($$params{limit}) unless (int($$params{limit}));
+ delete($$params{offset}) unless (int($$params{offset}));
+ delete($$params{chunk_size}) unless (int($$params{chunk_size}));
+ delete($$params{chunk_size}) if ($$params{chunk_size} && $$params{chunk_size} > 50); # keep the size reasonable
+ $$params{chunk_size} ||= 10;
+
+ $$params{org_id} = (defined $$params{org_id}) ? $$params{org_id}: $e->requestor->ws_ou;
+ return $e->die_event unless $e->allowed('VIEW_HOLD', $$params{org_id });
+
+ my $sort = [];
+ if ($$params{sort} && @{ $$params{sort} }) {
+ for my $s (@{ $$params{sort} }) {
+ if ($s eq 'acplo.position') {
+ push @$sort, {
+ "class" => "acplo", "field" => "position",
+ "transform" => "coalesce", "params" => [999]
+ };
+ } elsif ($s eq 'call_number') {
+ push @$sort, {"class" => "acn", "field" => "label"};
+ } elsif ($s eq 'request_time') {
+ push @$sort, {"class" => "ahr", "field" => "request_time"};
+ }
+ }
+ } else {
+ push @$sort, {"class" => "ahr", "field" => "request_time"};
+ }
+
+ my $holds_ids = $e->json_query(
+ {
+ "select" => {"ahr" => ["id"]},
+ "from" => {
+ "ahr" => {
+ "acp" => {
+ "field" => "id",
+ "fkey" => "current_copy",
+ "filter" => {
+ "circ_lib" => $$params{org_id}, "status" => [0,7]
+ },
+ "join" => {
+ "acn" => {
+ "field" => "id",
+ "fkey" => "call_number"
+ },
+ "acplo" => {
+ "field" => "org",
+ "fkey" => "circ_lib",
+ "type" => "left",
+ "filter" => {
+ "location" => {"=" => {"+acp" => "location"}}
+ }
+ }
+ }
+ }
+ }
+ },
+ "where" => {
+ "+ahr" => {
+ "capture_time" => undef,
+ "cancel_time" => undef,
+ "-or" => [
+ {"expire_time" => undef },
+ {"expire_time" => {">" => "now"}}
+ ]
+ }
+ },
+ (@$sort ? (order_by => $sort) : ()),
+ ($$params{limit} ? (limit => $$params{limit}) : ()),
+ ($$params{offset} ? (offset => $$params{offset}) : ())
+ }, {"substream" => 1}
+ ) or return $e->die_event;
+
+ $logger->info("about to stream back " . scalar(@$holds_ids) . " holds");
+
+ my @chunk;
+ for my $hid (@$holds_ids) {
+ push @chunk, $e->retrieve_action_hold_request([
+ $hid->{"id"}, {
+ "flesh" => 3,
+ "flesh_fields" => {
+ "ahr" => ["usr", "current_copy"],
+ "au" => ["card"],
+ "acp" => ["location", "call_number"],
+ "acn" => ["record"]
+ }
+ }
+ ]);
+
+ if (@chunk >= $$params{chunk_size}) {
+ $client->respond( \@chunk );
+ @chunk = ();
+ }
+ }
+ $client->respond_complete( \@chunk ) if (@chunk);
+ $e->disconnect;
+ return undef;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_hold_notify',
+ api_name => 'open-ils.circ.hold_notification.retrieve_by_hold',
+ authoritative => 1,
+ signature => q/
+Returns a list of hold notification objects based on hold id.
+@param authtoken The loggin session key
+@param holdid The id of the hold whose notifications we want to retrieve
+@return An array of hold notification objects, event on error.
+/
+);
+
+sub fetch_hold_notify {
+ my( $self, $conn, $authtoken, $holdid ) = @_;
+ my( $requestor, $evt ) = $U->checkses($authtoken);
+ return $evt if $evt;
+ my ($hold, $patron);
+ ($hold, $evt) = $U->fetch_hold($holdid);
+ return $evt if $evt;
+ ($patron, $evt) = $U->fetch_user($hold->usr);
+ return $evt if $evt;
+
+ $evt = $U->check_perms($requestor->id, $patron->home_ou, 'VIEW_HOLD_NOTIFICATION');
+ return $evt if $evt;
+
+ $logger->info("User ".$requestor->id." fetching hold notifications for hold $holdid");
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.action.hold_notification.search.atomic', {hold => $holdid} );
+}
+
+
+__PACKAGE__->register_method(
+ method => 'create_hold_notify',
+ api_name => 'open-ils.circ.hold_notification.create',
+ signature => q/
+Creates a new hold notification object
+@param authtoken The login session key
+@param notification The hold notification object to create
+@return ID of the new object on success, Event on error
+/
+);
+
+sub create_hold_notify {
+ my( $self, $conn, $auth, $note ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $hold = $e->retrieve_action_hold_request($note->hold)
+ or return $e->die_event;
+ my $patron = $e->retrieve_actor_user($hold->usr)
+ or return $e->die_event;
+
+ return $e->die_event unless
+ $e->allowed('CREATE_HOLD_NOTIFICATION', $patron->home_ou);
+
+ $note->notify_staff($e->requestor->id);
+ $e->create_action_hold_notification($note) or return $e->die_event;
+ $e->commit;
+ return $note->id;
+}
+
+__PACKAGE__->register_method(
+ method => 'create_hold_note',
+ api_name => 'open-ils.circ.hold_note.create',
+ signature => q/
+ Creates a new hold request note object
+ @param authtoken The login session key
+ @param note The hold note object to create
+ @return ID of the new object on success, Event on error
+ /
+);
+
+sub create_hold_note {
+ my( $self, $conn, $auth, $note ) = @_;
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $hold = $e->retrieve_action_hold_request($note->hold)
+ or return $e->die_event;
+ my $patron = $e->retrieve_actor_user($hold->usr)
+ or return $e->die_event;
+
+ return $e->die_event unless
+ $e->allowed('UPDATE_HOLD', $patron->home_ou); # FIXME: Using permcrud perm listed in fm_IDL.xml for ahrn. Probably want something more specific
+
+ $e->create_action_hold_request_note($note) or return $e->die_event;
+ $e->commit;
+ return $note->id;
+}
+
+__PACKAGE__->register_method(
+ method => 'reset_hold',
+ api_name => 'open-ils.circ.hold.reset',
+ signature => q/
+ Un-captures and un-targets a hold, essentially returning
+ it to the state it was in directly after it was placed,
+ then attempts to re-target the hold
+ @param authtoken The login session key
+ @param holdid The id of the hold
+ /
+);
+
+
+sub reset_hold {
+ my( $self, $conn, $auth, $holdid ) = @_;
+ my $reqr;
+ my ($hold, $evt) = $U->fetch_hold($holdid);
+ return $evt if $evt;
+ ($reqr, $evt) = $U->checksesperm($auth, 'UPDATE_HOLD');
+ return $evt if $evt;
+ $evt = _reset_hold($self, $reqr, $hold);
+ return $evt if $evt;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'reset_hold_batch',
+ api_name => 'open-ils.circ.hold.reset.batch'
+);
+
+sub reset_hold_batch {
+ my($self, $conn, $auth, $hold_ids) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ for my $hold_id ($hold_ids) {
+
+ my $hold = $e->retrieve_action_hold_request(
+ [$hold_id, {flesh => 1, flesh_fields => {ahr => ['usr']}}])
+ or return $e->event;
+
+ next unless $e->allowed('UPDATE_HOLD', $hold->usr->home_ou);
+ _reset_hold($self, $e->requestor, $hold);
+ }
+
+ return 1;
+}
+
+
+sub _reset_hold {
+ my ($self, $reqr, $hold) = @_;
+
+ my $e = new_editor(xact =>1, requestor => $reqr);
+
+ $logger->info("reseting hold ".$hold->id);
+
+ my $hid = $hold->id;
+
+ if( $hold->capture_time and $hold->current_copy ) {
+
+ my $copy = $e->retrieve_asset_copy($hold->current_copy)
+ or return $e->die_event;
+
+ if( $copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF ) {
+ $logger->info("setting copy to status 'reshelving' on hold retarget");
+ $copy->status(OILS_COPY_STATUS_RESHELVING);
+ $copy->editor($e->requestor->id);
+ $copy->edit_date('now');
+ $e->update_asset_copy($copy) or return $e->die_event;
+
+ } elsif( $copy->status == OILS_COPY_STATUS_IN_TRANSIT ) {
+
+ # We don't want the copy to remain "in transit"
+ $copy->status(OILS_COPY_STATUS_RESHELVING);
+ $logger->warn("! reseting hold [$hid] that is in transit");
+ my $transid = $e->search_action_hold_transit_copy({hold=>$hold->id},{idlist=>1})->[0];
+
+ if( $transid ) {
+ my $trans = $e->retrieve_action_transit_copy($transid);
+ if( $trans ) {
+ $logger->info("Aborting transit [$transid] on hold [$hid] reset...");
+ my $evt = OpenILS::Application::Circ::Transit::__abort_transit($e, $trans, $copy, 1);
+ $logger->info("Transit abort completed with result $evt");
+ unless ("$evt" eq 1) {
+ $e->rollback;
+ return $evt;
+ }
+ }
+ }
+ }
+ }
+
+ $hold->clear_capture_time;
+ $hold->clear_current_copy;
+ $hold->clear_shelf_time;
+ $hold->clear_shelf_expire_time;
+
+ $e->update_action_hold_request($hold) or return $e->die_event;
+ $e->commit;
+
+ $U->storagereq(
+ 'open-ils.storage.action.hold_request.copy_targeter', undef, $hold->id );
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_open_title_holds',
+ api_name => 'open-ils.circ.open_holds.retrieve',
+ signature => q/
+ Returns a list ids of un-fulfilled holds for a given title id
+ @param authtoken The login session key
+ @param id the id of the item whose holds we want to retrieve
+ @param type The hold type - M, T, I, V, C, F, R
+ /
+);
+
+sub fetch_open_title_holds {
+ my( $self, $conn, $auth, $id, $type, $org ) = @_;
+ my $e = new_editor( authtoken => $auth );
+ return $e->event unless $e->checkauth;
+
+ $type ||= "T";
+ $org ||= $e->requestor->ws_ou;
+
+# return $e->search_action_hold_request(
+# { target => $id, hold_type => $type, fulfillment_time => undef }, {idlist=>1});
+
+ # XXX make me return IDs in the future ^--
+ my $holds = $e->search_action_hold_request(
+ {
+ target => $id,
+ cancel_time => undef,
+ hold_type => $type,
+ fulfillment_time => undef
+ }
+ );
+
+ flesh_hold_transits($holds);
+ return $holds;
+}
+
+
+sub flesh_hold_transits {
+ my $holds = shift;
+ for my $hold ( @$holds ) {
+ $hold->transit(
+ $apputils->simplereq(
+ 'open-ils.cstore',
+ "open-ils.cstore.direct.action.hold_transit_copy.search.atomic",
+ { hold => $hold->id },
+ { order_by => { ahtc => 'id desc' }, limit => 1 }
+ )->[0]
+ );
+ }
+}
+
+sub flesh_hold_notices {
+ my( $holds, $e ) = @_;
+ $e ||= new_editor();
+
+ for my $hold (@$holds) {
+ my $notices = $e->search_action_hold_notification(
+ [
+ { hold => $hold->id },
+ { order_by => { anh => 'notify_time desc' } },
+ ],
+ {idlist=>1}
+ );
+
+ $hold->notify_count(scalar(@$notices));
+ if( @$notices ) {
+ my $n = $e->retrieve_action_hold_notification($$notices[0])
+ or return $e->event;
+ $hold->notify_time($n->notify_time);
+ }
+ }
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_captured_holds',
+ api_name => 'open-ils.circ.captured_holds.on_shelf.retrieve',
+ stream => 1,
+ signature => q/
+ Returns a list of un-fulfilled holds (on the Holds Shelf) for a given title id
+ @param authtoken The login session key
+ @param org The org id of the location in question
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'fetch_captured_holds',
+ api_name => 'open-ils.circ.captured_holds.id_list.on_shelf.retrieve',
+ stream => 1,
+ signature => q/
+ Returns list ids of un-fulfilled holds (on the Holds Shelf) for a given title id
+ @param authtoken The login session key
+ @param org The org id of the location in question
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'fetch_captured_holds',
+ api_name => 'open-ils.circ.captured_holds.id_list.expired_on_shelf.retrieve',
+ stream => 1,
+ signature => q/
+ Returns list ids of shelf-expired un-fulfilled holds for a given title id
+ @param authtoken The login session key
+ @param org The org id of the location in question
+ /
+);
+
+
+sub fetch_captured_holds {
+ my( $self, $conn, $auth, $org ) = @_;
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('VIEW_HOLD'); # XXX rely on editor perm
+
+ $org ||= $e->requestor->ws_ou;
+
+ my $query = {
+ select => { ahr => ['id'] },
+ from => {
+ ahr => {
+ acp => {
+ field => 'id',
+ fkey => 'current_copy'
+ },
+ }
+ },
+ where => {
+ '+acp' => { status => OILS_COPY_STATUS_ON_HOLDS_SHELF },
+ '+ahr' => {
+ capture_time => { "!=" => undef },
+ current_copy => { "!=" => undef },
+ fulfillment_time => undef,
+ pickup_lib => $org,
+ cancel_time => undef,
+ }
+ }
+ };
+ if($self->api_name =~ /expired/) {
+ $query->{'where'}->{'+ahr'}->{'shelf_expire_time'} = {'<' => 'now'};
+ $query->{'where'}->{'+ahr'}->{'shelf_time'} = {'!=' => undef};
+ }
+ my $hold_ids = $e->json_query( $query );
+
+ for my $hold_id (@$hold_ids) {
+ if($self->api_name =~ /id_list/) {
+ $conn->respond($hold_id->{id});
+ next;
+ } else {
+ $conn->respond(
+ $e->retrieve_action_hold_request([
+ $hold_id->{id},
+ {
+ flesh => 1,
+ flesh_fields => {ahr => ['notifications', 'transit', 'notes']},
+ order_by => {anh => 'notify_time desc'}
+ }
+ ])
+ );
+ }
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "print_expired_holds_stream",
+ api_name => "open-ils.circ.captured_holds.expired.print.stream",
+ stream => 1
+);
+
+sub print_expired_holds_stream {
+ my ($self, $client, $auth, $params) = @_;
+
+ # No need to check specific permissions: we're going to call another method
+ # that will do that.
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ delete($$params{org_id}) unless (int($$params{org_id}));
+ delete($$params{limit}) unless (int($$params{limit}));
+ delete($$params{offset}) unless (int($$params{offset}));
+ delete($$params{chunk_size}) unless (int($$params{chunk_size}));
+ delete($$params{chunk_size}) if ($$params{chunk_size} && $$params{chunk_size} > 50); # keep the size reasonable
+ $$params{chunk_size} ||= 10;
+
+ $$params{org_id} = (defined $$params{org_id}) ? $$params{org_id}: $e->requestor->ws_ou;
+
+ my @hold_ids = $self->method_lookup(
+ "open-ils.circ.captured_holds.id_list.expired_on_shelf.retrieve"
+ )->run($auth, $params->{"org_id"});
+
+ if (!@hold_ids) {
+ $e->disconnect;
+ return;
+ } elsif (defined $U->event_code($hold_ids[0])) {
+ $e->disconnect;
+ return $hold_ids[0];
+ }
+
+ $logger->info("about to stream back up to " . scalar(@hold_ids) . " expired holds");
+
+ while (@hold_ids) {
+ my @hid_chunk = splice @hold_ids, 0, $params->{"chunk_size"};
+
+ my $result_chunk = $e->json_query({
+ "select" => {
+ "acp" => ["barcode"],
+ "au" => [qw/
+ first_given_name second_given_name family_name alias
+ /],
+ "acn" => ["label"],
+ "bre" => ["marc"],
+ "acpl" => ["name"]
+ },
+ "from" => {
+ "ahr" => {
+ "acp" => {
+ "field" => "id", "fkey" => "current_copy",
+ "join" => {
+ "acn" => {
+ "field" => "id", "fkey" => "call_number",
+ "join" => {
+ "bre" => {
+ "field" => "id", "fkey" => "record"
+ }
+ }
+ },
+ "acpl" => {"field" => "id", "fkey" => "location"}
+ }
+ },
+ "au" => {"field" => "id", "fkey" => "usr"}
+ }
+ },
+ "where" => {"+ahr" => {"id" => \@hid_chunk}}
+ }) or return $e->die_event;
+ $client->respond($result_chunk);
+ }
+
+ $e->disconnect;
+ undef;
+}
+
+__PACKAGE__->register_method(
+ method => "check_title_hold_batch",
+ api_name => "open-ils.circ.title_hold.is_possible.batch",
+ stream => 1,
+ signature => {
+ desc => '@see open-ils.circ.title_hold.is_possible.batch',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Array of Hash of named parameters', type => 'array'},
+ ],
+ return => {
+ desc => 'Array of response objects',
+ type => 'array'
+ }
+ }
+);
+
+sub check_title_hold_batch {
+ my($self, $client, $authtoken, $param_list) = @_;
+ foreach (@$param_list) {
+ my ($res) = $self->method_lookup('open-ils.circ.title_hold.is_possible')->run($authtoken, $_);
+ $client->respond($res);
+ }
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "check_title_hold",
+ api_name => "open-ils.circ.title_hold.is_possible",
+ signature => {
+ desc => 'Determines if a hold were to be placed by a given user, ' .
+ 'whether or not said hold would have any potential copies to fulfill it.' .
+ 'The named paramaters of the second argument include: ' .
+ 'patronid, titleid, volume_id, copy_id, mrid, depth, pickup_lib, hold_type, selection_ou. ' .
+ 'See perldoc ' . __PACKAGE__ . ' for more info on these fields.' ,
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Hash of named parameters', type => 'object'},
+ ],
+ return => {
+ desc => 'List of new message IDs (empty if none)',
+ type => 'array'
+ }
+ }
+);
+
+=head3 check_title_hold (token, hash)
+
+The named fields in the hash are:
+
+ patronid - ID of the hold recipient (required)
+ depth - hold range depth (default 0)
+ pickup_lib - destination for hold, fallback value for selection_ou
+ selection_ou - ID of org_unit establishing hard and soft hold boundary settings
+ issuanceid - ID of the issuance to be held, required for Issuance level hold
+ titleid - ID (BRN) of the title to be held, required for Title level hold
+ volume_id - required for Volume level hold
+ copy_id - required for Copy level hold
+ mrid - required for Meta-record level hold
+ hold_type - T, C (or R or F), I, V or M for Title, Copy, Issuance, Volume or Meta-record (default "T")
+
+All key/value pairs are passed on to do_possibility_checks.
+
+=cut
+
+# FIXME: better params checking. what other params are required, if any?
+# FIXME: 3 copies of values confusing: $x, $params->{x} and $params{x}
+# FIXME: for example, $depth gets a default value, but then $$params{depth} is still
+# used in conditionals, where it may be undefined, causing a warning.
+# FIXME: specify proper usage/interaction of selection_ou and pickup_lib
+
+sub check_title_hold {
+ my( $self, $client, $authtoken, $params ) = @_;
+ my $e = new_editor(authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ my %params = %$params;
+ my $depth = $params{depth} || 0;
+ my $selection_ou = $params{selection_ou} || $params{pickup_lib};
+
+ my $patron = $e->retrieve_actor_user($params{patronid})
+ or return $e->event;
+
+ if( $e->requestor->id ne $patron->id ) {
+ return $e->event unless
+ $e->allowed('VIEW_HOLD_PERMIT', $patron->home_ou);
+ }
+
+ return OpenILS::Event->new('PATRON_BARRED') if $U->is_true($patron->barred);
+
+ my $request_lib = $e->retrieve_actor_org_unit($e->requestor->ws_ou)
+ or return $e->event;
+
+ my $soft_boundary = $U->ou_ancestor_setting_value($selection_ou, OILS_SETTING_HOLD_SOFT_BOUNDARY);
+ my $hard_boundary = $U->ou_ancestor_setting_value($selection_ou, OILS_SETTING_HOLD_HARD_BOUNDARY);
+
+ my @status = ();
+ my $return_depth = $hard_boundary; # default depth to return on success
+ if(defined $soft_boundary and $depth < $soft_boundary) {
+ # work up the tree and as soon as we find a potential copy, use that depth
+ # also, make sure we don't go past the hard boundary if it exists
+
+ # our min boundary is the greater of user-specified boundary or hard boundary
+ my $min_depth = (defined $hard_boundary and $hard_boundary > $depth) ?
+ $hard_boundary : $depth;
+
+ my $depth = $soft_boundary;
+ while($depth >= $min_depth) {
+ $logger->info("performing hold possibility check with soft boundary $depth");
+ @status = do_possibility_checks($e, $patron, $request_lib, $depth, %params);
+ if ($status[0]) {
+ $return_depth = $depth;
+ last;
+ }
+ $depth--;
+ }
+ } elsif(defined $hard_boundary and $depth < $hard_boundary) {
+ # there is no soft boundary, enforce the hard boundary if it exists
+ $logger->info("performing hold possibility check with hard boundary $hard_boundary");
+ @status = do_possibility_checks($e, $patron, $request_lib, $hard_boundary, %params);
+ } else {
+ # no boundaries defined, fall back to user specifed boundary or no boundary
+ $logger->info("performing hold possibility check with no boundary");
+ @status = do_possibility_checks($e, $patron, $request_lib, $params{depth}, %params);
+ }
+
+ if ($status[0]) {
+ return {
+ "success" => 1,
+ "depth" => $return_depth,
+ "local_avail" => $status[1]
+ };
+ } elsif ($status[2]) {
+ my $n = scalar @{$status[2]};
+ return {"success" => 0, "last_event" => $status[2]->[$n - 1]};
+ } else {
+ return {"success" => 0};
+ }
+}
+
+
+
+sub do_possibility_checks {
+ my($e, $patron, $request_lib, $depth, %params) = @_;
+
+ my $issuanceid = $params{issuanceid} || "";
+ my $titleid = $params{titleid} || "";
+ my $volid = $params{volume_id};
+ my $copyid = $params{copy_id};
+ my $mrid = $params{mrid} || "";
+ my $pickup_lib = $params{pickup_lib};
+ my $hold_type = $params{hold_type} || 'T';
+ my $selection_ou = $params{selection_ou} || $pickup_lib;
+
+
+ my $copy;
+ my $volume;
+ my $title;
+
+ if( $hold_type eq OILS_HOLD_TYPE_FORCE || $hold_type eq OILS_HOLD_TYPE_RECALL || $hold_type eq OILS_HOLD_TYPE_COPY ) {
+
+ return $e->event unless $copy = $e->retrieve_asset_copy($copyid);
+ return $e->event unless $volume = $e->retrieve_asset_call_number($copy->call_number);
+ return $e->event unless $title = $e->retrieve_biblio_record_entry($volume->record);
+
+ return verify_copy_for_hold(
+ $patron, $e->requestor, $title, $copy, $pickup_lib, $request_lib
+ );
+
+ } elsif( $hold_type eq OILS_HOLD_TYPE_VOLUME ) {
+
+ return $e->event unless $volume = $e->retrieve_asset_call_number($volid);
+ return $e->event unless $title = $e->retrieve_biblio_record_entry($volume->record);
+
+ return _check_volume_hold_is_possible(
+ $volume, $title, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
+ );
+
+ } elsif( $hold_type eq OILS_HOLD_TYPE_TITLE ) {
+
+ return _check_title_hold_is_possible(
+ $titleid, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
+ );
+
+ } elsif( $hold_type eq OILS_HOLD_TYPE_ISSUANCE ) {
+
+ return _check_issuance_hold_is_possible(
+ $issuanceid, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
+ );
+
+ } elsif( $hold_type eq OILS_HOLD_TYPE_METARECORD ) {
+
+ my $maps = $e->search_metabib_metarecord_source_map({metarecord=>$mrid});
+ my @recs = map { $_->source } @$maps;
+ my @status = ();
+ for my $rec (@recs) {
+ @status = _check_title_hold_is_possible(
+ $rec, $depth, $request_lib, $patron, $e->requestor, $pickup_lib, $selection_ou
+ );
+ last if $status[1];
+ }
+ return @status;
+ }
+# else { Unrecognized hold_type ! } # FIXME: return error? or 0?
+}
+
+my %prox_cache;
+sub create_ranged_org_filter {
+ my($e, $selection_ou, $depth) = @_;
+
+ # find the orgs from which this hold may be fulfilled,
+ # based on the selection_ou and depth
+
+ my $top_org = $e->search_actor_org_unit([
+ {parent_ou => undef},
+ {flesh=>1, flesh_fields=>{aou=>['ou_type']}}])->[0];
+ my %org_filter;
+
+ return () if $depth == $top_org->ou_type->depth;
+
+ my $org_list = $U->storagereq('open-ils.storage.actor.org_unit.descendants.atomic', $selection_ou, $depth);
+ %org_filter = (circ_lib => []);
+ push(@{$org_filter{circ_lib}}, $_->id) for @$org_list;
+
+ $logger->info("hold org filter at depth $depth and selection_ou ".
+ "$selection_ou created list of @{$org_filter{circ_lib}}");
+
+ return %org_filter;
+}
+
+
+sub _check_title_hold_is_possible {
+ my( $titleid, $depth, $request_lib, $patron, $requestor, $pickup_lib, $selection_ou ) = @_;
+
+ my $e = new_editor();
+ my %org_filter = create_ranged_org_filter($e, $selection_ou, $depth);
+
+ # this monster will grab the id and circ_lib of all of the "holdable" copies for the given record
+ my $copies = $e->json_query(
+ {
+ select => { acp => ['id', 'circ_lib'] },
+ from => {
+ acp => {
+ acn => {
+ field => 'id',
+ fkey => 'call_number',
+ 'join' => {
+ bre => {
+ field => 'id',
+ filter => { id => $titleid },
+ fkey => 'record'
+ }
+ }
+ },
+ acpl => { field => 'id', filter => { holdable => 't'}, fkey => 'location' },
+ ccs => { field => 'id', filter => { holdable => 't'}, fkey => 'status' }
+ }
+ },
+ where => {
+ '+acp' => { circulate => 't', deleted => 'f', holdable => 't', %org_filter }
+ }
+ }
+ );
+
+ $logger->info("title possible found ".scalar(@$copies)." potential copies");
+ return (
+ 0, 0, [
+ new OpenILS::Event(
+ "HIGH_LEVEL_HOLD_HAS_NO_COPIES",
+ "payload" => {"fail_part" => "no_ultimate_items"}
+ )
+ ]
+ ) unless @$copies;
+
+ # -----------------------------------------------------------------------
+ # sort the copies into buckets based on their circ_lib proximity to
+ # the patron's home_ou.
+ # -----------------------------------------------------------------------
+
+ my $home_org = $patron->home_ou;
+ my $req_org = $request_lib->id;
+
+ $logger->info("prox cache $home_org " . $prox_cache{$home_org});
+
+ $prox_cache{$home_org} =
+ $e->search_actor_org_unit_proximity({from_org => $home_org})
+ unless $prox_cache{$home_org};
+ my $home_prox = $prox_cache{$home_org};
+
+ my %buckets;
+ my %hash = map { ($_->to_org => $_->prox) } @$home_prox;
+ push( @{$buckets{ $hash{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
+
+ my @keys = sort { $a <=> $b } keys %buckets;
+
+
+ if( $home_org ne $req_org ) {
+ # -----------------------------------------------------------------------
+ # shove the copies close to the request_lib into the primary buckets
+ # directly before the farthest away copies. That way, they are not
+ # given priority, but they are checked before the farthest copies.
+ # -----------------------------------------------------------------------
+ $prox_cache{$req_org} =
+ $e->search_actor_org_unit_proximity({from_org => $req_org})
+ unless $prox_cache{$req_org};
+ my $req_prox = $prox_cache{$req_org};
+
+ my %buckets2;
+ my %hash2 = map { ($_->to_org => $_->prox) } @$req_prox;
+ push( @{$buckets2{ $hash2{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
+
+ my $highest_key = $keys[@keys - 1]; # the farthest prox in the exising buckets
+ my $new_key = $highest_key - 0.5; # right before the farthest prox
+ my @keys2 = sort { $a <=> $b } keys %buckets2;
+ for my $key (@keys2) {
+ last if $key >= $highest_key;
+ push( @{$buckets{$new_key}}, $_ ) for @{$buckets2{$key}};
+ }
+ }
+
+ @keys = sort { $a <=> $b } keys %buckets;
+
+ my $title;
+ my %seen;
+ my @status;
+ OUTER: for my $key (@keys) {
+ my @cps = @{$buckets{$key}};
+
+ $logger->info("looking at " . scalar(@{$buckets{$key}}). " copies in proximity bucket $key");
+
+ for my $copyid (@cps) {
+
+ next if $seen{$copyid};
+ $seen{$copyid} = 1; # there could be dupes given the merged buckets
+ my $copy = $e->retrieve_asset_copy($copyid);
+ $logger->debug("looking at bucket_key=$key, copy $copyid : circ_lib = " . $copy->circ_lib);
+
+ unless($title) { # grab the title if we don't already have it
+ my $vol = $e->retrieve_asset_call_number(
+ [ $copy->call_number, { flesh => 1, flesh_fields => { bre => ['fixed_fields'], acn => ['record'] } } ] );
+ $title = $vol->record;
+ }
+
+ @status = verify_copy_for_hold(
+ $patron, $requestor, $title, $copy, $pickup_lib, $request_lib);
+
+ last OUTER if $status[0];
+ }
+ }
+
+ return @status;
+}
+
+sub _check_issuance_hold_is_possible {
+ my( $issuanceid, $depth, $request_lib, $patron, $requestor, $pickup_lib, $selection_ou ) = @_;
+
+ my $e = new_editor();
+ my %org_filter = create_ranged_org_filter($e, $selection_ou, $depth);
+
+ # this monster will grab the id and circ_lib of all of the "holdable" copies for the given record
+ my $copies = $e->json_query(
+ {
+ select => { acp => ['id', 'circ_lib'] },
+ from => {
+ acp => {
+ sitem => {
+ field => 'unit',
+ fkey => 'id',
+ filter => { issuance => $issuanceid }
+ },
+ acpl => { field => 'id', filter => { holdable => 't'}, fkey => 'location' },
+ ccs => { field => 'id', filter => { holdable => 't'}, fkey => 'status' }
+ }
+ },
+ where => {
+ '+acp' => { circulate => 't', deleted => 'f', holdable => 't', %org_filter }
+ },
+ distinct => 1
+ }
+ );
+
+ $logger->info("issuance possible found ".scalar(@$copies)." potential copies");
+
+ my $empty_ok;
+ if (!@$copies) {
+ $empty_ok = $e->retrieve_config_global_flag('circ.holds.empty_issuance_ok');
+ $empty_ok = ($empty_ok and $U->is_true($empty_ok->enabled));
+
+ return (
+ 0, 0, [
+ new OpenILS::Event(
+ "HIGH_LEVEL_HOLD_HAS_NO_COPIES",
+ "payload" => {"fail_part" => "no_ultimate_items"}
+ )
+ ]
+ ) unless $empty_ok;
+
+ return (1, 0);
+ }
+
+ # -----------------------------------------------------------------------
+ # sort the copies into buckets based on their circ_lib proximity to
+ # the patron's home_ou.
+ # -----------------------------------------------------------------------
+
+ my $home_org = $patron->home_ou;
+ my $req_org = $request_lib->id;
+
+ $logger->info("prox cache $home_org " . $prox_cache{$home_org});
+
+ $prox_cache{$home_org} =
+ $e->search_actor_org_unit_proximity({from_org => $home_org})
+ unless $prox_cache{$home_org};
+ my $home_prox = $prox_cache{$home_org};
+
+ my %buckets;
+ my %hash = map { ($_->to_org => $_->prox) } @$home_prox;
+ push( @{$buckets{ $hash{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
+
+ my @keys = sort { $a <=> $b } keys %buckets;
+
+
+ if( $home_org ne $req_org ) {
+ # -----------------------------------------------------------------------
+ # shove the copies close to the request_lib into the primary buckets
+ # directly before the farthest away copies. That way, they are not
+ # given priority, but they are checked before the farthest copies.
+ # -----------------------------------------------------------------------
+ $prox_cache{$req_org} =
+ $e->search_actor_org_unit_proximity({from_org => $req_org})
+ unless $prox_cache{$req_org};
+ my $req_prox = $prox_cache{$req_org};
+
+ my %buckets2;
+ my %hash2 = map { ($_->to_org => $_->prox) } @$req_prox;
+ push( @{$buckets2{ $hash2{$_->{circ_lib}} } }, $_->{id} ) for @$copies;
+
+ my $highest_key = $keys[@keys - 1]; # the farthest prox in the exising buckets
+ my $new_key = $highest_key - 0.5; # right before the farthest prox
+ my @keys2 = sort { $a <=> $b } keys %buckets2;
+ for my $key (@keys2) {
+ last if $key >= $highest_key;
+ push( @{$buckets{$new_key}}, $_ ) for @{$buckets2{$key}};
+ }
+ }
+
+ @keys = sort { $a <=> $b } keys %buckets;
+
+ my $title;
+ my %seen;
+ my @status;
+ OUTER: for my $key (@keys) {
+ my @cps = @{$buckets{$key}};
+
+ $logger->info("looking at " . scalar(@{$buckets{$key}}). " copies in proximity bucket $key");
+
+ for my $copyid (@cps) {
+
+ next if $seen{$copyid};
+ $seen{$copyid} = 1; # there could be dupes given the merged buckets
+ my $copy = $e->retrieve_asset_copy($copyid);
+ $logger->debug("looking at bucket_key=$key, copy $copyid : circ_lib = " . $copy->circ_lib);
+
+ unless($title) { # grab the title if we don't already have it
+ my $vol = $e->retrieve_asset_call_number(
+ [ $copy->call_number, { flesh => 1, flesh_fields => { bre => ['fixed_fields'], acn => ['record'] } } ] );
+ $title = $vol->record;
+ }
+
+ @status = verify_copy_for_hold(
+ $patron, $requestor, $title, $copy, $pickup_lib, $request_lib);
+
+ last OUTER if $status[0];
+ }
+ }
+
+ if (!$status[0]) {
+ if (!defined($empty_ok)) {
+ $empty_ok = $e->retrieve_config_global_flag('circ.holds.empty_issuance_ok');
+ $empty_ok = ($empty_ok and $U->is_true($empty_ok->enabled));
+ }
+
+ return (1,0) if ($empty_ok);
+ }
+ return @status;
+}
+
+
+sub _check_volume_hold_is_possible {
+ my( $vol, $title, $depth, $request_lib, $patron, $requestor, $pickup_lib, $selection_ou ) = @_;
+ my %org_filter = create_ranged_org_filter(new_editor(), $selection_ou, $depth);
+ my $copies = new_editor->search_asset_copy({call_number => $vol->id, %org_filter});
+ $logger->info("checking possibility of volume hold for volume ".$vol->id);
+
+ return (
+ 0, 0, [
+ new OpenILS::Event(
+ "HIGH_LEVEL_HOLD_HAS_NO_COPIES",
+ "payload" => {"fail_part" => "no_ultimate_items"}
+ )
+ ]
+ ) unless @$copies;
+
+ my @status;
+ for my $copy ( @$copies ) {
+ @status = verify_copy_for_hold(
+ $patron, $requestor, $title, $copy, $pickup_lib, $request_lib );
+ last if $status[0];
+ }
+ return @status;
+}
+
+
+
+sub verify_copy_for_hold {
+ my( $patron, $requestor, $title, $copy, $pickup_lib, $request_lib ) = @_;
+ $logger->info("checking possibility of copy in hold request for copy ".$copy->id);
+ my $permitted = OpenILS::Utils::PermitHold::permit_copy_hold(
+ { patron => $patron,
+ requestor => $requestor,
+ copy => $copy,
+ title => $title,
+ title_descriptor => $title->fixed_fields, # this is fleshed into the title object
+ pickup_lib => $pickup_lib,
+ request_lib => $request_lib,
+ new_hold => 1,
+ show_event_list => 1
+ }
+ );
+
+ return (
+ (not scalar @$permitted), # true if permitted is an empty arrayref
+ (
+ ($copy->circ_lib == $pickup_lib) and
+ ($copy->status == OILS_COPY_STATUS_AVAILABLE)
+ ),
+ $permitted
+ );
+}
+
+
+
+sub find_nearest_permitted_hold {
+
+ my $class = shift;
+ my $editor = shift; # CStoreEditor object
+ my $copy = shift; # copy to target
+ my $user = shift; # staff
+ my $check_only = shift; # do no updates, just see if the copy could fulfill a hold
+
+ my $evt = OpenILS::Event->new('ACTION_HOLD_REQUEST_NOT_FOUND');
+
+ my $bc = $copy->barcode;
+
+ # find any existing holds that already target this copy
+ my $old_holds = $editor->search_action_hold_request(
+ { current_copy => $copy->id,
+ cancel_time => undef,
+ capture_time => undef
+ }
+ );
+
+ # hold->type "R" means we need this copy
+ for my $h (@$old_holds) { return ($h) if $h->hold_type eq 'R'; }
+
+
+ my $hold_stall_interval = $U->ou_ancestor_setting_value($user->ws_ou, OILS_SETTING_HOLD_SOFT_STALL);
+
+ $logger->info("circulator: searching for best hold at org ".$user->ws_ou.
+ " and copy $bc with a hold stalling interval of ". ($hold_stall_interval || "(none)"));
+
+ my $fifo = $U->ou_ancestor_setting_value($user->ws_ou, 'circ.holds_fifo');
+
+ # search for what should be the best holds for this copy to fulfill
+ my $best_holds = $U->storagereq(
+ "open-ils.storage.action.hold_request.nearest_hold.atomic",
+ $user->ws_ou, $copy->id, 10, $hold_stall_interval, $fifo );
+
+ unless(@$best_holds) {
+
+ if( my $hold = $$old_holds[0] ) {
+ $logger->info("circulator: using existing pre-targeted hold ".$hold->id." in hold search");
+ return ($hold);
+ }
+
+ $logger->info("circulator: no suitable holds found for copy $bc");
+ return (undef, $evt);
+ }
+
+
+ my $best_hold;
+
+ # for each potential hold, we have to run the permit script
+ # to make sure the hold is actually permitted.
+ my %reqr_cache;
+ my %org_cache;
+ for my $holdid (@$best_holds) {
+ next unless $holdid;
+ $logger->info("circulator: checking if hold $holdid is permitted for copy $bc");
+
+ my $hold = $editor->retrieve_action_hold_request($holdid) or next;
+ my $reqr = $reqr_cache{$hold->requestor} || $editor->retrieve_actor_user($hold->requestor);
+ my $rlib = $org_cache{$hold->request_lib} || $editor->retrieve_actor_org_unit($hold->request_lib);
+
+ $reqr_cache{$hold->requestor} = $reqr;
+ $org_cache{$hold->request_lib} = $rlib;
+
+ # see if this hold is permitted
+ my $permitted = OpenILS::Utils::PermitHold::permit_copy_hold(
+ { patron_id => $hold->usr,
+ requestor => $reqr,
+ copy => $copy,
+ pickup_lib => $hold->pickup_lib,
+ request_lib => $rlib,
+ retarget => 1
+ }
+ );
+
+ if( $permitted ) {
+ $best_hold = $hold;
+ last;
+ }
+ }
+
+
+ unless( $best_hold ) { # no "good" permitted holds were found
+ if( my $hold = $$old_holds[0] ) { # can we return a pre-targeted hold?
+ $logger->info("circulator: using existing pre-targeted hold ".$hold->id." in hold search");
+ return ($hold);
+ }
+
+ # we got nuthin
+ $logger->info("circulator: no suitable holds found for copy $bc");
+ return (undef, $evt);
+ }
+
+ $logger->info("circulator: best hold ".$best_hold->id." found for copy $bc");
+
+ # indicate a permitted hold was found
+ return $best_hold if $check_only;
+
+ # we've found a permitted hold. we need to "grab" the copy
+ # to prevent re-targeted holds (next part) from re-grabbing the copy
+ $best_hold->current_copy($copy->id);
+ $editor->update_action_hold_request($best_hold)
+ or return (undef, $editor->event);
+
+
+ my @retarget;
+
+ # re-target any other holds that already target this copy
+ for my $old_hold (@$old_holds) {
+ next if $old_hold->id eq $best_hold->id; # don't re-target the hold we want
+ $logger->info("circulator: clearing current_copy and prev_check_time on hold ".
+ $old_hold->id." after a better hold [".$best_hold->id."] was found");
+ $old_hold->clear_current_copy;
+ $old_hold->clear_prev_check_time;
+ $editor->update_action_hold_request($old_hold)
+ or return (undef, $editor->event);
+ push(@retarget, $old_hold->id);
+ }
+
+ return ($best_hold, undef, (@retarget) ? \@retarget : undef);
+}
+
+
+
+
+
+
+__PACKAGE__->register_method(
+ method => 'all_rec_holds',
+ api_name => 'open-ils.circ.holds.retrieve_all_from_title',
+);
+
+sub all_rec_holds {
+ my( $self, $conn, $auth, $title_id, $args ) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ $e->checkauth or return $e->event;
+ $e->allowed('VIEW_HOLD') or return $e->event;
+
+ $args ||= {};
+ $args->{fulfillment_time} = undef; # we don't want to see old fulfilled holds
+ $args->{cancel_time} = undef;
+
+ my $resp = { volume_holds => [], copy_holds => [], metarecord_holds => [] };
+
+ my $mr_map = $e->search_metabib_metarecord_source_map({source => $title_id})->[0];
+ if($mr_map) {
+ $resp->{metarecord_holds} = $e->search_action_hold_request(
+ { hold_type => OILS_HOLD_TYPE_METARECORD,
+ target => $mr_map->metarecord,
+ %$args
+ }, {idlist => 1}
+ );
+ }
+
+ $resp->{title_holds} = $e->search_action_hold_request(
+ {
+ hold_type => OILS_HOLD_TYPE_TITLE,
+ target => $title_id,
+ %$args
+ }, {idlist=>1} );
+
+ my $vols = $e->search_asset_call_number(
+ { record => $title_id, deleted => 'f' }, {idlist=>1});
+
+ return $resp unless @$vols;
+
+ $resp->{volume_holds} = $e->search_action_hold_request(
+ {
+ hold_type => OILS_HOLD_TYPE_VOLUME,
+ target => $vols,
+ %$args },
+ {idlist=>1} );
+
+ my $copies = $e->search_asset_copy(
+ { call_number => $vols, deleted => 'f' }, {idlist=>1});
+
+ return $resp unless @$copies;
+
+ $resp->{copy_holds} = $e->search_action_hold_request(
+ {
+ hold_type => OILS_HOLD_TYPE_COPY,
+ target => $copies,
+ %$args },
+ {idlist=>1} );
+
+ return $resp;
+}
+
+
+
+
+
+__PACKAGE__->register_method(
+ method => 'uber_hold',
+ authoritative => 1,
+ api_name => 'open-ils.circ.hold.details.retrieve'
+);
+
+sub uber_hold {
+ my($self, $client, $auth, $hold_id) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ $e->checkauth or return $e->event;
+ return uber_hold_impl($e, $hold_id);
+}
+
+__PACKAGE__->register_method(
+ method => 'batch_uber_hold',
+ authoritative => 1,
+ stream => 1,
+ api_name => 'open-ils.circ.hold.details.batch.retrieve'
+);
+
+sub batch_uber_hold {
+ my($self, $client, $auth, $hold_ids) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ $e->checkauth or return $e->event;
+ $client->respond(uber_hold_impl($e, $_)) for @$hold_ids;
+ return undef;
+}
+
+sub uber_hold_impl {
+ my($e, $hold_id) = @_;
+
+ my $resp = {};
+
+ my $hold = $e->retrieve_action_hold_request(
+ [
+ $hold_id,
+ {
+ flesh => 1,
+ flesh_fields => { ahr => [ 'current_copy', 'usr', 'notes' ] }
+ }
+ ]
+ ) or return $e->event;
+
+ if($hold->usr->id ne $e->requestor->id) {
+ # A user is allowed to see his/her own holds
+ $e->allowed('VIEW_HOLD') or return $e->event;
+ $hold->notes( # filter out any non-staff ("private") notes
+ [ grep { !$U->is_true($_->staff) } @{$hold->notes} ] );
+
+ } else {
+ # caller is asking for own hold, but may not have permission to view staff notes
+ unless($e->allowed('VIEW_HOLD')) {
+ $hold->notes( # filter out any staff notes
+ [ grep { $U->is_true($_->staff) } @{$hold->notes} ] );
+ }
+ }
+
+ my $user = $hold->usr;
+ $hold->usr($user->id);
+
+ my $card = $e->retrieve_actor_card($user->card)
+ or return $e->event;
+
+ my( $mvr, $volume, $copy ) = find_hold_mvr($e, $hold);
+
+ flesh_hold_notices([$hold], $e);
+ flesh_hold_transits([$hold]);
+
+ my $details = retrieve_hold_queue_status_impl($e, $hold);
+
+ return {
+ hold => $hold,
+ copy => $copy,
+ volume => $volume,
+ mvr => $mvr,
+ patron_first => $user->first_given_name,
+ patron_last => $user->family_name,
+ patron_barcode => $card->barcode,
+ patron_alias => $user->alias,
+ %$details
+ };
+}
+
+
+
+# -----------------------------------------------------
+# Returns the MVR object that represents what the
+# hold is all about
+# -----------------------------------------------------
+sub find_hold_mvr {
+ my( $e, $hold ) = @_;
+
+ my $tid;
+ my $copy;
+ my $volume;
+ my $issuance;
+
+ if( $hold->hold_type eq OILS_HOLD_TYPE_METARECORD ) {
+ my $mr = $e->retrieve_metabib_metarecord($hold->target)
+ or return $e->event;
+ $tid = $mr->master_record;
+
+ } elsif( $hold->hold_type eq OILS_HOLD_TYPE_TITLE ) {
+ $tid = $hold->target;
+
+ } elsif( $hold->hold_type eq OILS_HOLD_TYPE_VOLUME ) {
+ $volume = $e->retrieve_asset_call_number($hold->target)
+ or return $e->event;
+ $tid = $volume->record;
+
+ } elsif( $hold->hold_type eq OILS_HOLD_TYPE_ISSUANCE ) {
+ $issuance = $e->retrieve_serial_issuance([
+ $hold->target,
+ {flesh => 1, flesh_fields => {siss => [ qw/subscription/ ]}}
+ ]) or return $e->event;
+
+ $tid = $issuance->subscription->record_entry;
+
+ } elsif( $hold->hold_type eq OILS_HOLD_TYPE_COPY ) {
+ $copy = $e->retrieve_asset_copy([
+ $hold->target,
+ {flesh => 1, flesh_fields => {acp => ['call_number']}}
+ ]) or return $e->event;
+
+ $volume = $copy->call_number;
+ $tid = $volume->record;
+ }
+
+ if(!$copy and ref $hold->current_copy ) {
+ $copy = $hold->current_copy;
+ $hold->current_copy($copy->id);
+ }
+
+ if(!$volume and $copy) {
+ $volume = $e->retrieve_asset_call_number($copy->call_number);
+ }
+
+ # TODO return metarcord mvr for M holds
+ my $title = $e->retrieve_biblio_record_entry($tid);
+ return ( $U->record_to_mvr($title), $volume, $copy, $issuance );
+}
+
+__PACKAGE__->register_method(
+ method => 'clear_shelf_cache',
+ api_name => 'open-ils.circ.hold.clear_shelf.get_cache',
+ stream => 1,
+ signature => {
+ desc => q/
+ Returns the holds processed with the given cache key
+ /
+ }
+);
+
+sub clear_shelf_cache {
+ my($self, $client, $auth, $cache_key, $chunk_size) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth and $e->allowed('VIEW_HOLD');
+
+ $chunk_size ||= 25;
+ my $hold_data = OpenSRF::Utils::Cache->new('global')->get_cache($cache_key);
+
+ if (!$hold_data) {
+ $logger->info("no hold data found in cache"); # XXX TODO return event
+ $e->rollback;
+ return undef;
+ }
+
+ my $maximum = 0;
+ foreach (keys %$hold_data) {
+ $maximum += scalar(@{ $hold_data->{$_} });
+ }
+ $client->respond({"maximum" => $maximum, "progress" => 0});
+
+ for my $action (sort keys %$hold_data) {
+ while (@{$hold_data->{$action}}) {
+ my @hid_chunk = splice @{$hold_data->{$action}}, 0, $chunk_size;
+
+ my $result_chunk = $e->json_query({
+ "select" => {
+ "acp" => ["barcode"],
+ "au" => [qw/
+ first_given_name second_given_name family_name alias
+ /],
+ "acn" => ["label"],
+ "bre" => ["marc"],
+ "acpl" => ["name"],
+ "ahr" => ["id"]
+ },
+ "from" => {
+ "ahr" => {
+ "acp" => {
+ "field" => "id", "fkey" => "current_copy",
+ "join" => {
+ "acn" => {
+ "field" => "id", "fkey" => "call_number",
+ "join" => {
+ "bre" => {
+ "field" => "id", "fkey" => "record"
+ }
+ }
+ },
+ "acpl" => {"field" => "id", "fkey" => "location"}
+ }
+ },
+ "au" => {"field" => "id", "fkey" => "usr"}
+ }
+ },
+ "where" => {"+ahr" => {"id" => \@hid_chunk}}
+ }, {"substream" => 1}) or return $e->die_event;
+
+ $client->respond([
+ map {
+ +{"action" => $action, "hold_details" => $_}
+ } @$result_chunk
+ ]);
+ }
+ }
+
+ $e->rollback;
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'clear_shelf_process',
+ stream => 1,
+ api_name => 'open-ils.circ.hold.clear_shelf.process',
+ signature => {
+ desc => q/
+ 1. Find all holds that have expired on the holds shelf
+ 2. Cancel the holds
+ 3. If a clear-shelf status is configured, put targeted copies into this status
+ 4. Divide copies into 3 groups: items to transit, items to reshelve, and items
+ that are needed for holds. No subsequent action is taken on the holds
+ or items after grouping.
+ /
+ }
+);
+
+sub clear_shelf_process {
+ my($self, $client, $auth, $org_id) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact => 1);
+ $e->checkauth or return $e->die_event;
+ my $cache = OpenSRF::Utils::Cache->new('global');
+
+ $org_id ||= $e->requestor->ws_ou;
+ $e->allowed('UPDATE_HOLD', $org_id) or return $e->die_event;
+
+ my $copy_status = $U->ou_ancestor_setting_value($org_id, 'circ.holds.clear_shelf.copy_status');
+
+ # Find holds on the shelf that have been there too long
+ my $hold_ids = $e->search_action_hold_request(
+ { shelf_expire_time => {'<' => 'now'},
+ pickup_lib => $org_id,
+ cancel_time => undef,
+ fulfillment_time => undef,
+ shelf_time => {'!=' => undef},
+ capture_time => {'!=' => undef},
+ current_copy => {'!=' => undef},
+ },
+ { idlist => 1 }
+ );
+
+ my @holds;
+ my $chunk_size = 25; # chunked status updates
+ my $counter = 0;
+ for my $hold_id (@$hold_ids) {
+
+ $logger->info("Clear shelf processing hold $hold_id");
+
+ my $hold = $e->retrieve_action_hold_request([
+ $hold_id, {
+ flesh => 1,
+ flesh_fields => {ahr => ['current_copy']}
+ }
+ ]);
+
+ $hold->cancel_time('now');
+ $hold->cancel_cause(2); # Hold Shelf expiration
+ $e->update_action_hold_request($hold) or return $e->die_event;
+
+ my $copy = $hold->current_copy;
+
+ if($copy_status or $copy_status == 0) {
+ # if a clear-shelf copy status is defined, update the copy
+ $copy->status($copy_status);
+ $copy->edit_date('now');
+ $copy->editor($e->requestor->id);
+ $e->update_asset_copy($copy) or return $e->die_event;
+ }
+
+ push(@holds, $hold);
+ $client->respond({maximum => scalar(@holds), progress => $counter}) if ( (++$counter % $chunk_size) == 0);
+ }
+
+ if ($e->commit) {
+
+ my %cache_data = (
+ hold => [],
+ transit => [],
+ shelf => []
+ );
+
+ for my $hold (@holds) {
+
+ my $copy = $hold->current_copy;
+ my ($alt_hold) = __PACKAGE__->find_nearest_permitted_hold($e, $copy, $e->requestor, 1);
+
+ if($alt_hold) {
+
+ push(@{$cache_data{hold}}, $hold->id); # copy is needed for a hold
+
+ } elsif($copy->circ_lib != $e->requestor->ws_ou) {
+
+ push(@{$cache_data{transit}}, $hold->id); # copy needs to transit
+
+ } else {
+
+ push(@{$cache_data{shelf}}, $hold->id); # copy needs to go back to the shelf
+ }
+ }
+
+ my $cache_key = md5_hex(time . $$ . rand());
+ $logger->info("clear_shelf_cache: storing under $cache_key");
+ $cache->put_cache($cache_key, \%cache_data, 7200); # TODO: 2 hours. configurable?
+
+ # tell the client we're done
+ $client->respond_complete({cache_key => $cache_key});
+
+ # fire off the hold cancelation trigger and wait for response so don't flood the service
+ $U->create_events_for_hook(
+ 'hold_request.cancel.expire_holds_shelf',
+ $_, $org_id, undef, undef, 1) for @holds;
+
+ } else {
+ # tell the client we're done
+ $client->respond_complete;
+ }
+}
+
+__PACKAGE__->register_method(
+ method => 'usr_hold_summary',
+ api_name => 'open-ils.circ.holds.user_summary',
+ signature => q/
+ Returns a summary of holds statuses for a given user
+ /
+);
+
+sub usr_hold_summary {
+ my($self, $conn, $auth, $user_id) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ $e->checkauth or return $e->event;
+ $e->allowed('VIEW_HOLD') or return $e->event;
+
+ my $holds = $e->search_action_hold_request(
+ {
+ usr => $user_id ,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ );
+
+ my %summary = (1 => 0, 2 => 0, 3 => 0, 4 => 0);
+ $summary{_hold_status($e, $_)} += 1 for @$holds;
+ return \%summary;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'hold_has_copy_at',
+ api_name => 'open-ils.circ.hold.has_copy_at',
+ signature => {
+ desc =>
+ 'Returns the ID of the found copy and name of the shelving location if there is ' .
+ 'an available copy at the specified org unit. Returns empty hash otherwise. ' .
+ 'The anticipated use for this method is to determine whether an item is ' .
+ 'available at the library where the user is placing the hold (or, alternatively, '.
+ 'at the pickup library) to encourage bypassing the hold placement and just ' .
+ 'checking out the item.' ,
+ params => {
+ { desc => 'Authentication Token', type => 'string' },
+ { desc => 'Method Arguments. Options include: hold_type, hold_target, org_unit. '
+ . 'hold_type is the hold type code (T, V, C, M, ...). '
+ . 'hold_target is the identifier of the hold target object. '
+ . 'org_unit is org unit ID.',
+ type => 'object'
+ },
+ },
+ return => {
+ desc => q/Result hash like { "copy" : copy_id, "location" : location_name }, empty hash on misses, event on error./,
+ type => 'object'
+ }
+ }
+);
+
+sub hold_has_copy_at {
+ my($self, $conn, $auth, $args) = @_;
+
+ my $e = new_editor(authtoken=>$auth);
+ $e->checkauth or return $e->event;
+
+ my $hold_type = $$args{hold_type};
+ my $hold_target = $$args{hold_target};
+ my $org_unit = $$args{org_unit};
+
+ my $query = {
+ select => {acp => ['id'], acpl => ['name']},
+ from => {
+ acp => {
+ acpl => {field => 'id', filter => { holdable => 't'}, fkey => 'location'},
+ ccs => {field => 'id', filter => { holdable => 't'}, fkey => 'status' }
+ }
+ },
+ where => {'+acp' => { circulate => 't', deleted => 'f', holdable => 't', circ_lib => $org_unit}},
+ limit => 1
+ };
+
+ if($hold_type eq 'C') {
+
+ $query->{where}->{'+acp'}->{id} = $hold_target;
+
+ } elsif($hold_type eq 'V') {
+
+ $query->{where}->{'+acp'}->{call_number} = $hold_target;
+
+ } elsif($hold_type eq 'T') {
+
+ $query->{from}->{acp}->{acn} = {
+ field => 'id',
+ fkey => 'call_number',
+ 'join' => {
+ bre => {
+ field => 'id',
+ filter => {id => $hold_target},
+ fkey => 'record'
+ }
+ }
+ };
+
+ } else {
+
+ $query->{from}->{acp}->{acn} = {
+ field => 'id',
+ fkey => 'call_number',
+ join => {
+ bre => {
+ field => 'id',
+ fkey => 'record',
+ join => {
+ mmrsm => {
+ field => 'source',
+ fkey => 'id',
+ filter => {metarecord => $hold_target},
+ }
+ }
+ }
+ }
+ };
+ }
+
+ my $res = $e->json_query($query)->[0] or return {};
+ return {copy => $res->{id}, location => $res->{name}} if $res;
+}
+
+
+# returns true if the user already has an item checked out
+# that could be used to fulfill the requested hold.
+sub hold_item_is_checked_out {
+ my($e, $user_id, $hold_type, $hold_target) = @_;
+
+ my $query = {
+ select => {acp => ['id']},
+ from => {acp => {}},
+ where => {
+ '+acp' => {
+ id => {
+ in => { # copies for circs the user has checked out
+ select => {circ => ['target_copy']},
+ from => 'circ',
+ where => {
+ usr => $user_id,
+ checkin_time => undef,
+ '-or' => [
+ {stop_fines => ["MAXFINES","LONGOVERDUE"]},
+ {stop_fines => undef}
+ ],
+ }
+ }
+ }
+ }
+ },
+ limit => 1
+ };
+
+ if($hold_type eq 'C' || $hold_type eq 'R' || $hold_type eq 'F') {
+
+ $query->{where}->{'+acp'}->{id}->{in}->{where}->{'target_copy'} = $hold_target;
+
+ } elsif($hold_type eq 'V') {
+
+ $query->{where}->{'+acp'}->{call_number} = $hold_target;
+
+ } elsif($hold_type eq 'I') {
+
+ $query->{from}->{acp}->{sitem} = {
+ field => 'unit',
+ fkey => 'id',
+ filter => {issuance => $hold_target},
+ };
+
+ } elsif($hold_type eq 'T') {
+
+ $query->{from}->{acp}->{acn} = {
+ field => 'id',
+ fkey => 'call_number',
+ 'join' => {
+ bre => {
+ field => 'id',
+ filter => {id => $hold_target},
+ fkey => 'record'
+ }
+ }
+ };
+
+ } else {
+
+ $query->{from}->{acp}->{acn} = {
+ field => 'id',
+ fkey => 'call_number',
+ join => {
+ bre => {
+ field => 'id',
+ fkey => 'record',
+ join => {
+ mmrsm => {
+ field => 'source',
+ fkey => 'id',
+ filter => {metarecord => $hold_target},
+ }
+ }
+ }
+ }
+ };
+ }
+
+ return $e->json_query($query)->[0];
+}
+
+__PACKAGE__->register_method(
+ method => 'change_hold_title',
+ api_name => 'open-ils.circ.hold.change_title',
+ signature => {
+ desc => q/
+ Updates all title level holds targeting the specified bibs to point a new bib./,
+ params => [
+ { desc => 'Authentication Token', type => 'string' },
+ { desc => 'New Target Bib Id', type => 'number' },
+ { desc => 'Old Target Bib Ids', type => 'array' },
+ ],
+ return => { desc => '1 on success' }
+ }
+);
+
+sub change_hold_title {
+ my( $self, $client, $auth, $new_bib_id, $bib_ids ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+
+ my $holds = $e->search_action_hold_request(
+ [
+ {
+ cancel_time => undef,
+ fulfillment_time => undef,
+ hold_type => 'T',
+ target => $bib_ids
+ },
+ {
+ flesh => 1,
+ flesh_fields => { ahr => ['usr'] }
+ }
+ ],
+ { substream => 1 }
+ );
+
+ for my $hold (@$holds) {
+ $e->allowed('UPDATE_HOLD', $hold->usr->home_ou) or return $e->die_event;
+ $logger->info("Changing hold " . $hold->id . " target from " . $hold->target . " to $new_bib_id in title hold target change");
+ $hold->target( $new_bib_id );
+ $e->update_action_hold_request($hold) or return $e->die_event;
+ }
+
+ $e->commit;
+
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'rec_hold_count',
+ api_name => 'open-ils.circ.bre.holds.count',
+ signature => {
+ desc => q/Returns the total number of holds that target the
+ selected bib record or its associated copies and call_numbers/,
+ params => [
+ { desc => 'Bib ID', type => 'number' },
+ ],
+ return => {desc => 'Hold count', type => 'number'}
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'rec_hold_count',
+ api_name => 'open-ils.circ.mmr.holds.count',
+ signature => {
+ desc => q/Returns the total number of holds that target the
+ selected metarecord or its associated copies, call_numbers, and bib records/,
+ params => [
+ { desc => 'Metarecord ID', type => 'number' },
+ ],
+ return => {desc => 'Hold count', type => 'number'}
+ }
+);
+
+sub rec_hold_count {
+ my($self, $conn, $target_id) = @_;
+
+
+ my $mmr_join = {
+ mmrsm => {
+ field => 'id',
+ fkey => 'source',
+ filter => {metarecord => $target_id}
+ }
+ };
+
+ my $bre_join = {
+ bre => {
+ field => 'id',
+ filter => { id => $target_id },
+ fkey => 'record'
+ }
+ };
+
+ if($self->api_name =~ /mmr/) {
+ delete $bre_join->{bre}->{filter};
+ $bre_join->{bre}->{join} = $mmr_join;
+ }
+
+ my $cn_join = {
+ acn => {
+ field => 'id',
+ fkey => 'call_number',
+ join => $bre_join
+ }
+ };
+
+ my $query = {
+ select => {ahr => [{column => 'id', transform => 'count', alias => 'count'}]},
+ from => 'ahr',
+ where => {
+ '+ahr' => {
+ cancel_time => undef,
+ fulfillment_time => undef,
+ '-or' => [
+ {
+ '-and' => {
+ hold_type => 'C',
+ target => {
+ in => {
+ select => {acp => ['id']},
+ from => { acp => $cn_join }
+ }
+ }
+ }
+ },
+ {
+ '-and' => {
+ hold_type => 'V',
+ target => {
+ in => {
+ select => {acn => ['id']},
+ from => {acn => $bre_join}
+ }
+ }
+ }
+ },
+ {
+ '-and' => {
+ hold_type => 'T',
+ target => $target_id
+ }
+ }
+ ]
+ }
+ }
+ };
+
+ if($self->api_name =~ /mmr/) {
+ $query->{where}->{'+ahr'}->{'-or'}->[2] = {
+ '-and' => {
+ hold_type => 'T',
+ target => {
+ in => {
+ select => {bre => ['id']},
+ from => {bre => $mmr_join}
+ }
+ }
+ }
+ };
+
+ $query->{where}->{'+ahr'}->{'-or'}->[3] = {
+ '-and' => {
+ hold_type => 'M',
+ target => $target_id
+ }
+ };
+ }
+
+
+ return new_editor()->json_query($query)->[0]->{count};
+}
+
+
+
+
+
+
+1;
--- /dev/null
+# ---------------------------------------------------------------
+# Copyright (C) 2005 Georgia Public Library Service
+# Bill Erickson <billserickson@gmail.com>
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+package OpenILS::Application::Circ::Money;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use OpenILS::Application::AppUtils;
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = "OpenILS::Application::AppUtils";
+
+use OpenSRF::EX qw(:try);
+use OpenILS::Perm;
+use Data::Dumper;
+use OpenILS::Event;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Utils::Penalty;
+$Data::Dumper::Indent = 0;
+
+__PACKAGE__->register_method(
+ method => "make_payments",
+ api_name => "open-ils.circ.money.payment",
+ signature => {
+ desc => q/Create payments for a given user and set of transactions,
+ login must have CREATE_PAYMENT privileges.
+ If any payments fail, all are reverted back./,
+ params => [
+ {desc => 'Authtoken', type => 'string'},
+ {desc => q/Arguments Hash, supporting the following params:
+ {
+ payment_type
+ userid
+ patron_credit
+ note
+ cc_args: {
+ where_process 1 to use processor, !1 for out-of-band
+ approval_code (for out-of-band payment)
+ type (for out-of-band payment)
+ number (for call to payment processor)
+ expire_month (for call to payment processor)
+ expire_year (for call to payment processor)
+ billing_first (for out-of-band payments and for call to payment processor)
+ billing_last (for out-of-band payments and for call to payment processor)
+ billing_address (for call to payment processor)
+ billing_city (for call to payment processor)
+ billing_state (for call to payment processor)
+ billing_zip (for call to payment processor)
+ note (if payments->{note} is blank, use this)
+ },
+ check_number
+ payments: [
+ [trans_id, amt],
+ [...]
+ ],
+ }/, type => 'hash'
+ },
+ {
+ desc => q/Last user transaction ID. This is the actor.usr.last_xact_id value/,
+ type => 'string'
+ }
+ ],
+ "return" => {
+ "desc" =>
+ q{Array of payment IDs on success, event on failure. Event possibilities include:
+ BAD_PARAMS
+ Bad parameters were given to this API method itself.
+ See note field.
+ INVALID_USER_XACT_ID
+ The last user transaction ID does not match the ID in the database. This means
+ the user object has been updated since the last retrieval. The client should
+ be instructed to reload the user object and related transactions before attempting
+ another payment
+ REFUND_EXCEEDS_BALANCE
+ REFUND_EXCEEDS_DESK_PAYMENTS
+ CREDIT_PROCESSOR_NOT_SPECIFIED
+ Evergreen has not been set up to process CC payments.
+ CREDIT_PROCESSOR_NOT_ALLOWED
+ Evergreen has been incorrectly setup for CC payments.
+ CREDIT_PROCESSOR_NOT_ENABLED
+ Evergreen has been set up for CC payments, but an admin
+ has not explicitly enabled them.
+ CREDIT_PROCESSOR_BAD_PARAMS
+ Evergreen has been incorrectly setup for CC payments;
+ specifically, the login and/or password for the CC
+ processor weren't provided.
+ CREDIT_PROCESSOR_INVALID_CC_NUMBER
+ You have supplied a credit card number that Evergreen
+ has judged to be invalid even before attempting to contact
+ the payment processor.
+ CREDIT_PROCESSOR_DECLINED_TRANSACTION
+ We contacted the CC processor to attempt the charge, but
+ they declined it.
+ The error_message field of the event payload will
+ contain the payment processor's response. This
+ typically includes a message in plain English intended
+ for human consumption. In PayPal's case, the message
+ is preceded by an integer, a colon, and a space, so
+ a caller might take the 2nd match from /^(\d+: )?(.+)$/
+ to present to the user.
+ The payload also contains other fields from the payment
+ processor, but these are generally not user-friendly
+ strings.
+ CREDIT_PROCESSOR_SUCCESS_WO_RECORD
+ A payment was processed successfully, but couldn't be
+ recorded in Evergreen. This is _bad bad bad_, as it means
+ somebody made a payment but isn't getting credit for it.
+ See errors in the system log if this happens. Info from
+ the credit card transaction will also be available in the
+ event payload, although this probably won't be suitable for
+ staff client/OPAC display.
+},
+ "type" => "number"
+ }
+ }
+);
+sub make_payments {
+ my($self, $client, $auth, $payments, $last_xact_id) = @_;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $type = $payments->{payment_type};
+ my $user_id = $payments->{userid};
+ my $credit = $payments->{patron_credit} || 0;
+ my $drawer = $e->requestor->wsid;
+ my $note = $payments->{note};
+ my $cc_args = $payments->{cc_args};
+ my $check_number = $payments->{check_number};
+ my $total_paid = 0;
+ my $this_ou = $e->requestor->ws_ou;
+ my %orgs;
+
+ # unless/until determined by payment processor API
+ my ($approval_code, $cc_processor, $cc_type) = (undef,undef,undef);
+
+ my $patron = $e->retrieve_actor_user($user_id) or return $e->die_event;
+
+ if($patron->last_xact_id ne $last_xact_id) {
+ $e->rollback;
+ return OpenILS::Event->new('INVALID_USER_XACT_ID');
+ }
+
+ # A user is allowed to make credit card payments on his/her own behalf
+ # All other scenarious require permission
+ unless($type eq 'credit_card_payment' and $user_id == $e->requestor->id) {
+ return $e->die_event unless $e->allowed('CREATE_PAYMENT', $patron->home_ou);
+ }
+
+ # first collect the transactions and make sure the transaction
+ # user matches the requested user
+ my %xacts;
+ for my $pay (@{$payments->{payments}}) {
+ my $xact_id = $pay->[0];
+ my $xact = $e->retrieve_money_billable_transaction_summary($xact_id)
+ or return $e->die_event;
+
+ if($xact->usr != $user_id) {
+ $e->rollback;
+ return OpenILS::Event->new('BAD_PARAMS', note => q/user does not match transaction/);
+ }
+
+ $xacts{$xact_id} = $xact;
+ }
+
+ my @payment_objs;
+
+ for my $pay (@{$payments->{payments}}) {
+ my $transid = $pay->[0];
+ my $amount = $pay->[1];
+ $amount =~ s/\$//og; # just to be safe
+ my $trans = $xacts{$transid};
+
+ $total_paid += $amount;
+
+ $orgs{$U->xact_org($transid, $e)} = 1;
+
+ # A negative payment is a refund.
+ if( $amount < 0 ) {
+
+ # Negative credit card payments are not allowed
+ if($type eq 'credit_card_payment') {
+ $e->rollback;
+ return OpenILS::Event->new(
+ 'BAD_PARAMS',
+ note => q/Negative credit card payments not allowed/
+ );
+ }
+
+ # If the refund causes the transaction balance to exceed 0 dollars,
+ # we are in effect loaning the patron money. This is not allowed.
+ if( ($trans->balance_owed - $amount) > 0 ) {
+ $e->rollback;
+ return OpenILS::Event->new('REFUND_EXCEEDS_BALANCE');
+ }
+
+ # Otherwise, make sure the refund does not exceed desk payments
+ # This is also not allowed
+ my $desk_total = 0;
+ my $desk_payments = $e->search_money_desk_payment({xact => $transid, voided => 'f'});
+ $desk_total += $_->amount for @$desk_payments;
+
+ if( (-$amount) > $desk_total ) {
+ $e->rollback;
+ return OpenILS::Event->new(
+ 'REFUND_EXCEEDS_DESK_PAYMENTS',
+ payload => { allowed_refund => $desk_total, submitted_refund => -$amount } );
+ }
+ }
+
+ my $payobj = "Fieldmapper::money::$type";
+ $payobj = $payobj->new;
+
+ $payobj->amount($amount);
+ $payobj->amount_collected($amount);
+ $payobj->xact($transid);
+ $payobj->note($note);
+ if ((not $payobj->note) and ($type eq 'credit_card_payment')) {
+ $payobj->note($cc_args->{note});
+ }
+
+ if ($payobj->has_field('accepting_usr')) { $payobj->accepting_usr($e->requestor->id); }
+ if ($payobj->has_field('cash_drawer')) { $payobj->cash_drawer($drawer); }
+ if ($payobj->has_field('cc_type')) { $payobj->cc_type($cc_args->{type}); }
+ if ($payobj->has_field('check_number')) { $payobj->check_number($check_number); }
+
+ # Store the last 4 digits of the CC number
+ if ($payobj->has_field('cc_number')) {
+ $payobj->cc_number(substr($cc_args->{number}, -4));
+ }
+ if ($payobj->has_field('expire_month')) { $payobj->expire_month($cc_args->{expire_month}); }
+ if ($payobj->has_field('expire_year')) { $payobj->expire_year($cc_args->{expire_year}); }
+
+ # Note: It is important not to set approval_code
+ # on the fieldmapper object yet.
+
+ push(@payment_objs, $payobj);
+
+ } # all payment objects have been created and inserted.
+
+ #### NO WRITES TO THE DB ABOVE THIS LINE -- THEY'LL ONLY BE DISCARDED ###
+ $e->rollback;
+
+ # After we try to externally process a credit card (if desired), we'll
+ # open a new transaction. We cannot leave one open while credit card
+ # processing might be happening, as it can easily time out the database
+ # transaction.
+
+ my $cc_payload;
+
+ if($type eq 'credit_card_payment') {
+ $approval_code = $cc_args->{approval_code};
+ # If an approval code was not given, we'll need
+ # to call to the payment processor ourselves.
+ if ($cc_args->{where_process} == 1) {
+ return OpenILS::Event->new('BAD_PARAMS', note => 'Need CC number')
+ if not $cc_args->{number};
+ my $response =
+ OpenILS::Application::Circ::CreditCard::process_payment({
+ "desc" => $cc_args->{note},
+ "amount" => $total_paid,
+ "patron_id" => $user_id,
+ "cc" => $cc_args->{number},
+ "expiration" => sprintf(
+ "%02d-%04d",
+ $cc_args->{expire_month},
+ $cc_args->{expire_year}
+ ),
+ "ou" => $this_ou,
+ "first_name" => $cc_args->{billing_first},
+ "last_name" => $cc_args->{billing_last},
+ "address" => $cc_args->{billing_address},
+ "city" => $cc_args->{billing_city},
+ "state" => $cc_args->{billing_state},
+ "zip" => $cc_args->{billing_zip},
+ });
+
+ if ($U->event_code($response)) { # non-success
+ $logger->info(
+ "Credit card payment for user $user_id failed: " .
+ $response->{"textcode"} . " " .
+ $response->{"payload"}->{"error_message"}
+ );
+
+ return $response;
+ } else {
+ # We need to save this for later in case there's a failure on
+ # the EG side to store the processor's result.
+ $cc_payload = $response->{"payload"};
+
+ $approval_code = $cc_payload->{"authorization"};
+ $cc_type = $cc_payload->{"card_type"};
+ $cc_processor = $cc_payload->{"processor"};
+ $logger->info("Credit card payment for user $user_id succeeded");
+ }
+ } else {
+ return OpenILS::Event->new(
+ 'BAD_PARAMS', note => 'Need approval code'
+ ) if not $cc_args->{approval_code};
+ }
+ }
+
+ ### RE-OPEN TRANSACTION HERE ###
+ $e->xact_begin;
+ my @payment_ids;
+
+ # create payment records
+ my $create_money_method = "create_money_" . $type;
+ for my $payment (@payment_objs) {
+ # update the transaction if it's done
+ my $amount = $payment->amount;
+ my $transid = $payment->xact;
+ my $trans = $xacts{$transid};
+ if( (my $cred = ($trans->balance_owed - $amount)) <= 0 ) {
+ # Any overpay on this transaction goes directly into patron
+ # credit making payment with existing patron credit.
+ $credit -= $amount if $type eq 'credit_payment';
+
+ $cred = -$cred;
+ $credit += $cred;
+ my $circ = $e->retrieve_action_circulation($transid);
+
+ if(!$circ || $circ->stop_fines) {
+ # If this is a circulation, we can't close the transaction
+ # unless stop_fines is set.
+ $trans = $e->retrieve_money_billable_transaction($transid);
+ $trans->xact_finish("now");
+ if (!$e->update_money_billable_transaction($trans)) {
+ return _recording_failure(
+ $e, "update_money_billable_transaction() failed",
+ $payment, $cc_payload
+ )
+ }
+ }
+ }
+
+ $payment->approval_code($approval_code) if $approval_code;
+ $payment->cc_type($cc_type) if $cc_type;
+ $payment->cc_processor($cc_processor) if $cc_processor;
+ $payment->cc_first_name($cc_args->{'billing_first'}) if $cc_args->{'billing_first'};
+ $payment->cc_last_name($cc_args->{'billing_last'}) if $cc_args->{'billing_last'};
+ if (!$e->$create_money_method($payment)) {
+ return _recording_failure(
+ $e, "$create_money_method failed", $payment, $cc_payload
+ );
+ }
+
+ push(@payment_ids, $payment->id);
+ }
+
+ my $evt = _update_patron_credit($e, $patron, $credit);
+ if ($evt) {
+ return _recording_failure(
+ $e, "_update_patron_credit() failed", undef, $cc_payload
+ );
+ }
+
+ for my $org_id (keys %orgs) {
+ # calculate penalties for each of the affected orgs
+ $evt = OpenILS::Utils::Penalty->calculate_penalties(
+ $e, $user_id, $org_id
+ );
+ if ($evt) {
+ return _recording_failure(
+ $e, "calculate_penalties() failed", undef, $cc_payload
+ );
+ }
+ }
+
+ # update the user to create a new last_xact_id
+ $e->update_actor_user($patron) or return $e->die_event;
+ $patron = $e->retrieve_actor_user($patron) or return $e->die_event;
+ $e->commit;
+
+ # update the cached user object if a user is making a payment toward
+ # his/her own account
+ $U->simplereq('open-ils.auth', 'open-ils.auth.session.reset_timeout', $auth, 1)
+ if $user_id == $e->requestor->id;
+
+ return {last_xact_id => $patron->last_xact_id, payments => \@payment_ids};
+}
+
+sub _recording_failure {
+ my ($e, $msg, $payment, $payload) = @_;
+
+ if ($payload) { # If the payment processor already accepted a payment:
+ $logger->error($msg);
+ $logger->error("Payment processor payload: " . Dumper($payload));
+ # payment shouldn't contain CC number
+ $logger->error("Payment: " . Dumper($payment)) if $payment;
+
+ $e->rollback;
+
+ return new OpenILS::Event(
+ "CREDIT_PROCESSOR_SUCCESS_WO_RECORD",
+ "payload" => $payload
+ );
+ } else { # Otherwise, the problem is somewhat less severe:
+ $logger->warn($msg);
+ $logger->warn("Payment: " . Dumper($payment)) if $payment;
+ return $e->die_event;
+ }
+}
+
+sub _update_patron_credit {
+ my($e, $patron, $credit) = @_;
+ return undef if $credit == 0;
+ $patron->credit_forward_balance($patron->credit_forward_balance + $credit);
+ return OpenILS::Event->new('NEGATIVE_PATRON_BALANCE') if $patron->credit_forward_balance < 0;
+ $e->update_actor_user($patron) or return $e->die_event;
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_payments",
+ api_name => "open-ils.circ.money.payment.retrieve.all_",
+ notes => "Returns a list of payments attached to a given transaction"
+ );
+sub retrieve_payments {
+ my( $self, $client, $login, $transid ) = @_;
+
+ my( $staff, $evt ) =
+ $apputils->checksesperm($login, 'VIEW_TRANSACTION');
+ return $evt if $evt;
+
+ # XXX the logic here is wrong.. we need to check the owner of the transaction
+ # to make sure the requestor has access
+
+ # XXX grab the view, for each object in the view, grab the real object
+
+ return $apputils->simplereq(
+ 'open-ils.cstore',
+ 'open-ils.cstore.direct.money.payment.search.atomic', { xact => $transid } );
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_payments2",
+ authoritative => 1,
+ api_name => "open-ils.circ.money.payment.retrieve.all",
+ notes => "Returns a list of payments attached to a given transaction"
+ );
+
+sub retrieve_payments2 {
+ my( $self, $client, $login, $transid ) = @_;
+
+ my $e = new_editor(authtoken=>$login);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_TRANSACTION');
+
+ my @payments;
+ my $pmnts = $e->search_money_payment({ xact => $transid });
+ for( @$pmnts ) {
+ my $type = $_->payment_type;
+ my $meth = "retrieve_money_$type";
+ my $p = $e->$meth($_->id) or return $e->event;
+ $p->payment_type($type);
+ $p->cash_drawer($e->retrieve_actor_workstation($p->cash_drawer))
+ if $p->has_field('cash_drawer');
+ push( @payments, $p );
+ }
+
+ return \@payments;
+}
+
+__PACKAGE__->register_method(
+ method => "format_payment_receipt",
+ api_name => "open-ils.circ.money.payment_receipt.print",
+ signature => {
+ desc => 'Returns a printable receipt for the specified payments',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Payment ID or array of payment IDs', type => 'number' },
+ ],
+ return => {
+ desc => q/An action_trigger.event object or error event./,
+ type => 'object',
+ }
+ }
+);
+__PACKAGE__->register_method(
+ method => "format_payment_receipt",
+ api_name => "open-ils.circ.money.payment_receipt.email",
+ signature => {
+ desc => 'Emails a receipt for the specified payments to the user associated with the first payment',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Payment ID or array of payment IDs', type => 'number' },
+ ],
+ return => {
+ desc => q/Undefined on success, otherwise an error event./,
+ type => 'object',
+ }
+ }
+);
+
+sub format_payment_receipt {
+ my($self, $conn, $auth, $mp_id) = @_;
+
+ my $mp_ids;
+ if (ref $mp_id ne 'ARRAY') {
+ $mp_ids = [ $mp_id ];
+ } else {
+ $mp_ids = $mp_id;
+ }
+
+ my $for_print = ($self->api_name =~ /print/);
+ my $for_email = ($self->api_name =~ /email/);
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $payments = [];
+ for my $id (@$mp_ids) {
+
+ my $payment = $e->retrieve_money_payment([
+ $id,
+ { flesh => 2,
+ flesh_fields => {
+ mp => ['xact'],
+ mbt => ['usr']
+ }
+ }
+ ]) or return OpenILS::Event->new('MP_NOT_FOUND');
+
+ return $e->event unless $e->allowed('VIEW_TRANSACTION', $payment->xact->usr->home_ou);
+
+ push @$payments, $payment;
+ }
+
+ if ($for_print) {
+
+ return $U->fire_object_event(undef, 'money.format.payment_receipt.print', $payments, $$payments[0]->xact->usr->home_ou);
+
+ } elsif ($for_email) {
+
+ for my $p (@$payments) {
+ $U->create_events_for_hook('money.format.payment_receipt.email', $p, $p->xact->usr->home_ou, undef, undef, 1);
+ }
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => "create_grocery_bill",
+ api_name => "open-ils.circ.money.grocery.create",
+ notes => <<" NOTE");
+ Creates a new grocery transaction using the transaction object provided
+ PARAMS: (login_session, money.grocery (mg) object)
+ NOTE
+
+sub create_grocery_bill {
+ my( $self, $client, $login, $transaction ) = @_;
+
+ my( $staff, $evt ) = $apputils->checkses($login);
+ return $evt if $evt;
+ $evt = $apputils->check_perms($staff->id,
+ $transaction->billing_location, 'CREATE_TRANSACTION' );
+ return $evt if $evt;
+
+
+ $logger->activity("Creating grocery bill " . Dumper($transaction) );
+
+ $transaction->clear_id;
+ my $session = $apputils->start_db_session;
+ my $transid = $session->request(
+ 'open-ils.storage.direct.money.grocery.create', $transaction)->gather(1);
+
+ throw OpenSRF::EX ("Error creating new money.grocery") unless defined $transid;
+
+ $logger->debug("Created new grocery transaction $transid");
+
+ $apputils->commit_db_session($session);
+
+ my $e = new_editor(xact=>1);
+ $evt = _check_open_xact($e, $transid);
+ return $evt if $evt;
+ $e->commit;
+
+ return $transid;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_reservation',
+ api_name => 'open-ils.circ.booking.reservation.retrieve'
+);
+sub fetch_reservation {
+ my( $self, $conn, $auth, $id ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_TRANSACTION'); # eh.. basically the same permission
+ my $g = $e->retrieve_booking_reservation($id)
+ or return $e->event;
+ return $g;
+}
+
+__PACKAGE__->register_method(
+ method => 'fetch_grocery',
+ api_name => 'open-ils.circ.money.grocery.retrieve'
+);
+sub fetch_grocery {
+ my( $self, $conn, $auth, $id ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_TRANSACTION'); # eh.. basically the same permission
+ my $g = $e->retrieve_money_grocery($id)
+ or return $e->event;
+ return $g;
+}
+
+
+__PACKAGE__->register_method(
+ method => "billing_items",
+ api_name => "open-ils.circ.money.billing.retrieve.all",
+ authoritative => 1,
+ signature => {
+ desc => 'Returns a list of billing items for the given transaction ID. ' .
+ 'If the operator is not the owner of the transaction, the VIEW_TRANSACTION permission is required.',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Transaction ID', type => 'number'}
+ ],
+ return => {
+ desc => 'Transaction object, event on error'
+ },
+ }
+);
+
+sub billing_items {
+ my( $self, $client, $login, $transid ) = @_;
+
+ my( $trans, $evt ) = $U->fetch_billable_xact($transid);
+ return $evt if $evt;
+
+ my $staff;
+ ($staff, $evt ) = $apputils->checkses($login);
+ return $evt if $evt;
+
+ if($staff->id ne $trans->usr) {
+ $evt = $U->check_perms($staff->id, $staff->home_ou, 'VIEW_TRANSACTION');
+ return $evt if $evt;
+ }
+
+ return $apputils->simplereq( 'open-ils.cstore',
+ 'open-ils.cstore.direct.money.billing.search.atomic', { xact => $transid } )
+}
+
+
+__PACKAGE__->register_method(
+ method => "billing_items_create",
+ api_name => "open-ils.circ.money.billing.create",
+ notes => <<" NOTE");
+ Creates a new billing line item
+ PARAMS( login, bill_object (mb) )
+ NOTE
+
+sub billing_items_create {
+ my( $self, $client, $login, $billing ) = @_;
+
+ my $e = new_editor(authtoken => $login, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_BILL');
+
+ my $xact = $e->retrieve_money_billable_transaction($billing->xact)
+ or return $e->die_event;
+
+ # if the transaction was closed, re-open it
+ if($xact->xact_finish) {
+ $xact->clear_xact_finish;
+ $e->update_money_billable_transaction($xact)
+ or return $e->die_event;
+ }
+
+ my $amt = $billing->amount;
+ $amt =~ s/\$//og;
+ $billing->amount($amt);
+
+ $e->create_money_billing($billing) or return $e->die_event;
+ my $evt = OpenILS::Utils::Penalty->calculate_penalties($e, $xact->usr, $U->xact_org($xact->id));
+ return $evt if $evt;
+ $e->commit;
+
+ return $billing->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'void_bill',
+ api_name => 'open-ils.circ.money.billing.void',
+ signature => q/
+ Voids a bill
+ @param authtoken Login session key
+ @param billid Id for the bill to void. This parameter may be repeated to reference other bills.
+ @return 1 on success, Event on error
+ /
+);
+sub void_bill {
+ my( $s, $c, $authtoken, @billids ) = @_;
+
+ my $e = new_editor( authtoken => $authtoken, xact => 1 );
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('VOID_BILLING');
+
+ my %users;
+ for my $billid (@billids) {
+
+ my $bill = $e->retrieve_money_billing($billid)
+ or return $e->die_event;
+
+ my $xact = $e->retrieve_money_billable_transaction($bill->xact)
+ or return $e->die_event;
+
+ if($U->is_true($bill->voided)) {
+ $e->rollback;
+ return OpenILS::Event->new('BILL_ALREADY_VOIDED', payload => $bill);
+ }
+
+ my $org = $U->xact_org($bill->xact, $e);
+ $users{$xact->usr} = {} unless $users{$xact->usr};
+ $users{$xact->usr}->{$org} = 1;
+
+ $bill->voided('t');
+ $bill->voider($e->requestor->id);
+ $bill->void_time('now');
+
+ $e->update_money_billing($bill) or return $e->die_event;
+ my $evt = _check_open_xact($e, $bill->xact, $xact);
+ return $evt if $evt;
+ }
+
+ # calculate penalties for all user/org combinations
+ for my $user_id (keys %users) {
+ for my $org_id (keys %{$users{$user_id}}) {
+ OpenILS::Utils::Penalty->calculate_penalties($e, $user_id, $org_id);
+ }
+ }
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'edit_bill_note',
+ api_name => 'open-ils.circ.money.billing.note.edit',
+ signature => q/
+ Edits the note for a bill
+ @param authtoken Login session key
+ @param note The replacement note for the bills we're editing
+ @param billid Id for the bill to edit the note of. This parameter may be repeated to reference other bills.
+ @return 1 on success, Event on error
+ /
+);
+sub edit_bill_note {
+ my( $s, $c, $authtoken, $note, @billids ) = @_;
+
+ my $e = new_editor( authtoken => $authtoken, xact => 1 );
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('UPDATE_BILL_NOTE');
+
+ for my $billid (@billids) {
+
+ my $bill = $e->retrieve_money_billing($billid)
+ or return $e->die_event;
+
+ $bill->note($note);
+ # FIXME: Does this get audited? Need some way so that the original creator of the bill does not get credit/blame for the new note.
+
+ $e->update_money_billing($bill) or return $e->die_event;
+ }
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'edit_payment_note',
+ api_name => 'open-ils.circ.money.payment.note.edit',
+ signature => q/
+ Edits the note for a payment
+ @param authtoken Login session key
+ @param note The replacement note for the payments we're editing
+ @param paymentid Id for the payment to edit the note of. This parameter may be repeated to reference other payments.
+ @return 1 on success, Event on error
+ /
+);
+sub edit_payment_note {
+ my( $s, $c, $authtoken, $note, @paymentids ) = @_;
+
+ my $e = new_editor( authtoken => $authtoken, xact => 1 );
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('UPDATE_PAYMENT_NOTE');
+
+ for my $paymentid (@paymentids) {
+
+ my $payment = $e->retrieve_money_payment($paymentid)
+ or return $e->die_event;
+
+ $payment->note($note);
+ # FIXME: Does this get audited? Need some way so that the original taker of the payment does not get credit/blame for the new note.
+
+ $e->update_money_payment($payment) or return $e->die_event;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+sub _check_open_xact {
+ my( $editor, $xactid, $xact ) = @_;
+
+ # Grab the transaction
+ $xact ||= $editor->retrieve_money_billable_transaction($xactid);
+ return $editor->event unless $xact;
+ $xactid ||= $xact->id;
+
+ # grab the summary and see how much is owed on this transaction
+ my ($summary) = $U->fetch_mbts($xactid, $editor);
+
+ # grab the circulation if it is a circ;
+ my $circ = $editor->retrieve_action_circulation($xactid);
+
+ # If nothing is owed on the transaction but it is still open
+ # and this transaction is not an open circulation, close it
+ if(
+ ( $summary->balance_owed == 0 and ! $xact->xact_finish ) and
+ ( !$circ or $circ->stop_fines )) {
+
+ $logger->info("closing transaction ".$xact->id. ' becauase balance_owed == 0');
+ $xact->xact_finish('now');
+ $editor->update_money_billable_transaction($xact)
+ or return $editor->event;
+ return undef;
+ }
+
+ # If money is owed or a refund is due on the xact and xact_finish
+ # is set, clear it (to reopen the xact) and update
+ if( $summary->balance_owed != 0 and $xact->xact_finish ) {
+ $logger->info("re-opening transaction ".$xact->id. ' becauase balance_owed != 0');
+ $xact->clear_xact_finish;
+ $editor->update_money_billable_transaction($xact)
+ or return $editor->event;
+ return undef;
+ }
+ return undef;
+}
+
+
+__PACKAGE__->register_method (
+ method => 'fetch_mbts',
+ authoritative => 1,
+ api_name => 'open-ils.circ.money.billable_xact_summary.retrieve'
+);
+sub fetch_mbts {
+ my( $self, $conn, $auth, $id) = @_;
+
+ my $e = new_editor(xact => 1, authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my ($mbts) = $U->fetch_mbts($id, $e);
+
+ my $user = $e->retrieve_actor_user($mbts->usr)
+ or return $e->die_event;
+
+ return $e->die_event unless $e->allowed('VIEW_TRANSACTION', $user->home_ou);
+ $e->rollback;
+ return $mbts
+}
+
+
+__PACKAGE__->register_method(
+ method => 'desk_payments',
+ api_name => 'open-ils.circ.money.org_unit.desk_payments'
+);
+sub desk_payments {
+ my( $self, $conn, $auth, $org, $start_date, $end_date ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_TRANSACTION', $org);
+ my $data = $U->storagereq(
+ 'open-ils.storage.money.org_unit.desk_payments.atomic',
+ $org, $start_date, $end_date );
+
+ $_->workstation( $_->workstation->name ) for(@$data);
+ return $data;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'user_payments',
+ api_name => 'open-ils.circ.money.org_unit.user_payments'
+);
+
+sub user_payments {
+ my( $self, $conn, $auth, $org, $start_date, $end_date ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_TRANSACTION', $org);
+ my $data = $U->storagereq(
+ 'open-ils.storage.money.org_unit.user_payments.atomic',
+ $org, $start_date, $end_date );
+ for(@$data) {
+ $_->usr->card(
+ $e->retrieve_actor_card($_->usr->card)->barcode);
+ $_->usr->home_ou(
+ $e->retrieve_actor_org_unit($_->usr->home_ou)->shortname);
+ }
+ return $data;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_credit_payable_balance',
+ api_name => 'open-ils.circ.credit.payable_balance.retrieve',
+ authoritative => 1,
+ signature => {
+ desc => q/Returns the total amount the patron can pay via credit card/,
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'User id', type => 'number' }
+ ],
+ return => { desc => 'The ID of the new provider' }
+ }
+);
+
+sub retrieve_credit_payable_balance {
+ my ( $self, $conn, $auth, $user_id ) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $user = $e->retrieve_actor_user($user_id)
+ or return $e->event;
+
+ if($e->requestor->id != $user_id) {
+ return $e->event unless $e->allowed('VIEW_USER_TRANSACTIONS', $user->home_ou)
+ }
+
+ my $circ_orgs = $e->json_query({
+ "select" => {circ => ["circ_lib"]},
+ from => "circ",
+ "where" => {usr => $user_id, xact_finish => undef},
+ distinct => 1
+ });
+
+ my $groc_orgs = $e->json_query({
+ "select" => {mg => ["billing_location"]},
+ from => "mg",
+ "where" => {usr => $user_id, xact_finish => undef},
+ distinct => 1
+ });
+
+ my %hash;
+ for my $org ( @$circ_orgs, @$groc_orgs ) {
+ my $o = $org->{billing_location};
+ $o = $org->{circ_lib} unless $o;
+ next if $hash{$o}; # was $hash{$org}, but that doesn't make sense. $org is a hashref and $o gets added in the next line.
+ $hash{$o} = $U->ou_ancestor_setting_value($o, 'credit.payments.allow', $e);
+ }
+
+ my @credit_orgs = map { $hash{$_} ? ($_) : () } keys %hash;
+ $logger->debug("credit: relevant orgs that allow credit payments => @credit_orgs");
+
+ my $xact_summaries =
+ OpenILS::Application::AppUtils->simplereq('open-ils.actor',
+ 'open-ils.actor.user.transactions.have_charge', $auth, $user_id);
+
+ my $sum = 0.0;
+
+ for my $xact (@$xact_summaries) {
+
+ # make two lists and grab them in batch XXX
+ if ( $xact->xact_type eq 'circulation' ) {
+ my $circ = $e->retrieve_action_circulation($xact->id) or return $e->event;
+ next unless grep { $_ == $circ->circ_lib } @credit_orgs;
+
+ } elsif ($xact->xact_type eq 'grocery') {
+ my $bill = $e->retrieve_money_grocery($xact->id) or return $e->event;
+ next unless grep { $_ == $bill->billing_location } @credit_orgs;
+ } elsif ($xact->xact_type eq 'reservation') {
+ my $bill = $e->retrieve_booking_reservation($xact->id) or return $e->event;
+ next unless grep { $_ == $bill->pickup_lib } @credit_orgs;
+ }
+ $sum += $xact->balance_owed();
+ }
+
+ return $sum;
+}
+
+
+1;
--- /dev/null
+package OpenILS::Application::Circ::NonCat;
+use base 'OpenILS::Application';
+use strict; use warnings;
+use OpenSRF::EX qw(:try);
+use Data::Dumper;
+use DateTime;
+use DateTime::Format::ISO8601;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::Editor;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+$Data::Dumper::Indent = 0;
+
+my $U = "OpenILS::Application::AppUtils";
+my $_dt_parser = DateTime::Format::ISO8601->new;
+
+
+# returns ( $newid, $evt ). If $evt, then there was an error
+sub create_non_cat_circ {
+ my( $staffid, $patronid, $circ_lib, $noncat_type, $circ_time, $editor ) = @_;
+
+ my( $id, $nct, $evt );
+ $circ_time ||= 'now';
+ my $circ = Fieldmapper::action::non_cataloged_circulation->new;
+
+ $logger->activity("Creating non-cataloged circulation for ".
+ "staff $staffid, patron $patronid, location $circ_lib, and non-cat type $noncat_type");
+
+ $circ->patron($patronid);
+ $circ->staff($staffid);
+ $circ->circ_lib($circ_lib);
+ $circ->item_type($noncat_type);
+ $circ->circ_time($circ_time);
+
+ if( $editor ) {
+ $evt = $editor->event unless
+ $circ = $editor->create_action_non_cataloged_circulation( $circ )
+
+
+ } else {
+ $id = $U->simplereq(
+ 'open-ils.storage',
+ 'open-ils.storage.direct.action.non_cataloged_circulation.create', $circ );
+ $evt = $U->DB_UPDATE_FAILED($circ) unless $id;
+ $circ->id($id);
+ }
+
+ if($circ) {
+ my $e = ($editor) ? $editor : new_editor();
+ $circ = noncat_due_date($e, $circ);
+ }
+
+ return( $circ, $evt );
+}
+
+
+__PACKAGE__->register_method(
+ method => "create_noncat_type",
+ api_name => "open-ils.circ.non_cat_type.create",
+ notes => q/
+ Creates a new non cataloged item type
+ @param authtoken The login session key
+ @param name The name of the new type
+ @param orgId The location where the type will live
+ @return The type object on success and the corresponding
+ event on failure
+ /
+);
+
+sub create_noncat_type {
+ my( $self, $client, $authtoken, $name, $orgId, $interval, $inhouse ) = @_;
+
+ my $e = new_editor(authtoken=>$authtoken, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_NON_CAT_TYPE', $orgId);
+
+ # grab all of "my" non-cat types and see if one with
+ # the requested name already exists
+ my $types = retrieve_noncat_types_all($self, $client, $orgId);
+ for(@$types) {
+ if( $_->name eq $name ) {
+ $e->rollback;
+ return OpenILS::Event->new('NON_CAT_TYPE_EXISTS', payload => $name);
+ }
+ }
+
+ my $type = Fieldmapper::config::non_cataloged_type->new;
+ $type->name($name);
+ $type->owning_lib($orgId);
+ $type->circ_duration($interval);
+ $type->in_house( ($inhouse) ? 't' : 'f' );
+
+ $e->create_config_non_cataloged_type($type) or return $e->die_event;
+ $e->commit;
+ return $type;
+}
+
+
+__PACKAGE__->register_method(
+ method => "update_noncat_type",
+ api_name => "open-ils.circ.non_cat_type.update",
+ notes => q/
+ Updates a non-cataloged type object
+ @param authtoken The login session key
+ @param type The updated type object
+ @return The result of the DB update call unless a preceeding event occurs,
+ in which case the event will be returned
+ /
+);
+
+sub update_noncat_type {
+ my( $self, $client, $authtoken, $type ) = @_;
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+
+ my $otype = $e->retrieve_config_non_cataloged_type($type->id)
+ or return $e->die_event;
+
+ return $e->die_event unless
+ $e->allowed('UPDATE_NON_CAT_TYPE', $otype->owning_lib);
+
+ $type->owning_lib($otype->owning_lib); # do not allow them to "move" the object
+
+ $e->update_config_non_cataloged_type($type) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_noncat_types_all",
+ api_name => "open-ils.circ.non_cat_types.retrieve.all",
+ signature => {
+ desc => 'Retrieves the non-cat types at the requested location as well '
+ . 'as those above and below it in the org tree',
+ params => [
+ { name => 'orgId', desc => 'Org unit ID of the base location', type => 'number' },
+ { name => 'depth', desc => 'Depth limit of the tree (optional)', type => 'number' }
+ ],
+ return => {
+ desc => 'Array of non-cat objects, event on error'
+ },
+ }
+);
+
+sub retrieve_noncat_types_all {
+ my( $self, $client, $orgId, $depth ) = @_;
+ my $meth = 'open-ils.storage.ranged.config.non_cataloged_type.retrieve.atomic';
+ my $svc = 'open-ils.storage';
+ return $U->simplereq($svc, $meth, $orgId, $depth) if defined($depth);
+ return $U->simplereq($svc, $meth, $orgId);
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_noncat',
+ api_name => 'open-ils.circ.non_cataloged_circulation.retrieve',
+ signature => {
+ desc => 'Retrieve a circulation on a non cataloged item for a given Circ ID. If the operator is not the '
+ . 'patron owner of the circ, the VIEW_CIRCULATIONS permission is required',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'Circulation ID', type => 'number' }
+ ],
+ return => {
+ desc => 'Circulation object, event on error',
+ },
+ }
+);
+
+sub fetch_noncat {
+ my( $self, $conn, $auth, $circid ) = @_;
+ my $e = new_editor( authtoken => $auth );
+ return $e->event unless $e->checkauth;
+ my $c = $e->retrieve_action_non_cataloged_circulation($circid)
+ or return $e->event;
+ if( $c->patron ne $e->requestor->id ) {
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # XXX rely on editor perm
+ }
+ return noncat_due_date($e, $c);
+}
+
+sub noncat_due_date {
+ my($e, $circ) = @_;
+
+ my $otype = $e->retrieve_config_non_cataloged_type($circ->item_type)
+ or return $e->die_event;
+
+ my $duedate = $_dt_parser->parse_datetime( cleanse_ISO8601($circ->circ_time) );
+ $duedate = $duedate
+ ->add( seconds => interval_to_seconds($otype->circ_duration) )
+ ->strftime('%FT%T%z');
+
+ my $offset = $U->storagereq(
+ 'open-ils.storage.actor.org_unit.closed_date.overlap',
+ $circ->circ_lib,
+ $duedate
+ );
+
+ $duedate = $offset->{end} if ($offset);
+ $circ->duedate($duedate);
+
+ return $circ;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_open_noncats',
+ authoritative => 1,
+ api_name => 'open-ils.circ.open_non_cataloged_circulation.user',
+ signature => {
+ desca => 'For a given user, returns an id-list of non-cataloged circulations that are considered open as of now. ' .
+ 'A circ is open if circ time + circ duration (based on type) is > than now. If trying to view the circs ' .
+ 'of another user, the VIEW_CIRCULATIONS permission is required',
+ params => [
+ { desc => 'Authentication token', type => 'string' },
+ { desc => 'UserID (optional: defaults to the session user)', type => 'number' }
+ ],
+ return => {
+ desc => 'Array of non-cataloged circ IDs, event on error'
+ },
+ }
+);
+
+sub fetch_open_noncats {
+ my( $self, $conn, $auth, $userid ) = @_;
+ my $e = OpenILS::Utils::Editor->new( authtoken => $auth );
+ return $e->event unless $e->checkauth;
+ $userid ||= $e->requestor->id;
+ if( $e->requestor->id ne $userid ) {
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # XXX rely on editor perm
+ }
+ return $e->request(
+ 'open-ils.storage.action.open_non_cataloged_circulation.user', $userid );
+}
+
+
+__PACKAGE__->register_method(
+ method => 'delete_noncat',
+ api_name => 'open-ils.circ.non_cataloged_type.delete',
+);
+sub delete_noncat {
+ my( $self, $conn, $auth, $typeid ) = @_;
+ my $e = new_editor(xact=>1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $nc = $e->retrieve_config_non_cataloged_type($typeid)
+ or return $e->die_event;
+
+ $e->allowed('DELETE_NON_CAT_TYPE', $nc->owning_lib) # XXX rely on editor perm
+ or return $e->die_event;
+
+ # XXX Add checks to see if this type is in use by a transaction
+
+ $e->delete_config_non_cataloged_type($nc) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+1;
--- /dev/null
+package OpenILS::Application::Circ::ScriptBuilder;
+use strict; use warnings;
+use OpenILS::Utils::ScriptRunner;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Application::Circ::Holds;
+use DateTime::Format::ISO8601;
+use OpenSRF::Utils qw/:datetime/;
+use Scalar::Util qw/weaken/;
+my $U = "OpenILS::Application::AppUtils";
+use Data::Dumper;
+
+my $holdcode = "OpenILS::Application::Circ::Holds";
+
+my $evt = "environment";
+my %GROUP_SET;
+my $GROUP_TREE;
+my $ORG_TREE;
+my @ORG_LIST;
+my @OU_TYPES;
+
+
+# -----------------------------------------------------------------------
+# Possible Args:
+# copy
+# copy_id
+# copy_barcode
+#
+# patron
+# patron_id
+# patron_barcode
+#
+# fetch_patron_circ_info - load info on items out, overdues, and fines.
+#
+# _direct - this is a hash of key/value pairs to shove directly into the
+# script runner. Use this to cover data not covered by this module
+# -----------------------------------------------------------------------
+sub build {
+ my( $class, $args ) = @_;
+
+ my $evt;
+ my @evts;
+
+ my $rollback;
+ my $editor = $$args{editor};
+
+ unless($editor) {
+ $editor = new_editor(xact => 1);
+ $rollback = 1;
+ }
+
+ $args->{_direct} = {} unless $args->{_direct};
+ #$args->{editor} = $editor;
+
+ $evt = fetch_bib_data($editor, $args);
+ push(@evts, $evt) if $evt;
+ $evt = fetch_user_data($editor, $args);
+ push(@evts, $evt) if $evt;
+
+ if(@evts) {
+ my @e;
+ push( @e, $_->{textcode} ) for @evts;
+ $logger->info("script_builder: some events occurred: @e");
+ $logger->debug("script_builder: some events occurred: " . Dumper(\@evts));
+ $args->{_events} = \@evts;
+ }
+
+ my $r = build_runner($editor, $args);
+ $editor->rollback if $rollback;
+ return $r;
+}
+
+
+sub build_runner {
+ my $editor = shift;
+ my $ctx = shift;
+
+ my $runner = OpenILS::Utils::ScriptRunner->new;
+
+ my $gt = $GROUP_TREE;
+ $runner->insert( "$evt.groupTree", $gt, 1);
+
+
+ $runner->insert( "$evt.patron", $ctx->{patron}, 1);
+ $runner->insert( "$evt.copy", $ctx->{copy}, 1);
+ $runner->insert( "$evt.volume", $ctx->{volume}, 1);
+ $runner->insert( "$evt.title", $ctx->{title}, 1);
+
+ if( ref $ctx->{requestor} ) {
+ $runner->insert( "$evt.requestor", $ctx->{requestor}, 1);
+ if($ctx->{requestor}->ws_ou) {
+ $runner->insert( "$evt.location",
+ $editor->retrieve_actor_org_unit($ctx->{requestor}->ws_ou), 1);
+ }
+ }
+
+ $runner->insert( "$evt.patronItemsOut", $ctx->{patronItemsOut}, 1 );
+ $runner->insert( "$evt.patronOverdueCount", $ctx->{patronOverdue}, 1 );
+ $runner->insert( "$evt.patronFines", $ctx->{patronFines}, 1 );
+
+ $runner->insert("$evt.$_", $ctx->{_direct}->{$_}, 1) for keys %{$ctx->{_direct}};
+
+ insert_org_methods( $editor, $runner );
+ insert_copy_methods( $editor, $ctx, $runner );
+ insert_user_funcs( $editor, $ctx, $runner );
+
+ return $runner;
+}
+
+sub fetch_bib_data {
+ my $e = shift;
+ my $ctx = shift;
+
+ my $flesh = {
+ flesh => 2,
+ flesh_fields => {
+ acp => [ 'location', 'status', 'circ_lib', 'age_protect', 'call_number' ],
+ acn => [ 'record' ]
+ }
+ };
+
+ if( $ctx->{copy} ) {
+ $ctx->{copy_id} = $ctx->{copy}->id
+ unless $ctx->{copy_id} or $ctx->{copy_barcode};
+ }
+
+ my $copy;
+
+ if($ctx->{copy_id}) {
+ $copy = $e->retrieve_asset_copy(
+ [$ctx->{copy_id}, $flesh ]) or return $e->event;
+
+ } elsif( $ctx->{copy_barcode} ) {
+
+ $copy = $e->search_asset_copy(
+ [{barcode => $ctx->{copy_barcode}, deleted => 'f'}, $flesh ])->[0]
+ or return $e->event;
+ }
+
+ return undef unless $copy;
+
+ my $vol = $copy->call_number;
+ my $rec = $vol->record;
+ $ctx->{copy} = $copy;
+ $ctx->{volume} = $vol;
+ $copy->call_number($vol->id);
+ $ctx->{title} = $rec;
+ $vol->record($rec->id);
+
+ return undef;
+}
+
+
+
+sub fetch_user_data {
+ my( $e, $ctx ) = @_;
+
+ my $flesh = {
+ flesh => 2,
+ flesh_fields => {
+ au => [ qw/ profile home_ou card / ],
+ aou => [ 'ou_type' ],
+ }
+ };
+
+ if( $ctx->{patron} ) {
+ $ctx->{patron_id} = $ctx->{patron}->id unless $ctx->{patron_id};
+ }
+
+ my $patron;
+
+ if( $ctx->{patron_id} ) {
+ $patron = $e->retrieve_actor_user([$ctx->{patron_id}, $flesh]);
+
+ } elsif( $ctx->{patron_barcode} ) {
+
+ my $card = $e->search_actor_card(
+ { barcode => $ctx->{patron_barcode} } )->[0] or return $e->event;
+
+ $patron = $e->search_actor_user(
+ [{ card => $card->id }, $flesh ]
+ )->[0] or return $e->event;
+
+ } elsif( $ctx->{fetch_patron_by_circ_copy} ) {
+
+ if( my $copy = $ctx->{copy} ) {
+ my $circs = $e->search_action_circulation(
+ { target_copy => $copy->id, checkin_time => undef });
+
+ if( my $circ = $circs->[0] ) {
+ $patron = $e->retrieve_actor_user([$circ->usr, $flesh])
+ or return $e->event;
+ }
+ }
+ }
+
+ return undef unless $ctx->{patron} = $patron;
+
+ flatten_groups($e);
+
+ $ctx->{requestor} = $ctx->{requestor} || $e->requestor;
+
+ if( $ctx->{fetch_patron_circ_info} ) {
+ my $circ_counts = $U->storagereq('open-ils.storage.actor.user.checked_out.count', $patron->id);
+
+ $ctx->{patronOverdue} = $circ_counts->{overdue} + $circ_counts->{long_overdue};
+ my $out = $ctx->{patronOverdue} + $circ_counts->{out};
+
+ $ctx->{patronItemsOut} = $out
+ unless( $ctx->{patronItemsOut} and $ctx->{patronItemsOut} > $out );
+
+ $logger->debug("script_builder: patron overdue count is " . $ctx->{patronOverdue});
+ }
+
+ if( $ctx->{fetch_patron_money_info} ) {
+ $ctx->{patronFines} = $U->patron_money_owed($patron->id);
+ $logger->debug("script_builder: patron fines determined to be ".$ctx->{patronFines});
+ }
+
+ unless( $ctx->{ignore_user_status} ) {
+ return OpenILS::Event->new('PATRON_INACTIVE')
+ unless $U->is_true($patron->active);
+
+ return OpenILS::Event->new('PATRON_CARD_INACTIVE')
+ unless $U->is_true($patron->card->active);
+
+ my $expire = DateTime::Format::ISO8601->new->parse_datetime(
+ cleanse_ISO8601($patron->expire_date));
+
+ return OpenILS::Event->new('PATRON_ACCOUNT_EXPIRED')
+ if( CORE::time > $expire->epoch ) ;
+ }
+
+ return undef;
+}
+
+
+sub flatten_groups {
+ my $e = shift;
+ my $tree = shift;
+
+ if(!%GROUP_SET) {
+ $GROUP_TREE = $e->search_permission_grp_tree(
+ [
+ { parent => undef },
+ {
+ flesh => 100,
+ flesh_fields => { pgt => ['children'] }
+ }
+ ]
+ )->[0];
+ $tree = $GROUP_TREE;
+ }
+
+ return undef unless $tree;
+ $GROUP_SET{$tree->id} = $tree;
+ if( $tree->children ) {
+ flatten_groups($e, $_) for @{$tree->children};
+ }
+}
+
+sub flatten_org_tree {
+ my $tree = shift;
+ return undef unless $tree;
+ push( @ORG_LIST, $tree );
+ if( $tree->children ) {
+ flatten_org_tree($_) for @{$tree->children};
+ }
+}
+
+
+
+sub insert_org_methods {
+ my ( $editor, $runner ) = @_;
+
+ if(!$ORG_TREE) {
+ $ORG_TREE = $editor->search_actor_org_unit(
+ [
+ {"parent_ou" => undef },
+ {
+ flesh => -1,
+ flesh_fields => { aou => ['children'] },
+ order_by => { aou => 'name'}
+ }
+ ]
+ )->[0];
+ flatten_org_tree($ORG_TREE);
+ }
+
+ my $r = $runner;
+ weaken($r);
+
+ $r->insert(__OILS_FUNC_isOrgDescendent =>
+ sub {
+ my( $write_key, $sname, $id ) = @_;
+ my ($parent) = grep { $_->shortname eq $sname } @ORG_LIST;
+ my ($child) = grep { $_->id == $id } @ORG_LIST;
+ my $val = is_org_descendent( $parent, $child );
+ $logger->debug("script_builder: is_org_desc $sname:$id returned val $val, writing to $write_key");
+ $r->insert($write_key, $val, 1) if $val;
+ return $val;
+ }
+ );
+
+ $r->insert(__OILS_FUNC_hasCommonAncestor =>
+ sub {
+ my( $write_key, $orgid1, $orgid2, $depth ) = @_;
+ my $val = has_common_ancestor( $orgid1, $orgid2, $depth );
+ $logger->debug("script_builder: has_common_ancestor resturned $val");
+ $r->insert($write_key, $val, 1) if $val;
+ return $val;
+ }
+ );
+}
+
+
+sub is_org_descendent {
+ my( $parent, $child ) = @_;
+ return 0 unless $parent and $child;
+ $logger->debug("script_builder: is_org_desc checking parent=".$parent->id.", child=".$child->id);
+ do {
+ return 0 unless defined $child->parent_ou;
+ return 1 if $parent->id == $child->id;
+ } while( ($child) = grep { $_->id == $child->parent_ou } @ORG_LIST );
+ return 0;
+}
+
+sub has_common_ancestor {
+ my( $org1, $org2, $depth ) = @_;
+ return 0 unless $org1 and $org2;
+ $logger->debug("script_builder: has_common_ancestor checking orgs $org1 : $org2");
+
+ return 1 if $org1 == $org2;
+ ($org1) = grep { $_->id == $org1 } @ORG_LIST;
+ ($org2) = grep { $_->id == $org2 } @ORG_LIST;
+
+ my $p1 = find_parent_at_depth($org1, $depth);
+ my $p2 = find_parent_at_depth($org2, $depth);
+
+ return 1 if $p1->id == $p2->id;
+ return 0;
+}
+
+
+sub find_parent_at_depth {
+ my $org = shift;
+ my $depth = shift;
+ return undef unless $org and $depth;
+ fetch_ou_types();
+ do {
+ my ($t) = grep { $_->id == $org->ou_type } @OU_TYPES;
+ return $org if $t->depth == $depth;
+ } while( ($org) = grep { $_->id == $org->parent_ou } @ORG_LIST );
+ return undef;
+}
+
+
+sub fetch_ou_types {
+ return if @OU_TYPES;
+ @OU_TYPES = @{new_editor()->retrieve_all_actor_org_unit_type()};
+}
+
+sub insert_copy_methods {
+ my( $e, $ctx, $runner ) = @_;
+ my $reqr = $ctx->{requestor} || $e->requestor;
+ if( my $copy = $ctx->{copy} ) {
+ $runner->insert_method( 'environment.copy', '__OILS_FUNC_fetch_best_hold', sub {
+ my $key = shift;
+ $logger->debug("script_builder: searching for permitted hold for copy ".$copy->barcode);
+ my ($hold) = $holdcode->find_nearest_permitted_hold( $e, $copy, $reqr, 1 ); # do we need a new editor here since the xact may be dead??
+ $runner->insert( $key, $hold, 1 );
+ }
+ );
+ }
+}
+
+sub insert_user_funcs {
+ my( $e, $ctx, $runner ) = @_;
+
+ # tells how many holds a user has
+ $runner->insert(__OILS_FUNC_userHoldCount =>
+ sub {
+ my( $write_key, $userid ) = @_;
+ my $val = $holdcode->__user_hold_count(new_editor(), $userid);
+ $logger->info("script_runner: user hold count is $val");
+ $runner->insert($write_key, $val, 1) if $val;
+ return $val;
+ }
+ );
+
+ $runner->insert(__OILS_FUNC_userCircsByCircmod =>
+ sub {
+ my( $write_key, $userid ) = @_;
+ use OpenSRF::Utils::JSON;
+
+ # this bug ugly thing generates a count of checkouts by circ_modifier
+ my $query = {
+ "select" => {
+ "acp" => ["circ_modifier"],
+ "circ"=>[{
+ "aggregate"=> OpenSRF::Utils::JSON->true,
+ "transform"=>"count",
+ "alias"=>"count",
+ "column"=>"id"
+ }],
+ },
+ "from"=>{"acp"=>{"circ"=>{"field"=>"target_copy","fkey"=>"id"}}},
+ "where"=>{
+ "+circ"=>{
+ "checkin_time"=>undef,
+ "usr"=>$userid,
+ "-or"=>[
+ {"stop_fines"=>["MAXFINES","LONGOVERDUE"]},
+ {"stop_fines"=>undef}
+ ]
+ }
+ }
+ };
+
+ my $mods = $e->json_query($query);
+ my $breakdown = {};
+ $breakdown->{$_->{circ_modifier}} = $_->{count} for @$mods;
+ $logger->info("script_runner: Loaded checkouts by circ_modifier breakdown:".
+ OpenSRF::Utils::JSON->perl2JSON($breakdown));
+ $runner->insert($write_key, $breakdown, 1) if (keys %$breakdown);
+ }
+ );
+
+}
+
+
+
+
+1;
--- /dev/null
+# ---------------------------------------------------------------
+# Copyright (C) 2006 Georgia Public Library Service
+# Bill Erickson <billserickson@gmail.com>
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+package OpenILS::Application::Circ::StatCat;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::Utils::Logger qw($logger);
+use OpenSRF::EX qw/:try/;
+use OpenILS::Application::AppUtils;
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_stat_cat_list",
+ argc => 1,
+ api_name => "open-ils.circ.stat_cat.actor.retrieve.batch");
+
+__PACKAGE__->register_method(
+ method => "retrieve_stat_cat_list",
+ argc => 1,
+ api_name => "open-ils.circ.stat_cat.asset.retrieve.batch");
+
+# retrieves all of the stat cats for a given org unit
+# if no orgid, user_session->home_ou is used
+
+sub retrieve_stat_cat_list {
+ my( $self, $client, $user_session, @sc ) = @_;
+
+ if (ref($sc[0])) {
+ @sc = @{$sc[0]};
+ }
+
+ my $method = "open-ils.storage.fleshed.actor.stat_cat.retrieve.batch.atomic";
+ if( $self->api_name =~ /asset/ ) {
+ $method = "open-ils.storage.fleshed.asset.stat_cat.retrieve.batch.atomic";
+ }
+
+ my($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ my $cats = $apputils->simple_scalar_request(
+ "open-ils.storage", $method, @sc);
+
+ return [ sort { $a->name cmp $b->name } @$cats ];
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_stat_cats",
+ api_name => "open-ils.circ.stat_cat.actor.retrieve.all");
+
+__PACKAGE__->register_method(
+ method => "retrieve_stat_cats",
+ api_name => "open-ils.circ.stat_cat.asset.retrieve.all");
+
+# retrieves all of the stat cats for a given org unit
+# if no orgid, user_session->home_ou is used
+
+sub retrieve_stat_cats {
+ my( $self, $client, $user_session, $orgid ) = @_;
+
+ my $method = "open-ils.storage.ranged.fleshed.actor.stat_cat.all.atomic";
+ if( $self->api_name =~ /asset/ ) {
+ $method = "open-ils.storage.ranged.fleshed.asset.stat_cat.all.atomic";
+ }
+
+ my($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ if(!$orgid) { $orgid = $user_obj->home_ou; }
+ my $cats = $apputils->simple_scalar_request(
+ "open-ils.storage", $method, $orgid );
+
+ return [ sort { $a->name cmp $b->name } @$cats ];
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_ranged_intersect_stat_cats",
+ api_name => "open-ils.circ.stat_cat.asset.multirange.intersect.retrieve");
+
+sub retrieve_ranged_intersect_stat_cats {
+ my( $self, $client, $user_session, $orglist ) = @_;
+
+ my($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ if(!$orglist) { $orglist = [ $user_obj->home_ou ]; }
+
+ # uniquify, yay!
+ my %hash = map { ($_ => 1) } @$orglist;
+ $orglist = [ keys %hash ];
+
+ warn "range: @$orglist\n";
+
+ my $method = "open-ils.storage.multiranged.intersect.fleshed.asset.stat_cat.all.atomic";
+ return $apputils->simple_scalar_request(
+ "open-ils.storage", $method, $orglist );
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_ranged_union_stat_cats",
+ api_name => "open-ils.circ.stat_cat.asset.multirange.union.retrieve");
+
+sub retrieve_ranged_union_stat_cats {
+ my( $self, $client, $user_session, $orglist ) = @_;
+
+ my $method = "open-ils.storage.multiranged.union.fleshed.asset.stat_cat.all.atomic";
+ use Data::Dumper;
+ warn "Retrieving stat_cats with method $method and orgs " . Dumper($orglist) . "\n";
+
+ my($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ if(!$orglist) { $orglist = [ $user_obj->home_ou ]; }
+
+ # uniquify, yay!
+ my %hash = map { ($_ => 1) } @$orglist;
+ $orglist = [ keys %hash ];
+
+ warn "range: @$orglist\n";
+
+ return $apputils->simple_scalar_request(
+ "open-ils.storage", $method, $orglist );
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "stat_cat_create",
+ api_name => "open-ils.circ.stat_cat.asset.create");
+
+__PACKAGE__->register_method(
+ method => "stat_cat_create",
+ api_name => "open-ils.circ.stat_cat.actor.create");
+
+sub stat_cat_create {
+ my( $self, $client, $user_session, $stat_cat ) = @_;
+
+ my $method = "open-ils.storage.direct.actor.stat_cat.create";
+ my $entry_create = "open-ils.storage.direct.actor.stat_cat_entry.create";
+ my $perm = 'CREATE_PATRON_STAT_CAT';
+ my $eperm = 'CREATE_PATRON_STAT_CAT_ENTRY';
+
+ if($self->api_name =~ /asset/) {
+ $method = "open-ils.storage.direct.asset.stat_cat.create";
+ $entry_create = "open-ils.storage.direct.asset.stat_cat_entry.create";
+ $perm = 'CREATE_COPY_STAT_CAT_ENTRY';
+ }
+
+ #my $user_obj = $apputils->check_user_session($user_session);
+ #my $orgid = $user_obj->home_ou();
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $evt = $apputils->check_perms($user_obj->id, $stat_cat->owner, $perm);
+ return $evt if $evt;
+
+ if($stat_cat->entries) {
+ $evt = $apputils->check_perms($user_obj->id, $stat_cat->owner, $eperm);
+ return $evt if $evt;
+ }
+
+
+ my $session = $apputils->start_db_session();
+ my $newid = _create_stat_cat($session, $stat_cat, $method);
+
+ if( ref($stat_cat->entries) ) {
+ for my $entry (@{$stat_cat->entries}) {
+ $entry->stat_cat($newid);
+ _create_stat_entry($session, $entry, $entry_create);
+ }
+ }
+
+ $apputils->commit_db_session($session);
+
+ $logger->debug("Stat cat creation successful with id $newid");
+
+ my $orgid = $user_obj->home_ou;
+ if( $self->api_name =~ /asset/ ) {
+ return _flesh_asset_cat($newid, $orgid);
+ } else {
+ return _flesh_user_cat($newid, $orgid);
+ }
+}
+
+
+sub _flesh_user_cat {
+ my $id = shift;
+ my $orgid = shift;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ my $cat = $session->request(
+ "open-ils.storage.direct.actor.stat_cat.retrieve",
+ $id )->gather(1);
+
+ $cat->entries(
+ $session->request(
+ "open-ils.storage.ranged.actor.stat_cat_entry.search.stat_cat.atomic",
+ $orgid, $id )->gather(1) );
+
+ return $cat;
+}
+
+
+sub _flesh_asset_cat {
+ my $id = shift;
+ my $orgid = shift;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ my $cat = $session->request(
+ "open-ils.storage.direct.asset.stat_cat.retrieve",
+ $id )->gather(1);
+
+ $cat->entries(
+ $session->request(
+ "open-ils.storage.ranged.asset.stat_cat_entry.search.stat_cat.atomic",
+ $orgid, $id )->gather(1) );
+
+ return $cat;
+
+}
+
+
+sub _create_stat_cat {
+ my( $session, $stat_cat, $method) = @_;
+ warn "Creating new stat cat with name " . $stat_cat->name . "\n";
+ $stat_cat->clear_id();
+ my $req = $session->request( $method, $stat_cat );
+ my $id = $req->gather(1);
+ if(!$id) {
+ throw OpenSRF::EX::ERROR
+ ("Error creating new statistical category"); }
+
+ warn "Stat cat create returned id $id\n";
+ return $id;
+}
+
+
+sub _create_stat_entry {
+ my( $session, $stat_entry, $method) = @_;
+
+ warn "Creating new stat entry with value " . $stat_entry->value . "\n";
+ $stat_entry->clear_id();
+
+ my $req = $session->request($method, $stat_entry);
+ my $id = $req->gather(1);
+
+ warn "Stat entry " . Dumper($stat_entry) . "\n";
+
+ if(!$id) {
+ throw OpenSRF::EX::ERROR
+ ("Error creating new stat cat entry"); }
+
+ warn "Stat cat entry create returned id $id\n";
+ return $id;
+}
+
+
+__PACKAGE__->register_method(
+ method => "update_stat_entry",
+ api_name => "open-ils.circ.stat_cat.actor.entry.update");
+
+__PACKAGE__->register_method(
+ method => "update_stat_entry",
+ api_name => "open-ils.circ.stat_cat.asset.entry.update");
+
+sub update_stat_entry {
+ my( $self, $client, $user_session, $entry ) = @_;
+
+
+ my $method = "open-ils.storage.direct.actor.stat_cat_entry.update";
+ my $perm = 'UPDATE_PATRON_STAT_CAT_ENTRY';
+ if($self->api_name =~ /asset/) {
+ $method = "open-ils.storage.direct.asset.stat_cat_entry.update";
+ $perm = 'UPDATE_COPY_STAT_CAT_ENTRY';
+ }
+
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $evt = $apputils->check_perms( $user_obj->id, $entry->owner, $perm );
+ return $evt if $evt;
+
+ my $session = $apputils->start_db_session();
+ my $req = $session->request($method, $entry);
+ my $status = $req->gather(1);
+ $apputils->commit_db_session($session);
+ warn "stat cat entry with value " . $entry->value . " updated with status $status\n";
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "update_stat",
+ api_name => "open-ils.circ.stat_cat.actor.update");
+
+__PACKAGE__->register_method(
+ method => "update_stat",
+ api_name => "open-ils.circ.stat_cat.asset.update");
+
+sub update_stat {
+ my( $self, $client, $user_session, $cat ) = @_;
+
+ my $method = "open-ils.storage.direct.actor.stat_cat.update";
+ my $perm = 'UPDATE_PATRON_STAT_CAT';
+ if($self->api_name =~ /asset/) {
+ $method = "open-ils.storage.direct.asset.stat_cat.update";
+ $perm = 'UPDATE_COPY_STAT_CAT';
+ }
+
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $evt = $apputils->check_perms( $user_obj->id, $cat->owner, $perm );
+ return $evt if $evt;
+
+ my $session = $apputils->start_db_session();
+ my $req = $session->request($method, $cat);
+ my $status = $req->gather(1);
+ $apputils->commit_db_session($session);
+ warn "stat cat with id " . $cat->id . " updated with status $status\n";
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "create_stat_entry",
+ api_name => "open-ils.circ.stat_cat.actor.entry.create");
+
+__PACKAGE__->register_method(
+ method => "create_stat_entry",
+ api_name => "open-ils.circ.stat_cat.asset.entry.create");
+
+sub create_stat_entry {
+ my( $self, $client, $user_session, $entry ) = @_;
+
+ my $method = "open-ils.storage.direct.actor.stat_cat_entry.create";
+ my $perm = 'CREATE_PATRON_STAT_CAT_ENTRY';
+ if($self->api_name =~ /asset/) {
+ $method = "open-ils.storage.direct.asset.stat_cat_entry.create";
+ $perm = 'CREATE_COPY_STAT_CAT_ENTRY';
+ }
+
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $evt = $apputils->check_perms( $user_obj->id, $entry->owner, $perm );
+ return $evt if $evt;
+
+ $entry->clear_id();
+ my $session = $apputils->start_db_session();
+ my $req = $session->request($method, $entry);
+ my $status = $req->gather(1);
+ $apputils->commit_db_session($session);
+
+ $logger->info("created stat cat entry $status");
+ return $status;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "create_stat_map",
+ api_name => "open-ils.circ.stat_cat.actor.user_map.create");
+
+__PACKAGE__->register_method(
+ method => "create_stat_map",
+ api_name => "open-ils.circ.stat_cat.asset.copy_map.create");
+
+sub create_stat_map {
+ my( $self, $client, $user_session, $map ) = @_;
+
+
+ my ( $evt, $copy, $volume, $patron, $user_obj );
+
+ my $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.create";
+ my $ret = "open-ils.storage.direct.actor.stat_cat_entry_user_map.retrieve";
+ my $perm = 'CREATE_PATRON_STAT_CAT_ENTRY_MAP';
+ my $perm_org;
+
+ if($self->api_name =~ /asset/) {
+ $method = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.create";
+ $ret = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.retrieve";
+ $perm = 'CREATE_COPY_STAT_CAT_ENTRY_MAP';
+ ( $copy, $evt ) = $apputils->fetch_copy($map->owning_copy);
+ return $evt if $evt;
+ ( $volume, $evt ) = $apputils->fetch_callnumber($copy->call_number);
+ return $evt if $evt;
+ $perm_org = $volume->owning_lib;
+
+ } else {
+ ($patron, $evt) = $apputils->fetch_user($map->target_usr);
+ return $evt if $evt;
+ $perm_org = $patron->home_ou;
+ }
+
+ ( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $evt = $apputils->check_perms( $user_obj->id, $perm_org, $perm );
+ return $evt if $evt;
+
+ $logger->debug( $user_obj->id . " creating new stat cat map" );
+
+ $map->clear_id();
+
+ my $session = $apputils->start_db_session();
+ my $req = $session->request($method, $map);
+ my $newid = $req->gather(1);
+ warn "Created new stat cat map with id $newid\n";
+ $apputils->commit_db_session($session);
+
+ return $apputils->simple_scalar_request( "open-ils.storage", $ret, $newid );
+
+}
+
+
+__PACKAGE__->register_method(
+ method => "update_stat_map",
+ api_name => "open-ils.circ.stat_cat.actor.user_map.update");
+
+__PACKAGE__->register_method(
+ method => "update_stat_map",
+ api_name => "open-ils.circ.stat_cat.asset.copy_map.update");
+
+sub update_stat_map {
+ my( $self, $client, $user_session, $map ) = @_;
+
+ my ( $evt, $copy, $volume, $patron, $user_obj );
+
+ my $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.update";
+ my $perm = 'UPDATE_PATRON_STAT_ENTRY_MAP';
+ my $perm_org;
+
+ if($self->api_name =~ /asset/) {
+ $method = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.update";
+ $perm = 'UPDATE_COPY_STAT_ENTRY_MAP';
+ ( $copy, $evt ) = $apputils->fetch_copy($map->owning_copy);
+ return $evt if $evt;
+ ( $volume, $evt ) = $apputils->fetch_callnumber($copy->call_number);
+ return $evt if $evt;
+ $perm_org = $volume->owning_lib;
+
+ } else {
+ ($patron, $evt) = $apputils->fetch_user($map->target_usr);
+ return $evt if $evt;
+ $perm_org = $patron->home_ou;
+ }
+
+
+ ( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $evt = $apputils->check_perms( $user_obj->id, $perm_org, $perm );
+ return $evt if $evt;
+
+
+ my $session = $apputils->start_db_session();
+ my $req = $session->request($method, $map);
+ my $newid = $req->gather(1);
+ warn "Updated new stat cat map with id $newid\n";
+ $apputils->commit_db_session($session);
+
+ return $newid;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_maps",
+ api_name => "open-ils.circ.stat_cat.actor.user_map.retrieve");
+
+__PACKAGE__->register_method(
+ method => "retrieve_maps",
+ api_name => "open-ils.circ.stat_cat.asset.copy_map.retrieve");
+
+sub retrieve_maps {
+ my( $self, $client, $user_session, $target ) = @_;
+
+
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ my $method = "open-ils.storage.direct.asset.stat_cat_entry_copy_map.search.owning_copy.atomic";
+ if($self->api_name =~ /actor/ ) {
+ if(!$target) { $target = $user_obj->id; }
+ $method = "open-ils.storage.direct.actor.stat_cat_entry_user_map.search.target_usr.atomic";
+ }
+
+ return $apputils->simple_scalar_request("open-ils.storage", $method, $target);
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => "delete_stats",
+ api_name => "open-ils.circ.stat_cat.actor.delete");
+
+__PACKAGE__->register_method(
+ method => "delete_stats",
+ api_name => "open-ils.circ.stat_cat.asset.delete");
+
+sub delete_stats {
+ my( $self, $client, $user_session, $target ) = @_;
+
+ my $cat;
+
+ my $type = "actor";
+ my $perm = 'DELETE_PATRON_STAT_CAT';
+ if($self->api_name =~ /asset/) {
+ $type = "asset";
+ $perm = 'DELETE_COPY_STAT_CAT';
+ }
+
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ ( $cat, $evt ) = $apputils->fetch_stat_cat( $type, $target );
+ return $evt if $evt;
+
+ $evt = $apputils->check_perms( $user_obj->id, $cat->owner, $perm );
+ return $evt if $evt;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ return _delete_stats($session, $target, $type);
+}
+
+sub _delete_stats {
+ my( $session, $stat, $type) = @_;
+
+ my $method = "open-ils.storage.direct.asset.stat_cat.delete";
+ if($type =~ /actor/ ) {
+ $method = "open-ils.storage.direct.actor.stat_cat.delete";
+ }
+ return $session->request($method, $stat)->gather(1);
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "delete_entry",
+ api_name => "open-ils.circ.stat_cat.actor.entry.delete");
+
+__PACKAGE__->register_method(
+ method => "delete_entry",
+ api_name => "open-ils.circ.stat_cat.asset.entry.delete");
+
+sub delete_entry {
+ my( $self, $client, $user_session, $target ) = @_;
+
+ my $type = "actor";
+ my $perm = 'DELETE_PATRON_STAT_CAT_ENTRY';
+ if($self->api_name =~ /asset/) {
+ $type = "asset";
+ $perm = 'DELETE_COPY_STAT_CAT_ENTRY';
+ }
+
+ my $entry;
+ my( $user_obj, $evt ) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ ( $entry, $evt ) = $apputils->fetch_stat_cat_entry( $type, $target );
+ return $evt if $evt;
+
+ $evt = $apputils->check_perms( $user_obj->id, $entry->owner, $perm );
+ return $evt if $evt;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ return _delete_entry($session, $target, $type);
+}
+
+sub _delete_entry {
+ my( $session, $stat_entry, $type) = @_;
+
+ my $method = "open-ils.storage.direct.asset.stat_cat_entry.delete";
+ if($type =~ /actor/ ) {
+ $method = "open-ils.storage.direct.actor.stat_cat_entry.delete";
+ }
+
+ return $session->request($method, $stat_entry)->gather(1);
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_stats_by_copy',
+ api_name => 'open-ils.circ.asset.stat_cat_entries.fleshed.retrieve_by_copy',
+);
+
+
+sub fetch_stats_by_copy {
+ my( $self, $conn, $args ) = @_;
+
+ my @entries;
+
+ if( $$args{public} ) {
+ my $maps = $U->cstorereq(
+ 'open-ils.cstore.direct.asset.stat_cat_entry_copy_map.search.atomic', { owning_copy => $$args{copyid} });
+
+
+ warn "here\n";
+ for my $map (@$maps) {
+
+ warn "map ".$map->id."\n";
+ warn "map ".$map->stat_cat_entry."\n";
+
+ my $entry = $U->cstorereq(
+ 'open-ils.cstore.direct.asset.stat_cat_entry.retrieve', $map->stat_cat_entry);
+
+ warn "Found entry ".$entry->id."\n";
+
+ my $cat = $U->cstorereq(
+ 'open-ils.cstore.direct.asset.stat_cat.retrieve', $entry->stat_cat );
+ $entry->stat_cat( $cat );
+ push( @entries, $entry );
+ }
+ }
+
+ return \@entries;
+}
+
+
+
+1;
--- /dev/null
+# ---------------------------------------------------------------
+# Copyright (C) 2005 Georgia Public Library Service
+# Bill Erickson <highfalutin@gmail.com>
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+package OpenILS::Application::Circ::Survey;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use OpenSRF::EX qw/:try/;
+use OpenILS::Application::AppUtils;
+use Data::Dumper;
+use OpenILS::Event;
+use Time::HiRes qw(time);
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+
+my $apputils = "OpenILS::Application::AppUtils";
+
+# - creates a new survey
+# expects a survey complete with questions and answers
+__PACKAGE__->register_method(
+ method => "add_survey",
+ api_name => "open-ils.circ.survey.create");
+
+sub add_survey {
+ my( $self, $client, $user_session, $survey ) = @_;
+
+ my($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ my $session = $apputils->start_db_session();
+ my $err = undef; my $id;
+
+
+ try {
+
+ $survey = _add_survey($session, $survey);
+ _add_questions($session, $survey);
+ $apputils->commit_db_session($session);
+
+ } catch Error with {
+ my $e = shift;
+ $err = "Error creating survey: $e\n";
+ $apputils->rollback_db_session($session);
+ };
+
+ if($err) { throw OpenSRF::EX::ERROR ($err); }
+
+ # re-retrieve the survey from the db and return it
+ return get_fleshed_survey($self, $client, $survey->id() );
+}
+
+
+sub _add_survey {
+ my($session, $survey) = @_;
+ my $req = $session->request(
+ "open-ils.storage.direct.action.survey.create",
+ $survey );
+
+ my $id = $req->gather(1);
+
+ if(!$id) {
+ throw OpenSRF::EX::ERROR
+ ("Unable to create new survey " . $survey->name());
+ }
+
+ $survey->id($id);
+ return $survey;
+}
+
+sub _update_survey {
+ my($session, $survey) = @_;
+}
+
+sub _add_questions {
+ my($session, $survey) = @_;
+
+ # create new questions in the db
+ if( $survey->questions() ) {
+ for my $question (@{$survey->questions()}){
+
+ $question->survey($survey->id());
+ my $virtual_id = $question->id();
+ $question->clear_id();
+
+
+ my $req = $session->request(
+ 'open-ils.storage.direct.action.survey_question.create',
+ $question );
+ my $new_id = $req->gather(1);
+
+ if(!$new_id) {
+ throw OpenSRF::EX::ERROR
+ ("Error creating new survey question " . $question->question() . "\n")
+ }
+
+ # now update the responses to this question
+ if($question->answers()) {
+ for my $answer (@{$question->answers()}) {
+ $answer->question($new_id);
+ _add_answer($session,$answer);
+ }
+ }
+ }
+ }
+}
+
+
+sub _add_answer {
+ my($session, $answer) = @_;
+ $answer->clear_id();
+ my $req = $session->request(
+ "open-ils.storage.direct.action.survey_answer.create",
+ $answer );
+ my $id = $req->gather(1);
+ if(!$id) {
+ throw OpenSRF::EX::ERROR
+ ("Error creating survey answer " . $answer->answer() );
+ }
+
+}
+
+
+
+# retrieve surveys for a specific org subtree.
+__PACKAGE__->register_method(
+ method => "get_required_surveys",
+ api_name => "open-ils.circ.survey.retrieve.required");
+
+sub get_required_surveys {
+ my( $self, $client, $user_session ) = @_;
+
+
+ my ($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ my $orgid = $user_obj->ws_ou() ? $user_obj->ws_ou() : $user_obj->home_ou();
+ my $surveys = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.action.survey.required.atomic",
+ $orgid );
+
+ my @fleshed;
+ for my $survey (@$surveys) {
+ push(@fleshed, get_fleshed_survey($self, $client, $survey));
+ }
+ return \@fleshed;
+
+}
+
+__PACKAGE__->register_method(
+ method => "get_survey_responses",
+ api_name => "open-ils.circ.survey.response.retrieve");
+
+sub get_survey_responses {
+ my( $self, $client, $user_session, $survey_id, $user_id ) = @_;
+
+ if(!$user_id) {
+ my ($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+ $user_id = $user_obj->id;
+ }
+
+ my $res = $apputils->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.action.survey_response.search.atomic",
+ { usr => $user_id, survey => $survey_id } );
+
+ if( $res && ref($res) and $res->[0]) {
+ return [ sort { $a->id() <=> $b->id() } @$res ];
+ }
+
+ return [];
+}
+
+__PACKAGE__->register_method(
+ method => "get_all_surveys",
+ api_name => "open-ils.circ.survey.retrieve.all");
+
+sub get_all_surveys {
+ my( $self, $client, $user_session ) = @_;
+
+ my ($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ my $orgid = $user_obj->ws_ou() ? $user_obj->ws_ou() : $user_obj->home_ou();
+ my $surveys = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.action.survey.all.atomic",
+ $orgid );
+
+ my @fleshed;
+ for my $survey (@$surveys) {
+ push(@fleshed, get_fleshed_survey($self, $client, $survey));
+ }
+ return \@fleshed;
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => "get_fleshed_survey",
+ api_name => "open-ils.circ.survey.fleshed.retrieve");
+
+sub get_fleshed_survey {
+ my( $self, $client, $survey_id ) = @_;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+
+ my $survey;
+ if( ref($survey_id) and
+ (ref($survey_id) =~ /^Fieldmapper/)) {
+ $survey = $survey_id;
+
+ } else {
+
+ my $sreq = $session->request(
+ "open-ils.storage.direct.action.survey.retrieve",
+ $survey_id );
+ $survey = $sreq->gather(1);
+ if(! $survey) { return undef; }
+ }
+
+ $survey->questions([]);
+
+
+ my $qreq = $session->request(
+ "open-ils.storage.direct.action.survey_question.search.survey.atomic",
+ $survey->id() );
+
+ my $questions = $qreq->gather(1);
+
+ if($questions) {
+
+ for my $question (@$questions) {
+ next unless defined $question;
+
+ # add this question to the survey
+ push( @{$survey->questions()}, $question );
+
+
+ my $ans_req = $session->request(
+ "open-ils.storage.direct.action.survey_answer.search.question.atomic",
+ $question->id() );
+
+ # add this array of answers to this question
+ $question->answers( $ans_req->gather(1) );
+
+ }
+ }
+
+ $session->disconnect();
+ return $survey;
+
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "submit_survey",
+ api_name => "open-ils.circ.survey.submit.session");
+
+__PACKAGE__->register_method(
+ method => "submit_survey",
+ api_name => "open-ils.circ.survey.submit.user_id");
+
+__PACKAGE__->register_method(
+ method => "submit_survey",
+ api_name => "open-ils.circ.survey.submit.anon");
+
+
+sub submit_survey {
+ my( $self, $client, $responses ) = @_;
+
+ if(!$responses) {
+ throw OpenSRF::EX::ERROR
+ ("No survey object sent in update");
+ }
+
+
+ if(!ref($responses)) { $responses = [$responses]; }
+
+ my $session = $apputils->start_db_session();
+
+ my $group_id = $session->request(
+ "open-ils.storage.action.survey_response.next_group_id")->gather(1);
+
+ my %already_seen;
+ for my $res (@$responses) {
+
+ my $id;
+
+ if($self->api_name =~ /session/) {
+ if( ! ($id = $already_seen{$res->usr}) ) {
+ my ($user_obj, $evt) = $apputils->checkses($res->usr);
+ return $evt if $evt;
+ $id = $user_obj->id;
+ $already_seen{$res->usr} = $id;
+ }
+ $res->usr($id);
+ } elsif( $self->api_name =~ /anon/ ) {
+ $res->clear_usr();
+ }
+
+ $res->response_group_id($group_id);
+ my $req = $session->request(
+ "open-ils.storage.direct.action.survey_response.create",
+ $res );
+ my $newid = $req->gather(1);
+
+ if(!$newid) {
+ throw OpenSRF::EX::ERROR
+ ("Error creating new survey response");
+ }
+ }
+
+ $apputils->commit_db_session($session);
+
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => "get_random_survey",
+ api_name => "open-ils.circ.survey.retrieve.opac.random");
+
+sub get_random_survey {
+ my( $self, $client, $user_session ) = @_;
+
+ my ($user_obj, $evt) = $apputils->checkses($user_session);
+ return $evt if $evt;
+
+ my $surveys = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.action.survey.opac.atomic",
+ $user_obj->home_ou() );
+
+ my $random = int(rand(scalar(@$surveys)));
+ my $surv = $surveys->[$random];
+
+ return get_fleshed_survey($self, $client, $surv);
+
+}
+
+__PACKAGE__->register_method(
+ method => "get_random_survey_global",
+ api_name => "open-ils.circ.survey.retrieve.opac.random.global");
+
+sub get_random_survey_global {
+ my( $self, $client ) = @_;
+
+ my $surveys = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.direct.action.survey.search.atomic",
+ # XXX grab the org tree to get the root id...
+ { owner => 1, opac => 't' } );
+
+ my $random = int(rand(scalar(@$surveys)));
+ my $surv = $surveys->[$random];
+
+ return get_fleshed_survey($self, $client, $surv);
+
+}
+
+
+__PACKAGE__->register_method (
+ method => 'delete_survey',
+ api_name => 'open-ils.circ.survey.delete.cascade'
+);
+__PACKAGE__->register_method (
+ method => 'delete_survey',
+ api_name => 'open-ils.circ.survey.delete.cascade.override'
+);
+
+sub delete_survey {
+ my($self, $conn, $auth, $survey_id) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $survey = $e->retrieve_action_survey($survey_id)
+ or return $e->die_event;
+ return $e->die_event unless $e->allowed('ADMIN_SURVEY', $survey->owner);
+
+ my $questions = $e->search_action_survey_question({survey => $survey_id});
+ my @answers;
+ push(@answers, @{$e->search_action_survey_answer({question => $_->id})}) for @$questions;
+ my $responses = $e->search_action_survey_response({survey => $survey_id});
+
+ return OpenILS::Event->new('SURVEY_RESPONSES_EXIST')
+ if @$responses and $self->api_name =! /override/;
+
+ for my $resp (@$responses) {
+ $e->delete_action_survey_response($resp) or return $e->die_event;
+ }
+
+ for my $ans (@answers) {
+ $e->delete_action_survey_answer($ans) or return $e->die_event;
+ }
+
+ for my $quest (@$questions) {
+ $e->delete_action_survey_question($quest) or return $e->die_event;
+ }
+
+ $e->delete_action_survey($survey) or return $e->die_event;
+
+ $e->commit;
+ return 1;
+}
+
+
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::Circ::Transit;
+use base 'OpenILS::Application';
+use strict; use warnings;
+use OpenSRF::EX qw(:try);
+use Data::Dumper;
+use OpenSRF::Utils;
+use OpenSRF::Utils::Cache;
+use Digest::MD5 qw(md5_hex);
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Circ::Holds;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenSRF::AppSession;
+use OpenILS::Const qw/:const/;
+
+my $U = "OpenILS::Application::AppUtils";
+my $holdcode = "OpenILS::Application::Circ::Holds";
+$Data::Dumper::Indent = 0;
+
+
+
+__PACKAGE__->register_method(
+ method => "copy_transit_receive",
+ api_name => "open-ils.circ.copy_transit.receive",
+ notes => q/
+ Closes out a copy transit
+ Requestor needs the COPY_TRANSIT_RECEIVE permission
+ @param authtoken The login session key
+ @param params An object of named params including
+ copyid - the id of the copy in quest
+ barcode - the barcode of the copy in question
+ If copyid is not sent, this is used.
+ @return A ROUTE_ITEM if the copy is destined for a different location.
+ A SUCCESS event on success. Other events on error.
+ /);
+
+sub copy_transit_receive {
+ my( $self, $client, $authtoken, $params ) = @_;
+ my %params = %$params;
+ my( $evt, $copy, $requestor );
+ ($requestor, $evt) = $U->checksesperm($authtoken, 'COPY_TRANSIT_RECEIVE');
+ return $evt if $evt;
+ ($copy, $evt) = $U->fetch_copy($params{copyid});
+ ($copy, $evt) = $U->fetch_copy_by_barcode($params{barcode}) unless $copy;
+ return $evt if $evt;
+ my $session = $U->start_db_session();
+ $evt = transit_receive( $self, $copy, $requestor, $session );
+ $U->commit_db_session($session) if $U->event_equals($evt,'SUCCESS');
+ return $evt;
+}
+
+# ------------------------------------------------------------------------------
+# If the transit destination is different than the requestor's lib,
+# a ROUTE_TO event is returned with the org set.
+# If
+# ------------------------------------------------------------------------------
+sub transit_receive {
+ my ( $class, $copy, $requestor, $session ) = @_;
+ $U->logmark;
+
+ my( $transit, $evt );
+ my $copyid = $copy->id;
+
+ my $status_name = $U->copy_status_to_name($copy->status);
+ $logger->debug("Attempting transit receive on copy $copyid. Copy status is $status_name");
+
+ # fetch the transit
+ ($transit, $evt) = $U->fetch_open_transit_by_copy($copyid);
+ return $evt if $evt;
+
+ if( $transit->dest != $requestor->home_ou ) {
+ $logger->activity("Fowarding transit on copy which is destined ".
+ "for a different location. copy=$copyid,current ".
+ "location=".$requestor->home_ou.",destination location=".$transit->dest);
+
+ return OpenILS::Event->new('ROUTE_ITEM', org => $transit->dest );
+ }
+
+ # The transit is received, set the receive time
+ $transit->dest_recv_time('now');
+ my $r = $session->request(
+ 'open-ils.storage.direct.action.transit_copy.update', $transit )->gather(1);
+ return $U->DB_UPDATE_FAILED($transit) unless $r;
+
+ my $ishold = 0;
+ my ($ht) = $U->fetch_hold_transit( $transit->id );
+ if($ht) {
+ $logger->info("Hold transit found in transit receive...");
+ $ishold = 1;
+ }
+
+ $logger->info("Recovering original copy status in transit: ".$transit->copy_status);
+ $copy->status( $transit->copy_status );
+ return $evt if ( $evt =
+ $U->update_copy( copy => $copy, editor => $requestor->id, session => $session ));
+
+ return OpenILS::Event->new('SUCCESS', ishold => $ishold,
+ payload => { transit => $transit, holdtransit => $ht } );
+}
+
+
+
+
+
+__PACKAGE__->register_method(
+ method => "copy_transit_create",
+ api_name => "open-ils.circ.copy_transit.create",
+ notes => q/
+ Creates a new copy transit. Requestor must have the
+ CREATE_COPY_TRANSIT permission.
+ @param authtoken The login session key
+ @param params A param object containing the following keys:
+ copyid - the copy id
+ destination - the id of the org destination. If not defined,
+ defaults to the copy's circ_lib
+ @return SUCCESS event on success, other event on error
+ /);
+
+sub copy_transit_create {
+
+ my( $self, $client, $authtoken, $params ) = @_;
+ my %params = %$params;
+
+ my( $requestor, $evt ) =
+ $U->checksesperm( $authtoken, 'CREATE_COPY_TRANSIT' );
+ return $evt if $evt;
+
+ my $copy;
+ ($copy,$evt) = $U->fetch_copy($params{copyid});
+ return $evt if $evt;
+
+ my $session = $params{session} || $U->start_db_session();
+ my $source = $requestor->home_ou;
+ my $dest = $params{destination} || $copy->circ_lib;
+ my $transit = Fieldmapper::action::transit_copy->new;
+
+ $logger->activity("User ". $requestor->id ." creating a ".
+ " new copy transit for copy ".$copy->id." to org $dest");
+
+ $transit->source($source);
+ $transit->dest($dest);
+ $transit->target_copy($copy->id);
+ $transit->source_send_time("now");
+ $transit->copy_status($copy->status);
+
+ $logger->debug("Creating new copy_transit in DB");
+
+ my $s = $session->request(
+ "open-ils.storage.direct.action.transit_copy.create", $transit )->gather(1);
+ return $U->DB_UPDATE_FAILED($transit) unless $s;
+
+ my $stat = $U->copy_status_from_name('in transit');
+
+ $copy->status($stat->id);
+ return $evt if ($evt = $U->update_copy(
+ copy => $copy, editor => $requestor->id, session => $session ));
+
+ $U->commit_db_session($session) unless $params{session};
+
+ return OpenILS::Event->new('SUCCESS',
+ payload => { copy => $copy, transit => $transit } );
+}
+
+
+__PACKAGE__->register_method(
+ method => 'abort_transit',
+ api_name => 'open-ils.circ.transit.abort',
+ signature => q/
+ Deletes a cleans up a transit
+ /
+);
+
+sub abort_transit {
+ my( $self, $conn, $authtoken, $params ) = @_;
+
+ my $copyid = $$params{copyid};
+ my $barcode = $$params{barcode};
+ my $transitid = $$params{transitid};
+
+ my $copy;
+ my $transit;
+ my $evt;
+
+ my $e = new_editor(xact => 1, authtoken => $authtoken);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('ABORT_TRANSIT');
+
+ # ---------------------------------------------------------------------
+ # Find the related copy and/or transit based on whatever data we have
+ if( $barcode ) {
+ $copy = $e->search_asset_copy({barcode=>$barcode, deleted => 'f'})->[0];
+ return $e->event unless $copy;
+
+ } elsif( $copyid ) {
+ $copy = $e->retrieve_asset_copy($copyid) or return $e->event;
+ }
+
+ if( $transitid ) {
+ $transit = $e->retrieve_action_transit_copy($transitid)
+ or return $e->event;
+
+ } elsif( $copy ) {
+
+ $transit = $e->search_action_transit_copy(
+ { target_copy => $copy->id, dest_recv_time => undef })->[0];
+ return $e->event unless $transit;
+ }
+
+ if($transit and !$copy) {
+ $copy = $e->retrieve_asset_copy($transit->target_copy)
+ or return $e->event;
+ }
+ # ---------------------------------------------------------------------
+
+ return __abort_transit( $e, $transit, $copy );
+}
+
+
+
+sub __abort_transit {
+
+ my( $e, $transit, $copy, $no_reset_hold ) = @_;
+
+ my $evt;
+ my $hold;
+
+ if( $transit->copy_status == OILS_COPY_STATUS_LOST or
+ $transit->copy_status == OILS_COPY_STATUS_MISSING ) {
+ $e->rollback;
+ return OpenILS::Event->new('TRANSIT_ABORT_NOT_ALLOWED');
+ }
+
+
+ if( $transit->dest != $e->requestor->ws_ou
+ and $transit->source != $e->requestor->ws_ou ) {
+ return $e->event unless $e->allowed('ABORT_REMOTE_TRANSIT', $e->requestor->ws_ou);
+ }
+
+ # recover the copy status
+ $copy->status( $transit->copy_status );
+ $copy->editor( $e->requestor->id );
+ $copy->edit_date('now');
+
+ my $holdtransit = $e->retrieve_action_hold_transit_copy($transit->id);
+
+ if( $holdtransit ) {
+ $logger->info("setting copy to reshelving on hold transit abort");
+ $copy->status( OILS_COPY_STATUS_RESHELVING );
+ }
+
+ return $e->event unless $e->delete_action_transit_copy($transit);
+ return $e->event unless $e->update_asset_copy($copy);
+
+ $e->commit;
+
+ # if this is a hold transit, un-capture/un-target the hold
+ if($holdtransit and !$no_reset_hold) {
+ $hold = $e->retrieve_action_hold_request($holdtransit->hold)
+ or return $e->event;
+ $evt = $holdcode->_reset_hold( $e->requestor, $hold );
+ return $evt if $evt;
+ }
+
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'get_open_copy_transit',
+ api_name => 'open-ils.circ.open_copy_transit.retrieve',
+ signature => q/
+ Retrieves the open transit object for a given copy
+ @param auth The login session key
+ @param copyid The id of the copy
+ @return Transit object
+ /
+);
+
+sub get_open_copy_transit {
+ my( $self, $conn, $auth, $copyid ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER'); # XXX rely on editor perms
+ my $t = $e->search_action_transit_copy(
+ { target_copy => $copyid, dest_recv_time => undef });
+ return $e->event unless @$t;
+ return $$t[0];
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_transit_by_copy',
+ api_name => 'open-ils.circ.fetch_transit_by_copy',
+);
+
+sub fetch_transit_by_copy {
+ my( $self, $conn, $auth, $copyid ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ my $t = $e->search_action_transit_copy(
+ {
+ target_copy => $copyid,
+ dest_recv_time => undef
+ }
+ )->[0];
+ return $e->event unless $t;
+ my $ht = $e->retrieve_action_hold_transit_copy($t->id);
+ return { atc => $t, ahtc => $ht };
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'transits_by_lib',
+ api_name => 'open-ils.circ.transit.retrieve_by_lib',
+);
+
+
+# start_date and end_date are optional endpoints for the transit creation date
+sub transits_by_lib {
+ my( $self, $conn, $auth, $orgid, $start_date, $end_date ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # eh.. basically the same permission
+
+ my $order_by = {order_by => { atc => 'source_send_time' }};
+ my $search = { dest_recv_time => undef };
+
+ if($end_date) {
+ if($start_date) {
+ $search->{source_send_time} = {between => [$start_date, $end_date]};
+ } else {
+ $search->{source_send_time} = {'<=' => $end_date};
+ }
+ } elsif($start_date) {
+ $search->{source_send_time} = {'>=' => $start_date};
+ }
+
+ $search->{dest} = $orgid;
+
+ my $tos = $e->search_action_transit_copy([ $search, $order_by ], {idlist=>1});
+
+ delete $$search{dest};
+ $search->{source} = $orgid;
+
+ my $froms = $e->search_action_transit_copy([ $search, $order_by ], {idlist=>1});
+
+ return { from => $froms, to => $tos };
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_transit',
+ api_name => 'open-ils.circ.transit.retrieve',
+);
+sub fetch_transit {
+ my( $self, $conn, $auth, $transid ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_CIRCULATIONS'); # eh.. basically the same permission
+
+ my $ht = $e->retrieve_action_hold_transit_copy($transid);
+ return $ht if $ht;
+
+ my $t = $e->retrieve_action_transit_copy($transid)
+ or return $e->event;
+ return $t;
+}
+
+
+
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::Collections;
+use strict; use warnings;
+use OpenSRF::EX qw(:try);
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenSRF::Utils qw/:datetime/;
+use OpenILS::Application;
+use OpenILS::Utils::Fieldmapper;
+use base 'OpenILS::Application';
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Event;
+use OpenILS::Const qw/:const/;
+my $U = "OpenILS::Application::AppUtils";
+
+
+# --------------------------------------------------------------
+# Loads the config info
+# --------------------------------------------------------------
+sub initialize { return 1; }
+
+__PACKAGE__->register_method(
+ method => 'user_from_bc',
+ api_name => 'open-ils.collections.user_id_from_barcode',
+);
+
+sub user_from_bc {
+ my( $self, $conn, $auth, $bc ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('VIEW_USER');
+ my $card = $e->search_actor_card({barcode=>$bc})->[0]
+ or return $e->event;
+ my $user = $e->retrieve_actor_user($card->usr)
+ or return $e->event;
+ return $user->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'users_of_interest',
+ api_name => 'open-ils.collections.users_of_interest.retrieve',
+ api_level => 1,
+ argc => 4,
+ stream => 1,
+ signature => {
+ desc => q/
+ Returns an array of user information objects that the system
+ based on the search criteria provided. If the total fines
+ a user owes reaches or exceeds "fine_level" on or befre "age"
+ and the fines were created at "location", the user will be
+ included in the return set/,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'age',
+ desc => q/Number of days back to check/,
+ type => q/number/,
+ },
+
+ { name => 'fine_level',
+ desc => q/The fine threshold at which users will be included in the search results /,
+ type => q/number/,
+ },
+ { name => 'location',
+ desc => q/The short-name of the orginization unit (library) at which the fines were created.
+ If a selected location has 'child' locations (e.g. a library region), the
+ child locations will be included in the search/,
+ type => q/string/,
+ },
+ ],
+
+ 'return' => {
+ desc => q/An array of user information objects.
+ usr : Array of user information objects containing id, dob, profile, and groups
+ threshold_amount : The total amount the patron owes that is at least as old
+ as the fine "age" and whose transaction was created at the searched location
+ last_pertinent_billing : The time of the last billing that relates to this query
+ /,
+ type => 'array',
+ example => {
+ usr => {
+ id => 'id',
+ dob => '1970-01-01',
+ profile => 'Patron',
+ groups => [ 'Patron', 'Staff' ],
+ },
+ threshold_amount => 99,
+ }
+ }
+ }
+);
+
+
+sub users_of_interest {
+ my( $self, $conn, $auth, $age, $fine_level, $location ) = @_;
+
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless ($auth and $age and $location);
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $org = $e->search_actor_org_unit({shortname => $location})
+ or return $e->event; $org = $org->[0];
+
+ # they need global perms to view users so no org is provided
+ return $e->event unless $e->allowed('VIEW_USER');
+
+ my $data = [];
+
+ my $ses = OpenSRF::AppSession->create('open-ils.storage');
+
+ my $start = time;
+ my $req = $ses->request(
+ 'open-ils.storage.money.collections.users_of_interest',
+ $age, $fine_level, $location);
+
+ # let the client know we're still here
+ $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ return process_users_of_interest_results(
+ $self, $conn, $e, $req, $start, $age, $fine_level, $location);
+}
+
+
+__PACKAGE__->register_method(
+ method => 'users_of_interest_warning_penalty',
+ api_name => 'open-ils.collections.users_of_interest.warning_penalty.retrieve',
+ api_level => 1,
+ argc => 4,
+ stream => 1,
+ signature => {
+ desc => q/
+ Returns an array of user information objects for users that have the
+ PATRON_EXCEEDS_COLLECTIONS_WARNING penalty applied,
+ based on the search criteria provided./,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string'
+ }, {
+ name => 'location',
+ desc => q/The short-name of the orginization unit (library) at which the penalty is applied.
+ If a selected location has 'child' locations (e.g. a library region), the
+ child locations will be included in the search/,
+ type => q/string/,
+ }, {
+ name => 'min_age',
+ desc => q/Optional. Minimum age of the penalty application/,
+ type => q/interval, e.g "30 days"/,
+ }, {
+ name => 'max_age',
+ desc => q/Optional. Maximum age of the penalty application/,
+ type => q/interval, e.g "90 days"/,
+ }
+ ],
+
+ 'return' => {
+ desc => q/An array of user information objects.
+ usr : Array of user information objects containing id, dob, profile, and groups
+ threshold_amount : The total amount the patron owes that is at least as old
+ as the fine "age" and whose transaction was created at the searched location
+ last_pertinent_billing : The time of the last billing that relates to this query
+ /,
+ type => 'array',
+ example => {
+ usr => {
+ id => 'id',
+ dob => '1970-01-01',
+ profile => 'Patron',
+ groups => [ 'Patron', 'Staff' ],
+ },
+ threshold_amount => 99, # TODO: still needed?
+ }
+ }
+ }
+);
+
+
+
+sub users_of_interest_warning_penalty {
+ my( $self, $conn, $auth, $location, $min_age, $max_age ) = @_;
+
+ return OpenILS::Event->new('BAD_PARAMS') unless ($auth and $location);
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $org = $e->search_actor_org_unit({shortname => $location})
+ or return $e->event; $org = $org->[0];
+
+ # they need global perms to view users so no org is provided
+ return $e->event unless $e->allowed('VIEW_USER');
+
+ my $org_ids = $e->json_query({from => ['actor.org_unit_full_path', $org->id]});
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ # max age == oldest
+ my $max_set_date = DateTime->now->subtract(seconds =>
+ interval_to_seconds($max_age))->strftime( '%F %T%z' ) if $max_age;
+ my $min_set_date = DateTime->now->subtract(seconds =>
+ interval_to_seconds($min_age))->strftime( '%F %T%z' ) if $min_age;
+
+ my $start = time;
+ my $query = {
+ select => {ausp => ['usr']},
+ from => 'ausp',
+ where => {
+ standing_penalty => 4, # PATRON_EXCEEDS_COLLECTIONS_WARNING
+ org_unit => [ map {$_->{id}} @$org_ids ],
+ '-or' => [
+ {stop_date => undef},
+ {stop_date => {'>' => 'now'}}
+ ]
+ }
+ };
+
+ $query->{where}->{'-and'} = [] if $max_set_date or $min_set_date;
+ push(@{$query->{where}->{'-and'}}, {set_date => {'>' => $max_set_date}}) if $max_set_date;
+ push(@{$query->{where}->{'-and'}}, {set_date => {'<' => $min_set_date}}) if $min_set_date;
+
+ my $req = $ses->request('open-ils.cstore.json_query', $query);
+
+ # let the client know we're still here
+ $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ return process_users_of_interest_results(
+ $self, $conn, $e, $req, $start, $min_age, '', $location, $max_age);
+}
+
+
+
+
+sub process_users_of_interest_results {
+ my($self, $conn, $e, $req, $starttime, @params) = @_;
+
+ my $total;
+ while( my $resp = $req->recv(timeout => 7200) ) {
+
+ return $req->failed if $req->failed;
+ my $hash = $resp->content;
+ next unless $hash;
+
+ unless($total) {
+ $total = time - $starttime;
+ $logger->info("collections: request (@params) took $total seconds");
+ }
+
+ my $u = $e->retrieve_actor_user(
+ [
+ $hash->{usr},
+ {
+ flesh => 1,
+ flesh_fields => {au => ["groups","profile", "card"]},
+ }
+ ]
+ ) or return $e->event;
+
+ $hash->{usr} = {
+ id => $u->id,
+ dob => $u->dob,
+ profile => $u->profile->name,
+ barcode => $u->card->barcode,
+ groups => [ map { $_->name } @{$u->groups} ],
+ };
+
+ $conn->respond($hash);
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'users_owing_money',
+ api_name => 'open-ils.collections.users_owing_money.retrieve',
+ api_level => 1,
+ argc => 5,
+ stream => 1,
+ signature => {
+ desc => q/
+ Returns an array of users that owe money during
+ the given time frame at the location (or child locations)
+ provided/,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'start_date',
+ desc => 'The start of the time interval to check',
+ type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
+ },
+
+ { name => 'end_date',
+ desc => q/Then end date of the time interval to check/,
+ type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
+ },
+ { name => 'fine_level',
+ desc => q/The fine threshold at which users will be included in the search results /,
+ type => q/number/,
+ },
+ { name => 'locations',
+ desc => q/ A list of one or more org-unit short names.
+ If a selected location has 'child' locations (e.g. a library region), the
+ child locations will be included in the search/,
+ type => q'string',
+ },
+ ],
+ 'return' => {
+ desc => q/An array of user information objects/,
+ type => 'array',
+ }
+ }
+);
+
+
+sub users_owing_money {
+ my( $self, $conn, $auth, $start_date, $end_date, $fine_level, @locations ) = @_;
+
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless ($auth and $start_date and $end_date and @locations);
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ # they need global perms to view users so no org is provided
+ return $e->event unless $e->allowed('VIEW_USER');
+
+ my $data = [];
+
+ my $ses = OpenSRF::AppSession->create('open-ils.storage');
+
+ my $start = time;
+ my $req = $ses->request(
+ 'open-ils.storage.money.collections.users_owing_money',
+ $start_date, $end_date, $fine_level, @locations);
+
+ # let the client know we're still here
+ $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ return process_users_of_interest_results(
+ $self, $conn, $e, $req, $start, $start_date, $end_date, $fine_level, @locations);
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'users_with_activity',
+ api_name => 'open-ils.collections.users_with_activity.retrieve',
+ api_level => 1,
+ argc => 4,
+ stream => 1,
+ signature => {
+ desc => q/
+ Returns an array of users that are already in collections
+ and had any type of billing or payment activity within
+ the given time frame at the location (or child locations)
+ provided/,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'start_date',
+ desc => 'The start of the time interval to check',
+ type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
+ },
+
+ { name => 'end_date',
+ desc => q/Then end date of the time interval to check/,
+ type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
+ },
+ { name => 'location',
+ desc => q/The short-name of the orginization unit (library) at which the activity occurred.
+ If a selected location has 'child' locations (e.g. a library region), the
+ child locations will be included in the search/,
+ type => q'string',
+ },
+ ],
+
+ 'return' => {
+ desc => q/An array of user information objects/,
+ type => 'array',
+ }
+ }
+);
+
+sub users_with_activity {
+ my( $self, $conn, $auth, $start_date, $end_date, $location ) = @_;
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless ($auth and $start_date and $end_date and $location);
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ my $org = $e->search_actor_org_unit({shortname => $location})
+ or return $e->event; $org = $org->[0];
+ return $e->event unless $e->allowed('VIEW_USER', $org->id);
+
+ my $ses = OpenSRF::AppSession->create('open-ils.storage');
+
+ my $start = time;
+ my $req = $ses->request(
+ 'open-ils.storage.money.collections.users_with_activity.atomic',
+ $start_date, $end_date, $location);
+
+ $conn->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ my $total;
+ while( my $resp = $req->recv(timeout => 7200) ) {
+
+ unless($total) {
+ $total = time - $start;
+ $logger->info("collections: users_with_activity search ".
+ "($start_date, $end_date, $location) took $total seconds");
+ }
+
+ return $req->failed if $req->failed;
+ $conn->respond($resp->content);
+ }
+
+ return undef;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'put_into_collections',
+ api_name => 'open-ils.collections.put_into_collections',
+ api_level => 1,
+ argc => 3,
+ signature => {
+ desc => q/
+ Marks a user as being "in collections" at a given location
+ /,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'user_id',
+ desc => 'The id of the user to plact into collections',
+ type => 'number',
+ },
+
+ { name => 'location',
+ desc => q/The short-name of the orginization unit (library)
+ for which the user is being placed in collections/,
+ type => q'string',
+ },
+ { name => 'fee_amount',
+ desc => q/
+ The amount of money that a patron should be fined.
+ If this field is empty, no fine is created.
+ /,
+ type => 'string',
+ },
+ { name => 'fee_note',
+ desc => q/
+ Custom note that is added to the the billing.
+ This field is not required.
+ Note: fee_note is not the billing_type. Billing_type type is
+ decided by the system. (e.g. "fee for collections").
+ fee_note is purely used for any additional needed information
+ and is only visible to staff.
+ /,
+ type => 'string',
+ },
+ ],
+
+ 'return' => {
+ desc => q/A SUCCESS event on success, error event on failure/,
+ type => 'object',
+ }
+ }
+);
+sub put_into_collections {
+ my( $self, $conn, $auth, $user_id, $location, $fee_amount, $fee_note ) = @_;
+
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless ($auth and $user_id and $location);
+
+ my $e = new_editor(authtoken => $auth, xact =>1);
+ return $e->event unless $e->checkauth;
+
+ my $org = $e->search_actor_org_unit({shortname => $location});
+ return $e->event unless $org = $org->[0];
+ return $e->event unless $e->allowed('money.collections_tracker.create', $org->id);
+
+ my $existing = $e->search_money_collections_tracker(
+ {
+ location => $org->id,
+ usr => $user_id,
+ collector => $e->requestor->id
+ },
+ {idlist => 1}
+ );
+
+ return OpenILS::Event->new('MONEY_COLLECTIONS_TRACKER_EXISTS') if @$existing;
+
+ $logger->info("collect: user ".$e->requestor->id.
+ " putting user $user_id into collections for $location");
+
+ my $tracker = Fieldmapper::money::collections_tracker->new;
+
+ $tracker->usr($user_id);
+ $tracker->collector($e->requestor->id);
+ $tracker->location($org->id);
+ $tracker->enter_time('now');
+
+ $e->create_money_collections_tracker($tracker)
+ or return $e->event;
+
+ if( $fee_amount ) {
+ my $evt = add_collections_fee($e, $user_id, $org, $fee_amount, $fee_note );
+ return $evt if $evt;
+ }
+
+ $e->commit;
+
+ my $pen = Fieldmapper::actor::user_standing_penalty->new;
+ $pen->org_unit($org->id);
+ $pen->usr($user_id);
+ $pen->standing_penalty(30); # PATRON_IN_COLLECTIONS
+ $pen->staff($e->requestor->id);
+ $pen->note($fee_note) if $fee_note;
+ $U->simplereq('open-ils.actor', 'open-ils.actor.user.penalty.apply', $auth, $pen);
+
+ return OpenILS::Event->new('SUCCESS');
+}
+
+sub add_collections_fee {
+ my( $e, $patron_id, $org, $fee_amount, $fee_note ) = @_;
+
+ $fee_note ||= "";
+
+ $logger->info("collect: adding fee to user $patron_id : $fee_amount : $fee_note");
+
+ my $xact = Fieldmapper::money::grocery->new;
+ $xact->usr($patron_id);
+ $xact->xact_start('now');
+ $xact->billing_location($org->id);
+
+ $xact = $e->create_money_grocery($xact) or return $e->event;
+
+ my $bill = Fieldmapper::money::billing->new;
+ $bill->note($fee_note);
+ $bill->xact($xact->id);
+ $bill->btype(2);
+ $bill->billing_type(OILS_BILLING_TYPE_COLLECTION_FEE);
+ $bill->amount($fee_amount);
+
+ $e->create_money_billing($bill) or return $e->event;
+ return undef;
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => 'remove_from_collections',
+ api_name => 'open-ils.collections.remove_from_collections',
+ signature => q/
+ Returns the users that are currently in collections and
+ had activity during the provided interval. Dates are inclusive.
+ @param start_date The beginning of the activity interval
+ @param end_date The end of the activity interval
+ @param location The location at which the fines were created
+ /
+);
+
+
+__PACKAGE__->register_method(
+ method => 'remove_from_collections',
+ api_name => 'open-ils.collections.remove_from_collections',
+ api_level => 1,
+ argc => 3,
+ signature => {
+ desc => q/
+ Removes a user from the collections table for the given location
+ /,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'user_id',
+ desc => 'The id of the user to plact into collections',
+ type => 'number',
+ },
+
+ { name => 'location',
+ desc => q/The short-name of the orginization unit (library)
+ for which the user is being removed from collections/,
+ type => q'string',
+ },
+ ],
+
+ 'return' => {
+ desc => q/A SUCCESS event on success, error event on failure/,
+ type => 'object',
+ }
+ }
+);
+
+sub remove_from_collections {
+ my( $self, $conn, $auth, $user_id, $location ) = @_;
+
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless ($auth and $user_id and $location);
+
+ my $e = new_editor(authtoken => $auth, xact=>1);
+ return $e->event unless $e->checkauth;
+
+ my $org = $e->search_actor_org_unit({shortname => $location})
+ or return $e->event; $org = $org->[0];
+ return $e->event unless $e->allowed('money.collections_tracker.delete', $org->id);
+
+ my $tracker = $e->search_money_collections_tracker(
+ { usr => $user_id, location => $org->id })
+ or return $e->event;
+
+ $e->delete_money_collections_tracker($tracker->[0])
+ or return $e->event;
+
+ $e->commit;
+ return OpenILS::Event->new('SUCCESS');
+}
+
+
+#__PACKAGE__->register_method(
+# method => 'transaction_details',
+# api_name => 'open-ils.collections.user_transaction_details.retrieve',
+# signature => q/
+# /
+#);
+
+
+__PACKAGE__->register_method(
+ method => 'transaction_details',
+ api_name => 'open-ils.collections.user_transaction_details.retrieve',
+ api_level => 1,
+ argc => 5,
+ signature => {
+ desc => q/
+ Returns a list of fleshed user objects with transaction details
+ /,
+
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'start_date',
+ desc => 'The start of the time interval to check',
+ type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
+ },
+
+ { name => 'end_date',
+ desc => q/Then end date of the time interval to check/,
+ type => q/string (ISO 8601 timestamp. E.g. 2006-06-24, 1994-11-05T08:15:30-05:00 /,
+ },
+ { name => 'location',
+ desc => q/The short-name of the orginization unit (library) at which the activity occurred.
+ If a selected location has 'child' locations (e.g. a library region), the
+ child locations will be included in the search/,
+ type => q'string',
+ },
+ {
+ name => 'user_list',
+ desc => 'An array of user ids',
+ type => 'array',
+ },
+ ],
+
+ 'return' => {
+ desc => q/A list of objects. Object keys include:
+ usr :
+ transactions : An object with keys :
+ circulations : Fleshed circulation objects
+ grocery : Fleshed 'grocery' transaction objects
+ /,
+ type => 'object'
+ }
+ }
+);
+
+sub transaction_details {
+ my( $self, $conn, $auth, $start_date, $end_date, $location, $user_list ) = @_;
+
+ return OpenILS::Event->new('BAD_PARAMS')
+ unless ($auth and $start_date and $end_date and $location and $user_list);
+
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+
+ # they need global perms to view users so no org is provided
+ return $e->event unless $e->allowed('VIEW_USER');
+
+ my $org = $e->search_actor_org_unit({shortname => $location})
+ or return $e->event; $org = $org->[0];
+
+ # get a reference to the org inside of the tree
+ $org = $U->find_org($U->fetch_org_tree(), $org->id);
+
+ my @data;
+ for my $uid (@$user_list) {
+ my $blob = {};
+
+ $blob->{usr} = $e->retrieve_actor_user(
+ [
+ $uid,
+ {
+ "flesh" => 1,
+ "flesh_fields" => {
+ "au" => [
+ "cards",
+ "card",
+ "standing_penalties",
+ "addresses",
+ "billing_address",
+ "mailing_address",
+ "stat_cat_entries"
+ ]
+ }
+ }
+ ]
+ );
+
+ $blob->{transactions} = {
+ circulations =>
+ fetch_circ_xacts($e, $uid, $org, $start_date, $end_date),
+ grocery =>
+ fetch_grocery_xacts($e, $uid, $org, $start_date, $end_date),
+ reservations =>
+ fetch_reservation_xacts($e, $uid, $org, $start_date, $end_date)
+ };
+
+ # for each transaction, flesh the workstatoin on any attached payment
+ # and make the payment object a real object (e.g. cash payment),
+ # not just a generic payment object
+ for my $xact (
+ @{$blob->{transactions}->{circulations}},
+ @{$blob->{transactions}->{reservations}},
+ @{$blob->{transactions}->{grocery}} ) {
+
+ my $ps;
+ if( $ps = $xact->payments and @$ps ) {
+ my @fleshed; my $evt;
+ for my $p (@$ps) {
+ ($p, $evt) = flesh_payment($e,$p);
+ return $evt if $evt;
+ push(@fleshed, $p);
+ }
+ $xact->payments(\@fleshed);
+ }
+ }
+
+ push( @data, $blob );
+ }
+
+ return \@data;
+}
+
+sub flesh_payment {
+ my $e = shift;
+ my $p = shift;
+ my $type = $p->payment_type;
+ $logger->debug("collect: fleshing workstation on payment $type : ".$p->id);
+ my $meth = "retrieve_money_$type";
+ $p = $e->$meth($p->id) or return (undef, $e->event);
+ try {
+ $p->payment_type($type);
+ $p->cash_drawer(
+ $e->retrieve_actor_workstation(
+ [
+ $p->cash_drawer,
+ {
+ flesh => 1,
+ flesh_fields => { aws => [ 'owning_lib' ] }
+ }
+ ]
+ )
+ );
+ } catch Error with {};
+ return ($p);
+}
+
+
+# --------------------------------------------------------------
+# Collect all open circs for the user
+# For each circ, see if any billings or payments were created
+# during the given time period.
+# --------------------------------------------------------------
+sub fetch_circ_xacts {
+ my $e = shift;
+ my $uid = shift;
+ my $org = shift;
+ my $start_date = shift;
+ my $end_date = shift;
+
+ my @circs;
+
+ # at the specified org and each descendent org,
+ # fetch the open circs for this user
+ $U->walk_org_tree( $org,
+ sub {
+ my $n = shift;
+ $logger->debug("collect: searching for open circs at " . $n->shortname);
+ push( @circs,
+ @{
+ $e->search_action_circulation(
+ {
+ usr => $uid,
+ circ_lib => $n->id,
+ },
+ {idlist => 1}
+ )
+ }
+ );
+ }
+ );
+
+
+ my @data;
+ my $active_ids = fetch_active($e, \@circs, $start_date, $end_date);
+
+ for my $cid (@$active_ids) {
+ push( @data,
+ $e->retrieve_action_circulation(
+ [
+ $cid,
+ {
+ flesh => 1,
+ flesh_fields => {
+ circ => [ "billings", "payments", "circ_lib", 'target_copy' ]
+ }
+ }
+ ]
+ )
+ );
+ }
+
+ return \@data;
+}
+
+sub fetch_grocery_xacts {
+ my $e = shift;
+ my $uid = shift;
+ my $org = shift;
+ my $start_date = shift;
+ my $end_date = shift;
+
+ my @xacts;
+ $U->walk_org_tree( $org,
+ sub {
+ my $n = shift;
+ $logger->debug("collect: searching for open grocery xacts at " . $n->shortname);
+ push( @xacts,
+ @{
+ $e->search_money_grocery(
+ {
+ usr => $uid,
+ billing_location => $n->id,
+ },
+ {idlist => 1}
+ )
+ }
+ );
+ }
+ );
+
+ my @data;
+ my $active_ids = fetch_active($e, \@xacts, $start_date, $end_date);
+
+ for my $id (@$active_ids) {
+ push( @data,
+ $e->retrieve_money_grocery(
+ [
+ $id,
+ {
+ flesh => 1,
+ flesh_fields => {
+ mg => [ "billings", "payments", "billing_location" ] }
+ }
+ ]
+ )
+ );
+ }
+
+ return \@data;
+}
+
+sub fetch_reservation_xacts {
+ my $e = shift;
+ my $uid = shift;
+ my $org = shift;
+ my $start_date = shift;
+ my $end_date = shift;
+
+ my @xacts;
+ $U->walk_org_tree( $org,
+ sub {
+ my $n = shift;
+ $logger->debug("collect: searching for open grocery xacts at " . $n->shortname);
+ push( @xacts,
+ @{
+ $e->search_booking_reservation(
+ {
+ usr => $uid,
+ pickup_lib => $n->id,
+ },
+ {idlist => 1}
+ )
+ }
+ );
+ }
+ );
+
+ my @data;
+ my $active_ids = fetch_active($e, \@xacts, $start_date, $end_date);
+
+ for my $id (@$active_ids) {
+ push( @data,
+ $e->retrieve_booking_reservation(
+ [
+ $id,
+ {
+ flesh => 1,
+ flesh_fields => {
+ bresv => [ "billings", "payments", "pickup_lib" ] }
+ }
+ ]
+ )
+ );
+ }
+
+ return \@data;
+}
+
+
+
+# --------------------------------------------------------------
+# Given a list of xact id's, this returns a list of id's that
+# had any activity within the given time span
+# --------------------------------------------------------------
+sub fetch_active {
+ my( $e, $ids, $start_date, $end_date ) = @_;
+
+ # use this..
+ # { payment_ts => { between => [ $start, $end ] } } ' ;)
+
+ my @active;
+ for my $id (@$ids) {
+
+ # see if any billings were created in the given time range
+ my $bills = $e->search_money_billing (
+ {
+ xact => $id,
+ billing_ts => { between => [ $start_date, $end_date ] },
+ },
+ {idlist =>1}
+ );
+
+ my $payments = [];
+
+ if( !@$bills ) {
+
+ # see if any payments were created in the given range
+ $payments = $e->search_money_payment (
+ {
+ xact => $id,
+ payment_ts => { between => [ $start_date, $end_date ] },
+ },
+ {idlist =>1}
+ );
+ }
+
+
+ push( @active, $id ) if @$bills or @$payments;
+ }
+
+ return \@active;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'create_user_note',
+ api_name => 'open-ils.collections.patron_note.create',
+ api_level => 1,
+ argc => 4,
+ signature => {
+ desc => q/ Adds a note to a patron's account /,
+ params => [
+ { name => 'auth',
+ desc => 'The authentication token',
+ type => 'string' },
+
+ { name => 'user_barcode',
+ desc => q/The patron's barcode/,
+ type => q/string/,
+ },
+ { name => 'title',
+ desc => q/The title of the note/,
+ type => q/string/,
+ },
+
+ { name => 'note',
+ desc => q/The text of the note/,
+ type => q/string/,
+ },
+ ],
+
+ 'return' => {
+ desc => q/
+ Returns SUCCESS event on success, error event otherwise.
+ /,
+ type => 'object'
+ }
+ }
+);
+
+
+sub create_user_note {
+ my( $self, $conn, $auth, $user_barcode, $title, $note_txt ) = @_;
+
+ my $e = new_editor(authtoken=>$auth, xact=>1);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('UPDATE_USER'); # XXX Makre more specific perm for this
+
+ return $e->event unless
+ my $card = $e->search_actor_card({barcode=>$user_barcode})->[0];
+
+ my $note = Fieldmapper::actor::usr_note->new;
+ $note->usr($card->usr);
+ $note->title($title);
+ $note->creator($e->requestor->id);
+ $note->create_date('now');
+ $note->pub('f');
+ $note->value($note_txt);
+
+ $e->create_actor_usr_note($note) or return $e->event;
+ $e->commit;
+ return OpenILS::Event->new('SUCCESS');
+}
+
+
+
+1;
--- /dev/null
+# vim:et:ts=4:sw=4:
+
+package OpenILS::Application::Fielder;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+use Unicode::Normalize;
+use OpenSRF::EX qw/:try/;
+
+use OpenSRF::AppSession;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Cache;
+use OpenSRF::Utils::Logger qw/:level/;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::JSON;
+
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+
+use Digest::MD5 qw(md5_hex);
+
+use XML::LibXML;
+use XML::LibXML::XPathContext;
+use XML::LibXSLT;
+
+our %namespace_map = (
+ oils_persist=> {ns => 'http://open-ils.org/spec/opensrf/IDL/persistence/v1'},
+ oils_obj => {ns => 'http://open-ils.org/spec/opensrf/IDL/objects/v1'},
+ idl => {ns => 'http://opensrf.org/spec/IDL/base/v1'},
+ reporter => {ns => 'http://open-ils.org/spec/opensrf/IDL/reporter/v1'},
+ perm => {ns => 'http://open-ils.org/spec/opensrf/IDL/permacrud/v1'},
+);
+
+
+my $log = 'OpenSRF::Utils::Logger';
+
+my $cache;
+my $cache_timeout;
+my $parser = XML::LibXML->new();
+my $xslt = XML::LibXSLT->new();
+
+my $xpc = XML::LibXML::XPathContext->new();
+$xpc->registerNs($_, $namespace_map{$_}{ns}) for ( keys %namespace_map );
+
+my $idl;
+
+sub initialize {
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $idl_file = $conf->config_value( 'IDL' );
+
+ $idl = $parser->parse_file( $idl_file );
+
+ $log->debug( 'IDL XML file loaded' );
+
+ $cache_timeout = $conf->config_value(
+ "apps", "open-ils.fielder", "app_settings", "cache_timeout" ) || 300;
+
+ generate_methods();
+
+}
+sub child_init {
+ $cache = OpenSRF::Utils::Cache->new('global');
+}
+
+sub fielder_fetch {
+ my $self = shift;
+ my $client = shift;
+ my $obj = shift;
+
+ my $query = $obj->{query};
+ my $nocache = $obj->{cache} ? 0 : 1;
+ my $fields = $obj->{fields};
+ my $distinct = $obj->{distinct} ? 1 : 0;
+
+ return undef unless $query;
+
+ my $obj_class = $self->{class_hint};
+ my $fm_class = $self->{class_name};
+
+ if (!$fields) {
+ $fields = [ $fm_class->real_fields ];
+ }
+
+ $fields = [$fields] if (!ref($fields));
+
+ my $qstring = OpenSRF::Utils::JSON->perl2JSON( $query );
+ my $fstring = OpenSRF::Utils::JSON->perl2JSON( [ sort { $a cmp $b } @$fields ] );
+
+ $log->debug( 'Query Class: '. $obj_class );
+ $log->debug( 'Field list: '. $fstring );
+ $log->debug( 'Query: '. $qstring );
+
+ my ($key,$res);
+ unless ($nocache) {
+ $key = 'open-ils.fielder_' . md5_hex(
+ $self->api_name .
+ $qstring .
+ $fstring .
+ $distinct .
+ $obj_class
+ );
+
+ $res = $cache->get_cache( $key );
+
+ if ($res) {
+ $client->respond($_) for (@$res);
+ return undef;
+ }
+ }
+
+ $res = new_editor()->json_query({
+ select => { $obj_class => $fields },
+ from => $obj_class,
+ where => $query,
+ distinct=> $distinct
+ });
+
+ for my $value (@$res) {
+ $client->respond($value);
+ }
+
+ $client->respond_complete();
+
+ $cache->put_cache( $key => $res => $cache_timeout ) unless ($nocache);
+ return undef;
+}
+
+sub generate_methods {
+ try {
+ for my $class_node ( $xpc->findnodes( '//idl:class[@oils_persist:field_safe="true"]', $idl->documentElement ) ) {
+ my $hint = $class_node->getAttribute('id');
+ my $fm = $class_node->getAttributeNS('http://open-ils.org/spec/opensrf/IDL/objects/v1','fieldmapper');
+ $log->debug("Fielder class_node $hint");
+
+ __PACKAGE__->register_method(
+ method => 'fielder_fetch',
+ api_name => 'open-ils.fielder.' . $hint,
+ class_hint => $hint,
+ class_name => "Fieldmapper::$fm",
+ stream => 1,
+ argc => 1
+ );
+ }
+ } catch Error with {
+ my $e = shift;
+ $log->error("error generating Fielder methods: $e");
+ };
+}
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Ingest;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+use Unicode::Normalize;
+use OpenSRF::EX qw/:try/;
+
+use OpenSRF::AppSession;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/:level/;
+
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::ScriptRunner;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::JSON;
+
+use OpenILS::Utils::Fieldmapper;
+
+use XML::LibXML;
+use XML::LibXSLT;
+use Time::HiRes qw(time);
+
+our %supported_formats = (
+ mods33 => {ns => 'http://www.loc.gov/mods/v3'},
+ mods32 => {ns => 'http://www.loc.gov/mods/v3'},
+ mods3 => {ns => 'http://www.loc.gov/mods/v3'},
+ mods => {ns => 'http://www.loc.gov/mods/'},
+ marcxml => {ns => 'http://www.loc.gov/MARC21/slim'},
+ srw_dc => {ns => 'info:srw/schema/1/dc-schema'},
+ oai_dc => {ns => 'http://www.openarchives.org/OAI/2.0/oai_dc/'},
+ rdf_dc => {ns => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#'},
+ atom => {ns => 'http://www.w3.org/2005/Atom'},
+ rss091 => {ns => 'http://my.netscape.com/rdf/simple/0.9/'},
+ rss092 => {ns => ''},
+ rss093 => {ns => ''},
+ rss094 => {ns => ''},
+ rss10 => {ns => 'http://purl.org/rss/1.0/'},
+ rss11 => {ns => 'http://purl.org/net/rss1.1#'},
+ rss2 => {ns => ''},
+);
+
+
+my $log = 'OpenSRF::Utils::Logger';
+
+my $parser = XML::LibXML->new();
+my $xslt = XML::LibXSLT->new();
+
+my $mods_sheet;
+my $mads_sheet;
+my $xpathset = {};
+sub initialize {}
+sub child_init {}
+
+sub post_init {
+
+ unless (keys %$xpathset) {
+ $log->debug("Running post_init", DEBUG);
+
+ my $xsldir = OpenSRF::Utils::SettingsClient->new->config_value(dirs => 'xsl');
+
+ unless ($supported_formats{mods}{xslt}) {
+ $log->debug("Loading MODS XSLT", DEBUG);
+ my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS.xsl");
+ $supported_formats{mods}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
+ }
+
+ unless ($supported_formats{mods3}{xslt}) {
+ $log->debug("Loading MODS v3 XSLT", DEBUG);
+ my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS3.xsl");
+ $supported_formats{mods3}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
+ }
+
+ unless ($supported_formats{mods32}{xslt}) {
+ $log->debug("Loading MODS v32 XSLT", DEBUG);
+ my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS32.xsl");
+ $supported_formats{mods32}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
+ }
+
+ unless ($supported_formats{mods33}{xslt}) {
+ $log->debug("Loading MODS v33 XSLT", DEBUG);
+ my $xslt_doc = $parser->parse_file( $xsldir . "/MARC21slim2MODS33.xsl");
+ $supported_formats{mods33}{xslt} = $xslt->parse_stylesheet( $xslt_doc );
+ }
+
+ my $req = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+
+ # XXX testing new metabib field use for faceting
+ #->request( 'open-ils.cstore.direct.config.metabib_field.search.atomic', { id => { '!=' => undef } } )
+ ->request( 'open-ils.cstore.direct.config.metabib_field.search.atomic', { search_field => 't' } )
+
+ ->gather(1);
+
+ if (ref $req and @$req) {
+ for my $f (@$req) {
+ $xpathset->{ $f->field_class }->{ $f->name }->{xpath} = $f->xpath;
+ $xpathset->{ $f->field_class }->{ $f->name }->{id} = $f->id;
+ $xpathset->{ $f->field_class }->{ $f->name }->{format} = $f->format;
+ $log->debug("Loaded XPath from DB: ".$f->field_class." => ".$f->name." : ".$f->xpath, DEBUG);
+ }
+ }
+ }
+}
+
+# --------------------------------------------------------------------------------
+# Biblio ingest
+
+package OpenILS::Application::Ingest::Biblio;
+use base qw/OpenILS::Application::Ingest/;
+use Unicode::Normalize;
+
+sub rw_biblio_ingest_single_object {
+ my $self = shift;
+ my $client = shift;
+ my $bib = shift;
+
+ my ($blob) = $self->method_lookup("open-ils.ingest.full.biblio.object.readonly")->run($bib);
+ return undef unless ($blob);
+
+ $bib->fingerprint( $blob->{fingerprint}->{fingerprint} );
+ $bib->quality( $blob->{fingerprint}->{quality} );
+
+ my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
+
+ my $xact = $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
+ my $tmp;
+
+ # update uri stuff ...
+
+ # gather URI call numbers for this record
+ my $uri_cns = $u->{call_number} = $cstore->request(
+ 'open-ils.cstore.direct.asset.call_number.id_list.atomic' => { record => $bib->id, label => '##URI##' }
+ )->gather(1);
+
+ if (@$uri_cns) {
+ # gather the maps for those call numbers
+ my $uri_maps = $u->{call_number} = $cstore->request(
+ 'open-ils.cstore.direct.asset.uri_call_number_map.id_list.atomic' => { call_number => $uri_cns }
+ )->gather(1);
+
+ # delete the old maps
+ $cstore->request( 'open-ils.cstore.direct.asset.uri_call_number_map.delete' => $_ )->gather(1) for (@$uri_maps);
+
+ # and delete the call numbers if there are no more URIs
+ if (!@{ $blob->{uri} }) {
+ $cstore->request( 'open-ils.cstore.direct.asset.call_number.delete' => $_ )->gather(1) for (@$uri_cns);
+ }
+ }
+
+ # now, add CNs, URIs and maps
+ my %new_cns_by_owner;
+ my %new_uris_by_owner;
+ for my $u ( @{ $blob->{uri} } ) {
+
+ my $owner = $u->{call_number}->owning_lib;
+
+ if ($u->{call_number}->isnew) {
+ if ($new_cns_by_owner{$owner}) {
+ $u->{call_number} = $new_cns_by_owner{$owner};
+ } else {
+ $u->{call_number}->clear_id;
+ $u->{call_number} = $new_cns_by_owner{$owner} = $cstore->request(
+ 'open-ils.cstore.direct.asset.call_number.create' => $u->{call_number}
+ )->gather(1);
+ }
+ }
+
+ if ($u->{uri}->isnew) {
+ if ($new_uris_by_owner{$owner}) {
+ $u->{uri} = $new_uris_by_owner{$owner};
+ } else {
+ $u->{uri} = $new_uris_by_owner{$owner} = $cstore->request(
+ 'open-ils.cstore.direct.asset.uri.create' => $u->{uri}
+ )->gather(1);
+ }
+ }
+
+ # Check for an existing CN-URI map
+ $tmp = $cstore->request(
+ 'open-ils.cstore.direct.asset.uri_call_number_map.id_list',
+ { call_number => $u->{call_number}->id, uri => $u->{uri}->id }
+ )->gather(1);
+
+ next if ($tmp);
+
+ my $umap = Fieldmapper::asset::uri_call_number_map->new;
+ $umap->uri($u->{uri}->id);
+ $umap->call_number($u->{call_number}->id);
+
+ $cstore->request( 'open-ils.cstore.direct.asset.uri_call_number_map.create' => $umap )->gather(1);
+ }
+
+ # update full_rec stuff ...
+ $tmp = $cstore->request(
+ 'open-ils.cstore.direct.metabib.full_rec.id_list.atomic',
+ { record => $bib->id }
+ )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.direct.metabib.full_rec.delete' => $_ )->gather(1) for (@$tmp);
+ $cstore->request( 'open-ils.cstore.direct.metabib.full_rec.create' => $_ )->gather(1) for (@{ $blob->{full_rec} });
+
+ # update rec_descriptor stuff ...
+ $tmp = $cstore->request(
+ 'open-ils.cstore.direct.metabib.record_descriptor.id_list.atomic',
+ { record => $bib->id }
+ )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.direct.metabib.record_descriptor.delete' => $_ )->gather(1) for (@$tmp);
+ $cstore->request( 'open-ils.cstore.direct.metabib.record_descriptor.create' => $blob->{descriptor} )->gather(1);
+
+ # deal with classed fields...
+ for my $class ( qw/title author subject keyword series identifier/ ) {
+ $tmp = $cstore->request(
+ "open-ils.cstore.direct.metabib.${class}_field_entry.id_list.atomic",
+ { source => $bib->id }
+ )->gather(1);
+
+ $cstore->request( "open-ils.cstore.direct.metabib.${class}_field_entry.delete" => $_ )->gather(1) for (@$tmp);
+ }
+ for my $obj ( @{ $blob->{field_entries} } ) {
+ my $class = $obj->class_name;
+ $class =~ s/^Fieldmapper:://o;
+ $class =~ s/::/./go;
+ $cstore->request( "open-ils.cstore.direct.$class.create" => $obj )->gather(1);
+ }
+
+ # update MR map ...
+
+ $tmp = $cstore->request(
+ 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
+ { source => $bib->id }
+ )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.direct.metabib.metarecord_source_map.delete' => $_->id )->gather(1) for (@$tmp);
+
+ # get the old MRs
+ my $old_mrs = $cstore->request(
+ 'open-ils.cstore.direct.metabib.metarecord.search.atomic' => { id => [map { $_->metarecord } @$tmp] }
+ )->gather(1) if (@$tmp);
+
+ $old_mrs = [] if (!ref($old_mrs));
+
+ my $mr;
+ for my $m (@$old_mrs) {
+ if ($m->fingerprint eq $bib->fingerprint) {
+ $mr = $m;
+ } else {
+ my $others = $cstore->request(
+ 'open-ils.cstore.direct.metabib.metarecord_source_map.id_list.atomic' => { metarecord => $m->id }
+ )->gather(1);
+
+ if (!@$others) {
+ $cstore->request(
+ 'open-ils.cstore.direct.metabib.metarecord.delete' => $m->id
+ )->gather(1);
+ }
+
+ $m->isdeleted(1);
+ }
+ }
+
+ my $holds;
+ if (!$mr) {
+ # Get the matchin MR, if any.
+ $mr = $cstore->request(
+ 'open-ils.cstore.direct.metabib.metarecord.search',
+ { fingerprint => $bib->fingerprint }
+ )->gather(1);
+
+ $holds = $cstore->request(
+ 'open-ils.cstore.direct.action.hold_request.search.atomic',
+ { hold_type => 'M', target => [ map { $_->id } grep { $_->isdeleted } @$old_mrs ] }
+ )->gather(1) if (@$old_mrs);
+
+ if ($mr) {
+ for my $h (@$holds) {
+ $h->target($mr);
+ $cstore->request( 'open-ils.cstore.direct.action.hold_request.update' => $h )->gather(1);
+ $h->ischanged(1);
+ }
+ }
+ }
+
+ if (!$mr) {
+ $mr = new Fieldmapper::metabib::metarecord;
+ $mr->fingerprint( $bib->fingerprint );
+ $mr->master_record( $bib->id );
+ $mr->id(
+ $cstore->request(
+ "open-ils.cstore.direct.metabib.metarecord.create",
+ $mr => { quiet => 'true' }
+ )->gather(1)
+ );
+
+ for my $h (grep { !$_->ischanged } @$holds) {
+ $h->target($mr);
+ $cstore->request( 'open-ils.cstore.direct.action.hold_request.update' => $h )->gather(1);
+ }
+ } else {
+ my $mrm = $cstore->request(
+ 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
+ { metarecord => $mr->id }
+ )->gather(1);
+
+ if (@$mrm) {
+ my $best = $cstore->request(
+ "open-ils.cstore.direct.biblio.record_entry.search",
+ { id => [ map { $_->source } @$mrm ] },
+ { 'select' => { bre => [ qw/id quality/ ] },
+ order_by => { bre => "quality desc" },
+ limit => 1,
+ }
+ )->gather(1);
+
+ if ($best->quality > $bib->quality) {
+ $mr->master_record($best->id);
+ } else {
+ $mr->master_record($bib->id);
+ }
+ } else {
+ $mr->master_record($bib->id);
+ }
+
+ $mr->clear_mods;
+
+ $cstore->request( 'open-ils.cstore.direct.metabib.metarecord.update' => $mr )->gather(1);
+ }
+
+ my $mrm = new Fieldmapper::metabib::metarecord_source_map;
+ $mrm->source($bib->id);
+ $mrm->metarecord($mr->id);
+
+ $cstore->request( 'open-ils.cstore.direct.metabib.metarecord_source_map.create' => $mrm )->gather(1);
+ $cstore->request( 'open-ils.cstore.direct.biblio.record_entry.update' => $bib )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.json_query.atomic' => { from => [ 'reporter.simple_rec_update', $bib->id ] } )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.transaction.commit' )->gather(1) || return undef;;
+ $cstore->disconnect;
+
+ return $bib->id;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.object",
+ method => "rw_biblio_ingest_single_object",
+ api_level => 1,
+ argc => 1,
+);
+
+sub rw_biblio_ingest_single_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
+ $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
+
+ my $r = $cstore->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )->gather(1);
+
+ $cstore->request('open-ils.cstore.transaction.rollback')->gather(1);
+ $cstore->disconnect;
+
+ return undef unless ($r and @$r);
+
+ return ($self->method_lookup("open-ils.ingest.full.biblio.object")->run($r))[0];
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.record",
+ method => "rw_biblio_ingest_single_record",
+ api_level => 1,
+ argc => 1,
+);
+
+sub rw_biblio_ingest_record_list {
+ my $self = shift;
+ my $client = shift;
+ my @rec = ref($_[0]) ? @{ $_[0] } : @_ ;
+
+ OpenILS::Application::Ingest->post_init();
+ my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
+ $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
+
+ my $r = $cstore->request( 'open-ils.cstore.direct.biblio.record_entry.search.atomic' => { id => \@rec } )->gather(1);
+
+ $cstore->request('open-ils.cstore.transaction.rollback')->gather(1);
+ $cstore->disconnect;
+
+ return undef unless ($r and @$r);
+
+ my $count = 0;
+ for (@$r) {
+ if (($self->method_lookup("open-ils.ingest.full.biblio.object")->run($_))[0]) {
+ $count++
+ }
+ }
+ return $count;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.record_list",
+ method => "rw_biblio_ingest_record_list",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_biblio_ingest_single_object {
+ my $self = shift;
+ my $client = shift;
+ my $bib = shift;
+ my $xml = OpenILS::Application::AppUtils->entityize($bib->marc);
+ my $max_cn = shift;
+ my $max_uri = shift;
+
+ my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
+
+ if (!$max_cn) {
+ my $cn = $cstore->request( 'open-ils.cstore.direct.asset.call_number.search' => { id => { '!=' => undef } }, { limit => 1, order_by => { acn => 'id desc' } } )->gather(1);
+ $max_cn = int($cn->id) + 1000;
+ }
+
+ if (!$max_uri) {
+ my $cn = $cstore->request( 'open-ils.cstore.direct.asset.call_number.search' => { id => { '!=' => undef } }, { limit => 1, order_by => { acn => 'id desc' } } )->gather(1);
+ $max_uri = int($cn->id) + 1000;
+ }
+
+ $cstore->disconnect;
+
+ my $document = $parser->parse_string($xml);
+
+ my @uris = $self->method_lookup("open-ils.ingest.856_uri.object")->run($bib, $max_cn, $max_uri);
+ my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.biblio.xml")->run($document);
+ my @mXfe = $self->method_lookup("open-ils.ingest.extract.field_entry.all.xml")->run($document);
+ my ($fp) = $self->method_lookup("open-ils.ingest.fingerprint.xml")->run($xml);
+ my ($rd) = $self->method_lookup("open-ils.ingest.descriptor.xml")->run($xml);
+
+ $_->source($bib->id) for (@mXfe);
+ $_->record($bib->id) for (@mfr);
+ $rd->record($bib->id) if ($rd);
+
+ return { full_rec => \@mfr, field_entries => \@mXfe, fingerprint => $fp, descriptor => $rd, uri => \@uris };
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.object.readonly",
+ method => "ro_biblio_ingest_single_object",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_biblio_ingest_single_xml {
+ my $self = shift;
+ my $client = shift;
+ my $xml = OpenILS::Application::AppUtils->entityize(shift);
+
+ my $document = $parser->parse_string($xml);
+
+ my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.biblio.xml")->run($document);
+ my @mXfe = $self->method_lookup("open-ils.ingest.extract.field_entry.all.xml")->run($document);
+ my ($fp) = $self->method_lookup("open-ils.ingest.fingerprint.xml")->run($xml);
+ my ($rd) = $self->method_lookup("open-ils.ingest.descriptor.xml")->run($xml);
+
+ return { full_rec => \@mfr, field_entries => \@mXfe, fingerprint => $fp, descriptor => $rd };
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.xml.readonly",
+ method => "ro_biblio_ingest_single_xml",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_biblio_ingest_single_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )
+ ->gather(1);
+
+ return undef unless ($r and @$r);
+
+ my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.xml.readonly")->run($r->marc);
+
+ $_->source($rec) for (@{$res->{field_entries}});
+ $_->record($rec) for (@{$res->{full_rec}});
+ $res->{descriptor}->record($rec);
+
+ return $res;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.record.readonly",
+ method => "ro_biblio_ingest_single_record",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_biblio_ingest_stream_record {
+ my $self = shift;
+ my $client = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
+
+ my $rec = $resp->content;
+ last unless (defined $rec);
+
+ $log->debug("Running open-ils.ingest.full.biblio.record.readonly ...");
+ my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.record.readonly")->run($rec);
+
+ $_->source($rec) for (@{$res->{field_entries}});
+ $_->record($rec) for (@{$res->{full_rec}});
+
+ $client->respond( $res );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.record_stream.readonly",
+ method => "ro_biblio_ingest_stream_record",
+ api_level => 1,
+ stream => 1,
+);
+
+sub ro_biblio_ingest_stream_xml {
+ my $self = shift;
+ my $client = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
+
+ my $xml = $resp->content;
+ last unless (defined $xml);
+
+ $log->debug("Running open-ils.ingest.full.biblio.xml.readonly ...");
+ my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.xml.readonly")->run($xml);
+
+ $client->respond( $res );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.xml_stream.readonly",
+ method => "ro_biblio_ingest_stream_xml",
+ api_level => 1,
+ stream => 1,
+);
+
+sub rw_biblio_ingest_stream_import {
+ my $self = shift;
+ my $client = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
+
+ my $bib = $resp->content;
+ last unless (defined $bib);
+
+ $log->debug("Running open-ils.ingest.full.biblio.xml.readonly ...");
+ my ($res) = $self->method_lookup("open-ils.ingest.full.biblio.xml.readonly")->run($bib->marc);
+
+ $_->source($bib->id) for (@{$res->{field_entries}});
+ $_->record($bib->id) for (@{$res->{full_rec}});
+
+ $client->respond( $res );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.biblio.bib_stream.import",
+ method => "rw_biblio_ingest_stream_import",
+ api_level => 1,
+ stream => 1,
+);
+
+
+# --------------------------------------------------------------------------------
+# Authority ingest
+
+package OpenILS::Application::Ingest::Authority;
+use base qw/OpenILS::Application::Ingest/;
+use Unicode::Normalize;
+
+sub rw_authority_ingest_single_object {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+
+ my ($blob) = $self->method_lookup("open-ils.ingest.full.authority.object.readonly")->run($auth);
+ return undef unless ($blob);
+
+ my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
+
+ my $xact = $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
+ my $tmp;
+
+ # update full_rec stuff ...
+ $tmp = $cstore->request(
+ 'open-ils.cstore.direct.authority.full_rec.id_list.atomic',
+ { record => $auth->id }
+ )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.direct.authority.full_rec.delete' => $_ )->gather(1) for (@$tmp);
+ $cstore->request( 'open-ils.cstore.direct.authority.full_rec.create' => $_ )->gather(1) for (@{ $blob->{full_rec} });
+
+ # XXX when we start extracting authority descriptors and adding sources ...
+ #
+ # update rec_descriptor stuff ...
+ #$tmp = $cstore->request(
+ # 'open-ils.cstore.direct.authority.record_descriptor.id_list.atomic',
+ # { record => $auth->id }
+ #)->gather(1);
+ #
+ #$cstore->request( 'open-ils.cstore.direct.authority.record_descriptor.delete' => $_ )->gather(1) for (@$tmp);
+ #$cstore->request( 'open-ils.cstore.direct.authority.record_descriptor.create' => $blob->{descriptor} )->gather(1);
+ #$cstore->request( 'open-ils.cstore.direct.authority.record_entry.update' => $auth )->gather(1);
+
+ $cstore->request( 'open-ils.cstore.transaction.commit' )->gather(1) || return undef;;
+ $cstore->disconnect;
+
+ return $auth->id;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.object",
+ method => "rw_authority_ingest_single_object",
+ api_level => 1,
+ argc => 1,
+);
+
+sub rw_authority_ingest_single_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $cstore = OpenSRF::AppSession->connect( 'open-ils.cstore' );
+ $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
+
+ my $r = $cstore->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rec )->gather(1);
+
+ $cstore->request('open-ils.cstore.transaction.rollback')->gather(1);
+ $cstore->disconnect;
+
+ return undef unless ($r and @$r);
+
+ return ($self->method_lookup("open-ils.ingest.full.authority.object")->run($r))[0];
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.record",
+ method => "rw_authority_ingest_single_record",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_authority_ingest_single_object {
+ my $self = shift;
+ my $client = shift;
+ my $bib = shift;
+ my $xml = OpenILS::Application::AppUtils->entityize($bib->marc);
+
+ my $document = $parser->parse_string($xml);
+
+ my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.authority.xml")->run($document);
+
+ $_->record($bib->id) for (@mfr);
+
+ return { full_rec => \@mfr };
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.object.readonly",
+ method => "ro_authority_ingest_single_object",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_authority_ingest_single_xml {
+ my $self = shift;
+ my $client = shift;
+ my $xml = OpenILS::Application::AppUtils->entityize(shift);
+
+ my $document = $parser->parse_string($xml);
+
+ my @mfr = $self->method_lookup("open-ils.ingest.flat_marc.authority.xml")->run($document);
+
+ return { full_rec => \@mfr };
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.xml.readonly",
+ method => "ro_authority_ingest_single_xml",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_authority_ingest_single_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rec )
+ ->gather(1);
+
+ return undef unless ($r and @$r);
+
+ my ($res) = $self->method_lookup("open-ils.ingest.full.authority.xml.readonly")->run($r->marc);
+
+ $_->record($rec) for (@{$res->{full_rec}});
+ $res->{descriptor}->record($rec);
+
+ return $res;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.record.readonly",
+ method => "ro_authority_ingest_single_record",
+ api_level => 1,
+ argc => 1,
+);
+
+sub ro_authority_ingest_stream_record {
+ my $self = shift;
+ my $client = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
+
+ my $rec = $resp->content;
+ last unless (defined $rec);
+
+ $log->debug("Running open-ils.ingest.full.authority.record.readonly ...");
+ my ($res) = $self->method_lookup("open-ils.ingest.full.authority.record.readonly")->run($rec);
+
+ $_->record($rec) for (@{$res->{full_rec}});
+
+ $client->respond( $res );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.record_stream.readonly",
+ method => "ro_authority_ingest_stream_record",
+ api_level => 1,
+ stream => 1,
+);
+
+sub ro_authority_ingest_stream_xml {
+ my $self = shift;
+ my $client = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
+
+ my $xml = $resp->content;
+ last unless (defined $xml);
+
+ $log->debug("Running open-ils.ingest.full.authority.xml.readonly ...");
+ my ($res) = $self->method_lookup("open-ils.ingest.full.authority.xml.readonly")->run($xml);
+
+ $client->respond( $res );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.xml_stream.readonly",
+ method => "ro_authority_ingest_stream_xml",
+ api_level => 1,
+ stream => 1,
+);
+
+sub rw_authority_ingest_stream_import {
+ my $self = shift;
+ my $client = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ while (my ($resp) = $client->recv( count => 1, timeout => 5 )) {
+
+ my $bib = $resp->content;
+ last unless (defined $bib);
+
+ $log->debug("Running open-ils.ingest.full.authority.xml.readonly ...");
+ my ($res) = $self->method_lookup("open-ils.ingest.full.authority.xml.readonly")->run($bib->marc);
+
+ $_->record($bib->id) for (@{$res->{full_rec}});
+
+ $client->respond( $res );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.full.authority.bib_stream.import",
+ method => "rw_authority_ingest_stream_import",
+ api_level => 1,
+ stream => 1,
+);
+
+# --------------------------------------------------------------------------------
+# MARC index extraction
+
+package OpenILS::Application::Ingest::XPATH;
+use base qw/OpenILS::Application::Ingest/;
+use Unicode::Normalize;
+
+# give this an XML documentElement and an XPATH expression
+sub xpath_to_string {
+ my $xml = shift;
+ my $xpath = shift;
+ my $ns_uri = shift;
+ my $ns_prefix = shift;
+ my $unique = shift;
+
+ $xml->setNamespace( $ns_uri, $ns_prefix, 1 ) if ($ns_uri && $ns_prefix);
+
+ my $string = "";
+
+ # grab the set of matching nodes
+ my @nodes = $xml->findnodes( $xpath );
+ for my $value (@nodes) {
+
+ # grab all children of the node
+ my @children = $value->childNodes();
+ for my $child (@children) {
+
+ # add the childs content to the growing buffer
+ my $content = quotemeta($child->textContent);
+ next if ($unique && $string =~ /$content/); # uniquify the values
+ $string .= $child->textContent . " ";
+ }
+ if( ! @children ) {
+ $string .= $value->textContent . " ";
+ }
+ }
+
+ $string =~ s/(\w+)\/(\w+)/$1 $2/sgo;
+ # Split date ranges and ISSNs on the hyphen
+ $string =~ s/(\d{4})-(\d{3,4}x?)/ $1 $2 /goi;
+
+ return NFD($string);
+}
+
+sub class_index_string_xml {
+ my $self = shift;
+ my $client = shift;
+ my $xml = shift;
+ my @classes = @_;
+
+ OpenILS::Application::Ingest->post_init();
+ $xml = $parser->parse_string(OpenILS::Application::AppUtils->entityize($xml)) unless (ref $xml);
+
+ my %transform_cache;
+
+ for my $class (@classes) {
+ my $class_constructor = "Fieldmapper::metabib::${class}_field_entry";
+ for my $type ( keys %{ $xpathset->{$class} } ) {
+
+ my $def = $xpathset->{$class}->{$type};
+ my $sf = $OpenILS::Application::Ingest::supported_formats{$def->{format}};
+
+ my $document = $xml;
+
+ if ($sf->{xslt}) {
+ $document = $transform_cache{$def->{format}} || $sf->{xslt}->transform($xml);
+ $transform_cache{$def->{format}} = $document;
+ }
+
+ my $value = xpath_to_string(
+ $document->documentElement => $def->{xpath},
+ $sf->{ns} => $def->{format},
+ 1
+ );
+
+ next unless $value;
+
+ $value = NFD($value);
+ $value =~ s/\pM+//sgo;
+ $value =~ s/\pC+//sgo;
+ $value =~ s/\W+$//sgo;
+
+ # hack to normalize ratio-like strings
+ while ($term =~ /\b\d{1}:[, ]?\d+(?:[ ,]\d+[^:])+/o) {
+ $term = $` . join ('', split(/[, ]/, $&)) . $';
+ }
+
+ $value =~ s/\b\.+\b//sgo;
+ $value = lc($value);
+
+ my $fm = $class_constructor->new;
+ $fm->value( $value );
+ $fm->field( $xpathset->{$class}->{$type}->{id} );
+ $client->respond($fm);
+ }
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.field_entry.class.xml",
+ method => "class_index_string_xml",
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+);
+
+sub class_index_string_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+ my @classes = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rec )
+ ->gather(1);
+
+ return undef unless ($r and @$r);
+
+ for my $fm ($self->method_lookup("open-ils.ingest.field_entry.class.xml")->run($r->marc, @classes)) {
+ $fm->source($rec);
+ $client->respond($fm);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.field_entry.class.record",
+ method => "class_index_string_record",
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+);
+
+sub all_index_string_xml {
+ my $self = shift;
+ my $client = shift;
+ my $xml = shift;
+
+ for my $fm ($self->method_lookup("open-ils.ingest.field_entry.class.xml")->run($xml, keys(%$xpathset))) {
+ $client->respond($fm);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.extract.field_entry.all.xml",
+ method => "all_index_string_xml",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+sub all_index_string_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )
+ ->gather(1);
+
+ return undef unless ($r and @$r);
+
+ for my $fm ($self->method_lookup("open-ils.ingest.field_entry.class.xml")->run($r->marc, keys(%$xpathset))) {
+ $fm->source($rec);
+ $client->respond($fm);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.extract.field_entry.all.record",
+ method => "all_index_string_record",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+# --------------------------------------------------------------------------------
+# Flat MARC
+
+package OpenILS::Application::Ingest::FlatMARC;
+use base qw/OpenILS::Application::Ingest/;
+use Unicode::Normalize;
+
+
+sub _marcxml_to_full_rows {
+
+ my $marcxml = shift;
+ my $xmltype = shift || 'metabib';
+
+ my $type = "Fieldmapper::${xmltype}::full_rec";
+
+ my @ns_list;
+
+ my ($root) = $marcxml->findnodes('//*[local-name()="record"]');
+
+ for my $tagline ( @{$root->getChildrenByTagName("leader")} ) {
+ next unless $tagline;
+ _special_tag_to_full_rows($type, $tagline, \@ns_list, 'LDR');
+ }
+
+ for my $tagline ( @{$root->getChildrenByTagName("controlfield")} ) {
+ next unless $tagline;
+ _special_tag_to_full_rows($type, $tagline, \@ns_list, $tagline->getAttribute( "tag" ));
+ }
+
+ for my $tagline ( @{$root->getChildrenByTagName("datafield")} ) {
+ next unless $tagline;
+ _data_tag_to_full_rows($type, $tagline, \@ns_list, $tagline->getAttribute( "tag" ));
+
+ if ($xmltype eq 'metabib' and $tag eq '245') {
+ _data_tag_to_full_rows($type, $tagline, \@ns_list, 'tnf');
+ }
+ }
+
+ $log->debug("Returning ".scalar(@ns_list)." Fieldmapper nodes from $xmltype xml");
+ return @ns_list;
+}
+
+=head2 _special_tag_to_full_rows
+
+Converts a leader or control field to a set of normalized values
+
+=cut
+
+sub _special_tag_to_full_rows {
+ my $type = shift;
+ my $tagline = shift;
+ my $ns_list = shift;
+ my $tagname = shift;
+
+ my $ns = $type->new;
+
+ $ns->tag( $tagname );
+ my $val = $tagline->textContent;
+ $val = NFD($val);
+ $val =~ s/\pM+//sgo;
+ $val =~ s/\pC+//sgo;
+ $val =~ s/\W+$//sgo;
+ $ns->value( $val );
+
+ push @$ns_list, $ns;
+}
+
+=head2 _data_tag_to_full_rows
+
+Converts a data field to a set of normalized values
+
+=cut
+
+sub _data_tag_to_full_rows {
+ my $type = shift;
+ my $tagline = shift;
+ my $ns_list = shift;
+ my $tag = shift;
+
+ my $ind1 = $tagline->getAttribute( "ind1" );
+ my $ind2 = $tagline->getAttribute( "ind2" );
+
+ for my $data ( @{$tagline->getChildrenByTagName('subfield')} ) {
+ next unless $data;
+
+ my $ns = $type->new;
+
+ $ns->tag( $tag );
+ $ns->ind1( $ind1 );
+ $ns->ind2( $ind2 );
+ $ns->subfield( $data->getAttribute( "code" ) );
+ my $val = $data->textContent;
+ $val = NFD($val);
+ $val =~ s/\pM+//sgo;
+ $val =~ s/\pC+//sgo;
+ $val =~ s/\W+$//sgo;
+ # Split date ranges and ISSNs on the hyphen
+ $val =~ s/(\d{4})-(\d{3,4}x?)/ $1 $2 /goi;
+ $val =~ s/(\w+)\/(\w+)/$1 $2/sgo;
+ $ns->value( lc($val) );
+
+ push @$ns_list, $ns;
+ }
+}
+
+sub flat_marc_xml {
+ my $self = shift;
+ my $client = shift;
+ my $xml = shift;
+
+ $log->debug("processing [$xml]");
+
+ $xml = $parser->parse_string(OpenILS::Application::AppUtils->entityize($xml)) unless (ref $xml);
+
+ my $type = 'metabib';
+ $type = 'authority' if ($self->api_name =~ /authority/o);
+
+ OpenILS::Application::Ingest->post_init();
+
+ $client->respond($_) for (_marcxml_to_full_rows($xml, $type));
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.flat_marc.authority.xml",
+ method => "flat_marc_xml",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.flat_marc.biblio.xml",
+ method => "flat_marc_xml",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+sub flat_marc_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ my $type = 'biblio';
+ $type = 'authority' if ($self->api_name =~ /authority/o);
+
+ OpenILS::Application::Ingest->post_init();
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( "open-ils.cstore.direct.${type}.record_entry.retrieve" => $rec )
+ ->gather(1);
+
+
+ return undef unless ($r and $r->marc);
+
+ my @rows = $self->method_lookup("open-ils.ingest.flat_marc.$type.xml")->run($r->marc);
+ for my $row (@rows) {
+ $client->respond($row);
+ $log->debug(OpenSRF::Utils::JSON->perl2JSON($row), DEBUG);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.flat_marc.biblio.record_entry",
+ method => "flat_marc_record",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.flat_marc.authority.record_entry",
+ method => "flat_marc_record",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+# --------------------------------------------------------------------------------
+# URI extraction
+
+package OpenILS::Application::Ingest::Biblio::URI;
+use base qw/OpenILS::Application::Ingest/;
+use Unicode::Normalize;
+use OpenSRF::EX qw/:try/;
+
+
+sub _extract_856_uris {
+
+ my $rec = shift;
+ my $max_cn = shift;
+ my $max_uri = shift;
+ my @objects;
+
+ my $recid = $rec->id;
+ my $marcxml = $rec->marc;
+
+ my $document = $parser->parse_string($marcxml);
+ my @nodes = $document->findnodes('//*[local-name()="datafield" and @tag="856" and (@ind1="4" or @ind1="1") and (@ind2="0" or @ind2="1")]');
+
+ my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
+
+ my %cn_cache;
+
+ for my $node (@nodes) {
+ # first, is there a URI?
+ my $href = $node->findvalue('*[local-name()="subfield" and @code="u"]/text()');
+ next unless ($href);
+
+ # now, find the best possible label
+ my $label = $node->findvalue('*[local-name()="subfield" and @code="y"]/text()');
+ $label ||= $node->findvalue('*[local-name()="subfield" and @code="3"]/text()');
+ $label ||= $href;
+
+ # look for use info
+ my $use = $node->findvalue('*[local-name()="subfield" and @code="z"]/text()');
+ $use ||= $node->findvalue('*[local-name()="subfield" and @code="2"]/text()');
+ $use ||= $node->findvalue('*[local-name()="subfield" and @code="n"]/text()');
+
+ # moving on to the URI owner
+ my $owner = $node->findvalue('*[local-name()="subfield" and @code="9"]/text()'); # Evergreen special sauce
+ $owner ||= $node->findvalue('*[local-name()="subfield" and @code="w"]/text()');
+ $owner ||= $node->findvalue('*[local-name()="subfield" and @code="n"]/text()');
+
+ $owner =~ s/^.*?\((\w+)\).*$/$1/o; # unwrap first paren-enclosed string and then ...
+
+ # no owner? skip it :(
+ next unless ($owner);
+
+ my $org = $cstore
+ ->request( 'open-ils.cstore.direct.actor.org_unit.search' => { shortname => $owner} )
+ ->gather(1);
+
+ next unless ($org);
+
+ # now we can construct the uri object
+ my $uri = $cstore
+ ->request( 'open-ils.cstore.direct.asset.uri.search' => { label => $label, href => $href, use_restriction => $use, active => 't' } )
+ ->gather(1);
+
+ if (!$uri) {
+ $uri = Fieldmapper::asset::uri->new;
+ $uri->isnew( 1 );
+ $uri->id( $$max_uri++ );
+ $uri->label($label);
+ $uri->href($href);
+ $uri->active('t');
+ $uri->use_restriction($use);
+ }
+
+ # see if we need to create a call number
+ my $cn = $cn_cache{$org->id};
+ $cn = $cn->clone if ($cn);
+ $cn->clear_isnew if ($cn);
+
+ $cn ||= $cstore
+ ->request( 'open-ils.cstore.direct.asset.call_number.search' => { owning_lib => $org->id, record => $recid, label => '##URI##' } )
+ ->gather(1);
+
+ if (!$cn) {
+ $cn = Fieldmapper::asset::call_number->new;
+ $cn->isnew( 1 );
+ $cn->deleted('f');
+ $cn->id( $$max_cn++ );
+ $cn->owning_lib( $org->id );
+ $cn->record( $recid );
+ $cn->create_date( 'now' );
+ $cn->creator( $rec->creator );
+ $cn->editor( $rec->editor );
+ $cn->edit_date( 'now' );
+ $cn->label( '##URI##' );
+ }
+
+ $cn_cache{$org->id} = $cn;
+
+ push @objects, { uri => $uri, call_number => $cn };
+ }
+
+ $log->debug("Returning ".scalar(@objects)." URI nodes for record $recid");
+ $cstore->disconnect;
+ return @objects;
+}
+
+sub get_uris_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( "open-ils.cstore.direct.biblio.record_entry.retrieve" => $rec )
+ ->gather(1);
+
+ return undef unless ($r and $r->marc);
+
+ $client->respond($_) for (_extract_856_uris($r));
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.856_uri.record",
+ method => "get_uris_record",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+sub get_uris_object {
+ my $self = shift;
+ my $client = shift;
+ my $obj = shift;
+ my $max_cn = shift;
+ my $max_uri = shift;
+
+ return undef unless ($obj and $obj->marc);
+
+ $client->respond($_) for (_extract_856_uris($obj, \$max_cn, \$max_uri));
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.856_uri.object",
+ method => "get_uris_object",
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+
+# --------------------------------------------------------------------------------
+# Fingerprinting
+
+package OpenILS::Application::Ingest::Biblio::Fingerprint;
+use base qw/OpenILS::Application::Ingest/;
+use Unicode::Normalize;
+use OpenSRF::EX qw/:try/;
+
+sub biblio_fingerprint_record {
+ my $self = shift;
+ my $client = shift;
+ my $rec = shift;
+
+ OpenILS::Application::Ingest->post_init();
+
+ my $r = OpenSRF::AppSession
+ ->create('open-ils.cstore')
+ ->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rec )
+ ->gather(1);
+
+ return undef unless ($r and $r->marc);
+
+ my ($fp) = $self->method_lookup('open-ils.ingest.fingerprint.xml')->run($r->marc);
+ $log->debug("Returning [$fp] as fingerprint for record $rec", INFO);
+ $fp->{quality} = int($fp->{quality});
+ return $fp;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.fingerprint.record",
+ method => "biblio_fingerprint_record",
+ api_level => 1,
+ argc => 1,
+);
+
+our $fp_script;
+sub biblio_fingerprint {
+ my $self = shift;
+ my $client = shift;
+ my $xml = OpenILS::Application::AppUtils->entityize(shift);
+
+ $log->internal("Got MARC [$xml]");
+
+ if(!$fp_script) {
+ my @pfx = ( "apps", "open-ils.ingest","app_settings" );
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+
+ my $libs = $conf->config_value(@pfx, 'script_path');
+ my $script_file = $conf->config_value(@pfx, 'scripts', 'biblio_fingerprint');
+ my $script_libs = (ref($libs)) ? $libs : [$libs];
+
+ $log->debug("Loading script $script_file for biblio fingerprinting...");
+
+ $fp_script = new OpenILS::Utils::ScriptRunner
+ ( file => $script_file,
+ paths => $script_libs,
+ reset_count => 100 );
+ }
+
+ $fp_script->insert('environment' => {marc => $xml} => 1);
+
+ my $res = $fp_script->run || ($log->error( "Fingerprint script died! $@" ) && return undef);
+ $log->debug("Script for biblio fingerprinting completed successfully...");
+
+ return $res;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.fingerprint.xml",
+ method => "biblio_fingerprint",
+ api_level => 1,
+ argc => 1,
+);
+
+our $rd_script;
+sub biblio_descriptor {
+ my $self = shift;
+ my $client = shift;
+ my $xml = OpenILS::Application::AppUtils->entityize(shift);
+
+ $log->internal("Got MARC [$xml]");
+
+ if(!$rd_script) {
+ my @pfx = ( "apps", "open-ils.ingest","app_settings" );
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+
+ my $libs = $conf->config_value(@pfx, 'script_path');
+ my $script_file = $conf->config_value(@pfx, 'scripts', 'biblio_descriptor');
+ my $script_libs = (ref($libs)) ? $libs : [$libs];
+
+ $log->debug("Loading script $script_file for biblio descriptor extraction...");
+
+ $rd_script = new OpenILS::Utils::ScriptRunner
+ ( file => $script_file,
+ paths => $script_libs,
+ reset_count => 100 );
+ }
+
+ $log->debug("Setting up environment for descriptor extraction script...");
+ $rd_script->insert('environment.marc' => $xml => 1);
+ $log->debug("Environment building complete...");
+
+ my $res = $rd_script->run || ($log->error( "Descriptor script died! $@" ) && return undef);
+ $log->debug("Script for biblio descriptor extraction completed successfully");
+
+ my $d1 = $res->date1;
+ if ($d1 && $d1 ne ' ') {
+ $d1 =~ tr/ux/00/;
+ $res->date1( $d1 );
+ }
+
+ my $d2 = $res->date2;
+ if ($d2 && $d2 ne ' ') {
+ $d2 =~ tr/ux/99/;
+ $res->date2( $d2 );
+ }
+
+ return $res;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.ingest.descriptor.xml",
+ method => "biblio_descriptor",
+ api_level => 1,
+ argc => 1,
+);
+
+
+1;
+
+# vim:et:ts=4:sw=4:
--- /dev/null
+package OpenILS::Application::Penalty;
+use strict; use warnings;
+use OpenSRF::EX qw(:try);
+use OpenILS::Application;
+use OpenILS::Utils::Penalty;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use base 'OpenILS::Application';
+
+__PACKAGE__->register_method (
+ method => 'patron_penalty',
+ api_name => 'open-ils.penalty.patron_penalty.calculate',
+ signature => q/
+ Calculates the patron's standing penalties
+ @param args An object of named params including:
+ patronid The id of the patron
+ update True if this call should update the database
+ background True if this call should return immediately,
+ then go on to process the penalties. This flag
+ works only in conjunction with the 'update' flag.
+ @return An object with keys 'fatal_penalties' and
+ 'info_penalties' who are themeselves arrays of 0 or
+ more penalties. Returns event on error.
+ /
+);
+
+# --------------------------------------------------------------
+# if $args->{background} is true, immediately respond complete
+# to the caller, then finish the calculation
+# --------------------------------------------------------------
+sub patron_penalty {
+ my( $self, $conn, $args ) = @_;
+ $conn->respond_complete(1) if $$args{background};
+ my $e = new_editor(xact => 1);
+ OpenILS::Utils::Penalty->calculate_penalties($e, $args->{patronid}, $args->{context_org});
+ my $p = OpenILS::Utils::Penalty->retrieve_penalties($e, $args->{patronid}, $args->{context_org});
+ $e->commit;
+ return $p
+}
+
+
+1;
--- /dev/null
+# vim:et:ts=4:sw=4:
+
+package OpenILS::Application::PermaCrud;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use Unicode::Normalize;
+use OpenSRF::EX qw/:try/;
+
+use OpenSRF::AppSession;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/:level/;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::JSON;
+
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+
+use XML::LibXML;
+use XML::LibXML::XPathContext;
+use XML::LibXSLT;
+use OpenILS::Event;
+
+our %namespace_map = (
+ oils_persist=> {ns => 'http://open-ils.org/spec/opensrf/IDL/persistence/v1'},
+ oils_obj => {ns => 'http://open-ils.org/spec/opensrf/IDL/objects/v1'},
+ idl => {ns => 'http://opensrf.org/spec/IDL/base/v1'},
+ reporter => {ns => 'http://open-ils.org/spec/opensrf/IDL/reporter/v1'},
+ perm => {ns => 'http://open-ils.org/spec/opensrf/IDL/permacrud/v1'},
+);
+
+
+my $log = 'OpenSRF::Utils::Logger';
+
+my $parser = XML::LibXML->new();
+my $xslt = XML::LibXSLT->new();
+
+my $xpc = XML::LibXML::XPathContext->new();
+$xpc->registerNs($_, $namespace_map{$_}{ns}) for ( keys %namespace_map );
+
+my $idl;
+
+sub initialize {
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $idl_file = $conf->config_value( 'IDL' );
+
+ $idl = $parser->parse_file( $idl_file );
+
+ $log->debug( 'IDL XML file loaded' );
+
+ generate_methods();
+
+}
+sub child_init {}
+
+sub CRUD_action_object_permcheck {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $obj = shift;
+
+ my $e = shift || new_editor(authtoken => $auth, xact => 1);
+ return $e->event unless $e->checkauth;
+
+ if (ref($obj) && $obj->json_hint ne $self->{class_hint}) {
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Class missmatch: $self->{class_hint} method called with " . $obj->json_hint,
+ );
+ }
+
+ my $class_node;
+ my $error = '';
+ try {
+ ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
+ } catch Error with {
+ $error = shift;
+ $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
+ );
+ };
+
+ if (!$class_node) {
+ $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
+ );
+ }
+
+ my $action_node;
+ try {
+ ($action_node) = $xpc->findnodes( "perm:permacrud/perm:actions/perm:$self->{action}", $class_node );
+ } catch Error with {
+ $error = shift;
+ $log->error("Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]");
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]"
+ );
+ };
+
+ if (!$action_node) {
+ $log->error("Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]");
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Error finding action node: $error [perm:permacrud/perm:actions/perm:$self->{action}]"
+ );
+ }
+
+ my $all_perms = $action_node->getAttribute( 'all_perms' );
+
+ my $fm_class = $xpc->findvalue( '@oils_obj:fieldmapper', $class_node );
+ if (!ref($obj)) {
+ my $retrieve_method = 'retrieve_' . $fm_class;
+ $retrieve_method =~ s/::/_/go;
+ $obj = $e->$retrieve_method( $obj ) or return $e->die_event;
+ }
+
+ (my $o_type = $fm_class) =~ s/::/./go;
+
+ my $perm_field_value = $action_node->getAttribute('permission');
+
+ if ($perm_field_value) {
+ my @perms = split ' ', $perm_field_value;
+
+ my @context_ous;
+ if ($action_node->getAttribute('global_required')) {
+ push @context_ous, $e->search_actor_org_unit( { parent_ou => undef } )->[0]->id;
+
+ } else {
+ my $context_field_value = $action_node->getAttribute('context_field');
+
+ if ($context_field_value) {
+ push @context_ous, $obj->$_ for ( split ' ', $context_field_value );
+ } else {
+ for my $context_node ( $xpc->findnodes( "perm:context", $action_node ) ) {
+ my $context_field = $context_node->getAttribute('field');
+ my $link_field = $context_node->getAttribute('link');
+
+ if ($link_field) {
+
+ my ($link_node) = $xpc->findnodes( "idl:links/idl:link[\@field='$link_field']", $class_node );
+ my $link_class_hint = $link_node->getAttribute('class');
+ my $remote_field = $link_node->getAttribute('key');
+
+ my ($remote_class_node) = $xpc->findnodes( "//idl:class[\@id='$link_class_hint']", $idl->documentElement );
+ my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $remote_class_node );
+ $search_method =~ s/::/_/go;
+
+ for my $remote_object ( @{$e->$search_method( { $remote_field => $obj->$link_field } )} ) {
+ push @context_ous, $remote_object->$context_field;
+ }
+ } else {
+ push @context_ous, $obj->$_ for ( split ' ', $context_field );
+ }
+ }
+ }
+ }
+
+ my $pok = 0;
+ for my $perm (@perms) {
+ if (@context_ous) {
+ for my $c_ou (@context_ous) {
+ if ($e->allowed($perm => $c_ou => $obj)) {
+ $pok++;
+ last;
+ }
+ }
+ } else {
+ $pok++ if ($e->allowed($perm => undef => $obj));
+ }
+ }
+
+ if ((lc($all_perms) eq 'true' && @perms != $pok) or !$pok) {
+ return OpenILS::Event->new('PERM_FAILURE',
+ ilsperm => "", # XXX add logic to report which perm failed
+ ilspermloc => "",
+ payload => "Perm failure -- action: $self->{action}, object type: $self->{json_hint}",
+ );
+ }
+ }
+
+ if ($self->{action} eq 'retrieve') {
+ $e->rollback;
+ return $obj;
+ }
+
+ $o_type =~ s/\./_/og;
+ my $method = $self->{action} . "_$o_type";
+ my $val = $e->$method($obj) or return $e->die_event;
+ $e->commit;
+
+ return $val;
+}
+
+sub search_permacrud {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my @args = @_;
+
+ if (@args > 1) {
+ delete $args[1]{flesh};
+ delete $args[1]{flesh_fields};
+ }
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->event unless $e->checkauth;
+
+ my $class_node;
+ try {
+ ($class_node) = $xpc->findnodes( "//idl:class[\@id='$self->{class_hint}']", $idl->documentElement );
+ } catch Error with {
+ my $error = shift;
+ $log->error("Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]");
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Error finding class node: $error [//idl:class[\@id='$self->{class_hint}']]"
+ );
+ };
+
+ my $search_method = 'search_' . $xpc->findvalue( '@oils_obj:fieldmapper', $class_node );
+ $search_method =~ s/::/_/go;
+
+ $log->debug("Calling CStoreEditor search method: $search_method");
+
+ my $obj_list = $e->$search_method( \@args );
+
+ my $retriever = $self->method_lookup( $self->{retriever} );
+ for my $o ( @$obj_list ) {
+ try {
+ ($o) = $retriever->run( $auth, $o, $e );
+ $client->respond( $o ) if ($o);
+ };
+ }
+
+ return undef;
+}
+
+sub generate_methods {
+ try {
+ for my $class_node ( $xpc->findnodes( '//idl:class[perm:permacrud]', $idl->documentElement ) ) {
+ my $hint = $class_node->getAttribute('id');
+ $log->debug("permacrud class_node $hint");
+
+ for my $action_node ( $xpc->findnodes( "perm:permacrud/perm:actions/perm:*", $class_node ) ) {
+ (my $method = $action_node->localname) =~ s/^.+:(.+)$/$1/o;
+ $log->internal("permacrud method = $method");
+
+ __PACKAGE__->register_method(
+ method => 'CRUD_action_object_permcheck',
+ api_name => 'open-ils.permacrud.' . $method . '.' . $hint,
+ class_hint => $hint,
+ action => $method,
+ );
+
+ if ($method eq 'retrieve') {
+ __PACKAGE__->register_method(
+ method => 'search_permacrud',
+ api_name => 'open-ils.permacrud.search.' . $hint,
+ class_hint => $hint,
+ retriever => 'open-ils.permacrud.retrieve.' . $hint,
+ stream => 1
+ );
+ }
+ }
+ }
+ } catch Error with {
+ my $e = shift;
+ $log->error("error generating permacrud methods: $e");
+ };
+}
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Proxy;
+use strict; use warnings;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use OpenSRF::EX qw(:try);
+
+
+__PACKAGE__->register_method(
+ method => "proxy",
+ api_name => "open-ils.proxy.proxy",
+ stream => 1,
+);
+
+
+sub proxy {
+ my($self, $client, $user_session,
+ $server, $method, @params) = @_;
+
+ warn "$user_session - $server - $method\n";
+
+ throw OpenSRF::EX::ERROR ("Not enough args to proxy")
+ unless ($user_session and $server and $method);
+
+
+ my $session = OpenSRF::AppSession->create($server);
+ my $request = $session->request( $method, @params );
+ if(!$request) {
+ throw OpenSRF::EX::ERROR
+ ("No request built on call to session->request( $method, @params )");
+ }
+
+ $request->wait_complete;
+
+ if( $request->failed() ) {
+
+ throw OpenSRF::EX::ERROR
+ ($request->failed()->stringify());
+
+ } else {
+
+ while( my $response = $request->recv ) {
+ $client->respond( $response->content );
+ }
+ }
+
+ $request->finish();
+ $session->finish();
+ $session->disconnect();
+
+ return undef;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Reporter;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Application::AppUtils;
+my $U = "OpenILS::Application::AppUtils";
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.folder.create',
+ method => 'create_folder'
+);
+
+sub create_folder {
+ my( $self, $conn, $auth, $type, $folder ) = @_;
+
+ my $e = new_rstore_editor(xact=>1, authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+
+ return 0 if $folder->owner ne $e->requestor->id;
+
+ $folder->owner($e->requestor->id);
+ my $meth = "create_reporter_${type}_folder";
+ $e->$meth($folder) or return $e->die_event;
+ $e->commit;
+
+ return $folder->id;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report.exists',
+ method => 'report_exists',
+ notes => q/
+ Returns 1 if a report with the given name and folder already exists.
+ /
+);
+
+sub report_exists {
+ my( $self, $conn, $auth, $report ) = @_;
+
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+
+ my $existing = $e->search_reporter_report(
+ {folder=>$report->folder, name=>$report->name});
+ return 1 if @$existing;
+ return 0;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.folder.visible.retrieve',
+ method => 'retrieve_visible_folders'
+);
+
+sub retrieve_visible_folders {
+ my( $self, $conn, $auth, $type ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+
+ my $class = 'rrf';
+ $class = 'rtf' if $type eq 'template';
+ $class = 'rof' if $type eq 'output';
+ my $flesh = {flesh => 1,flesh_fields => { $class => ['owner', 'share_with']}};
+
+ my $meth = "search_reporter_${type}_folder";
+ my $fs = $e->$meth( [{ owner => $e->requestor->id }, $flesh] );
+
+ my @orgs;
+ my $o = $U->storagereq(
+ 'open-ils.storage.actor.org_unit.full_path.atomic', $e->requestor->ws_ou);
+ push( @orgs, $_->id ) for @$o;
+
+ my $fs2 = $e->$meth(
+ [
+ {
+ shared => 't',
+ share_with => \@orgs,
+ owner => { '!=' => $e->requestor->id }
+ },
+ $flesh
+ ]
+ );
+ push( @$fs, @$fs2);
+ return $fs;
+}
+
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.folder_data.retrieve',
+ method => 'retrieve_folder_data'
+);
+
+sub retrieve_folder_data {
+ my( $self, $conn, $auth, $type, $folderid, $limit ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+ my $meth = "search_reporter_${type}";
+ my $class = 'rr';
+ $class = 'rt' if $type eq 'template';
+ my $flesh = {
+ flesh => 1,
+ flesh_fields => { $class => ['owner']},
+ order_by => { $class => 'create_time DESC'}
+ };
+ $flesh->{limit} = $limit if $limit;
+ return $e->$meth([{ folder => $folderid }, $flesh]);
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.schedule.retrieve_by_folder',
+ method => 'retrieve_schedules');
+sub retrieve_schedules {
+ my( $self, $conn, $auth, $folderId, $limit, $complete ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+
+ my $search = { folder => $folderId };
+ my $query = [
+ { folder => $folderId },
+ {
+ order_by => { rs => 'run_time DESC' } ,
+ flesh => 1,
+ flesh_fields => { rs => ['report'] }
+ }
+ ];
+
+ $query->[1]->{limit} = $limit if $limit;
+ $query->[0]->{complete_time} = undef unless $complete;
+ $query->[0]->{complete_time} = { '!=' => undef } if $complete;
+
+ return $e->search_reporter_schedule($query);
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.schedule.retrieve',
+ method => 'retrieve_schedules');
+sub retrieve_schedule {
+ my( $self, $conn, $auth, $sched_id ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+ my $s = $e->retrieve_reporter_schedule($sched_id)
+ or return $e->event;
+ return $s;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.template.create',
+ method => 'create_template');
+sub create_template {
+ my( $self, $conn, $auth, $template ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ $template->owner($e->requestor->id);
+
+ my $existing = $e->search_reporter_template( {owner=>$template->owner,
+ folder=>$template->folder, name=>$template->name},{idlist=>1});
+ return OpenILS::Event->new('REPORT_TEMPLATE_EXISTS') if @$existing;
+
+ my $tmpl = $e->create_reporter_template($template)
+ or return $e->die_event;
+ $e->commit;
+ return $tmpl;
+}
+
+
+
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report.create',
+ method => 'create_report');
+sub create_report {
+ my( $self, $conn, $auth, $report, $schedule ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ $report->owner($e->requestor->id);
+
+ my $existing = $e->search_reporter_report( {owner=>$report->owner,
+ folder=>$report->folder, name=>$report->name},{idlist=>1});
+ return OpenILS::Event->new('REPORT_REPORT_EXISTS') if @$existing;
+
+ my $rpt = $e->create_reporter_report($report)
+ or return $e->die_event;
+ $schedule->report($rpt->id);
+ $schedule->runner($e->requestor->id);
+ $e->create_reporter_schedule($schedule) or return $e->die_event;
+ $e->commit;
+ return $rpt;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.schedule.create',
+ method => 'create_schedule');
+sub create_schedule {
+ my( $self, $conn, $auth, $schedule ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $sched = $e->create_reporter_schedule($schedule)
+ or return $e->die_event;
+ $e->commit;
+ return $sched;
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.template.retrieve',
+ method => 'retrieve_template');
+sub retrieve_template {
+ my( $self, $conn, $auth, $id ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+ my $t = $e->retrieve_reporter_template($id)
+ or return $e->event;
+ return $t;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report.retrieve',
+ method => 'retrieve_report');
+sub retrieve_report {
+ my( $self, $conn, $auth, $id ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+ my $r = $e->retrieve_reporter_report($id)
+ or return $e->event;
+ return $r;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.template.update',
+ method => 'update_template');
+sub update_template {
+ my( $self, $conn, $auth, $tmpl ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $t = $e->retrieve_reporter_template($tmpl->id)
+ or return $e->die_event;
+ return 0 if $t->owner ne $e->requestor->id;
+ $e->update_reporter_template($tmpl)
+ or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report.update',
+ method => 'update_report');
+sub update_report {
+ my( $self, $conn, $auth, $report ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $r = $e->retrieve_reporter_report($report->id)
+ or return $e->die_event;
+ if( $r->owner ne $e->requestor->id ) {
+ $e->rollback;
+ return 0;
+ }
+ $e->update_reporter_report($report)
+ or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.schedule.update',
+ method => 'update_schedule');
+sub update_schedule {
+ my( $self, $conn, $auth, $schedule ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $s = $e->retrieve_reporter_schedule($schedule->id)
+ or return $e->die_event;
+ my $r = $e->retrieve_reporter_report($s->report)
+ or return $e->die_event;
+ if( $r->owner ne $e->requestor->id ) {
+ $e->rollback;
+ return 0;
+ }
+ $e->update_reporter_schedule($schedule)
+ or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.folder.update',
+ method => 'update_folder');
+sub update_folder {
+ my( $self, $conn, $auth, $type, $folder ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $meth = "retrieve_reporter_${type}_folder";
+ my $f = $e->$meth($folder->id) or return $e->die_event;
+ return 0 if $f->owner ne $e->requestor->id;
+ $meth = "update_reporter_${type}_folder";
+ $e->$meth($folder) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.folder.delete',
+ method => 'delete_folder');
+sub delete_folder {
+ my( $self, $conn, $auth, $type, $folderId ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $meth = "retrieve_reporter_${type}_folder";
+ my $f = $e->$meth($folderId) or return $e->die_event;
+ return 0 if $f->owner ne $e->requestor->id;
+ $meth = "delete_reporter_${type}_folder";
+ $e->$meth($f) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.template.delete',
+ method => 'delete_template');
+sub delete_template {
+ my( $self, $conn, $auth, $templateId ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+
+ my $t = $e->retrieve_reporter_template($templateId)
+ or return $e->die_event;
+ return 0 if $t->owner ne $e->requestor->id;
+ $e->delete_reporter_template($t) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.template.delete.cascade',
+ method => 'cascade_delete_template');
+
+#__PACKAGE__->register_method(
+# api_name => 'open-ils.reporter.template.delete.cascade.force',
+# method => 'cascade_delete_template');
+
+sub cascade_delete_template {
+ my( $self, $conn, $auth, $templateId ) = @_;
+
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+
+ my $ret = cascade_delete_template_impl(
+ $e, $e->requestor->id, $templateId, ($self->api_name =~ /force/o) );
+ return $ret if ref $ret; # some fatal event occurred
+
+ $e->rollback if $ret == 0;
+ $e->commit if $ret > 0;
+ return $ret;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report.delete.cascade',
+ method => 'cascade_delete_report');
+
+#__PACKAGE__->register_method(
+# api_name => 'open-ils.reporter.report.delete.cascade.force',
+# method => 'cascade_delete_report');
+
+sub cascade_delete_report {
+ my( $self, $conn, $auth, $reportId ) = @_;
+
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+
+ my $ret = cascade_delete_report_impl($e, $e->requestor->id, $reportId);
+ return $ret if ref $ret; # some fatal event occurred
+
+ $e->rollback if $ret == 0;
+ $e->commit if $ret > 0;
+ return $ret;
+}
+
+
+# performs a cascading template delete
+# returns 2 if all data was deleted
+# returns 1 if some data was deleted
+# returns 0 if no data was deleted
+# returns event on error
+sub cascade_delete_template_impl {
+ my( $e, $owner, $templateId ) = @_;
+
+ # fetch the template to delete
+ my $template = $e->search_reporter_template(
+ {id=>$templateId, owner=>$owner})->[0] or return 0;
+
+ # fetch he attached report IDs for this owner
+ my $reports = $e->search_reporter_report(
+ {template=>$templateId, owner=>$owner},{idlist=>1});
+
+ # delete the attached reports
+ my $all_rpts_deleted = 1;
+ for my $r (@$reports) {
+ my $evt = cascade_delete_report_impl($e, $owner, $r);
+ return $evt if ref $evt;
+ $all_rpts_deleted = 0 unless $evt == 2;
+ }
+
+ # fetch all reports attached to this template that
+ # do not belong to $owner. If there are any, we can't
+ # delete the template
+ my $alt_reports = $e->search_reporter_report(
+ {template=>$templateId, owner=>{"!=" => $owner}},{idlist=>1});
+
+ # all_rpts_deleted will be false if a report has an
+ # attached scheduled owned by a different user
+ return 1 if @$alt_reports or not $all_rpts_deleted;
+
+ $e->delete_reporter_template($template)
+ or return $e->die_event;
+ return 2;
+}
+
+# performs a cascading report delete
+# returns 2 if all data was deleted
+# returns 1 if some data was deleted
+# returns 0 if no data was deleted
+# returns event on error
+sub cascade_delete_report_impl {
+ my( $e, $owner, $reportId ) = @_;
+
+ # fetch the report to delete
+ my $report = $e->search_reporter_report(
+ {id=>$reportId, owner=>$owner})->[0] or return 0;
+
+ # fetch the attached schedule IDs for this owner
+ my $scheds = $e->search_reporter_schedule(
+ {report=>$reportId, runner=>$owner},{idlist=>1});
+
+ # delete the attached schedules
+ for my $sched (@$scheds) {
+ my $evt = delete_schedule_impl($e, $sched);
+ return $evt if $evt;
+ }
+
+ # fetch all schedules attached to this report that
+ # do not belong to $owner. If there are any, we can't
+ # delete the report
+ my $alt_scheds = $e->search_reporter_schedule(
+ {report=>$reportId, runner=>{"!=" => $owner}},{idlist=>1});
+
+ return 1 if @$alt_scheds;
+
+ $e->delete_reporter_report($report)
+ or return $e->die_event;
+
+ return 2;
+}
+
+
+# deletes the requested schedule
+# returns undef on success, event on error
+sub delete_schedule_impl {
+ my( $e, $schedId ) = @_;
+ my $s = $e->retrieve_reporter_schedule($schedId)
+ or return $e->die_event;
+ $e->delete_reporter_schedule($s) or return $e->die_event;
+ return undef;
+}
+
+
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report.delete',
+ method => 'delete_report');
+sub delete_report {
+ my( $self, $conn, $auth, $reportId ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+
+ my $t = $e->retrieve_reporter_report($reportId)
+ or return $e->die_event;
+ return 0 if $t->owner ne $e->requestor->id;
+ $e->delete_reporter_report($t) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.schedule.delete',
+ method => 'delete_schedule');
+sub delete_schedule {
+ my( $self, $conn, $auth, $scheduleId ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth, xact=>1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+
+ my $t = $e->retrieve_reporter_schedule($scheduleId)
+ or return $e->die_event;
+ return 0 if $t->runner ne $e->requestor->id;
+ $e->delete_reporter_schedule($t) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.template_has_reports',
+ method => 'has_reports');
+sub has_reports {
+ my( $self, $conn, $auth, $templateId ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $rpts = $e->search_reporter_report({template=>$templateId},{idlist=>1});
+ return 1 if @$rpts;
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.reporter.report_has_output',
+ method => 'has_output');
+sub has_output {
+ my( $self, $conn, $auth, $reportId ) = @_;
+ my $e = new_rstore_editor(authtoken=>$auth);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('RUN_REPORTS');
+ my $outs = $e->search_reporter_schedule({report=>$reportId},{idlist=>1});
+ return 1 if @$outs;
+ return 0;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'org_full_path',
+ api_name => 'open-ils.reporter.org_unit.full_path');
+
+sub org_full_path {
+ my( $self, $conn, $orgid ) = @_;
+ return $U->storagereq(
+ 'open-ils.storage.actor.org_unit.full_path.atomic', $orgid );
+}
+
+
+
+
+__PACKAGE__->register_method(
+ method => 'magic_fetch_all',
+ api_name => 'open-ils.reporter.magic_fetch');
+sub magic_fetch_all {
+ my( $self, $conn, $auth, $args ) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('RUN_REPORTS');
+
+ my $hint = $$args{hint};
+ my $org_col = $$args{org_column};
+ my $orgs = $$args{org};
+
+# if ($orgs && !$$args{no_fetch}) {
+# ($orgs) = $self
+# ->method_lookup( 'open-ils.reporter.org_unit.full_path' )
+# ->run( @$orgs );
+# $orgs = [ map {$_->id} @$orgs ];
+# }
+
+ # Find the class the iplements the given hint
+ my ($class) = grep {
+ $Fieldmapper::fieldmap->{$_}{hint} eq $hint } Fieldmapper->classes;
+
+ return undef unless $class->Selector;
+
+ $class =~ s/Fieldmapper:://og;
+ $class =~ s/::/_/og;
+
+ my $method;
+ my $margs;
+
+ if( $org_col ) {
+ $method = "search_$class";
+ $margs = { $org_col => $orgs };
+ } else {
+ $method = "retrieve_all_$class";
+ }
+
+ $logger->info("reporter.magic_fetch => $method");
+
+ return $e->$method($margs);
+}
+
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# Copyright (C) 2009-2010 Dan Scott <dscott@laurentian.ca>
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+=head1 NAME
+
+OpenILS::Application::ResolverResolver - retrieves holdings from OpenURL resolvers
+
+=head1 SYNOPSIS
+
+Via srfsh:
+ request open-ils.resolver open-ils.resolver.resolve_holdings "issn", "0022-362X"
+or:
+ request open-ils.resolver open-ils.resolver.resolve_holdings.raw "issn", "0022-362X"
+
+Via Perl:
+ my $session = OpenSRF::AppSession->create("open-ils.resolver");
+ my $request = $session->request("open-ils.resolver.resolve_holdings", [ "issn", "0022-362X" ] )->gather();
+ $session->disconnect();
+
+ # $request is a reference to the list of hashes
+
+=head1 DESCRIPTION
+
+OpenILS::Application::ResolverResolver caches responses from OpenURL resolvers
+to requests for full-text holdings. Currently integration with SFX is supported.
+
+Each org_unit can specify a different base URL as the third argument to
+resolve_holdings(). Eventually org_units will have org_unit settings to hold
+their resolver type and base URL.
+
+=head1 AUTHOR
+
+Dan Scott, dscott@laurentian.ca
+
+=cut
+
+package OpenILS::Application::ResolverResolver;
+
+use strict;
+use warnings;
+use LWP::UserAgent;
+use XML::LibXML;
+
+# All OpenSRF applications must be based on OpenSRF::Application or
+# a subclass thereof. Makes sense, eh?
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+# This is the client class, used for connecting to open-ils.storage
+use OpenSRF::AppSession;
+
+# This is an extension of Error.pm that supplies some error types to throw
+use OpenSRF::EX qw(:try);
+
+# This is a helper class for querying the OpenSRF Settings application ...
+use OpenSRF::Utils::SettingsClient;
+
+# ... and here we have the built in logging helper ...
+use OpenSRF::Utils::Logger qw($logger);
+
+# ... and this manages cached results for us ...
+use OpenSRF::Utils::Cache;
+
+# ... and this gives us access to the Fieldmapper
+use OpenILS::Utils::Fieldmapper;
+
+my $prefix = "open-ils.resolver_"; # Prefix for caching values
+my $cache;
+my $cache_timeout;
+my $default_url_base; # Default resolver location
+
+our ($ua, $parser);
+
+
+sub initialize {
+ $cache = OpenSRF::Utils::Cache->new('global');
+ my $sclient = OpenSRF::Utils::SettingsClient->new();
+ $cache_timeout = $sclient->config_value(
+ "apps", "open-ils.resolver", "app_settings", "cache_timeout" ) || 300;
+ $default_url_base = $sclient->config_value(
+ "apps", "open-ils.resolver", "app_settings", "default_url_base");
+}
+
+sub child_init {
+ # We need a User Agent to speak to the SFX beast
+ $ua = new LWP::UserAgent;
+ $ua->agent('SameOrigin/1.0');
+
+ # SFX returns XML to us; let us parse
+ $parser = new XML::LibXML;
+}
+
+sub resolve_holdings {
+ my $self = shift;
+ my $conn = shift;
+ my $id_type = shift; # keep it simple for now, either 'issn' or 'isbn'
+ my $id_value = shift; # the normalized ISSN or ISBN
+ my $url_base = shift || $default_url_base;
+
+ # We'll use this in our cache key
+ my $method = $self->api_name;
+
+ # We might want to return raw JSON for speedier responses
+ my $format = 'fieldmapper';
+ if ($self->api_name =~ /raw$/) {
+ $format = 'raw';
+ }
+
+ # Big ugly SFX OpenURL request
+ my $url_args = '?url_ver=Z39.88-2004&url_ctx_fmt=infofi/fmt:kev:mtx:ctx&'
+ . 'ctx_enc=UTF-8&ctx_ver=Z39.88-2004&rfr_id=info:sid/conifer&'
+ . 'sfx.ignore_date_threshold=1&'
+ . 'sfx.response_type=multi_obj_detailed_xml&__service_type=getFullTxt';
+
+ if ($id_type eq 'issn') {
+ $url_args .= "&rft.issn=$id_value";
+ } elsif ($id_type eq 'isbn') {
+ $url_args .= "&rft.isbn=$id_value";
+ }
+
+ my $ckey = $prefix . $method . $url_base . $id_type . $id_value;
+
+ # Check the cache to see if we've already looked this up
+ # If we have, shortcut our return value
+ my $result = $cache->get_cache($ckey) || undef;
+ if ($result) {
+ $logger->info("Resolver found a cache hit");
+ return $result;
+ }
+
+ # Otherwise, let's go and grab the info from the SFX server
+ my $req = HTTP::Request->new('GET', "$url_base$url_args");
+
+ # Let's see what we we're trying to request
+ $logger->info("Resolving the following request: $url_base$url_args");
+
+ my $res = $ua->request($req);
+
+ my $xml = $res->content;
+ my $parsed_sfx = $parser->parse_string($xml);
+
+ my (@targets) = $parsed_sfx->findnodes('//target');
+
+ my @sfx_result;
+ foreach my $target (@targets) {
+ if ($format eq 'raw') {
+ push @sfx_result, {
+ public_name => $target->findvalue('./target_public_name'),
+ target_url => $target->findvalue('.//target_url'),
+ target_coverage => $target->findvalue('.//coverage_statement'),
+ target_embargo => $target->findvalue('.//embargo_statement'),
+ };
+ } else {
+ my $rhr = Fieldmapper::resolver::holdings_record->new;
+ $rhr->public_name($target->findvalue('./target_public_name'));
+ $rhr->target_url($target->findvalue('.//target_url'));
+ $rhr->target_coverage($target->findvalue('.//coverage_statement'));
+ $rhr->target_embargo($target->findvalue('.//embargo_statement'));
+ push @sfx_result, $rhr;
+ }
+ }
+
+ # Stuff this into the cache
+ $cache->put_cache($ckey, \@sfx_result, $cache_timeout);
+
+ # Don't return the list unless it contains results
+ if (scalar(@sfx_result)) {
+ return \@sfx_result;
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'resolve_holdings',
+ api_name => 'open-ils.resolver.resolve_holdings',
+ api_level => 1,
+ argc => 3,
+ signature => {
+ desc => <<" DESC",
+Returns a list of "rhr" objects representing the full-text holdings for a given ISBN or ISSN
+ DESC
+ 'params' => [ {
+ name => 'id_type',
+ desc => 'The type of identifier ("issn" or "isbn")',
+ type => 'string'
+ }, {
+ name => 'id_value',
+ desc => 'The identifier value',
+ type => 'string'
+ }, {
+ name => 'url_base',
+ desc => 'The base URL for the resolver and instance',
+ type => 'string'
+ },
+ ],
+ 'return' => {
+ desc => 'Returns a list of "rhr" objects representing the full-text holdings for a given ISBN or ISSN',
+ type => 'array'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'resolve_holdings',
+ api_name => 'open-ils.resolver.resolve_holdings.raw',
+ api_level => 1,
+ argc => 3,
+ signature => {
+ desc => <<" DESC",
+Returns a list of raw JSON objects representing the full-text holdings for a given ISBN or ISSN
+ DESC
+ 'params' => [ {
+ name => 'id_type',
+ desc => 'The type of identifier ("issn" or "isbn")',
+ type => 'string'
+ }, {
+ name => 'id_value',
+ desc => 'The identifier value',
+ type => 'string'
+ }, {
+ name => 'url_base',
+ desc => 'The base URL for the resolver and instance',
+ type => 'string'
+ },
+ ],
+ 'return' => {
+ desc => 'Returns a list of raw JSON objects representing the full-text holdings for a given ISBN or ISSN',
+ type => 'array'
+ }
+ }
+);
+
+# Clear cache for specific lookups
+sub delete_cached_holdings {
+ my $self = shift;
+ my $conn = shift;
+ my $id_type = shift; # keep it simple for now, either 'issn' or 'isbn'
+ my $id_value = shift; # the normalized ISSN or ISBN
+ my $url_base = shift || $default_url_base;
+ my @deleted_keys;
+
+ $logger->warn("Deleting value [$id_value]");
+ # We'll use this in our cache key
+ foreach my $method ('open-ils.resolver.resolve_holdings.raw', 'open-ils.resolver.resolve_holdings') {
+ my $ckey = $prefix . $method . $url_base . $id_type . $id_value;
+
+ $logger->warn("Deleted cache key [$ckey]");
+ my $result = $cache->delete_cache($ckey);
+
+ $logger->warn("Result of deleting cache key: [$result]");
+ push @deleted_keys, $result;
+ }
+
+ return \@deleted_keys;
+}
+
+__PACKAGE__->register_method(
+ method => 'delete_holdings_cache',
+ api_name => 'open-ils.resolver.delete_cached_holdings',
+ api_level => 1,
+ argc => 3,
+ signature => {
+ desc => <<" DESC",
+Deletes the cached value of the full-text holdings for a given ISBN or ISSN
+ DESC
+ 'params' => [ {
+ name => 'id_type',
+ desc => 'The type of identifier ("issn" or "isbn")',
+ type => 'string'
+ }, {
+ name => 'id_value',
+ desc => 'The identifier value',
+ type => 'string'
+ }, {
+ name => 'url_base',
+ desc => 'The base URL for the resolver and instance',
+ type => 'string'
+ },
+ ],
+ 'return' => {
+ desc => 'Deletes the cached value of the full-text holdings for a given ISBN or ISSN',
+ type => 'array'
+ }
+ }
+);
+
+
+1;
--- /dev/null
+package OpenILS::Application::Search;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:logger);
+
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::ModsParser;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Cache;
+
+use OpenILS::Application::Search::Biblio;
+use OpenILS::Application::Search::Authority;
+use OpenILS::Application::Search::Z3950;
+use OpenILS::Application::Search::Zips;
+use OpenILS::Application::Search::CNBrowse;
+use OpenILS::Application::Search::Serial;
+
+
+use OpenILS::Application::AppUtils;
+
+use Time::HiRes qw(time);
+use OpenSRF::EX qw(:try);
+
+use Text::Aspell;
+
+# Houses generic search utilites
+
+sub initialize {
+ OpenILS::Application::Search::Z3950->initialize();
+ OpenILS::Application::Search::Zips->initialize();
+ OpenILS::Application::Search::Biblio->initialize();
+}
+
+sub child_init {
+ OpenILS::Application::Search::Z3950->child_init;
+}
+
+
+
+# ------------------------------------------------------------------
+# Create custom dictionaries like so:
+# aspell --lang=en create master ./oils_authority.dict < /tmp/words
+# where /tmp/words is a space separated list of words
+# ------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => "spellcheck",
+ api_name => "open-ils.search.spellcheck",
+ signature => {
+ desc => 'Returns alternate spelling suggestions',
+ param => [
+ {
+ name => 'phrase',
+ desc => 'Word or phrase to return alternate spelling suggestions for',
+ type => 'string'
+ },
+ {
+ name => 'Dictionary class',
+ desc => 'Alternate configured dictionary to use (optional)',
+ type => 'string'
+ },
+ ],
+ return => {
+ desc => 'Array with a suggestions hash for each word in the phrase, like: '
+ . q# [{ word: original_word, suggestions: [sug1, sug2, ...], found: 1 }, ... ] #
+ . 'The "found" value will be 1 if the word was found in the dictionary, 0 otherwise.',
+ type => 'array',
+ }
+ }
+);
+
+my $speller = Text::Aspell->new();
+
+sub spellcheck {
+ my( $self, $client, $phrase, $class ) = @_;
+
+ return [] unless $phrase; # nothing to check, abort.
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ $class ||= 'default';
+
+ my @conf_path = (apps => 'open-ils.search' => app_settings => spelling_dictionary => $class);
+
+ if( my $dict = $conf->config_value(@conf_path) ) {
+ $speller->set_option('master', $dict);
+ $logger->debug("spelling dictionary set to $dict");
+ }
+
+ my @resp;
+
+ for my $word (split(/\s+/,$phrase) ) {
+
+ my @suggestions = $speller->suggest($word);
+ my @trimmed;
+
+ for my $sug (@suggestions) {
+
+ # suggestion matches alternate case of original word
+ next if lc($sug) eq lc($word);
+
+ # suggestion matches alternate case of already suggested word
+ next if grep { lc($sug) eq lc($_) } @trimmed;
+
+ push(@trimmed, $sug);
+ }
+
+ push( @resp,
+ {
+ word => $word,
+ suggestions => (@trimmed) ? [@trimmed] : undef,
+ found => $speller->check($word)
+ }
+ );
+ }
+ return \@resp;
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::Search::AddedContent;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+sub initialize { return 1; }
+
+
+__PACKAGE__->register_method(
+ method => "summary",
+ api_name => "open-ils.search.added_content.summary.retrieve",
+ notes => <<" NOTE");
+ Returns an object like so:
+ {
+ Review : true/false
+ Inventory : true/false
+ Annotation : true/false
+ Jacket : true/false
+ TOC : true/false
+ Product : true/false
+ }
+ This object indicates the existance of each type of added content for the given ISBN
+ PARAMS( ISBN ),
+ NOTE
+
+sub summary {
+ return {
+ Review => "false",
+ Inventory => "false",
+ Annotation => "false",
+ Jacket => "false",
+ TOC => "false",
+ Product => "false",
+ };
+}
+
+
+__PACKAGE__->register_method(
+ method => "reviews",
+ api_name => "open-ils.search.added_content.review.retrieve.random",
+ notes => <<" NOTE");
+ Returns a singe random review article object
+ PARAMS( ISBN ),
+ NOTE
+
+__PACKAGE__->register_method(
+ method => "reviews",
+ api_name => "open-ils.search.added_content.review.retrieve.all",
+ notes => <<" NOTE");
+ Returns an array review article objects
+ PARAMS( ISBN ),
+ NOTE
+
+sub reviews { return []; }
+
+
+__PACKAGE__->register_method(
+ method => "toc",
+ api_name => "open-ils.search.added_content.toc.retrieve",
+ notes => <<" NOTE");
+ Returns the table of contents for the given ISBN
+ PARAMS( ISBN ),
+ NOTE
+
+sub toc { return ""; }
+
+
+1;
--- /dev/null
+package OpenILS::Application::Search::Authority;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Application::AppUtils;
+use XML::LibXML;
+use XML::LibXSLT;
+use OpenILS::Utils::Editor q/:funcs/;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use OpenSRF::Utils::JSON;
+
+use Time::HiRes qw(time);
+use OpenSRF::EX qw(:try);
+use Digest::MD5 qw(md5_hex);
+
+my $cache;
+
+
+sub validate_authority {
+ my $self = shift;
+ my $client = shift;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ return $session->request( 'open-ils.storage.authority.validate.tag' => @_ )->gather(1);
+}
+__PACKAGE__->register_method(
+ method => "validate_authority",
+ api_name => "open-ils.search.authority.validate.tag",
+ argc => 4,
+ note => "Validates authority data from existing controlled terms",
+);
+
+sub validate_authority_return_records_by_id {
+ my $self = shift;
+ my $client = shift;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ return $session->request( 'open-ils.storage.authority.validate.tag.id_list' => @_ )->gather(1);
+}
+__PACKAGE__->register_method(
+ method => "validate_authority_return_records_by_id",
+ api_name => "open-ils.search.authority.validate.tag.id_list",
+ argc => 4,
+ note => "Validates authority data from existing controlled terms",
+);
+
+sub search_authority {
+ my $self = shift;
+ my $client = shift;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+ return $session->request( 'open-ils.storage.authority.search.marc.atomic' => @_ )->gather(1);
+}
+__PACKAGE__->register_method(
+ method => "search_authority",
+ api_name => "open-ils.search.authority.fts",
+ argc => 2,
+ note => "Searches authority data for existing controlled terms and crossrefs",
+);
+
+
+sub crossref_authority {
+ my $self = shift;
+ my $client = shift;
+ my $class = shift;
+ my $term = shift;
+ my $limit = shift || 10;
+
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+
+ # Avoid generating spurious errors for more granular indexes, like author|personal
+ $class =~ s/^(.*?)\|.*?$/$1/;
+
+ $logger->info("authority xref search for $class=$term, limit=$limit");
+ my $fr = $session->request(
+ "open-ils.storage.authority.$class.see_from.controlled.atomic",$term, $limit)->gather(1);
+ my $al = $session->request(
+ "open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, $limit)->gather(1);
+
+ my $data = _auth_flatten( $term, $fr, $al, 1 );
+
+ return $data;
+}
+
+sub _auth_flatten {
+ my $term = shift;
+ my $fr = shift;
+ my $al = shift;
+ my $limit = shift;
+
+ my %hash = ();
+ for my $x (@$fr) {
+ my $string = $$x[0];
+ for my $i (1..10) {
+ last unless ($$x[$i]);
+ if ($string =~ /\W$/o) {
+ $string .= ' '.$$x[$i];
+ } else {
+ $string .= ' -- '.$$x[$i];
+ }
+ }
+ next if (lc($string) eq lc($term));
+ $hash{$string}++;
+ $hash{$string}++ if (lc($$x[0]) eq lc($term));
+ }
+ my $from = [keys %hash]; #[ sort { $hash{$b} <=> $hash{$a} || $a cmp $b } keys %hash ];
+
+# $from = [ @$from[0..4] ] if $limit;
+
+ %hash = ();
+ for my $x (@$al) {
+ my $string = $$x[0];
+ for my $i (1..10) {
+ last unless ($$x[$i]);
+ if ($string =~ /\W$/o) {
+ $string .= ' '.$$x[$i];
+ } else {
+ $string .= ' -- '.$$x[$i];
+ }
+ }
+ next if (lc($string) eq lc($term));
+ $hash{$string}++;
+ $hash{$string}++ if (lc($$x[0]) eq lc($term));
+ }
+ my $also = [keys %hash]; #[ sort { $hash{$b} <=> $hash{$a} || $a cmp $b } keys %hash ];
+
+# $also = [ @$also[0..4] ] if $limit;
+
+ #warn Dumper( { from => $from, also => $also } );
+
+ return { from => $from, also => $also };
+}
+
+__PACKAGE__->register_method(
+ method => "crossref_authority",
+ api_name => "open-ils.search.authority.crossref",
+ argc => 2,
+ note => "Searches authority data for existing controlled terms and crossrefs",
+);
+
+__PACKAGE__->register_method(
+ #method => "new_crossref_authority_batch",
+ method => "crossref_authority_batch2",
+ api_name => "open-ils.search.authority.crossref.batch",
+ argc => 1,
+ note => <<" NOTE");
+ Takes an array of class,term pair sub-arrays and performs an authority lookup for each
+
+ PARAMS( [ ["subject", "earth"], ["author","shakespeare"] ] );
+
+ Returns an object like so:
+ {
+ "classname" : {
+ "term" : { "from" : [ ...], "also" : [...] }
+ "term2" : { "from" : [ ...], "also" : [...] }
+ }
+ }
+ NOTE
+
+sub new_crossref_authority_batch {
+ my( $self, $client, $reqs ) = @_;
+
+ my $response = {};
+ my $lastr = [];
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+
+ for my $req (@$reqs) {
+
+ my $class = $req->[0];
+ my $term = $req->[1];
+ next unless $class and $term;
+ $logger->info("Sending authority request for $class : $term");
+ my $fr = $session->request("open-ils.storage.authority.$class.see_from.controlled.atomic",$term, 10)->gather(1);
+ my $al = $session->request("open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, 10)->gather(1);
+
+ $response->{$class} = {} unless exists $response->{$class};
+ $response->{$class}->{$term} = _auth_flatten( $term, $fr, $al, 1 );
+
+ }
+
+ #warn Dumper( $response );
+ return $response;
+}
+
+sub crossref_authority_batch {
+ my( $self, $client, $reqs ) = @_;
+
+ my $response = {};
+ my $lastr = [];
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+
+ for my $req (@$reqs) {
+
+ my $class = $req->[0];
+ my $term = $req->[1];
+ next unless $class and $term;
+ $logger->info("Sending authority request for $class : $term");
+ my $freq = $session->request("open-ils.storage.authority.$class.see_from.controlled.atomic",$term, 10);
+ my $areq = $session->request("open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, 10);
+
+ if( $lastr->[0] ) { #process old data while waiting on new data
+ my $cls = $lastr->[0];
+ my $trm = $lastr->[1];
+ my $fr = $lastr->[2];
+ my $al = $lastr->[3];
+ $response->{$cls} = {} unless exists $response->{$cls};
+ $response->{$cls}->{$trm} = _auth_flatten( $trm, $fr, $al, 1 );
+ }
+
+ $lastr->[0] = $class;
+ $lastr->[1] = $term;
+ $lastr->[2] = $freq->gather(1);
+ $lastr->[3] = $areq->gather(1);
+ }
+
+ if( $lastr->[0] ) { #process old data while waiting on new data
+ my $cls = $lastr->[0];
+ my $trm = $lastr->[1];
+ my $fr = $lastr->[2];
+ my $al = $lastr->[3];
+ $response->{$cls} = {} unless exists $response->{$cls};
+ $response->{$cls}->{$trm} = _auth_flatten( $trm, $fr, $al, 1);
+ }
+
+ return $response;
+}
+
+
+
+
+sub crossref_authority_batch2 {
+ my( $self, $client, $reqs ) = @_;
+
+ my $response = {};
+ my $lastr = [];
+ my $session = OpenSRF::AppSession->create("open-ils.storage");
+
+ $cache = OpenSRF::Utils::Cache->new('global') unless $cache;
+
+ for my $req (@$reqs) {
+
+ my $class = $req->[0];
+ my $term = $req->[1];
+ next unless $class and $term;
+
+ my $t = $term;
+ $t =~ s/\s//og;
+ my $cdata = $cache->get_cache("oils_authority_${class}_$t");
+
+ if( $cdata ) {
+ $logger->debug("returning authority response from cache..");
+ $response->{$class} = {} unless exists $response->{$class};
+ $response->{$class}->{$term} = $cdata;
+ next;
+ }
+
+ $logger->debug("authority data not found in cache.. fetching from storage");
+
+ $logger->info("Sending authority request for $class : $term");
+ my $freq = $session->request("open-ils.storage.authority.$class.see_from.controlled.atomic",$term, 10);
+ my $areq = $session->request("open-ils.storage.authority.$class.see_also_from.controlled.atomic",$term, 10);
+ my $fr = $freq->gather(1);
+ my $al = $areq->gather(1);
+ $response->{$class} = {} unless exists $response->{$class};
+ my $auth = _auth_flatten( $term, $fr, $al, 1 );
+
+ my $timeout = 7200; #two hours
+ $timeout = 300 if @{$auth->{from}} or @{$auth->{also}}; # 5 minutes
+ $response->{$class}->{$term} = $auth;
+ $logger->debug("adding authority lookup to cache with timeout $timeout");
+ $cache->put_cache("oils_authority_${class}_$t", $auth, $timeout);
+ }
+ return $response;
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::Application::Search::Biblio;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+
+use OpenSRF::Utils::JSON;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::ModsParser;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Cache;
+use Encode;
+
+use OpenSRF::Utils::Logger qw/:logger/;
+
+
+use OpenSRF::Utils::JSON;
+
+use Time::HiRes qw(time);
+use OpenSRF::EX qw(:try);
+use Digest::MD5 qw(md5_hex);
+
+use XML::LibXML;
+use XML::LibXSLT;
+
+use Data::Dumper;
+$Data::Dumper::Indent = 0;
+
+use OpenILS::Const qw/:const/;
+
+use OpenILS::Application::AppUtils;
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+
+my $pfx = "open-ils.search_";
+
+my $cache;
+my $cache_timeout;
+my $superpage_size;
+my $max_superpages;
+
+sub initialize {
+ $cache = OpenSRF::Utils::Cache->new('global');
+ my $sclient = OpenSRF::Utils::SettingsClient->new();
+ $cache_timeout = $sclient->config_value(
+ "apps", "open-ils.search", "app_settings", "cache_timeout" ) || 300;
+
+ $superpage_size = $sclient->config_value(
+ "apps", "open-ils.search", "app_settings", "superpage_size" ) || 500;
+
+ $max_superpages = $sclient->config_value(
+ "apps", "open-ils.search", "app_settings", "max_superpages" ) || 20;
+
+ $logger->info("Search cache timeout is $cache_timeout, ".
+ " superpage_size is $superpage_size, max_superpages is $max_superpages");
+}
+
+
+
+# ---------------------------------------------------------------------------
+# takes a list of record id's and turns the docs into friendly
+# mods structures. Creates one MODS structure for each doc id.
+# ---------------------------------------------------------------------------
+sub _records_to_mods {
+ my @ids = @_;
+
+ my @results;
+ my @marcxml_objs;
+
+ my $session = OpenSRF::AppSession->create("open-ils.cstore");
+ my $request = $session->request(
+ "open-ils.cstore.direct.biblio.record_entry.search", { id => \@ids } );
+
+ while( my $resp = $request->recv ) {
+ my $content = $resp->content;
+ next if $content->id == OILS_PRECAT_RECORD;
+ my $u = OpenILS::Utils::ModsParser->new(); # FIXME: we really need a new parser for each object?
+ $u->start_mods_batch( $content->marc );
+ my $mods = $u->finish_mods_batch();
+ $mods->doc_id($content->id());
+ $mods->tcn($content->tcn_value);
+ push @results, $mods;
+ }
+
+ $session->disconnect();
+ return \@results;
+}
+
+__PACKAGE__->register_method(
+ method => "record_id_to_mods",
+ api_name => "open-ils.search.biblio.record.mods.retrieve",
+ argc => 1,
+ signature => {
+ desc => "Provide ID, we provide the MODS object with copy count. "
+ . "Note: this method does NOT take an array of IDs like mods_slim.retrieve", # FIXME: do it here too
+ params => [
+ { desc => 'Record ID', type => 'number' }
+ ],
+ return => {
+ desc => 'MODS object', type => 'object'
+ }
+ }
+);
+
+# converts a record into a mods object with copy counts attached
+sub record_id_to_mods {
+
+ my( $self, $client, $org_id, $id ) = @_;
+
+ my $mods_list = _records_to_mods( $id );
+ my $mods_obj = $mods_list->[0];
+ my $cmethod = $self->method_lookup("open-ils.search.biblio.record.copy_count");
+ my ($count) = $cmethod->run($org_id, $id);
+ $mods_obj->copy_count($count);
+
+ return $mods_obj;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "record_id_to_mods_slim",
+ api_name => "open-ils.search.biblio.record.mods_slim.retrieve",
+ argc => 1,
+ authoritative => 1,
+ signature => {
+ desc => "Provide ID(s), we provide the MODS",
+ params => [
+ { desc => 'Record ID or array of IDs' }
+ ],
+ return => {
+ desc => 'MODS object(s), event on error'
+ }
+ }
+);
+
+# converts a record into a mods object with NO copy counts attached
+sub record_id_to_mods_slim {
+ my( $self, $client, $id ) = @_;
+ return undef unless defined $id;
+
+ if(ref($id) and ref($id) == 'ARRAY') {
+ return _records_to_mods( @$id );
+ }
+ my $mods_list = _records_to_mods( $id );
+ my $mods_obj = $mods_list->[0];
+ return OpenILS::Event->new('BIBLIO_RECORD_ENTRY_NOT_FOUND') unless $mods_obj;
+ return $mods_obj;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => "record_id_to_mods_slim_batch",
+ api_name => "open-ils.search.biblio.record.mods_slim.batch.retrieve",
+ stream => 1
+);
+sub record_id_to_mods_slim_batch {
+ my($self, $conn, $id_list) = @_;
+ $conn->respond(_records_to_mods($_)->[0]) for @$id_list;
+ return undef;
+}
+
+
+# Returns the number of copies attached to a record based on org location
+__PACKAGE__->register_method(
+ method => "record_id_to_copy_count",
+ api_name => "open-ils.search.biblio.record.copy_count",
+ signature => {
+ desc => q/Returns a copy summary for the given record for the context org
+ unit and all ancestor org units/,
+ params => [
+ {desc => 'Context org unit id', type => 'number'},
+ {desc => 'Record ID', type => 'number'}
+ ],
+ return => {
+ desc => q/summary object per org unit in the set, where the set
+ includes the context org unit and all parent org units.
+ Object includes the keys "transcendant", "count", "org_unit", "depth",
+ "unshadow", "available". Each is a count, except "org_unit" which is
+ the context org unit and "depth" which is the depth of the context org unit
+ /,
+ type => 'array'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "record_id_to_copy_count",
+ api_name => "open-ils.search.biblio.record.copy_count.staff",
+ authoritative => 1,
+ signature => {
+ desc => q/Returns a copy summary for the given record for the context org
+ unit and all ancestor org units/,
+ params => [
+ {desc => 'Context org unit id', type => 'number'},
+ {desc => 'Record ID', type => 'number'}
+ ],
+ return => {
+ desc => q/summary object per org unit in the set, where the set
+ includes the context org unit and all parent org units.
+ Object includes the keys "transcendant", "count", "org_unit", "depth",
+ "unshadow", "available". Each is a count, except "org_unit" which is
+ the context org unit and "depth" which is the depth of the context org unit
+ /,
+ type => 'array'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "record_id_to_copy_count",
+ api_name => "open-ils.search.biblio.metarecord.copy_count",
+ signature => {
+ desc => q/Returns a copy summary for the given record for the context org
+ unit and all ancestor org units/,
+ params => [
+ {desc => 'Context org unit id', type => 'number'},
+ {desc => 'Record ID', type => 'number'}
+ ],
+ return => {
+ desc => q/summary object per org unit in the set, where the set
+ includes the context org unit and all parent org units.
+ Object includes the keys "transcendant", "count", "org_unit", "depth",
+ "unshadow", "available". Each is a count, except "org_unit" which is
+ the context org unit and "depth" which is the depth of the context org unit
+ /,
+ type => 'array'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => "record_id_to_copy_count",
+ api_name => "open-ils.search.biblio.metarecord.copy_count.staff",
+ signature => {
+ desc => q/Returns a copy summary for the given record for the context org
+ unit and all ancestor org units/,
+ params => [
+ {desc => 'Context org unit id', type => 'number'},
+ {desc => 'Record ID', type => 'number'}
+ ],
+ return => {
+ desc => q/summary object per org unit in the set, where the set
+ includes the context org unit and all parent org units.
+ Object includes the keys "transcendant", "count", "org_unit", "depth",
+ "unshadow", "available". Each is a count, except "org_unit" which is
+ the context org unit and "depth" which is the depth of the context org
+ unit. "depth" is always -1 when the count from a lasso search is
+ performed, since depth doesn't mean anything in a lasso context.
+ /,
+ type => 'array'
+ }
+ }
+);
+
+sub record_id_to_copy_count {
+ my( $self, $client, $org_id, $record_id ) = @_;
+
+ return [] unless $record_id;
+
+ my $key = $self->api_name =~ /metarecord/ ? 'metarecord' : 'record';
+ my $staff = $self->api_name =~ /staff/ ? 't' : 'f';
+
+ my $data = $U->cstorereq(
+ "open-ils.cstore.json_query.atomic",
+ { from => ['asset.' . $key . '_copy_count' => $org_id => $record_id => $staff] }
+ );
+
+ my @count;
+ for my $d ( @$data ) { # fix up the key name change required by stored-proc version
+ $$d{count} = delete $$d{visible};
+ push @count, $d;
+ }
+
+ return [ sort { $a->{depth} <=> $b->{depth} } @count ];
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_search_tcn",
+ api_name => "open-ils.search.biblio.tcn",
+ argc => 1,
+ signature => {
+ desc => "Retrieve related record ID(s) given a TCN",
+ params => [
+ { desc => 'TCN', type => 'string' },
+ { desc => 'Flag indicating to include deleted records', type => 'string' }
+ ],
+ return => {
+ desc => 'Results object like: { "count": $i, "ids": [...] }',
+ type => 'object'
+ }
+ }
+
+);
+
+sub biblio_search_tcn {
+
+ my( $self, $client, $tcn, $include_deleted ) = @_;
+
+ $tcn =~ s/^\s+|\s+$//og;
+
+ my $e = new_editor();
+ my $search = {tcn_value => $tcn};
+ $search->{deleted} = 'f' unless $include_deleted;
+ my $recs = $e->search_biblio_record_entry( $search, {idlist =>1} );
+
+ return { count => scalar(@$recs), ids => $recs };
+}
+
+
+# --------------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => "biblio_barcode_to_copy",
+ api_name => "open-ils.search.asset.copy.find_by_barcode",
+);
+sub biblio_barcode_to_copy {
+ my( $self, $client, $barcode ) = @_;
+ my( $copy, $evt ) = $U->fetch_copy_by_barcode($barcode);
+ return $evt if $evt;
+ return $copy;
+}
+
+__PACKAGE__->register_method(
+ method => "biblio_id_to_copy",
+ api_name => "open-ils.search.asset.copy.batch.retrieve",
+);
+sub biblio_id_to_copy {
+ my( $self, $client, $ids ) = @_;
+ $logger->info("Fetching copies @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.asset.copy.search.atomic", { id => $ids } );
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_id_to_uris",
+ api_name=> "open-ils.search.asset.uri.retrieve_by_bib",
+ argc => 2,
+ stream => 1,
+ signature => q#
+ @param BibID Which bib record contains the URIs
+ @param OrgID Where to look for URIs
+ @param OrgDepth Range adjustment for OrgID
+ @return A stream or list of 'auri' objects
+ #
+
+);
+sub biblio_id_to_uris {
+ my( $self, $client, $bib, $org, $depth ) = @_;
+ die "Org ID required" unless defined($org);
+ die "Bib ID required" unless defined($bib);
+
+ my @params;
+ push @params, $depth if (defined $depth);
+
+ my $ids = $U->cstorereq( "open-ils.cstore.json_query.atomic",
+ { select => { auri => [ 'id' ] },
+ from => {
+ acn => {
+ auricnm => {
+ field => 'call_number',
+ fkey => 'id',
+ join => {
+ auri => {
+ field => 'id',
+ fkey => 'uri',
+ filter => { active => 't' }
+ }
+ }
+ }
+ }
+ },
+ where => {
+ '+acn' => {
+ record => $bib,
+ owning_lib => {
+ in => {
+ select => { aou => [ { column => 'id', transform => 'actor.org_unit_descendants', params => \@params, result_field => 'id' } ] },
+ from => 'aou',
+ where => { id => $org },
+ distinct=> 1
+ }
+ }
+ }
+ },
+ distinct=> 1,
+ }
+ );
+
+ my $uris = $U->cstorereq(
+ "open-ils.cstore.direct.asset.uri.search.atomic",
+ { id => [ map { (values %$_) } @$ids ] }
+ );
+
+ $client->respond($_) for (@$uris);
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "copy_retrieve",
+ api_name => "open-ils.search.asset.copy.retrieve",
+ argc => 1,
+ signature => {
+ desc => 'Retrieve a copy object based on the Copy ID',
+ params => [
+ { desc => 'Copy ID', type => 'number'}
+ ],
+ return => {
+ desc => 'Copy object, event on error'
+ }
+ }
+);
+
+sub copy_retrieve {
+ my( $self, $client, $cid ) = @_;
+ my( $copy, $evt ) = $U->fetch_copy($cid);
+ return $evt || $copy;
+}
+
+__PACKAGE__->register_method(
+ method => "volume_retrieve",
+ api_name => "open-ils.search.asset.call_number.retrieve"
+);
+sub volume_retrieve {
+ my( $self, $client, $vid ) = @_;
+ my $e = new_editor();
+ my $vol = $e->retrieve_asset_call_number($vid) or return $e->event;
+ return $vol;
+}
+
+__PACKAGE__->register_method(
+ method => "fleshed_copy_retrieve_batch",
+ api_name => "open-ils.search.asset.copy.fleshed.batch.retrieve",
+ authoritative => 1,
+);
+
+sub fleshed_copy_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+ $logger->info("Fetching fleshed copies @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.asset.copy.search.atomic",
+ { id => $ids },
+ { flesh => 1,
+ flesh_fields => { acp => [ qw/ circ_lib location status stat_cat_entries / ] }
+ });
+}
+
+
+__PACKAGE__->register_method(
+ method => "fleshed_copy_retrieve",
+ api_name => "open-ils.search.asset.copy.fleshed.retrieve",
+);
+
+sub fleshed_copy_retrieve {
+ my( $self, $client, $id ) = @_;
+ my( $c, $e) = $U->fetch_fleshed_copy($id);
+ return $e || $c;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fleshed_by_barcode',
+ api_name => "open-ils.search.asset.copy.fleshed2.find_by_barcode",
+ authoritative => 1,
+);
+sub fleshed_by_barcode {
+ my( $self, $conn, $barcode ) = @_;
+ my $e = new_editor();
+ my $copyid = $e->search_asset_copy(
+ {barcode => $barcode, deleted => 'f'}, {idlist=>1})->[0]
+ or return $e->event;
+ return fleshed_copy_retrieve2( $self, $conn, $copyid);
+}
+
+
+__PACKAGE__->register_method(
+ method => "fleshed_copy_retrieve2",
+ api_name => "open-ils.search.asset.copy.fleshed2.retrieve",
+ authoritative => 1,
+);
+
+sub fleshed_copy_retrieve2 {
+ my( $self, $client, $id ) = @_;
+ my $e = new_editor();
+ my $copy = $e->retrieve_asset_copy(
+ [
+ $id,
+ {
+ flesh => 2,
+ flesh_fields => {
+ acp => [
+ qw/ location status stat_cat_entry_copy_maps notes age_protect /
+ ],
+ ascecm => [qw/ stat_cat stat_cat_entry /],
+ }
+ }
+ ]
+ ) or return $e->event;
+
+ # For backwards compatibility
+ #$copy->stat_cat_entries($copy->stat_cat_entry_copy_maps);
+
+ if( $copy->status->id == OILS_COPY_STATUS_CHECKED_OUT ) {
+ $copy->circulations(
+ $e->search_action_circulation(
+ [
+ { target_copy => $copy->id },
+ {
+ order_by => { circ => 'xact_start desc' },
+ limit => 1
+ }
+ ]
+ )
+ );
+ }
+
+ return $copy;
+}
+
+
+__PACKAGE__->register_method(
+ method => 'flesh_copy_custom',
+ api_name => 'open-ils.search.asset.copy.fleshed.custom',
+ authoritative => 1,
+);
+
+sub flesh_copy_custom {
+ my( $self, $conn, $copyid, $fields ) = @_;
+ my $e = new_editor();
+ my $copy = $e->retrieve_asset_copy(
+ [
+ $copyid,
+ {
+ flesh => 1,
+ flesh_fields => {
+ acp => $fields,
+ }
+ }
+ ]
+ ) or return $e->event;
+ return $copy;
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_barcode_to_title",
+ api_name => "open-ils.search.biblio.find_by_barcode",
+);
+
+sub biblio_barcode_to_title {
+ my( $self, $client, $barcode ) = @_;
+
+ my $title = $apputils->simple_scalar_request(
+ "open-ils.storage",
+ "open-ils.storage.biblio.record_entry.retrieve_by_barcode", $barcode );
+
+ return { ids => [ $title->id ], count => 1 } if $title;
+ return { count => 0 };
+}
+
+__PACKAGE__->register_method(
+ method => 'title_id_by_item_barcode',
+ api_name => 'open-ils.search.bib_id.by_barcode',
+ authoritative => 1,
+ signature => {
+ desc => 'Retrieve copy object with fleshed record, given the barcode',
+ params => [
+ { desc => 'Item barcode', type => 'string' }
+ ],
+ return => {
+ desc => 'Asset copy object with fleshed record and callnumber, or event on error or null set'
+ }
+ }
+);
+
+sub title_id_by_item_barcode {
+ my( $self, $conn, $barcode ) = @_;
+ my $e = new_editor();
+ my $copies = $e->search_asset_copy(
+ [
+ { deleted => 'f', barcode => $barcode },
+ {
+ flesh => 2,
+ flesh_fields => {
+ acp => [ 'call_number' ],
+ acn => [ 'record' ]
+ }
+ }
+ ]
+ );
+
+ return $e->event unless @$copies;
+ return $$copies[0]->call_number->record->id;
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_copy_to_mods",
+ api_name => "open-ils.search.biblio.copy.mods.retrieve",
+);
+
+# takes a copy object and returns it fleshed mods object
+sub biblio_copy_to_mods {
+ my( $self, $client, $copy ) = @_;
+
+ my $volume = $U->cstorereq(
+ "open-ils.cstore.direct.asset.call_number.retrieve",
+ $copy->call_number() );
+
+ my $mods = _records_to_mods($volume->record());
+ $mods = shift @$mods;
+ $volume->copies([$copy]);
+ push @{$mods->call_numbers()}, $volume;
+
+ return $mods;
+}
+
+
+=head1 NAME
+
+OpenILS::Application::Search::Biblio
+
+=head1 DESCRIPTION
+
+=head2 API METHODS
+
+=head3 open-ils.search.biblio.multiclass.query (arghash, query, docache)
+
+For arghash and docache, see B<open-ils.search.biblio.multiclass>.
+
+The query argument is a string, but built like a hash with key: value pairs.
+Recognized search keys include:
+
+ keyword (kw) - search keyword(s) *
+ author (au) - search author(s) *
+ name (au) - same as author *
+ title (ti) - search title *
+ subject (su) - search subject *
+ series (se) - search series *
+ lang - limit by language (specifiy multiple langs with lang:l1 lang:l2 ...)
+ site - search at specified org unit, corresponds to actor.org_unit.shortname
+ sort - sort type (title, author, pubdate)
+ dir - sort direction (asc, desc)
+ available - if set to anything other than "false" or "0", limits to available items
+
+* Searching keyword, author, title, subject, and series supports additional search
+subclasses, specified with a "|". For example, C<title|proper:gone with the wind>.
+
+For more, see B<config.metabib_field>.
+
+=cut
+
+foreach (qw/open-ils.search.biblio.multiclass.query
+ open-ils.search.biblio.multiclass.query.staff
+ open-ils.search.metabib.multiclass.query
+ open-ils.search.metabib.multiclass.query.staff/)
+{
+__PACKAGE__->register_method(
+ api_name => $_,
+ method => 'multiclass_query',
+ signature => {
+ desc => 'Perform a search query. The .staff version of the call includes otherwise hidden hits.',
+ params => [
+ {name => 'arghash', desc => 'Arg hash (see open-ils.search.biblio.multiclass)', type => 'object'},
+ {name => 'query', desc => 'Raw human-readable query (see perldoc '. __PACKAGE__ .')', type => 'string'},
+ {name => 'docache', desc => 'Flag for caching (see open-ils.search.biblio.multiclass)', type => 'object'},
+ ],
+ return => {
+ desc => 'Search results from query, like: { "count" : $count, "ids" : [ [ $id, $relevancy, $total ], ...] }',
+ type => 'object', # TODO: update as miker's new elements are included
+ }
+ }
+);
+}
+
+sub multiclass_query {
+ my($self, $conn, $arghash, $query, $docache) = @_;
+
+ $logger->debug("initial search query => $query");
+ my $orig_query = $query;
+
+ $query =~ s/\+/ /go;
+ $query =~ s/'/ /go;
+ $query =~ s/^\s+//go;
+
+ # convert convenience classes (e.g. kw for keyword) to the full class name
+ # ensure that the convenience class isn't part of a word (e.g. 'playhouse')
+ $query =~ s/(^|\s)kw(:|\|)/$1keyword$2/go;
+ $query =~ s/(^|\s)ti(:|\|)/$1title$2/go;
+ $query =~ s/(^|\s)au(:|\|)/$1author$2/go;
+ $query =~ s/(^|\s)su(:|\|)/$1subject$2/go;
+ $query =~ s/(^|\s)se(:|\|)/$1series$2/go;
+ $query =~ s/(^|\s)name(:|\|)/$1author$2/og;
+
+ $logger->debug("cleansed query string => $query");
+ my $search = {};
+
+ my $simple_class_re = qr/((?:\w+(?:\|\w+)?):[^:]+?)$/;
+ my $class_list_re = qr/(?:keyword|title|author|subject|series)/;
+ my $modifier_list_re = qr/(?:site|dir|sort|lang|available)/;
+
+ my $tmp_value = '';
+ while ($query =~ s/$simple_class_re//so) {
+
+ my $qpart = $1;
+ my $where = index($qpart,':');
+ my $type = substr($qpart, 0, $where++);
+ my $value = substr($qpart, $where);
+
+ if ($type !~ /^(?:$class_list_re|$modifier_list_re)/o) {
+ $tmp_value = "$qpart $tmp_value";
+ next;
+ }
+
+ if ($type =~ /$class_list_re/o ) {
+ $value .= $tmp_value;
+ $tmp_value = '';
+ }
+
+ next unless $type and $value;
+
+ $value =~ s/^\s*//og;
+ $value =~ s/\s*$//og;
+ $type = 'sort_dir' if $type eq 'dir';
+
+ if($type eq 'site') {
+ # 'site' is the org shortname. when using this, we also want
+ # to search at the requested org's depth
+ my $e = new_editor();
+ if(my $org = $e->search_actor_org_unit({shortname => $value})->[0]) {
+ $arghash->{org_unit} = $org->id if $org;
+ $arghash->{depth} = $e->retrieve_actor_org_unit_type($org->ou_type)->depth;
+ } else {
+ $logger->warn("'site:' query used on invalid org shortname: $value ... ignoring");
+ }
+
+ } elsif($type eq 'available') {
+ # limit to available
+ $arghash->{available} = 1 unless $value eq 'false' or $value eq '0';
+
+ } elsif($type eq 'lang') {
+ # collect languages into an array of languages
+ $arghash->{language} = [] unless $arghash->{language};
+ push(@{$arghash->{language}}, $value);
+
+ } elsif($type =~ /^sort/o) {
+ # sort and sort_dir modifiers
+ $arghash->{$type} = $value;
+
+ } else {
+ # append the search term to the term under construction
+ $search->{$type} = {} unless $search->{$type};
+ $search->{$type}->{term} =
+ ($search->{$type}->{term}) ? $search->{$type}->{term} . " $value" : $value;
+ }
+ }
+
+ $query .= " $tmp_value";
+ $query =~ s/\s+/ /go;
+ $query =~ s/^\s+//go;
+ $query =~ s/\s+$//go;
+
+ my $type = $arghash->{default_class} || 'keyword';
+ $type = ($type eq '-') ? 'keyword' : $type;
+ $type = ($type !~ /^(title|author|keyword|subject|series)(?:\|\w+)?$/o) ? 'keyword' : $type;
+
+ if($query) {
+ # This is the front part of the string before any special tokens were
+ # parsed OR colon-separated strings that do not denote a class.
+ # Add this data to the default search class
+ $search->{$type} = {} unless $search->{$type};
+ $search->{$type}->{term} =
+ ($search->{$type}->{term}) ? $search->{$type}->{term} . " $query" : $query;
+ }
+ my $real_search = $arghash->{searches} = { $type => { term => $orig_query } };
+
+ # capture the original limit because the search method alters the limit internally
+ my $ol = $arghash->{limit};
+
+ my $sclient = OpenSRF::Utils::SettingsClient->new;
+
+ (my $method = $self->api_name) =~ s/\.query//o;
+
+ $method =~ s/multiclass/multiclass.staged/
+ if $sclient->config_value(apps => 'open-ils.search',
+ app_settings => 'use_staged_search') =~ /true/i;
+
+ # XXX This stops the session locale from doing the right thing.
+ # XXX Revisit this and have it translate to a lang instead of a locale.
+ #$arghash->{preferred_language} = $U->get_org_locale($arghash->{org_unit})
+ # unless $arghash->{preferred_language};
+
+ $method = $self->method_lookup($method);
+ my ($data) = $method->run($arghash, $docache);
+
+ $arghash->{searches} = $search if (!$data->{complex_query});
+
+ $arghash->{limit} = $ol if $ol;
+ $data->{compiled_search} = $arghash;
+ $data->{query} = $orig_query;
+
+ $logger->info("compiled search is " . OpenSRF::Utils::JSON->perl2JSON($arghash));
+
+ return $data;
+}
+
+__PACKAGE__->register_method(
+ method => 'cat_search_z_style_wrapper',
+ api_name => 'open-ils.search.biblio.zstyle',
+ stream => 1,
+ signature => q/@see open-ils.search.biblio.multiclass/
+);
+
+__PACKAGE__->register_method(
+ method => 'cat_search_z_style_wrapper',
+ api_name => 'open-ils.search.biblio.zstyle.staff',
+ stream => 1,
+ signature => q/@see open-ils.search.biblio.multiclass/
+);
+
+sub cat_search_z_style_wrapper {
+ my $self = shift;
+ my $client = shift;
+ my $authtoken = shift;
+ my $args = shift;
+
+ my $cstore = OpenSRF::AppSession->connect('open-ils.cstore');
+
+ my $ou = $cstore->request(
+ 'open-ils.cstore.direct.actor.org_unit.search',
+ { parent_ou => undef }
+ )->gather(1);
+
+ my $result = { service => 'native-evergreen-catalog', records => [] };
+ my $searchhash = { limit => $$args{limit}, offset => $$args{offset}, org_unit => $ou->id };
+
+ $$searchhash{searches}{title}{term} = $$args{search}{title} if $$args{search}{title};
+ $$searchhash{searches}{author}{term} = $$args{search}{author} if $$args{search}{author};
+ $$searchhash{searches}{subject}{term} = $$args{search}{subject} if $$args{search}{subject};
+ $$searchhash{searches}{keyword}{term} = $$args{search}{keyword} if $$args{search}{keyword};
+
+ $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{tcn} if $$args{search}{tcn};
+ $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{isbn} if $$args{search}{isbn};
+ $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{issn} if $$args{search}{issn};
+ $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{publisher} if $$args{search}{publisher};
+ $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{pubdate} if $$args{search}{pubdate};
+ $$searchhash{searches}{keyword}{term} .= join ' ', $$searchhash{searches}{keyword}{term}, $$args{search}{item_type} if $$args{search}{item_type};
+
+ my $list = the_quest_for_knowledge( $self, $client, $searchhash );
+
+ if ($list->{count} > 0) {
+ $result->{count} = $list->{count};
+
+ my $records = $cstore->request(
+ 'open-ils.cstore.direct.biblio.record_entry.search.atomic',
+ { id => [ map { ( $_->[0] ) } @{$list->{ids}} ] }
+ )->gather(1);
+
+ for my $rec ( @$records ) {
+
+ my $u = OpenILS::Utils::ModsParser->new();
+ $u->start_mods_batch( $rec->marc );
+ my $mods = $u->finish_mods_batch();
+
+ push @{ $result->{records} }, { mvr => $mods, marcxml => $rec->marc, bibid => $rec->id };
+
+ }
+
+ }
+
+ $cstore->disconnect();
+ return $result;
+}
+
+# ----------------------------------------------------------------------------
+# These are the main OPAC search methods
+# ----------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => 'the_quest_for_knowledge',
+ api_name => 'open-ils.search.biblio.multiclass',
+ signature => {
+ desc => "Performs a multi class biblio or metabib search",
+ params => [
+ {
+ desc => "A search hash with keys: "
+ . "searches, org_unit, depth, limit, offset, format, sort, sort_dir. "
+ . "See perldoc " . __PACKAGE__ . " for more detail",
+ type => 'object',
+ },
+ {
+ desc => "A flag to enable/disable searching and saving results in cache (default OFF)",
+ type => 'string',
+ }
+ ],
+ return => {
+ desc => 'An object of the form: '
+ . '{ "count" : $count, "ids" : [ [ $id, $relevancy, $total ], ...] }',
+ }
+ }
+);
+
+=head3 open-ils.search.biblio.multiclass (search-hash, docache)
+
+The search-hash argument can have the following elements:
+
+ searches: { "$class" : "$value", ...} [REQUIRED]
+ org_unit: The org id to focus the search at
+ depth : The org depth
+ limit : The search limit default: 10
+ offset : The search offset default: 0
+ format : The MARC format
+ sort : What field to sort the results on? [ author | title | pubdate ]
+ sort_dir: What direction do we sort? [ asc | desc ]
+ tag_circulated_records : Boolean, if true, records that are in the user's visible checkout history
+ will be tagged with an additional value ("1") as the last value in the record ID array for
+ each record. Requires the 'authtoken'
+ authtoken : Authentication token string; When actions are performed that require a user login
+ (e.g. tagging circulated records), the authentication token is required
+
+The searches element is required, must have a hashref value, and the hashref must contain at least one
+of the following classes as a key:
+
+ title
+ author
+ subject
+ series
+ keyword
+
+The value paired with a key is the associated search string.
+
+The docache argument enables/disables searching and saving results in cache (default OFF).
+
+The return object, if successful, will look like:
+
+ { "count" : $count, "ids" : [ [ $id, $relevancy, $total ], ...] }
+
+=cut
+
+__PACKAGE__->register_method(
+ method => 'the_quest_for_knowledge',
+ api_name => 'open-ils.search.biblio.multiclass.staff',
+ signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass/
+);
+__PACKAGE__->register_method(
+ method => 'the_quest_for_knowledge',
+ api_name => 'open-ils.search.metabib.multiclass',
+ signature => q/@see open-ils.search.biblio.multiclass/
+);
+__PACKAGE__->register_method(
+ method => 'the_quest_for_knowledge',
+ api_name => 'open-ils.search.metabib.multiclass.staff',
+ signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass/
+);
+
+sub the_quest_for_knowledge {
+ my( $self, $conn, $searchhash, $docache ) = @_;
+
+ return { count => 0 } unless $searchhash and
+ ref $searchhash->{searches} eq 'HASH';
+
+ my $method = 'open-ils.storage.biblio.multiclass.search_fts';
+ my $ismeta = 0;
+ my @recs;
+
+ if($self->api_name =~ /metabib/) {
+ $ismeta = 1;
+ $method =~ s/biblio/metabib/o;
+ }
+
+ # do some simple sanity checking
+ if(!$searchhash->{searches} or
+ ( !grep { /^(?:title|author|subject|series|keyword)/ } keys %{$searchhash->{searches}} ) ) {
+ return { count => 0 };
+ }
+
+ my $offset = $searchhash->{offset} || 0; # user value or default in local var now
+ my $limit = $searchhash->{limit} || 10; # user value or default in local var now
+ my $end = $offset + $limit - 1;
+
+ my $maxlimit = 5000;
+ $searchhash->{offset} = 0; # possible user value overwritten in hash
+ $searchhash->{limit} = $maxlimit; # possible user value overwritten in hash
+
+ return { count => 0 } if $offset > $maxlimit;
+
+ my @search;
+ push( @search, ($_ => $$searchhash{$_})) for (sort keys %$searchhash);
+ my $s = OpenSRF::Utils::JSON->perl2JSON(\@search);
+ my $ckey = $pfx . md5_hex($method . $s);
+
+ $logger->info("bib search for: $s");
+
+ $searchhash->{limit} -= $offset;
+
+
+ my $trim = 0;
+ my $result = ($docache) ? search_cache($ckey, $offset, $limit) : undef;
+
+ if(!$result) {
+
+ $method .= ".staff" if($self->api_name =~ /staff/);
+ $method .= ".atomic";
+
+ for (keys %$searchhash) {
+ delete $$searchhash{$_}
+ unless defined $$searchhash{$_};
+ }
+
+ $result = $U->storagereq( $method, %$searchhash );
+ $trim = 1;
+
+ } else {
+ $docache = 0; # results came FROM cache, so we don't write back
+ }
+
+ return {count => 0} unless ($result && $$result[0]);
+
+ @recs = @$result;
+
+ my $count = ($ismeta) ? $result->[0]->[3] : $result->[0]->[2];
+
+ if($docache) {
+ # If we didn't get this data from the cache, put it into the cache
+ # then return the correct offset of records
+ $logger->debug("putting search cache $ckey\n");
+ put_cache($ckey, $count, \@recs);
+ }
+
+ if($trim) {
+ # if we have the full set of data, trim out
+ # the requested chunk based on limit and offset
+ my @t;
+ for ($offset..$end) {
+ last unless $recs[$_];
+ push(@t, $recs[$_]);
+ }
+ @recs = @t;
+ }
+
+ return { ids => \@recs, count => $count };
+}
+
+
+__PACKAGE__->register_method(
+ method => 'staged_search',
+ api_name => 'open-ils.search.biblio.multiclass.staged',
+ signature => {
+ desc => 'Staged search filters out unavailable items. This means that it relies on an estimation strategy for determining ' .
+ 'how big a "raw" search result chunk (i.e. a "superpage") to obtain prior to filtering. See "estimation_strategy" in your SRF config.',
+ params => [
+ {
+ desc => "A search hash with keys: "
+ . "searches, limit, offset. The others are optional, but the 'searches' key/value pair is required, with the value being a hashref. "
+ . "See perldoc " . __PACKAGE__ . " for more detail",
+ type => 'object',
+ },
+ {
+ desc => "A flag to enable/disable searching and saving results in cache, including facets (default OFF)",
+ type => 'string',
+ }
+ ],
+ return => {
+ desc => 'Hash with keys: count, core_limit, superpage_size, superpage_summary, facet_key, ids. '
+ . 'The superpage_summary value is a hashref that includes keys: estimated_hit_count, visible.',
+ type => 'object',
+ }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'staged_search',
+ api_name => 'open-ils.search.biblio.multiclass.staged.staff',
+ signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass.staged/
+);
+__PACKAGE__->register_method(
+ method => 'staged_search',
+ api_name => 'open-ils.search.metabib.multiclass.staged',
+ signature => q/@see open-ils.search.biblio.multiclass.staged/
+);
+__PACKAGE__->register_method(
+ method => 'staged_search',
+ api_name => 'open-ils.search.metabib.multiclass.staged.staff',
+ signature => q/The .staff search includes hidden bibs, hidden items and bibs with no items. Otherwise, @see open-ils.search.biblio.multiclass.staged/
+);
+
+sub staged_search {
+ my($self, $conn, $search_hash, $docache) = @_;
+
+ my $IAmMetabib = ($self->api_name =~ /metabib/) ? 1 : 0;
+
+ my $method = $IAmMetabib?
+ 'open-ils.storage.metabib.multiclass.staged.search_fts':
+ 'open-ils.storage.biblio.multiclass.staged.search_fts';
+
+ $method .= '.staff' if $self->api_name =~ /staff$/;
+ $method .= '.atomic';
+
+ return {count => 0} unless (
+ $search_hash and
+ $search_hash->{searches} and
+ scalar( keys %{$search_hash->{searches}} ));
+
+ my $search_duration;
+ my $user_offset = $search_hash->{offset} || 0; # user-specified offset
+ my $user_limit = $search_hash->{limit} || 10;
+ my $ignore_facet_classes = $search_hash->{ignore_facet_classes};
+ $user_offset = ($user_offset >= 0) ? $user_offset : 0;
+ $user_limit = ($user_limit >= 0) ? $user_limit : 10;
+
+
+ # we're grabbing results on a per-superpage basis, which means the
+ # limit and offset should coincide with superpage boundaries
+ $search_hash->{offset} = 0;
+ $search_hash->{limit} = $superpage_size;
+
+ # force a well-known check_limit
+ $search_hash->{check_limit} = $superpage_size;
+ # restrict total tested to superpage size * number of superpages
+ $search_hash->{core_limit} = $superpage_size * $max_superpages;
+
+ # Set the configured estimation strategy, defaults to 'inclusion'.
+ my $estimation_strategy = OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value(
+ apps => 'open-ils.search', app_settings => 'estimation_strategy'
+ ) || 'inclusion';
+ $search_hash->{estimation_strategy} = $estimation_strategy;
+
+ # pull any existing results from the cache
+ my $key = search_cache_key($method, $search_hash);
+ my $facet_key = $key.'_facets';
+ my $cache_data = $cache->get_cache($key) || {};
+
+ # keep retrieving results until we find enough to
+ # fulfill the user-specified limit and offset
+ my $all_results = [];
+ my $page; # current superpage
+ my $est_hit_count = 0;
+ my $current_page_summary = {};
+ my $global_summary = {checked => 0, visible => 0, excluded => 0, deleted => 0, total => 0};
+ my $is_real_hit_count = 0;
+ my $new_ids = [];
+
+ for($page = 0; $page < $max_superpages; $page++) {
+
+ my $data = $cache_data->{$page};
+ my $results;
+ my $summary;
+
+ $logger->debug("staged search: analyzing superpage $page");
+
+ if($data) {
+ # this window of results is already cached
+ $logger->debug("staged search: found cached results");
+ $summary = $data->{summary};
+ $results = $data->{results};
+
+ } else {
+ # retrieve the window of results from the database
+ $logger->debug("staged search: fetching results from the database");
+ $search_hash->{skip_check} = $page * $superpage_size;
+ my $start = time;
+ $results = $U->storagereq($method, %$search_hash);
+ $search_duration = time - $start;
+ $logger->info("staged search: DB call took $search_duration seconds and returned ".scalar(@$results)." rows, including summary");
+ $summary = shift(@$results) if $results;
+
+ unless($summary) {
+ $logger->info("search timed out: duration=$search_duration: params=".
+ OpenSRF::Utils::JSON->perl2JSON($search_hash));
+ return {count => 0};
+ }
+
+ my $hc = $summary->{estimated_hit_count} || $summary->{visible};
+ if($hc == 0) {
+ $logger->info("search returned 0 results: duration=$search_duration: params=".
+ OpenSRF::Utils::JSON->perl2JSON($search_hash));
+ }
+
+ # Create backwards-compatible result structures
+ if($IAmMetabib) {
+ $results = [map {[$_->{id}, $_->{rel}, $_->{record}]} @$results];
+ } else {
+ $results = [map {[$_->{id}]} @$results];
+ }
+
+ tag_circulated_records($search_hash->{authtoken}, $results, $IAmMetabib)
+ if $search_hash->{tag_circulated_records} and $search_hash->{authtoken};
+
+ push @$new_ids, grep {defined($_)} map {$_->[0]} @$results;
+ $results = [grep {defined $_->[0]} @$results];
+ cache_staged_search_page($key, $page, $summary, $results) if $docache;
+ }
+
+ $current_page_summary = $summary;
+
+ # add the new set of results to the set under construction
+ push(@$all_results, @$results);
+
+ my $current_count = scalar(@$all_results);
+
+ $est_hit_count = $summary->{estimated_hit_count} || $summary->{visible}
+ if $page == 0;
+
+ $logger->debug("staged search: located $current_count, with estimated hits=".
+ $summary->{estimated_hit_count}." : visible=".$summary->{visible}.", checked=".$summary->{checked});
+
+ if (defined($summary->{estimated_hit_count})) {
+ foreach (qw/ checked visible excluded deleted /) {
+ $global_summary->{$_} += $summary->{$_};
+ }
+ $global_summary->{total} = $summary->{total};
+ }
+
+ # we've found all the possible hits
+ last if $current_count == $summary->{visible}
+ and not defined $summary->{estimated_hit_count};
+
+ # we've found enough results to satisfy the requested limit/offset
+ last if $current_count >= ($user_limit + $user_offset);
+
+ # we've scanned all possible hits
+ if($summary->{checked} < $superpage_size) {
+ $est_hit_count = scalar(@$all_results);
+ # we have all possible results in hand, so we know the final hit count
+ $is_real_hit_count = 1;
+ last;
+ }
+ }
+
+ my @results = grep {defined $_} @$all_results[$user_offset..($user_offset + $user_limit - 1)];
+
+ # refine the estimate if we have more than one superpage
+ if ($page > 0 and not $is_real_hit_count) {
+ if ($global_summary->{checked} >= $global_summary->{total}) {
+ $est_hit_count = $global_summary->{visible};
+ } else {
+ my $updated_hit_count = $U->storagereq(
+ 'open-ils.storage.fts_paging_estimate',
+ $global_summary->{checked},
+ $global_summary->{visible},
+ $global_summary->{excluded},
+ $global_summary->{deleted},
+ $global_summary->{total}
+ );
+ $est_hit_count = $updated_hit_count->{$estimation_strategy};
+ }
+ }
+
+ $conn->respond_complete(
+ {
+ count => $est_hit_count,
+ core_limit => $search_hash->{core_limit},
+ superpage_size => $search_hash->{check_limit},
+ superpage_summary => $current_page_summary,
+ facet_key => $facet_key,
+ ids => \@results
+ }
+ );
+
+ cache_facets($facet_key, $new_ids, $IAmMetabib, $ignore_facet_classes) if $docache;
+
+ return undef;
+}
+
+sub tag_circulated_records {
+ my ($auth, $results, $metabib) = @_;
+ my $e = new_editor(authtoken => $auth);
+ return $results unless $e->checkauth;
+
+ my $query = {
+ select => { acn => [{ column => 'record', alias => 'tagme' }] },
+ from => { acp => 'acn' },
+ where => { id => { in => { from => ['action.usr_visible_circ_copies', $e->requestor->id] } } },
+ distinct => 1
+ };
+
+ if ($metabib) {
+ $query = {
+ select => { mmsm => [{ column => 'metarecord', alias => 'tagme' }] },
+ from => 'mmsm',
+ where => { source => { in => $query } },
+ distinct => 1
+ };
+ }
+
+ # Give me the distinct set of bib records that exist in the user's visible circulation history
+ my $circ_recs = $e->json_query( $query );
+
+ # if the record appears in the circ history, push a 1 onto
+ # the rec array structure to indicate truthiness
+ for my $rec (@$results) {
+ push(@$rec, 1) if grep { $_->{tagme} eq $$rec[0] } @$circ_recs;
+ }
+
+ $results
+}
+
+# creates a unique token to represent the query in the cache
+sub search_cache_key {
+ my $method = shift;
+ my $search_hash = shift;
+ my @sorted;
+ for my $key (sort keys %$search_hash) {
+ push(@sorted, ($key => $$search_hash{$key}))
+ unless $key eq 'limit' or
+ $key eq 'offset' or
+ $key eq 'skip_check';
+ }
+ my $s = OpenSRF::Utils::JSON->perl2JSON(\@sorted);
+ return $pfx . md5_hex($method . $s);
+}
+
+sub retrieve_cached_facets {
+ my $self = shift;
+ my $client = shift;
+ my $key = shift;
+ my $limit = shift;
+
+ return undef unless ($key and $key =~ /_facets$/);
+
+ my $blob = $cache->get_cache($key) || {};
+
+ my $facets = {};
+ if ($limit) {
+ for my $f ( keys %$blob ) {
+ my @sorted = map{ { $$_[1] => $$_[0] } } sort {$$b[0] <=> $$a[0] || $$a[1] cmp $$b[1]} map { [$$blob{$f}{$_}, $_] } keys %{ $$blob{$f} };
+ @sorted = @sorted[0 .. $limit - 1] if (scalar(@sorted) > $limit);
+ for my $s ( @sorted ) {
+ my ($k) = keys(%$s);
+ my ($v) = values(%$s);
+ $$facets{$f}{$k} = $v;
+ }
+ }
+ } else {
+ $facets = $blob;
+ }
+
+ return $facets;
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_cached_facets",
+ api_name => "open-ils.search.facet_cache.retrieve",
+ signature => {
+ desc => 'Returns facet data derived from a specific search based on a key '.
+ 'generated by open-ils.search.biblio.multiclass.staged and friends.',
+ params => [
+ {
+ desc => "The facet cache key returned with the initial search as the facet_key hash value",
+ type => 'string',
+ }
+ ],
+ return => {
+ desc => 'Two level hash of facet values. Top level key is the facet id defined on the config.metabib_field table. '.
+ 'Second level key is a string facet value. Datum attached to each facet value is the number of distinct records, '.
+ 'or metarecords for a metarecord search, which use that facet value and are visible to the search at the time of '.
+ 'facet retrieval. These counts are calculated for all superpages that have been checked for visibility.',
+ type => 'object',
+ }
+ }
+);
+
+
+sub cache_facets {
+ # add facets for this search to the facet cache
+ my($key, $results, $metabib, $ignore) = @_;
+ my $data = $cache->get_cache($key);
+ $data ||= {};
+
+ if (!ref($ignore)) {
+ $ignore = ['identifier']; # ignore the identifier class by default
+ }
+
+ return undef unless (@$results);
+
+ # The query we're constructing
+ #
+ # select mfae.field as id,
+ # mfae.value,
+ # count(distinct mmrsm.appropriate-id-field )
+ # from metabib.facet_entry mfae
+ # join metabib.metarecord_sourc_map mmrsm on (mfae.source = mmrsm.source)
+ # where mmrsm.appropriate-id-field in IDLIST
+ # group by 1,2;
+
+ my $count_field = $metabib ? 'metarecord' : 'source';
+ my $facets = $U->cstorereq( "open-ils.cstore.json_query.atomic",
+ { select => {
+ mfae => [ { column => 'field', alias => 'id'}, 'value' ],
+ mmrsm => [{
+ transform => 'count',
+ distinct => 1,
+ column => $count_field,
+ alias => 'count',
+ aggregate => 1
+ }]
+ },
+ from => {
+ mfae => {
+ mmrsm => { field => 'source', fkey => 'source' },
+ cmf => { field => 'id', fkey => 'field' }
+ }
+ },
+ where => {
+ '+mmrsm' => { $count_field => $results },
+ '+cmf' => { field_class => { 'not in' => $ignore } }
+ }
+ }
+ );
+
+ for my $facet (@$facets) {
+ next unless ($facet->{value});
+ $data->{$facet->{id}}->{$facet->{value}} += $facet->{count};
+ }
+
+ $logger->info("facet compilation: cached with key=$key");
+
+ $cache->put_cache($key, $data, $cache_timeout);
+}
+
+sub cache_staged_search_page {
+ # puts this set of results into the cache
+ my($key, $page, $summary, $results) = @_;
+ my $data = $cache->get_cache($key);
+ $data ||= {};
+ $data->{$page} = {
+ summary => $summary,
+ results => $results
+ };
+
+ $logger->info("staged search: cached with key=$key, superpage=$page, estimated=".
+ $summary->{estimated_hit_count}.", visible=".$summary->{visible});
+
+ $cache->put_cache($key, $data, $cache_timeout);
+}
+
+sub search_cache {
+
+ my $key = shift;
+ my $offset = shift;
+ my $limit = shift;
+ my $start = $offset;
+ my $end = $offset + $limit - 1;
+
+ $logger->debug("searching cache for $key : $start..$end\n");
+
+ return undef unless $cache;
+ my $data = $cache->get_cache($key);
+
+ return undef unless $data;
+
+ my $count = $data->[0];
+ $data = $data->[1];
+
+ return undef unless $offset < $count;
+
+ my @result;
+ for( my $i = $offset; $i <= $end; $i++ ) {
+ last unless my $d = $$data[$i];
+ push( @result, $d );
+ }
+
+ $logger->debug("search_cache found ".scalar(@result)." items for count=$count, start=$start, end=$end");
+
+ return \@result;
+}
+
+
+sub put_cache {
+ my( $key, $count, $data ) = @_;
+ return undef unless $cache;
+ $logger->debug("search_cache putting ".
+ scalar(@$data)." items at key $key with timeout $cache_timeout");
+ $cache->put_cache($key, [ $count, $data ], $cache_timeout);
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_mrid_to_modsbatch_batch",
+ api_name => "open-ils.search.biblio.metarecord.mods_slim.batch.retrieve"
+);
+
+sub biblio_mrid_to_modsbatch_batch {
+ my( $self, $client, $mrids) = @_;
+ # warn "Performing mrid_to_modsbatch_batch..."; # unconditional warn
+ my @mods;
+ my $method = $self->method_lookup("open-ils.search.biblio.metarecord.mods_slim.retrieve");
+ for my $id (@$mrids) {
+ next unless defined $id;
+ my ($m) = $method->run($id);
+ push @mods, $m;
+ }
+ return \@mods;
+}
+
+
+foreach (qw /open-ils.search.biblio.metarecord.mods_slim.retrieve
+ open-ils.search.biblio.metarecord.mods_slim.retrieve.staff/)
+ {
+ __PACKAGE__->register_method(
+ method => "biblio_mrid_to_modsbatch",
+ api_name => $_,
+ signature => {
+ desc => "Returns the mvr associated with a given metarecod. If none exists, it is created. "
+ . "As usual, the .staff version of this method will include otherwise hidden records.",
+ params => [
+ { desc => 'Metarecord ID', type => 'number' },
+ { desc => '(Optional) Search filters hash with possible keys: format, org, depth', type => 'object' }
+ ],
+ return => {
+ desc => 'MVR Object, event on error',
+ }
+ }
+ );
+}
+
+sub biblio_mrid_to_modsbatch {
+ my( $self, $client, $mrid, $args) = @_;
+
+ # warn "Grabbing mvr for $mrid\n"; # unconditional warn
+
+ my ($mr, $evt) = _grab_metarecord($mrid);
+ return $evt unless $mr;
+
+ my $mvr = biblio_mrid_check_mvr($self, $client, $mr) ||
+ biblio_mrid_make_modsbatch($self, $client, $mr);
+
+ return $mvr unless ref($args);
+
+ # Here we find the lead record appropriate for the given filters
+ # and use that for the title and author of the metarecord
+ my $format = $$args{format};
+ my $org = $$args{org};
+ my $depth = $$args{depth};
+
+ return $mvr unless $format or $org or $depth;
+
+ my $method = "open-ils.storage.ordered.metabib.metarecord.records";
+ $method = "$method.staff" if $self->api_name =~ /staff/o;
+
+ my $rec = $U->storagereq($method, $format, $org, $depth, 1);
+
+ if( my $mods = $U->record_to_mvr($rec) ) {
+
+ $mvr->title( $mods->title );
+ $mvr->author($mods->author);
+ $logger->debug("mods_slim updating title and ".
+ "author in mvr with ".$mods->title." : ".$mods->author);
+ }
+
+ return $mvr;
+}
+
+# converts a metarecord to an mvr
+sub _mr_to_mvr {
+ my $mr = shift;
+ my $perl = OpenSRF::Utils::JSON->JSON2perl($mr->mods());
+ return Fieldmapper::metabib::virtual_record->new($perl);
+}
+
+# checks to see if a metarecord has mods, if so returns true;
+
+__PACKAGE__->register_method(
+ method => "biblio_mrid_check_mvr",
+ api_name => "open-ils.search.biblio.metarecord.mods_slim.check",
+ notes => "Takes a metarecord ID or a metarecord object and returns true "
+ . "if the metarecord already has an mvr associated with it."
+);
+
+sub biblio_mrid_check_mvr {
+ my( $self, $client, $mrid ) = @_;
+ my $mr;
+
+ my $evt;
+ if(ref($mrid)) { $mr = $mrid; }
+ else { ($mr, $evt) = _grab_metarecord($mrid); }
+ return $evt if $evt;
+
+ # warn "Checking mvr for mr " . $mr->id . "\n"; # unconditional warn
+
+ return _mr_to_mvr($mr) if $mr->mods();
+ return undef;
+}
+
+sub _grab_metarecord {
+ my $mrid = shift;
+ #my $e = OpenILS::Utils::Editor->new;
+ my $e = new_editor();
+ my $mr = $e->retrieve_metabib_metarecord($mrid) or return ( undef, $e->event );
+ return ($mr);
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_mrid_make_modsbatch",
+ api_name => "open-ils.search.biblio.metarecord.mods_slim.create",
+ notes => "Takes either a metarecord ID or a metarecord object. "
+ . "Forces the creations of an mvr for the given metarecord. "
+ . "The created mvr is returned."
+);
+
+sub biblio_mrid_make_modsbatch {
+ my( $self, $client, $mrid ) = @_;
+
+ #my $e = OpenILS::Utils::Editor->new;
+ my $e = new_editor();
+
+ my $mr;
+ if( ref($mrid) ) {
+ $mr = $mrid;
+ $mrid = $mr->id;
+ } else {
+ $mr = $e->retrieve_metabib_metarecord($mrid)
+ or return $e->event;
+ }
+
+ my $masterid = $mr->master_record;
+ $logger->info("creating new mods batch for metarecord=$mrid, master record=$masterid");
+
+ my $ids = $U->storagereq(
+ 'open-ils.storage.ordered.metabib.metarecord.records.staff.atomic', $mrid);
+ return undef unless @$ids;
+
+ my $master = $e->retrieve_biblio_record_entry($masterid)
+ or return $e->event;
+
+ # start the mods batch
+ my $u = OpenILS::Utils::ModsParser->new();
+ $u->start_mods_batch( $master->marc );
+
+ # grab all of the sub-records and shove them into the batch
+ my @ids = grep { $_ ne $masterid } @$ids;
+ #my $subrecs = (@ids) ? $e->batch_retrieve_biblio_record_entry(\@ids) : [];
+
+ my $subrecs = [];
+ if(@$ids) {
+ for my $i (@$ids) {
+ my $r = $e->retrieve_biblio_record_entry($i);
+ push( @$subrecs, $r ) if $r;
+ }
+ }
+
+ for(@$subrecs) {
+ $logger->debug("adding record ".$_->id." to mods batch for metarecord=$mrid");
+ $u->push_mods_batch( $_->marc ) if $_->marc;
+ }
+
+
+ # finish up and send to the client
+ my $mods = $u->finish_mods_batch();
+ $mods->doc_id($mrid);
+ $client->respond_complete($mods);
+
+
+ # now update the mods string in the db
+ my $string = OpenSRF::Utils::JSON->perl2JSON($mods->decast);
+ $mr->mods($string);
+
+ #$e = OpenILS::Utils::Editor->new(xact => 1);
+ $e = new_editor(xact => 1);
+ $e->update_metabib_metarecord($mr)
+ or $logger->error("Error setting mods text on metarecord $mrid : " . Dumper($e->event));
+ $e->finish;
+
+ return undef;
+}
+
+
+# converts a mr id into a list of record ids
+
+foreach (qw/open-ils.search.biblio.metarecord_to_records
+ open-ils.search.biblio.metarecord_to_records.staff/)
+{
+ __PACKAGE__->register_method(
+ method => "biblio_mrid_to_record_ids",
+ api_name => $_,
+ signature => {
+ desc => "Fetch record IDs corresponding to a meta-record ID, with optional search filters. "
+ . "As usual, the .staff version of this method will include otherwise hidden records.",
+ params => [
+ { desc => 'Metarecord ID', type => 'number' },
+ { desc => '(Optional) Search filters hash with possible keys: format, org, depth', type => 'object' }
+ ],
+ return => {
+ desc => 'Results object like {count => $i, ids =>[...]}',
+ type => 'object'
+ }
+
+ }
+ );
+}
+
+sub biblio_mrid_to_record_ids {
+ my( $self, $client, $mrid, $args ) = @_;
+
+ my $format = $$args{format};
+ my $org = $$args{org};
+ my $depth = $$args{depth};
+
+ my $method = "open-ils.storage.ordered.metabib.metarecord.records.atomic";
+ $method =~ s/atomic/staff\.atomic/o if $self->api_name =~ /staff/o;
+ my $recs = $U->storagereq($method, $mrid, $format, $org, $depth);
+
+ return { count => scalar(@$recs), ids => $recs };
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_record_to_marc_html",
+ api_name => "open-ils.search.biblio.record.html"
+);
+
+__PACKAGE__->register_method(
+ method => "biblio_record_to_marc_html",
+ api_name => "open-ils.search.authority.to_html"
+);
+
+# Persistent parsers and setting objects
+my $parser = XML::LibXML->new();
+my $xslt = XML::LibXSLT->new();
+my $marc_sheet;
+my $slim_marc_sheet;
+my $settings_client = OpenSRF::Utils::SettingsClient->new();
+
+sub biblio_record_to_marc_html {
+ my($self, $client, $recordid, $slim, $marcxml) = @_;
+
+ my $sheet;
+ my $dir = $settings_client->config_value("dirs", "xsl");
+
+ if($slim) {
+ unless($slim_marc_sheet) {
+ my $xsl = $settings_client->config_value(
+ "apps", "open-ils.search", "app_settings", 'marc_html_xsl_slim');
+ if($xsl) {
+ $xsl = $parser->parse_file("$dir/$xsl");
+ $slim_marc_sheet = $xslt->parse_stylesheet($xsl);
+ }
+ }
+ $sheet = $slim_marc_sheet;
+ }
+
+ unless($sheet) {
+ unless($marc_sheet) {
+ my $xsl_key = ($slim) ? 'marc_html_xsl_slim' : 'marc_html_xsl';
+ my $xsl = $settings_client->config_value(
+ "apps", "open-ils.search", "app_settings", 'marc_html_xsl');
+ $xsl = $parser->parse_file("$dir/$xsl");
+ $marc_sheet = $xslt->parse_stylesheet($xsl);
+ }
+ $sheet = $marc_sheet;
+ }
+
+ my $record;
+ unless($marcxml) {
+ my $e = new_editor();
+ if($self->api_name =~ /authority/) {
+ $record = $e->retrieve_authority_record_entry($recordid)
+ or return $e->event;
+ } else {
+ $record = $e->retrieve_biblio_record_entry($recordid)
+ or return $e->event;
+ }
+ $marcxml = $record->marc;
+ }
+
+ my $xmldoc = $parser->parse_string($marcxml);
+ my $html = $sheet->transform($xmldoc);
+ return $html->documentElement->toString();
+}
+
+__PACKAGE__->register_method(
+ method => "format_biblio_record_entry",
+ api_name => "open-ils.search.biblio.record.print",
+ signature => {
+ desc => 'Returns a printable version of the specified bib record',
+ params => [
+ { desc => 'Biblio record entry ID or array of IDs', type => 'number' },
+ ],
+ return => {
+ desc => q/An action_trigger.event object or error event./,
+ type => 'object',
+ }
+ }
+);
+__PACKAGE__->register_method(
+ method => "format_biblio_record_entry",
+ api_name => "open-ils.search.biblio.record.email",
+ signature => {
+ desc => 'Emails an A/T templated version of the specified bib records to the authorized user',
+ params => [
+ { desc => 'Authentication token', type => 'string'},
+ { desc => 'Biblio record entry ID or array of IDs', type => 'number' },
+ ],
+ return => {
+ desc => q/Undefined on success, otherwise an error event./,
+ type => 'object',
+ }
+ }
+);
+
+sub format_biblio_record_entry {
+ my($self, $conn, $arg1, $arg2) = @_;
+
+ my $for_print = ($self->api_name =~ /print/);
+ my $for_email = ($self->api_name =~ /email/);
+
+ my $e; my $auth; my $bib_id; my $context_org;
+
+ if ($for_print) {
+ $bib_id = $arg1;
+ $context_org = $arg2 || $U->fetch_org_tree->id;
+ $e = new_editor(xact => 1);
+ } elsif ($for_email) {
+ $auth = $arg1;
+ $bib_id = $arg2;
+ $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ $context_org = $e->requestor->home_ou;
+ }
+
+ my $bib_ids;
+ if (ref $bib_id ne 'ARRAY') {
+ $bib_ids = [ $bib_id ];
+ } else {
+ $bib_ids = $bib_id;
+ }
+
+ my $bucket = Fieldmapper::container::biblio_record_entry_bucket->new;
+ $bucket->btype('temp');
+ $bucket->name('format_biblio_record_entry ' . $U->create_uuid_string);
+ if ($for_email) {
+ $bucket->owner($e->requestor)
+ } else {
+ $bucket->owner(1);
+ }
+ my $bucket_obj = $e->create_container_biblio_record_entry_bucket($bucket);
+
+ for my $id (@$bib_ids) {
+
+ my $bib = $e->retrieve_biblio_record_entry([$id]) or return $e->die_event;
+
+ my $bucket_entry = Fieldmapper::container::biblio_record_entry_bucket_item->new;
+ $bucket_entry->target_biblio_record_entry($bib);
+ $bucket_entry->bucket($bucket_obj->id);
+ $e->create_container_biblio_record_entry_bucket_item($bucket_entry);
+ }
+
+ $e->commit;
+
+ if ($for_print) {
+
+ return $U->fire_object_event(undef, 'biblio.format.record_entry.print', [ $bucket ], $context_org);
+
+ } elsif ($for_email) {
+
+ $U->create_events_for_hook('biblio.format.record_entry.email', $bucket, $context_org, undef, undef, 1);
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "retrieve_all_copy_statuses",
+ api_name => "open-ils.search.config.copy_status.retrieve.all"
+);
+
+sub retrieve_all_copy_statuses {
+ my( $self, $client ) = @_;
+ return new_editor()->retrieve_all_config_copy_status();
+}
+
+
+__PACKAGE__->register_method(
+ method => "copy_counts_per_org",
+ api_name => "open-ils.search.biblio.copy_counts.retrieve"
+);
+
+__PACKAGE__->register_method(
+ method => "copy_counts_per_org",
+ api_name => "open-ils.search.biblio.copy_counts.retrieve.staff"
+);
+
+sub copy_counts_per_org {
+ my( $self, $client, $record_id ) = @_;
+
+ warn "Retreiveing copy copy counts for record $record_id and method " . $self->api_name . "\n";
+
+ my $method = "open-ils.storage.biblio.record_entry.global_copy_count.atomic";
+ if($self->api_name =~ /staff/) { $method =~ s/atomic/staff\.atomic/; }
+
+ my $counts = $apputils->simple_scalar_request(
+ "open-ils.storage", $method, $record_id );
+
+ $counts = [ sort {$a->[0] <=> $b->[0]} @$counts ];
+ return $counts;
+}
+
+
+__PACKAGE__->register_method(
+ method => "copy_count_summary",
+ api_name => "open-ils.search.biblio.copy_counts.summary.retrieve",
+ notes => "returns an array of these: "
+ . "[ org_id, callnumber_label, <status1_count>, <status2_count>,...] "
+ . "where statusx is a copy status name. The statuses are sorted by ID.",
+);
+
+
+sub copy_count_summary {
+ my( $self, $client, $rid, $org, $depth ) = @_;
+ $org ||= 1;
+ $depth ||= 0;
+ my $data = $U->storagereq(
+ 'open-ils.storage.biblio.record_entry.status_copy_count.atomic', $rid, $org, $depth );
+
+ return [ sort { $a->[1] cmp $b->[1] } @$data ];
+}
+
+__PACKAGE__->register_method(
+ method => "copy_location_count_summary",
+ api_name => "open-ils.search.biblio.copy_location_counts.summary.retrieve",
+ notes => "returns an array of these: "
+ . "[ org_id, callnumber_label, copy_location, <status1_count>, <status2_count>,...] "
+ . "where statusx is a copy status name. The statuses are sorted by ID.",
+);
+
+sub copy_location_count_summary {
+ my( $self, $client, $rid, $org, $depth ) = @_;
+ $org ||= 1;
+ $depth ||= 0;
+ my $data = $U->storagereq(
+ 'open-ils.storage.biblio.record_entry.status_copy_location_count.atomic', $rid, $org, $depth );
+
+ return [ sort { $a->[1] cmp $b->[1] || $a->[2] cmp $b->[2] } @$data ];
+}
+
+__PACKAGE__->register_method(
+ method => "copy_count_location_summary",
+ api_name => "open-ils.search.biblio.copy_counts.location.summary.retrieve",
+ notes => "returns an array of these: "
+ . "[ org_id, callnumber_label, <status1_count>, <status2_count>,...] "
+ . "where statusx is a copy status name. The statuses are sorted by ID."
+);
+
+sub copy_count_location_summary {
+ my( $self, $client, $rid, $org, $depth ) = @_;
+ $org ||= 1;
+ $depth ||= 0;
+ my $data = $U->storagereq(
+ 'open-ils.storage.biblio.record_entry.status_copy_location_count.atomic', $rid, $org, $depth );
+ return [ sort { $a->[1] cmp $b->[1] } @$data ];
+}
+
+
+foreach (qw/open-ils.search.biblio.marc
+ open-ils.search.biblio.marc.staff/)
+{
+__PACKAGE__->register_method(
+ method => "marc_search",
+ api_name => $_,
+ signature => {
+ desc => 'Fetch biblio IDs based on MARC record criteria. '
+ . 'As usual, the .staff version of the search includes otherwise hidden records',
+ params => [
+ {
+ desc => 'Search hash (required) with possible elements: searches, limit, offset, sort, sort_dir. ' .
+ 'See perldoc ' . __PACKAGE__ . ' for more detail.',
+ type => 'object'
+ },
+ {desc => 'limit (optional)', type => 'number'},
+ {desc => 'offset (optional)', type => 'number'}
+ ],
+ return => {
+ desc => 'Results object like: { "count": $i, "ids": [...] }',
+ type => 'object'
+ }
+ }
+);
+}
+
+=head3 open-ils.search.biblio.marc (arghash, limit, offset)
+
+As elsewhere the arghash is the required argument, and must be a hashref. The keys are:
+
+ searches: complex query object (required)
+ org_unit: The org ID to focus the search at
+ depth : The org depth
+ limit : integer search limit default: 10
+ offset : integer search offset default: 0
+ sort : What field to sort the results on? [ author | title | pubdate ]
+ sort_dir: In what direction do we sort? [ asc | desc ]
+
+Additional keys to refine search criteria:
+
+ audience : Audience
+ language : Language (code)
+ lit_form : Literary form
+ item_form: Item form
+ item_type: Item type
+ format : The MARC format
+
+Please note that the specific strings to be used in the "addtional keys" will be entirely
+dependent on your loaded data.
+
+All keys except "searches" are optional.
+The "searches" value must be an arrayref of hashref elements, including keys "term" and "restrict".
+
+For example, an arg hash might look like:
+
+ $arghash = {
+ searches => [
+ {
+ term => "harry",
+ restrict => [
+ {
+ tag => 245,
+ subfield => "a"
+ }
+ # ...
+ ]
+ }
+ # ...
+ ],
+ org_unit => 1,
+ limit => 5,
+ sort => "author",
+ item_type => "g"
+ }
+
+The arghash is eventually passed to the SRF call:
+L<open-ils.storage.biblio.full_rec.multi_search[.staff].atomic>
+
+Presently, search uses the cache unconditionally.
+
+=cut
+
+# FIXME: that example above isn't actually tested.
+# TODO: docache option?
+sub marc_search {
+ my( $self, $conn, $args, $limit, $offset ) = @_;
+
+ my $method = 'open-ils.storage.biblio.full_rec.multi_search';
+ $method .= ".staff" if $self->api_name =~ /staff/;
+ $method .= ".atomic";
+
+ $limit ||= 10; # FIXME: what about $args->{limit} ?
+ $offset ||= 0; # FIXME: what about $args->{offset} ?
+
+ my @search;
+ push( @search, ($_ => $$args{$_}) ) for (sort keys %$args);
+ my $ckey = $pfx . md5_hex($method . OpenSRF::Utils::JSON->perl2JSON(\@search));
+
+ my $recs = search_cache($ckey, $offset, $limit);
+
+ if(!$recs) {
+ $recs = $U->storagereq($method, %$args) || [];
+ if( $recs ) {
+ put_cache($ckey, scalar(@$recs), $recs);
+ $recs = [ @$recs[$offset..($offset + ($limit - 1))] ];
+ } else {
+ $recs = [];
+ }
+ }
+
+ my $count = 0;
+ $count = $recs->[0]->[2] if $recs->[0] and $recs->[0]->[2];
+ my @recs = map { $_->[0] } @$recs;
+
+ return { ids => \@recs, count => $count };
+}
+
+
+__PACKAGE__->register_method(
+ method => "biblio_search_isbn",
+ api_name => "open-ils.search.biblio.isbn",
+ signature => {
+ desc => 'Retrieve biblio IDs for a given ISBN',
+ params => [
+ {desc => 'ISBN', type => 'string'} # or number maybe? How normalized is our storage data?
+ ],
+ return => {
+ desc => 'Results object like: { "count": $i, "ids": [...] }',
+ type => 'object'
+ }
+ }
+);
+
+sub biblio_search_isbn {
+ my( $self, $client, $isbn ) = @_;
+ $logger->debug("Searching ISBN $isbn");
+ my $recs = $U->storagereq('open-ils.storage.id_list.biblio.record_entry.search.isbn.atomic', $isbn);
+ return { ids => $recs, count => scalar(@$recs) };
+}
+
+__PACKAGE__->register_method(
+ method => "biblio_search_isbn_batch",
+ api_name => "open-ils.search.biblio.isbn_list",
+);
+
+sub biblio_search_isbn_batch {
+ my( $self, $client, $isbn_list ) = @_;
+ $logger->debug("Searching ISBNs @$isbn_list");
+ my @recs = (); my %rec_set = ();
+ foreach my $isbn ( @$isbn_list ) {
+ foreach my $rec ( @{ $U->storagereq(
+ 'open-ils.storage.id_list.biblio.record_entry.search.isbn.atomic', $isbn )
+ } ) {
+ if (! $rec_set{ $rec }) {
+ $rec_set{ $rec } = 1;
+ push @recs, $rec;
+ }
+ }
+ }
+ return { ids => \@recs, count => scalar(@recs) };
+}
+
+__PACKAGE__->register_method(
+ method => "biblio_search_issn",
+ api_name => "open-ils.search.biblio.issn",
+ signature => {
+ desc => 'Retrieve biblio IDs for a given ISSN',
+ params => [
+ {desc => 'ISBN', type => 'string'}
+ ],
+ return => {
+ desc => 'Results object like: { "count": $i, "ids": [...] }',
+ type => 'object'
+ }
+ }
+);
+
+sub biblio_search_issn {
+ my( $self, $client, $issn ) = @_;
+ $logger->debug("Searching ISSN $issn");
+ my $e = new_editor();
+ $issn =~ s/-/ /g;
+ my $recs = $U->storagereq(
+ 'open-ils.storage.id_list.biblio.record_entry.search.issn.atomic', $issn );
+ return { ids => $recs, count => scalar(@$recs) };
+}
+
+
+__PACKAGE__->register_method(
+ method => "fetch_mods_by_copy",
+ api_name => "open-ils.search.biblio.mods_from_copy",
+ argc => 1,
+ signature => {
+ desc => 'Retrieve MODS record given an attached copy ID',
+ params => [
+ { desc => 'Copy ID', type => 'number' }
+ ],
+ returns => {
+ desc => 'MODS record, event on error or uncataloged item'
+ }
+ }
+);
+
+sub fetch_mods_by_copy {
+ my( $self, $client, $copyid ) = @_;
+ my ($record, $evt) = $apputils->fetch_record_by_copy( $copyid );
+ return $evt if $evt;
+ return OpenILS::Event->new('ITEM_NOT_CATALOGED') unless $record->marc;
+ return $apputils->record_to_mvr($record);
+}
+
+
+# -------------------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => "cn_browse",
+ api_name => "open-ils.search.callnumber.browse.target",
+ notes => "Starts a callnumber browse"
+);
+
+__PACKAGE__->register_method(
+ method => "cn_browse",
+ api_name => "open-ils.search.callnumber.browse.page_up",
+ notes => "Returns the previous page of callnumbers",
+);
+
+__PACKAGE__->register_method(
+ method => "cn_browse",
+ api_name => "open-ils.search.callnumber.browse.page_down",
+ notes => "Returns the next page of callnumbers",
+);
+
+
+# RETURNS array of arrays like so: label, owning_lib, record, id
+sub cn_browse {
+ my( $self, $client, @params ) = @_;
+ my $method;
+
+ $method = 'open-ils.storage.asset.call_number.browse.target.atomic'
+ if( $self->api_name =~ /target/ );
+ $method = 'open-ils.storage.asset.call_number.browse.page_up.atomic'
+ if( $self->api_name =~ /page_up/ );
+ $method = 'open-ils.storage.asset.call_number.browse.page_down.atomic'
+ if( $self->api_name =~ /page_down/ );
+
+ return $apputils->simplereq( 'open-ils.storage', $method, @params );
+}
+# -------------------------------------------------------------------------------------
+
+__PACKAGE__->register_method(
+ method => "fetch_cn",
+ api_name => "open-ils.search.callnumber.retrieve",
+ authoritative => 1,
+ notes => "retrieves a callnumber based on ID",
+);
+
+sub fetch_cn {
+ my( $self, $client, $id ) = @_;
+ my( $cn, $evt ) = $apputils->fetch_callnumber( $id );
+ return $evt if $evt;
+ return $cn;
+}
+
+__PACKAGE__->register_method(
+ method => "fetch_copy_by_cn",
+ api_name => 'open-ils.search.copies_by_call_number.retrieve',
+ signature => q/
+ Returns an array of copy ID's by callnumber ID
+ @param cnid The callnumber ID
+ @return An array of copy IDs
+ /
+);
+
+sub fetch_copy_by_cn {
+ my( $self, $conn, $cnid ) = @_;
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.asset.copy.id_list.atomic',
+ { call_number => $cnid, deleted => 'f' } );
+}
+
+__PACKAGE__->register_method(
+ method => 'fetch_cn_by_info',
+ api_name => 'open-ils.search.call_number.retrieve_by_info',
+ signature => q/
+ @param label The callnumber label
+ @param record The record the cn is attached to
+ @param org The owning library of the cn
+ @return The callnumber object
+ /
+);
+
+
+sub fetch_cn_by_info {
+ my( $self, $conn, $label, $record, $org ) = @_;
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.asset.call_number.search',
+ { label => $label, record => $record, owning_lib => $org, deleted => 'f' });
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'bib_extras',
+ api_name => 'open-ils.search.biblio.lit_form_map.retrieve.all'
+);
+__PACKAGE__->register_method(
+ method => 'bib_extras',
+ api_name => 'open-ils.search.biblio.item_form_map.retrieve.all'
+);
+__PACKAGE__->register_method(
+ method => 'bib_extras',
+ api_name => 'open-ils.search.biblio.item_type_map.retrieve.all'
+);
+__PACKAGE__->register_method(
+ method => 'bib_extras',
+ api_name => 'open-ils.search.biblio.bib_level_map.retrieve.all'
+);
+__PACKAGE__->register_method(
+ method => 'bib_extras',
+ api_name => 'open-ils.search.biblio.audience_map.retrieve.all'
+);
+
+sub bib_extras {
+ my $self = shift;
+
+ my $e = new_editor();
+
+ return $e->retrieve_all_config_lit_form_map()
+ if( $self->api_name =~ /lit_form/ );
+
+ return $e->retrieve_all_config_item_form_map()
+ if( $self->api_name =~ /item_form_map/ );
+
+ return $e->retrieve_all_config_item_type_map()
+ if( $self->api_name =~ /item_type_map/ );
+
+ return $e->retrieve_all_config_bib_level_map()
+ if( $self->api_name =~ /bib_level_map/ );
+
+ return $e->retrieve_all_config_audience_map()
+ if( $self->api_name =~ /audience_map/ );
+
+ return [];
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_slim_record',
+ api_name => 'open-ils.search.biblio.record_entry.slim.retrieve',
+ signature => {
+ desc => "Retrieves one or more biblio.record_entry without the attached marcxml",
+ params => [
+ { desc => 'Array of Record IDs', type => 'array' }
+ ],
+ return => {
+ desc => 'Array of biblio records, event on error'
+ }
+ }
+);
+
+sub fetch_slim_record {
+ my( $self, $conn, $ids ) = @_;
+
+#my $editor = OpenILS::Utils::Editor->new;
+ my $editor = new_editor();
+ my @res;
+ for( @$ids ) {
+ return $editor->event unless
+ my $r = $editor->retrieve_biblio_record_entry($_);
+ $r->clear_marc;
+ push(@res, $r);
+ }
+ return \@res;
+}
+
+
+
+__PACKAGE__->register_method(
+ method => 'rec_to_mr_rec_descriptors',
+ api_name => 'open-ils.search.metabib.record_to_descriptors',
+ signature => q/
+ specialized method...
+ Given a biblio record id or a metarecord id,
+ this returns a list of metabib.record_descriptor
+ objects that live within the same metarecord
+ @param args Object of args including:
+ /
+);
+
+sub rec_to_mr_rec_descriptors {
+ my( $self, $conn, $args ) = @_;
+
+ my $rec = $$args{record};
+ my $mrec = $$args{metarecord};
+ my $item_forms = $$args{item_forms};
+ my $item_types = $$args{item_types};
+ my $item_lang = $$args{item_lang};
+
+ my $e = new_editor();
+ my $recs;
+
+ if( !$mrec ) {
+ my $map = $e->search_metabib_metarecord_source_map({source => $rec});
+ return $e->event unless @$map;
+ $mrec = $$map[0]->metarecord;
+ }
+
+ $recs = $e->search_metabib_metarecord_source_map({metarecord => $mrec});
+ return $e->event unless @$recs;
+
+ my @recs = map { $_->source } @$recs;
+ my $search = { record => \@recs };
+ $search->{item_form} = $item_forms if $item_forms and @$item_forms;
+ $search->{item_type} = $item_types if $item_types and @$item_types;
+ $search->{item_lang} = $item_lang if $item_lang;
+
+ my $desc = $e->search_metabib_record_descriptor($search);
+
+ return { metarecord => $mrec, descriptors => $desc };
+}
+
+
+__PACKAGE__->register_method(
+ method => 'fetch_age_protect',
+ api_name => 'open-ils.search.copy.age_protect.retrieve.all',
+);
+
+sub fetch_age_protect {
+ return new_editor()->retrieve_all_config_rule_age_hold_protect();
+}
+
+
+__PACKAGE__->register_method(
+ method => 'copies_by_cn_label',
+ api_name => 'open-ils.search.asset.copy.retrieve_by_cn_label',
+);
+
+__PACKAGE__->register_method(
+ method => 'copies_by_cn_label',
+ api_name => 'open-ils.search.asset.copy.retrieve_by_cn_label.staff',
+);
+
+sub copies_by_cn_label {
+ my( $self, $conn, $record, $label, $circ_lib ) = @_;
+ my $e = new_editor();
+ my $cns = $e->search_asset_call_number({record => $record, label => $label, deleted => 'f'}, {idlist=>1});
+ return [] unless @$cns;
+
+ # show all non-deleted copies in the staff client ...
+ if ($self->api_name =~ /staff$/o) {
+ return $e->search_asset_copy({call_number => $cns, circ_lib => $circ_lib, deleted => 'f'}, {idlist=>1});
+ }
+
+ # ... otherwise, grab the copies ...
+ my $copies = $e->search_asset_copy(
+ [ {call_number => $cns, circ_lib => $circ_lib, deleted => 'f', opac_visible => 't'},
+ {flesh => 1, flesh_fields => { acp => [ qw/location status/] } }
+ ]
+ );
+
+ # ... and test for location and status visibility
+ return [ map { ($U->is_true($_->location->opac_visible) && $U->is_true($_->status->opac_visible)) ? ($_->id) : () } @$copies ];
+}
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Search::CNBrowse;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::EX qw(:try);
+use OpenILS::Application::AppUtils;
+use Data::Dumper;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenSRF::AppSession;
+my $U = "OpenILS::Application::AppUtils";
+
+
+__PACKAGE__->register_method(
+ method => "cn_browse_start",
+ api_name => "open-ils.search.callnumber.browse.target",
+ notes => "Starts a callnumber browse"
+ );
+
+__PACKAGE__->register_method(
+ method => "cn_browse_up",
+ api_name => "open-ils.search.callnumber.browse.page_up",
+ notes => "Returns the previous page of callnumbers",
+ );
+
+__PACKAGE__->register_method(
+ method => "cn_browse_down",
+ api_name => "open-ils.search.callnumber.browse.page_down",
+ notes => "Returns the next page of callnumbers",
+ );
+
+# XXX Deprecate me
+
+sub cn_browse_start {
+ my( $self, $client, @params ) = @_;
+ my $method;
+ $method = 'open-ils.storage.asset.call_number.browse.target.atomic'
+ if( $self->api_name =~ /target/ );
+ $method = 'open-ils.storage.asset.call_number.browse.page_up'
+ if( $self->api_name =~ /page_up/ );
+ $method = 'open-ils.storage.asset.call_number.browse.page_down'
+ if( $self->api_name =~ /page_down/ );
+
+ return $U->simplereq( 'open-ils.storage', $method, @params );
+}
+
+
+__PACKAGE__->register_method(
+ method => "cn_browse",
+ api_name => "open-ils.search.callnumber.browse",
+ signature => {
+ desc => q/Paged call number browse/,
+ params => [
+ { name => 'label',
+ desc => 'The target call number lable',
+ type => 'string' },
+ { name => 'org_unit',
+ desc => 'The org unit shortname (or "-" or undef for global) to browse',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'offset',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ { name => 'statuses',
+ desc => 'Array of statuses to filter copies by, optional and can be undef.',
+ type => 'array' },
+ { name => 'locations',
+ desc => 'Array of copy locations to filter copies by, optional and can be undef.',
+ type => 'array' },
+ ],
+ return => {
+ type => 'array',
+ desc => q/List of callnumber (acn) and record (mvr) objects/
+ }
+ }
+);
+
+sub cn_browse {
+ my( $self, $conn, $cn, $orgid, $size, $offset, $copy_statuses, $copy_locations ) = @_;
+ my $ses = OpenSRF::AppSession->create('open-ils.supercat');
+
+ my $tree = $U->get_slim_org_tree;
+ my $name = _find_shortname($orgid, $tree);
+
+ $logger->debug("cn browse found or name $name");
+
+ my $data = $ses->request(
+ 'open-ils.supercat.call_number.browse',
+ $cn, $name, $size, $offset, $copy_statuses, $copy_locations )->gather(1);
+
+ return [] unless $data;
+
+ my @res;
+ for my $d (@$data) {
+ my $mods = $U->record_to_mvr($d->record);
+ $d->owning_lib( $d->owning_lib->id );
+ $d->record($mods->doc_id);
+ push( @res, { cn => $d, mods => $mods });
+ }
+
+ return \@res;
+}
+
+
+sub _find_shortname {
+ my $id = shift;
+ my $node = shift;
+ return undef unless $node;
+ return $node->shortname if $node->id == $id;
+ if( $node->children ) {
+ for my $c (@{$node->children()}) {
+ my $d = _find_shortname($id, $c);
+ return $d if $d;
+ }
+ }
+ return undef;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Search::Serial;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+
+use OpenSRF::Utils::JSON;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::MFHDParser;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Cache;
+use Encode;
+
+use OpenSRF::Utils::Logger qw/:logger/;
+
+use Data::Dumper;
+
+use OpenSRF::Utils::JSON;
+
+use Time::HiRes qw(time);
+use OpenSRF::EX qw(:try);
+use Digest::MD5 qw(md5_hex);
+
+use XML::LibXML;
+use XML::LibXSLT;
+
+use OpenILS::Const qw/:const/;
+
+use OpenILS::Application::AppUtils;
+my $apputils = "OpenILS::Application::AppUtils";
+my $U = $apputils;
+
+my $pfx = "open-ils.search_";
+
+=over
+
+=item * mfhd_to_hash
+
+=back
+
+Takes an MFHD record ID and returns a hash of holdings statements
+
+=cut
+
+sub mfhd_to_hash {
+ my ($self, $client, $id) = @_;
+
+ my $session = OpenSRF::AppSession->create("open-ils.cstore");
+ my $request = $session->request(
+ "open-ils.cstore.direct.serial.record_entry.retrieve", $id )->gather(1);
+
+ my $u = OpenILS::Utils::MFHDParser->new();
+ my $mfhd_hash = $u->generate_svr( $request->id, $request->marc, $request->owning_lib );
+
+ $session->disconnect();
+ return $mfhd_hash;
+}
+
+__PACKAGE__->register_method(
+ method => "mfhd_to_hash",
+ api_name => "open-ils.search.serial.record.mfhd.retrieve",
+ argc => 1,
+ note => "Given a serial record ID, return MFHD holdings"
+);
+
+=over
+
+=item * bib_to_mfhd_hash
+
+=back
+
+Given a bib record ID, returns a hash of holdings statements
+
+=cut
+
+# DEFUNCT ?
+#sub bib_to_mfhd_hash {
+# my ($self, $client, $bib) = @_;
+#
+# my $mfhd_hash;
+#
+# # XXX perhaps this? --miker
+## my $e = OpenILS::Utils::CStoreEditor->new();
+## my $mfhd = $e->search_serial_record_entry({ record => $bib });
+## return $u->generate_svr( $mfhd->[0] ) if (ref $mfhd);
+## return undef;
+#
+# my @mfhd = $U->cstorereq( "open-ils.cstore.json_query.atomic", {
+# select => { sre => 'marc' },
+# from => 'sre',
+# where => { record => $bib, deleted => 'f' },
+# distinct => 1
+# });
+#
+# if (!@mfhd or scalar(@mfhd) == 0) {
+# return undef;
+# }
+#
+# my $u = OpenILS::Utils::MFHDParser->new();
+# $mfhd_hash = $u->generate_svr( $mfhd[0][0]->{id}, $mfhd[0][0]->{marc}, $mfhd[0][0]->{owning_lib} );
+#
+# return $mfhd_hash;
+#}
+#
+#__PACKAGE__->register_method(
+# method => "bib_to_mfhd_hash",
+# api_name => "open-ils.search.serial.record.bib_to_mfhd.retrieve",
+# argc => 1,
+# note => "Given a bibliographic record ID, return MFHD holdings"
+#);
+
+sub bib_to_svr {
+ my ($self, $client, $bib) = @_;
+
+ my $svrs = [];
+
+ my $e = OpenILS::Utils::CStoreEditor->new();
+ # TODO: 'deleted' ssub support
+ my $sdists = $e->search_serial_distribution([{ "+ssub" => {"record_entry" => $bib} }, { "flesh" => 1, "flesh_fields" => {'sdist' => [ "record_entry", "holding_lib", "basic_summary", "supplement_summary", "index_summary" ]}, "join" => {"ssub" => {}} }]);
+ my $sres = $e->search_serial_record_entry([{ record => $bib, deleted => 'f', "+sdist" => {"id" => undef} }, { "join" => {"sdist" => { 'type' => 'left' }} }]);
+ if (!ref $sres and !ref $sdists) {
+ return undef;
+ }
+
+ my $mfhd_parser = OpenILS::Utils::MFHDParser->new();
+ foreach (@$sdists) {
+ my $svr;
+ if (ref $_->record_entry) {
+ $svr = $mfhd_parser->generate_svr($_->record_entry->id, $_->record_entry->marc, $_->record_entry->owning_lib);
+ } else {
+ $svr = Fieldmapper::serial::virtual_record->new;
+ $svr->sre_id(-1);
+ $svr->location($_->holding_lib->name);
+ $svr->owning_lib($_->holding_lib);
+ $svr->basic_holdings([]);
+ $svr->supplement_holdings([]);
+ $svr->index_holdings([]);
+ $svr->basic_holdings_add([]);
+ $svr->supplement_holdings_add([]);
+ $svr->index_holdings_add([]);
+ $svr->online([]);
+ $svr->missing([]);
+ $svr->incomplete([]);
+ }
+ if (ref $_->basic_summary) { #TODO: 'show-generated' boolean on summaries
+ if ($_->basic_summary->generated_coverage) {
+ push(@{$svr->basic_holdings}, $_->basic_summary->generated_coverage);
+ }
+ if ($_->basic_summary->textual_holdings) {
+ push(@{$svr->basic_holdings_add}, $_->basic_summary->textual_holdings);
+ }
+ }
+ if (ref $_->supplement_summary) {
+ if ($_->supplement_summary->generated_coverage) {
+ push(@{$svr->supplement_holdings}, $_->supplement_summary->generated_coverage);
+ }
+ if ($_->supplement_summary->textual_holdings) {
+ push(@{$svr->supplement_holdings_add}, $_->supplement_summary->textual_holdings);
+ }
+ }
+ if (ref $_->index_summary) {
+ if ($_->index_summary->generated_coverage) {
+ push(@{$svr->index_holdings}, $_->index_summary->generated_coverage);
+ }
+ if ($_->index_summary->textual_holdings) {
+ push(@{$svr->index_holdings_add}, $_->index_summary->textual_holdings);
+ }
+ }
+ push(@$svrs, $svr);
+ }
+ foreach (@$sres) {
+ push(@$svrs, $mfhd_parser->generate_svr($_->id, $_->marc, $_->owning_lib));
+ }
+
+ # do a basic location sort for simple predictability
+ @$svrs = sort { $a->location cmp $b->location } @$svrs;
+
+ return $svrs;
+}
+
+__PACKAGE__->register_method(
+ method => "bib_to_svr",
+ api_name => "open-ils.search.serial.record.bib.retrieve",
+ argc => 1,
+ note => "Given a bibliographic record ID, return holdings in svr form"
+);
+
+1;
--- /dev/null
+package OpenILS::Application::Search::Z3950;
+use strict; use warnings;
+use base qw/OpenILS::Application/;
+
+use OpenILS::Utils::ZClient;
+use MARC::Record;
+use MARC::File::XML;
+use Unicode::Normalize;
+use XML::LibXML;
+
+use OpenILS::Event;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::ModsParser;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+
+my $output = "usmarc";
+my $U = 'OpenILS::Application::AppUtils';
+
+my $sclient;
+my %services;
+my $default_service;
+
+
+__PACKAGE__->register_method(
+ method => 'do_class_search',
+ api_name => 'open-ils.search.z3950.search_class',
+ stream => 1,
+ signature => q/
+ Performs a class based Z search. The classes available
+ are defined by the 'attr' fields in the config for the
+ requested service.
+ @param auth The login session key
+ @param shash The search hash : { attr : value, attr2: value, ...}
+ @param service The service to connect to
+ @param username The username to use when connecting to the service
+ @param password The password to use when connecting to the service
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'do_service_search',
+ api_name => 'open-ils.search.z3950.search_service',
+ signature => q/
+ @param auth The login session key
+ @param query The Z3950 search string to use
+ @param service The service to connect to
+ @param username The username to use when connecting to the service
+ @param password The password to use when connecting to the service
+ /
+);
+
+
+__PACKAGE__->register_method(
+ method => 'do_service_search',
+ api_name => 'open-ils.search.z3950.search_raw',
+ signature => q/
+ @param auth The login session key
+ @param args An object of search params which must include:
+ host, port, db and query.
+ optional fields include username and password
+ /
+);
+
+
+__PACKAGE__->register_method(
+ method => "query_services",
+ api_name => "open-ils.search.z3950.retrieve_services",
+ signature => q/
+ Returns a list of service names that we have config
+ data for
+ /
+);
+
+
+
+# -------------------------------------------------------------------
+# What services do we have config info for?
+# -------------------------------------------------------------------
+sub query_services {
+ my( $self, $client, $auth ) = @_;
+ my $e = new_editor(authtoken=>$auth);
+ return $e->event unless $e->checkauth;
+ return $e->event unless $e->allowed('REMOTE_Z3950_QUERY');
+
+ return fetch_service_defs();
+}
+
+# -------------------------------------------------------------------
+# What services do we have config info for?
+# -------------------------------------------------------------------
+sub fetch_service_defs {
+
+ my $hash = $sclient->config_value('z3950', 'services');
+
+ # overlay config file values with in-db values
+ my $e = new_editor();
+ if($e->can('search_config_z3950_source')) {
+
+ my $sources = $e->search_config_z3950_source(
+ [ { name => { '!=' => undef } },
+ { flesh => 1, flesh_fields => { czs => ['attrs'] } } ]
+ );
+
+ for my $s ( @$sources ) {
+ $$hash{ $s->name } = {
+ name => $s->name,
+ label => $s->label,
+ host => $s->host,
+ port => $s->port,
+ db => $s->db,
+ record_format => $s->record_format,
+ transmission_format => $s->transmission_format,
+ auth => $s->auth,
+ };
+
+ for my $a ( @{ $s->attrs } ) {
+ $$hash{ $a->source }{attrs}{ $a->name } = {
+ name => $a->name,
+ label => $a->label,
+ code => $a->code,
+ format => $a->format,
+ source => $a->source,
+ truncation => $a->truncation,
+ };
+ }
+ }
+ }
+
+ # Define the set of native catalog services
+ # XXX There are i18n problems here, but let's get the staff client working first
+ # XXX Move into the DB?
+ $hash->{'native-evergreen-catalog'} = {
+ attrs => {
+ title => {code => 'title', label => 'Title'},
+ author => {code => 'author', label => 'Author'},
+ subject => {code => 'subject', label => 'Subject'},
+ keyword => {code => 'keyword', label => 'Keyword'},
+ tcn => {code => 'tcn', label => 'TCN'},
+ isbn => {code => 'isbn', label => 'ISBN'},
+ issn => {code => 'issn', label => 'ISSN'},
+ publisher => {code => 'publisher', label => 'Publisher'},
+ pubdate => {code => 'pubdate', label => 'Pub Date'},
+ item_type => {code => 'item_type', label => 'Item Type'},
+ }
+ };
+
+ %services = %$hash; # cache these internally so we can actually use the db-configured sources
+ return $hash;
+}
+
+
+
+# -------------------------------------------------------------------
+# Load the pre-defined Z server configs
+# -------------------------------------------------------------------
+sub child_init {
+ $sclient = OpenSRF::Utils::SettingsClient->new();
+ $default_service = $sclient->config_value("z3950", "default" );
+}
+
+
+# -------------------------------------------------------------------
+# High-level class based search.
+# -------------------------------------------------------------------
+sub do_class_search {
+
+ fetch_service_defs() unless (scalar(keys(%services)));
+
+ my $self = shift;
+ my $conn = shift;
+ my $auth = shift;
+ my $args = shift;
+
+ if (!ref($$args{service})) {
+ $$args{service} = [$$args{service}];
+ $$args{username} = [$$args{username}];
+ $$args{password} = [$$args{password}];
+ }
+
+ $$args{async} = 1;
+
+ my @connections;
+ my @results;
+ my @services;
+ for (my $i = 0; $i < @{$$args{service}}; $i++) {
+ my %tmp_args = %$args;
+ $tmp_args{service} = $$args{service}[$i];
+ $tmp_args{username} = $$args{username}[$i];
+ $tmp_args{password} = $$args{password}[$i];
+
+ $logger->debug("z3950: service: $tmp_args{service}, async: $tmp_args{async}");
+
+ if ($tmp_args{service} eq 'native-evergreen-catalog') {
+ my $method = $self->method_lookup('open-ils.search.biblio.zstyle.staff');
+ $conn->respond(
+ $self->method_lookup('open-ils.search.biblio.zstyle.staff')->run($auth, \%tmp_args)
+ );
+
+ } else {
+
+ $tmp_args{query} = compile_query('and', $tmp_args{service}, $tmp_args{search});
+
+ my $res = do_service_search( $self, $conn, $auth, \%tmp_args );
+
+ if ($U->event_code($res)) {
+ $conn->respond($res) if $U->event_code($res);
+
+ } else {
+ push @services, $tmp_args{service};
+ push @results, $res->{result};
+ push @connections, $res->{connection};
+ }
+ }
+
+ $logger->debug("z3950: Result object: $results[$i], Connection object: $connections[$i]");
+ }
+
+ $logger->debug("z3950: Connections created");
+
+ return undef unless (@connections);
+ my @records;
+
+ # local catalog search is not processed with other z39 results;
+ $$args{service} = [grep {$_ ne 'native-evergreen-catalog'} @{$$args{service}}];
+
+ @connections = grep {defined $_} @connections;
+ return undef unless @connections;
+
+ while ((my $index = OpenILS::Utils::ZClient::event( \@connections )) != 0) {
+ my $ev = $connections[$index - 1]->last_event();
+ $logger->debug("z3950: Received event $ev");
+ if ($ev == OpenILS::Utils::ZClient::EVENT_END()) {
+ my $munged = process_results( $results[$index - 1], $$args{limit}, $$args{offset}, $$args{service}[$index -1] );
+ $$munged{service} = $$args{service}[$index - 1];
+ $conn->respond($munged);
+ }
+ }
+
+ $logger->debug("z3950: Search Complete");
+ return undef;
+}
+
+
+# -------------------------------------------------------------------
+# This handles the host settings, but expects a fully formed z query
+# -------------------------------------------------------------------
+sub do_service_search {
+
+ fetch_service_defs() unless (scalar(keys(%services)));
+
+ my $self = shift;
+ my $conn = shift;
+ my $auth = shift;
+ my $args = shift;
+
+ my $info = $services{$$args{service}};
+
+ $$args{host} = $$info{host};
+ $$args{port} = $$info{port};
+ $$args{db} = $$info{db};
+ $logger->debug("z3950: do_search...");
+
+ return do_search( $self, $conn, $auth, $args );
+}
+
+
+
+# -------------------------------------------------------------------
+# This is the low level search method. All config and query
+# data must be provided to this method
+# -------------------------------------------------------------------
+sub do_search {
+
+ fetch_service_defs() unless (scalar(keys(%services)));
+
+ my $self = shift;
+ my $conn = shift;
+ my $auth = shift;
+ my $args = shift;
+
+ my $host = $$args{host} or return undef;
+ my $port = $$args{port} or return undef;
+ my $db = $$args{db} or return undef;
+ my $query = $$args{query} or return undef;
+ my $async = $$args{async} || 0;
+
+ my $limit = $$args{limit} || 10;
+ my $offset = $$args{offset} || 0;
+
+ my $username = $$args{username} || "";
+ my $password = $$args{password} || "";
+
+ my $tformat = $services{$args->{service}}->{transmission_format} || $output;
+
+ my $editor = new_editor(authtoken => $auth);
+ return $editor->event unless $editor->checkauth;
+ return $editor->event unless $editor->allowed('REMOTE_Z3950_QUERY');
+
+ $logger->info("z3950: connecting to server $host:$port:$db as $username");
+
+ my $connection = OpenILS::Utils::ZClient->new(
+ $host, $port,
+ databaseName => $db,
+ user => $username,
+ password => $password,
+ async => $async,
+ preferredRecordSyntax => $tformat,
+ );
+
+ if( ! $connection ) {
+ $logger->error("z3950: Unable to connect to Z server: ".
+ "$host:$port:$db:$username:$password");
+ return OpenILS::Event->new('Z3950_LOGIN_FAILED') unless $connection;
+ }
+
+ my $start = time;
+ my $results;
+ my $err;
+
+ $logger->info("z3950: query => $query");
+
+ try {
+ $results = $connection->search_pqf( $query );
+ } catch Error with { $err = shift; };
+
+ return OpenILS::Event->new(
+ 'Z3950_BAD_QUERY', payload => $query, debug => "$err") if $err;
+
+ return OpenILS::Event->new('Z3950_SEARCH_FAILED',
+ debug => $connection->errcode." => ".$connection->errmsg." : query = $query") unless $results;
+
+ $logger->info("z3950: search [$query] took ".(time - $start)." seconds");
+
+ return {result => $results, connection => $connection} if ($async);
+
+ my $munged = process_results($results, $limit, $offset, $$args{service});
+ $munged->{query} = $query;
+
+ return $munged;
+}
+
+
+# -------------------------------------------------------------------
+# Takes a result batch and returns the hitcount and a list of xml
+# and mvr objects
+# -------------------------------------------------------------------
+sub process_results {
+
+ fetch_service_defs() unless (scalar(keys(%services)));
+
+ my $results = shift;
+ my $limit = shift || 10;
+ my $offset = shift || 0;
+ my $service = shift;
+
+ my $rformat = $services{$service}->{record_format};
+ my $tformat = $services{$service}->{transmission_format} || $output;
+
+ $results->option(elementSetName => $rformat);
+ $results->option(preferredRecordSyntax => $tformat);
+ $logger->info("z3950: using record format '$rformat' and transmission format '$tformat'");
+
+ my @records;
+ my $res = {};
+ my $count = $$res{count} = $results->size;
+
+ $logger->info("z3950: search returned $count hits");
+
+ my $tend = $limit + $offset;
+
+ my $end = ($tend <= $count) ? $tend : $count;
+
+ for($offset..$end - 1) {
+
+ my $err;
+ my $mods;
+ my $marc;
+ my $marcs;
+ my $marcxml;
+
+ $logger->info("z3950: fetching record $_");
+
+ try {
+
+ my $rec = $results->record($_);
+
+ if ($tformat eq 'usmarc') {
+ $marc = MARC::Record->new_from_usmarc($rec->raw());
+ } elsif ($tformat eq 'xml') {
+ $marc = MARC::Record->new_from_xml($rec->raw());
+ } else {
+ die "Unsupported record transmission format $tformat"
+ }
+
+ $marcs = $U->entityize($marc->as_xml_record);
+ $marcs = $U->strip_ctrl_chars($marcs);
+ my $doc = XML::LibXML->new->parse_string($marcs);
+ $marcxml = $U->entityize($doc->documentElement->toString);
+ $marcxml = $U->strip_ctrl_chars($marcxml);
+
+ my $u = OpenILS::Utils::ModsParser->new();
+ $u->start_mods_batch( $marcxml );
+ $mods = $u->finish_mods_batch();
+
+
+ } catch Error with { $err = shift; };
+
+ push @records, { 'mvr' => $mods, 'marcxml' => $marcxml } unless $err;
+ $logger->error("z3950: bad XML : $err") if $err;
+
+ if( $err ) {
+ warn "\n\n$marcs\n\n";
+ }
+ }
+
+ $res->{records} = \@records;
+ return $res;
+}
+
+
+
+# -------------------------------------------------------------------
+# Compiles the class based search query
+# -------------------------------------------------------------------
+sub compile_query {
+
+ fetch_service_defs() unless (scalar(keys(%services)));
+
+ my $separator = shift;
+ my $service = shift;
+ my $hash = shift;
+
+ my $count = scalar(keys %$hash);
+
+ my $str = "";
+ $str .= "\@$separator " for (1..$count-1);
+
+ # -------------------------------------------------------------------
+ # "code" is the bib-1 "use attribute", "format" is the bib-1
+ # "structure attribute"
+ # -------------------------------------------------------------------
+ for( keys %$hash ) {
+ next unless ( exists $services{$service}->{attrs}->{$_} );
+ $str .= '@attr 1=' . $services{$service}->{attrs}->{$_}->{code} . # add the use attribute
+ ' @attr 4=' . $services{$service}->{attrs}->{$_}->{format}; # add the structure attribute
+ if (exists $services{$service}->{attrs}->{$_}->{truncation}
+ && $services{$service}->{attrs}->{$_}->{truncation} >= 0) {
+ $str .= ' @attr 5=' . $services{$service}->{attrs}->{$_}->{truncation};
+ }
+ $str .= " \"" . $$hash{$_} . "\" "; # add the search term
+ }
+ return $str;
+}
+
+1;
+# vim:et:ts=4:sw=4:
--- /dev/null
+package OpenILS::Application::Search::Zips;
+use base qw/OpenILS::Application/;
+use strict; use warnings;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::Editor;
+use OpenSRF::Utils::SettingsClient;
+
+my %zips;
+
+# -----------------------------------------------------------------
+# Reads zip code information from a file. File format is :
+# ID|StateAbb|City|Zip|IsDefault|StateID|County|AreaCode
+# Currently, StateAbb, City, Zip, County, AreaCode are used.
+# IsDefault should be set to 1
+# -----------------------------------------------------------------
+
+sub initialize {
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $zfile = $conf->config_value(
+ "apps", "open-ils.search", "app_settings", "zips_file");
+ return 1 unless $zfile and -f $zfile;
+
+ $logger->info("search loaded zips file $zfile");
+ open(F,$zfile);
+ my @data = <F>;
+ close(F);
+
+ for(@data) {
+ chomp $_;
+ my @items = split(/\|/, "$_");
+ my $items = {
+ state => $items[1],
+ city => $items[2],
+ zip => $items[3],
+ stateid => $items[5],
+ county => $items[6],
+ areacode => $items[7],
+ alert => $items[8]
+ };
+
+ next unless $items[4] eq '1';
+ $zips{$$items{zip}} = $items;
+ }
+}
+
+__PACKAGE__->register_method(
+ method => 'search_zip',
+ api_name => 'open-ils.search.zip',
+ signature => q/
+ Given a zip code, returns address info for the zip code
+ @param auth the login session key
+ @param zip The zip code to check
+ @return On success, returns an object of the form:
+ { state=>, city=>, zip=>, stateid=>, county=>, areacode=>}
+ returns event on error
+ /
+);
+sub search_zip {
+ #my( $self, $conn, $auth, $zip ) = @_;
+ #my $e = OpenILS::Utils::Editor->new(authtoken=>$auth);
+ #return $e->event unless $e->checkauth;
+ #return $e->event unless $e->allowed('VIEW_ZIP_DATA');
+ my( $self, $conn, $zip ) = @_;
+ $zip =~ s/(^\d{5}).*/$1/; # we don't care about the last 4 digits if they exist
+ return $zips{$zip};
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+=head1 NAME
+
+OpenILS::Application::Serial - Performs serials-related tasks such as receiving issues and generating predictions
+
+=head1 SYNOPSIS
+
+TBD
+
+=head1 DESCRIPTION
+
+TBD
+
+=head1 AUTHOR
+
+Dan Wells, dbw2@calvin.edu
+
+=cut
+
+package OpenILS::Application::Serial;
+
+use strict;
+use warnings;
+
+
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Event;
+use OpenSRF::AppSession;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::MFHD;
+use DateTime::Format::ISO8601;
+use MARC::File::XML (BinaryEncoding => 'utf8');
+my $U = 'OpenILS::Application::AppUtils';
+my @MFHD_NAMES = ('basic','supplement','index');
+my %MFHD_NAMES_BY_TAG = ( '853' => $MFHD_NAMES[0],
+ '863' => $MFHD_NAMES[0],
+ '854' => $MFHD_NAMES[1],
+ '864' => $MFHD_NAMES[1],
+ '855' => $MFHD_NAMES[2],
+ '865' => $MFHD_NAMES[2] );
+my %MFHD_TAGS_BY_NAME = ( $MFHD_NAMES[0] => '853',
+ $MFHD_NAMES[1] => '854',
+ $MFHD_NAMES[2] => '855');
+my $_strp_date = new DateTime::Format::Strptime(pattern => '%F');
+
+# helper method for conforming dates to ISO8601
+sub _cleanse_dates {
+ my $item = shift;
+ my $fields = shift;
+
+ foreach my $field (@$fields) {
+ $item->$field(OpenSRF::Utils::clense_ISO8601($item->$field)) if $item->$field;
+ }
+ return 0;
+}
+
+sub _get_mvr {
+ $U->simplereq(
+ "open-ils.search",
+ "open-ils.search.biblio.record.mods_slim.retrieve",
+ @_
+ );
+}
+
+
+##########################################################################
+# item methods
+#
+__PACKAGE__->register_method(
+ method => "create_item_safely",
+ api_name => "open-ils.serial.item.create",
+ api_level => 1,
+ stream => 1,
+ argc => 3,
+ signature => {
+ desc => q/Creates any number of items, respecting only a few of the
+ submitted fields, as the user shouldn't be able to freely set certain
+ ones/,
+ params => [
+ {name=> "authtoken", desc => "Authtoken for current user session",
+ type => "string"},
+ {name => "item", desc => "serial item",
+ type => "object", class => "sitem"},
+ {name => "count",
+ desc => "optional: how many items to make " .
+ "(default 1; 1-100 permitted)",
+ type => "number"}
+ ],
+ return => {
+ desc => "created items (a stream of them)",
+ type => "object", class => "sitem"
+ }
+ }
+);
+__PACKAGE__->register_method(
+ method => "update_item_safely",
+ api_name => "open-ils.serial.item.update",
+ api_level => 1,
+ stream => 1,
+ argc => 2,
+ signature => {
+ desc => q/Edit a serial item, respecting only a few of the
+ submitted fields, as the user shouldn't be able to freely set certain
+ ones/,
+ params => [
+ {name=> "authtoken", desc => "Authtoken for current user session",
+ type => "string"},
+ {name => "item", desc => "serial item",
+ type => "object", class => "sitem"},
+ ],
+ return => {
+ desc => "created item", type => "object", class => "sitem"
+ }
+ }
+);
+
+sub _set_safe_item_fields {
+ my $dest = shift;
+ my $source = shift;
+ my $requestor_id = shift;
+ # extra fields remain in @_
+
+ $dest->edit_date("now");
+ $dest->editor($requestor_id);
+
+ my @fields = qw/date_expected date_received status/;
+
+ for my $field (@fields, @_) {
+ $dest->$field($source->$field);
+ }
+}
+
+sub update_item_safely {
+ my ($self, $client, $auth, $item) = @_;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ $e->checkauth or return $e->die_event;
+
+ my $orig = $e->retrieve_serial_item([
+ $item->id, {
+ "flesh" => 2, "flesh_fields" => {
+ "sitem" => ["stream"], "sstr" => ["distribution"]
+ }
+ }
+ ]) or return $e->die_event;
+
+ return $e->die_event unless $e->allowed(
+ "ADMIN_SERIAL_ITEM", $orig->stream->distribution->holding_lib
+ );
+
+ _set_safe_item_fields($orig, $item, $e->requestor->id);
+ $e->update_serial_item($orig) or return $e->die_event;
+
+ $client->respond($e->retrieve_serial_item($item->id));
+ $e->commit or return $e->die_event;
+ undef;
+}
+
+sub create_item_safely {
+ my ($self, $client, $auth, $item, $count) = @_;
+
+ $count = int $count;
+ $count ||= 1;
+ return new OpenILS::Event(
+ "BAD_PARAMS", note => "Count should be from 1 to 100"
+ ) unless $count >= 1 and $count <= 100;
+
+ my $e = new_editor("xact" => 1, "authtoken" => $auth);
+ $e->checkauth or return $e->die_event;
+
+ my $stream = $e->retrieve_serial_stream([
+ $item->stream, {
+ "flesh" => 1, "flesh_fields" => {"sstr" => ["distribution"]}
+ }
+ ]) or return $e->die_event;
+
+ return $e->die_event unless $e->allowed(
+ "ADMIN_SERIAL_ITEM", $stream->distribution->holding_lib
+ );
+
+ for (my $i = 0; $i < $count; $i++) {
+ my $actual = new Fieldmapper::serial::item;
+ $actual->creator($e->requestor->id);
+ _set_safe_item_fields(
+ $actual, $item, $e->requestor->id, "issuance", "stream"
+ );
+
+ $e->create_serial_item($actual) or return $e->die_event;
+ $client->respond($e->data);
+ }
+
+ $e->commit or return $e->die_event;
+ undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'fleshed_item_alter',
+ api_name => 'open-ils.serial.item.fleshed.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more items and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'items',
+ desc => 'Array of fleshed items',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub fleshed_item_alter {
+ my( $self, $conn, $auth, $items ) = @_;
+ return 1 unless ref $items;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission check
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $item (@$items) {
+
+ my $itemid = $item->id;
+ $item->editor($editor->requestor->id);
+ $item->edit_date('now');
+
+ if( $item->isdeleted ) {
+ $evt = _delete_sitem( $editor, $override, $item);
+ } elsif( $item->isnew ) {
+ # TODO: reconsider this
+ # if the item has a new issuance, create the issuance first
+ if (ref $item->issuance eq 'Fieldmapper::serial::issuance' and $item->issuance->isnew) {
+ fleshed_issuance_alter($self, $conn, $auth, [$item->issuance]);
+ }
+ _cleanse_dates($item, ['date_expected','date_received']);
+ $evt = _create_sitem( $editor, $item );
+ } else {
+ _cleanse_dates($item, ['date_expected','date_received']);
+ $evt = _update_sitem( $editor, $override, $item );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("fleshed item-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("item-alter: done updating item batch");
+ $editor->commit;
+ $logger->info("fleshed item-alter successfully updated ".scalar(@$items)." items");
+ return 1;
+}
+
+sub _delete_sitem {
+ my ($editor, $override, $item) = @_;
+ $logger->info("item-alter: delete item ".OpenSRF::Utils::JSON->perl2JSON($item));
+ return $editor->event unless $editor->delete_serial_item($item);
+ return 0;
+}
+
+sub _create_sitem {
+ my ($editor, $item) = @_;
+
+ $item->creator($editor->requestor->id);
+ $item->create_date('now');
+
+ $logger->info("item-alter: new item ".OpenSRF::Utils::JSON->perl2JSON($item));
+ return $editor->event unless $editor->create_serial_item($item);
+ return 0;
+}
+
+sub _update_sitem {
+ my ($editor, $override, $item) = @_;
+
+ $logger->info("item-alter: retrieving item ".$item->id);
+ my $orig_item = $editor->retrieve_serial_item($item->id);
+
+ $logger->info("item-alter: original item ".OpenSRF::Utils::JSON->perl2JSON($orig_item));
+ $logger->info("item-alter: updated item ".OpenSRF::Utils::JSON->perl2JSON($item));
+ return $editor->event unless $editor->update_serial_item($item);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "fleshed_serial_item_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.item.fleshed.batch.retrieve"
+);
+
+sub fleshed_serial_item_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+# FIXME: permissions?
+ $logger->info("Fetching fleshed serial items @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.item.search.atomic",
+ { id => $ids },
+ { flesh => 2,
+ flesh_fields => {sitem => [ qw/issuance creator editor stream unit notes/ ], sstr => ["distribution"], sunit => ["call_number"], siss => [qw/creator editor subscription/]}
+ });
+}
+
+
+##########################################################################
+# issuance methods
+#
+__PACKAGE__->register_method(
+ method => 'fleshed_issuance_alter',
+ api_name => 'open-ils.serial.issuance.fleshed.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more issuances and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'issuances',
+ desc => 'Array of fleshed issuances',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub fleshed_issuance_alter {
+ my( $self, $conn, $auth, $issuances ) = @_;
+ return 1 unless ref $issuances;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission support
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $issuance (@$issuances) {
+ my $issuanceid = $issuance->id;
+ $issuance->editor($editor->requestor->id);
+ $issuance->edit_date('now');
+
+ if( $issuance->isdeleted ) {
+ $evt = _delete_siss( $editor, $override, $issuance);
+ } elsif( $issuance->isnew ) {
+ _cleanse_dates($issuance, ['date_published']);
+ $evt = _create_siss( $editor, $issuance );
+ } else {
+ _cleanse_dates($issuance, ['date_published']);
+ $evt = _update_siss( $editor, $override, $issuance );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("fleshed issuance-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("issuance-alter: done updating issuance batch");
+ $editor->commit;
+ $logger->info("fleshed issuance-alter successfully updated ".scalar(@$issuances)." issuances");
+ return 1;
+}
+
+sub _delete_siss {
+ my ($editor, $override, $issuance) = @_;
+ $logger->info("issuance-alter: delete issuance ".OpenSRF::Utils::JSON->perl2JSON($issuance));
+ return $editor->event unless $editor->delete_serial_issuance($issuance);
+ return 0;
+}
+
+sub _create_siss {
+ my ($editor, $issuance) = @_;
+
+ $issuance->creator($editor->requestor->id);
+ $issuance->create_date('now');
+
+ $logger->info("issuance-alter: new issuance ".OpenSRF::Utils::JSON->perl2JSON($issuance));
+ return $editor->event unless $editor->create_serial_issuance($issuance);
+ return 0;
+}
+
+sub _update_siss {
+ my ($editor, $override, $issuance) = @_;
+
+ $logger->info("issuance-alter: retrieving issuance ".$issuance->id);
+ my $orig_issuance = $editor->retrieve_serial_issuance($issuance->id);
+
+ $logger->info("issuance-alter: original issuance ".OpenSRF::Utils::JSON->perl2JSON($orig_issuance));
+ $logger->info("issuance-alter: updated issuance ".OpenSRF::Utils::JSON->perl2JSON($issuance));
+ return $editor->event unless $editor->update_serial_issuance($issuance);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "fleshed_serial_issuance_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.issuance.fleshed.batch.retrieve"
+);
+
+sub fleshed_serial_issuance_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+# FIXME: permissions?
+ $logger->info("Fetching fleshed serial issuances @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.issuance.search.atomic",
+ { id => $ids },
+ { flesh => 1,
+ flesh_fields => {siss => [ qw/creator editor subscription/ ]}
+ });
+}
+
+__PACKAGE__->register_method(
+ method => "pub_fleshed_serial_issuance_retrieve_batch",
+ api_name => "open-ils.serial.issuance.pub_fleshed.batch.retrieve",
+ signature => {
+ desc => q/
+ Public (i.e. OPAC) call for getting at the sub and
+ ultimately the record entry from an issuance
+ /,
+ params => [{name => 'ids', desc => 'Array of IDs', type => 'array'}],
+ return => {
+ desc => q/
+ issuance objects, fleshed with subscriptions
+ /,
+ class => 'siss'
+ }
+ }
+);
+sub pub_fleshed_serial_issuance_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+ return [] unless $ids and @$ids;
+ return new_editor()->search_serial_issuance([
+ { id => $ids },
+ {
+ flesh => 1,
+ flesh_fields => {siss => [ qw/subscription/ ]}
+ }
+ ]);
+}
+
+sub received_siss_by_bib {
+ my $self = shift;
+ my $client = shift;
+ my $bib = shift;
+
+ my $args = shift || {};
+ $$args{order} ||= 'asc';
+
+ my $global = $$args{global} == 0 ? 0 : 1;
+
+ my $e = new_editor();
+ my $issuances = $e->json_query({
+ select => {
+ siss => [
+ $global ? { transform => "min", column => "id", aggregate => 1 } : "id",
+ "label",
+ "date_published"
+ ],
+ "sitem" => [
+ # We're not really interested in the minimum here. This is
+ # just a way to distinguish issuances whose items have units
+ # from issuances whose items have no units, without altogether
+ # excluding the latter type of issuances.
+ {"transform" => "min", "alias" => "has_units",
+ "column" => "unit", "aggregate" => 1}
+ ]
+ },
+ from => {
+ ssub => {
+ siss => {
+ field => 'subscription',
+ fkey => 'id',
+ join => {
+ sitem => {
+ field => 'issuance',
+ fkey => 'id',
+ $$args{ou} ? ( join => {
+ sstr => {
+ field => 'id',
+ fkey => 'stream',
+ join => {
+ sdist => {
+ field => 'id',
+ fkey => 'distribution'
+ }
+ }
+ }
+ }) : ()
+ }
+ }
+ }
+ }
+ },
+ where => {
+ '+ssub' => { record_entry => $bib },
+ $$args{type} ? ( '+siss' => { 'holding_type' => $$args{type} } ) : (),
+ '+sitem' => {
+ # XXX should we also take specific item statuses into account?
+ date_received => { '!=' => undef },
+ $$args{status} ? ( 'status' => $$args{status} ) : ()
+ },
+ $$args{ou} ? ( '+sdist' => {
+ holding_lib => {
+ 'in' => $U->get_org_descendants($$args{ou}, $$args{depth})
+ }
+ }) : ()
+ },
+ $$args{limit} ? ( limit => $$args{limit} ) : (),
+ $$args{offset} ? ( offset => $$args{offset} ) : (),
+ order_by => [{ class => 'siss', field => 'date_published', direction => $$args{order} }],
+ distinct => 1
+ });
+
+ $client->respond({
+ "issuance" => $e->retrieve_serial_issuance($_->{"id"}),
+ "has_units" => $_->{"has_units"} ? 1 : 0
+ }) for @$issuances;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'received_siss_by_bib',
+ api_name => 'open-ils.serial.received_siss.retrieve.by_bib',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ signature => {
+ desc => 'Receives a Bib ID and other optional params and returns "siss" (issuance) objects',
+ params => [
+ { name => 'bibid',
+ desc => 'id of the bre to which the issuances belong',
+ type => 'number'
+ },
+ { name => 'args',
+ desc =>
+q/A hash of optional arguments. Valid keys and their meanings:
+ global := If true, return only one representative version of a conceptual issuance regardless of the number of subscriptions, otherwise return all issuance objects meeting the requested criteria, including conceptual duplicates. Valid values are 0 (false) and 1 (true, default).
+ order := date_published sort direction, either "asc" (chronological, default) or "desc" (reverse chronological)
+ limit := Number of issuances to return. Useful for paging results, or finding the oldest or newest
+ offset := Number of issuance to skip before returning results. Useful for paging.
+ orgid := OU id used to scope retrieval, based on distribution.holding_lib
+ depth := OU depth used to range the scope of orgid
+ type := Holding type filter. Valid values are "basic", "supplement" and "index". Can be a scalar (one) or arrayref (one or more).
+ status := Item status filter. Valid values are "Bindery", "Bound", "Claimed", "Discarded", "Expected", "Not Held", "Not Published" and "Received". Can be a scalar (one) or arrayref (one or more).
+/
+ }
+ ]
+ }
+);
+
+
+sub scoped_bib_holdings_summary {
+ my $self = shift;
+ my $client = shift;
+ my $bibid = shift;
+ my $args = shift || {};
+
+ $args->{order} = 'asc';
+
+ my ($issuances) = $self->method_lookup('open-ils.serial.received_siss.retrieve.by_bib.atomic')->run( $bibid => $args );
+
+ # split into issuance type sets
+ my %type_blob = (basic => [], supplement => [], index => []);
+ push @{ $type_blob{ $_->{"issuance"}->holding_type } }, $_->{"issuance"}
+ for (@$issuances);
+
+ # generate a statement list for each type
+ my %statement_blob;
+ for my $type ( keys %type_blob ) {
+ my ($mfhd,$list) = _summarize_contents(new_editor(), $type_blob{$type});
+ $statement_blob{$type} = $list;
+ }
+
+ return \%statement_blob;
+}
+__PACKAGE__->register_method(
+ method => 'scoped_bib_holdings_summary',
+ api_name => 'open-ils.serial.bib.summary_statements',
+ api_level => 1,
+ argc => 1,
+ signature => {
+ desc => 'Receives a Bib ID and other optional params and returns set of holdings statements',
+ params => [
+ { name => 'bibid',
+ desc => 'id of the bre to which the issuances belong',
+ type => 'number'
+ },
+ { name => 'args',
+ desc =>
+q/A hash of optional arguments. Valid keys and their meanings:
+ orgid := OU id used to scope retrieval, based on distribution.holding_lib
+ depth := OU depth used to range the scope of orgid
+ type := Holding type filter. Valid values are "basic", "supplement" and "index". Can be a scalar (one) or arrayref (one or more).
+ status := Item status filter. Valid values are "Bindery", "Bound", "Claimed", "Discarded", "Expected", "Not Held", "Not Published" and "Received". Can be a scalar (one) or arrayref (one or more).
+/
+ }
+ ]
+ }
+);
+
+
+##########################################################################
+# unit methods
+#
+__PACKAGE__->register_method(
+ method => 'fleshed_sunit_alter',
+ api_name => 'open-ils.serial.sunit.fleshed.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more Units and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'sunits',
+ desc => 'Array of fleshed Units',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub fleshed_sunit_alter {
+ my( $self, $conn, $auth, $sunits ) = @_;
+ return 1 unless ref $sunits;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission support
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $sunit (@$sunits) {
+ if( $sunit->isdeleted ) {
+ $evt = _delete_sunit( $editor, $override, $sunit );
+ } else {
+ $sunit->default_location( $sunit->default_location->id ) if ref $sunit->default_location;
+
+ if( $sunit->isnew ) {
+ $evt = _create_sunit( $editor, $sunit );
+ } else {
+ $evt = _update_sunit( $editor, $override, $sunit );
+ }
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("fleshed sunit-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("sunit-alter: done updating sunit batch");
+ $editor->commit;
+ $logger->info("fleshed sunit-alter successfully updated ".scalar(@$sunits)." Units");
+ return 1;
+}
+
+sub _delete_sunit {
+ my ($editor, $override, $sunit) = @_;
+ $logger->info("sunit-alter: delete sunit ".OpenSRF::Utils::JSON->perl2JSON($sunit));
+ return $editor->event unless $editor->delete_serial_unit($sunit);
+ return 0;
+}
+
+sub _create_sunit {
+ my ($editor, $sunit) = @_;
+
+ $logger->info("sunit-alter: new Unit ".OpenSRF::Utils::JSON->perl2JSON($sunit));
+ return $editor->event unless $editor->create_serial_unit($sunit);
+ return 0;
+}
+
+sub _update_sunit {
+ my ($editor, $override, $sunit) = @_;
+
+ $logger->info("sunit-alter: retrieving sunit ".$sunit->id);
+ my $orig_sunit = $editor->retrieve_serial_unit($sunit->id);
+
+ $logger->info("sunit-alter: original sunit ".OpenSRF::Utils::JSON->perl2JSON($orig_sunit));
+ $logger->info("sunit-alter: updated sunit ".OpenSRF::Utils::JSON->perl2JSON($sunit));
+ return $editor->event unless $editor->update_serial_unit($sunit);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_unit_list",
+ authoritative => 1,
+ api_name => "open-ils.serial.unit_list.retrieve"
+);
+
+sub retrieve_unit_list {
+
+ my( $self, $client, @sdist_ids ) = @_;
+
+ if(ref($sdist_ids[0])) { @sdist_ids = @{$sdist_ids[0]}; }
+
+ my $e = new_editor();
+
+ my $query = {
+ 'select' =>
+ { 'sunit' => [ 'id', 'summary_contents', 'sort_key' ],
+ 'sitem' => ['stream'],
+ 'sstr' => ['distribution'],
+ 'sdist' => [{'column' => 'label', 'alias' => 'sdist_label'}]
+ },
+ 'from' =>
+ { 'sdist' =>
+ { 'sstr' =>
+ { 'join' =>
+ { 'sitem' =>
+ { 'join' => { 'sunit' => {} } }
+ }
+ }
+ }
+ },
+ 'distinct' => 'true',
+ 'where' => { '+sdist' => {'id' => \@sdist_ids} },
+ 'order_by' => [{'class' => 'sunit', 'field' => 'sort_key'}]
+ };
+
+ my $unit_list_entries = $e->json_query($query);
+
+ my @entries;
+ foreach my $entry (@$unit_list_entries) {
+ my $value = {'sunit' => $entry->{id}, 'sstr' => $entry->{stream}, 'sdist' => $entry->{distribution}};
+ my $label = $entry->{summary_contents};
+ if (length($label) > 100) {
+ $label = substr($label, 0, 100) . '...'; # limited space in dropdown / menu
+ }
+ $label = "[$entry->{sdist_label}/$entry->{stream} #$entry->{id}] " . $label;
+ push (@entries, [$label, OpenSRF::Utils::JSON->perl2JSON($value)]);
+ }
+
+ return \@entries;
+}
+
+
+
+##########################################################################
+# predict and receive methods
+#
+__PACKAGE__->register_method(
+ method => 'make_predictions',
+ api_name => 'open-ils.serial.make_predictions',
+ api_level => 1,
+ argc => 1,
+ signature => {
+ desc => 'Receives an ssub id and populates the issuance and item tables',
+ 'params' => [ {
+ name => 'ssub_id',
+ desc => 'Serial Subscription ID',
+ type => 'int'
+ }
+ ]
+ }
+);
+
+sub make_predictions {
+ my ($self, $conn, $authtoken, $args) = @_;
+
+ my $editor = OpenILS::Utils::CStoreEditor->new();
+ my $ssub_id = $args->{ssub_id};
+ my $mfhd = MFHD->new(MARC::Record->new());
+
+ my $ssub = $editor->retrieve_serial_subscription([$ssub_id]);
+ my $scaps = $editor->search_serial_caption_and_pattern({ subscription => $ssub_id, active => 't'});
+ my $sdists = $editor->search_serial_distribution( [{ subscription => $ssub->id }, { flesh => 1, flesh_fields => {sdist => [ qw/ streams / ]} }] ); #TODO: 'deleted' support?
+
+ my $total_streams = 0;
+ foreach (@$sdists) {
+ $total_streams += scalar(@{$_->streams});
+ }
+ if ($total_streams < 1) {
+ $editor->disconnect;
+ # XXX TODO new event type
+ return new OpenILS::Event(
+ "BAD_PARAMS", note =>
+ "There are no streams to direct items. Can't predict."
+ );
+ }
+
+ unless (@$scaps) {
+ $editor->disconnect;
+ # XXX TODO new event type
+ return new OpenILS::Event(
+ "BAD_PARAMS", note =>
+ "There are no active caption-and-pattern objects associated " .
+ "with this subscription. Can't predict."
+ );
+ }
+
+ my @predictions;
+ my $link_id = 1;
+ foreach my $scap (@$scaps) {
+ my $caption_field = _revive_caption($scap);
+ $caption_field->update('8' => $link_id);
+ my $using_fake_chron = 0;
+ # if we have no chronology, add one for prediction puposes
+ if (!$caption_field->subfield('i') and !$caption_field->enumeration_is_chronology) {
+ $using_fake_chron = 1;
+ }
+ $mfhd->append_fields($caption_field);
+ my $options = {
+ 'caption' => $caption_field,
+ 'scap_id' => $scap->id,
+ 'num_to_predict' => $args->{num_to_predict},
+ 'end_date' => defined $args->{end_date} ?
+ $_strp_date->parse_datetime($args->{end_date}) : undef
+ };
+ if ($args->{base_issuance}) { # predict from a given issuance
+ $options->{predict_from} = _revive_holding($args->{base_issuance}->holding_code, $caption_field, 1); # fresh MFHD Record, so we simply default to 1 for seqno
+ $options->{faked_chron_date} = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($args->{base_issuance}->date_published)) if $using_fake_chron;
+ } else { # default to predicting from last published
+ my $last_published = $editor->search_serial_issuance([
+ {'caption_and_pattern' => $scap->id,
+ 'subscription' => $ssub_id},
+ {limit => 1, order_by => { siss => "date_published DESC" }}]
+ );
+ if ($last_published->[0]) {
+ my $last_siss = $last_published->[0];
+ unless ($last_siss->holding_code) {
+ $editor->disconnect;
+ # XXX TODO new event type
+ return new OpenILS::Event(
+ "BAD_PARAMS", note =>
+ "Last issuance has no holding code. Can't predict."
+ );
+ }
+ $options->{predict_from} = _revive_holding($last_siss->holding_code, $caption_field, 1);
+ $options->{faked_chron_date} = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($last_siss->date_published)) if $using_fake_chron;
+ } else {
+ $editor->disconnect;
+ # XXX TODO make a new event type instead of hijacking this one
+ return new OpenILS::Event(
+ "BAD_PARAMS", note => "No issuance from which to predict!"
+ );
+ }
+ }
+ push( @predictions, _generate_issuance_values($mfhd, $options) );
+ $link_id++;
+ }
+
+ my @issuances;
+ foreach my $prediction (@predictions) {
+ my $issuance = new Fieldmapper::serial::issuance;
+ $issuance->isnew(1);
+ $issuance->label($prediction->{label});
+ $issuance->date_published($prediction->{date_published}->strftime('%F'));
+ $issuance->holding_code(OpenSRF::Utils::JSON->perl2JSON($prediction->{holding_code}));
+ $issuance->holding_type($prediction->{holding_type});
+ $issuance->caption_and_pattern($prediction->{caption_and_pattern});
+ $issuance->subscription($ssub->id);
+ push (@issuances, $issuance);
+ }
+
+ fleshed_issuance_alter($self, $conn, $authtoken, \@issuances); # FIXME: catch events
+
+ my @items;
+ for (my $i = 0; $i < @issuances; $i++) {
+ my $date_expected = $predictions[$i]->{date_published}->add(seconds => interval_to_seconds($ssub->expected_date_offset))->strftime('%F');
+ my $issuance = $issuances[$i];
+ #$issuance->label(interval_to_seconds($ssub->expected_date_offset));
+ foreach my $sdist (@$sdists) {
+ my $streams = $sdist->streams;
+ foreach my $stream (@$streams) {
+ my $item = new Fieldmapper::serial::item;
+ $item->isnew(1);
+ $item->stream($stream->id);
+ $item->date_expected($date_expected);
+ $item->issuance($issuance->id);
+ push (@items, $item);
+ }
+ }
+ }
+ fleshed_item_alter($self, $conn, $authtoken, \@items); # FIXME: catch events
+ return \@items;
+}
+
+#
+# _generate_issuance_values() is an initial attempt at a function which can be used
+# to populate an issuance table with a list of predicted issues. It accepts
+# a hash ref of options initially defined as:
+# caption : the caption field to predict on
+# num_to_predict : the number of issues you wish to predict
+# last_rec_date : the date of the last received issue, to be used as an offset
+# for predicting future issues
+# faked_chron_date : if the serial does not actually have a chronology caption (but we need one for prediction's sake), base predictions on this date
+#
+# The basic method is to first convert to a single holding if compressed, then
+# increment the holding and save the resulting values to @issuances.
+#
+# returns @issuance_values, an array of hashrefs containing (formatted
+# label, formatted chronology date, formatted estimated arrival date, and an
+# array ref of holding subfields as (key, value, key, value ...)) (not a hash
+# to protect order and possible duplicate keys), and a holding type.
+#
+sub _generate_issuance_values {
+ my ($mfhd, $options) = @_;
+ my $caption = $options->{caption};
+ my $scap_id = $options->{scap_id};
+ my $num_to_predict = $options->{num_to_predict};
+ my $end_date = $options->{end_date};
+ my $predict_from = $options->{predict_from}; # issuance to predict from
+ my $faked_chron_date = $options->{faked_chron_date}; # serial does not have a chronology caption, so add one (temporarily) based on this date
+ #my $last_rec_date = $options->{last_rec_date}; # expected or actual
+
+
+# Only needed for 'real' MFHD records, not our temp records
+# my $link_id = $caption->link_id;
+# if(!$predict_from) {
+# my $htag = $caption->tag;
+# $htag =~ s/^85/86/;
+# my @holdings = $mfhd->holdings($htag, $link_id);
+# my $last_holding = $holdings[-1];
+#
+# #if ($last_holding->is_compressed) {
+# # $last_holding->compressed_to_last; # convert to last in range
+# #}
+# $predict_from = $last_holding;
+# }
+#
+
+ $predict_from->notes('public', []);
+# add a note marker for system use (?)
+ $predict_from->notes('private', ['AUTOGEN']);
+
+ # our basic method for dealing with 'faked' chronologies will be to add it in, do the predicting, then take it back out
+ my $orig_caption;
+ my $faked_caption;
+ if ($faked_chron_date) {
+ $orig_caption = $predict_from->caption;
+ # because of the way MFHD::Caption and Holding work, it is simplest
+ # to recreate rather than try to update
+ $faked_caption = new MFHD::Caption(new MARC::Field($orig_caption->tag, $orig_caption->indicator(1), $orig_caption->indicator(2), $orig_caption->subfields_list, 'i' => '(year)', 'j' => '(month)', 'k' => '(day)'));
+ $predict_from = new MFHD::Holding($predict_from->seqno, new MARC::Field($predict_from->tag, $predict_from->indicator(1), $predict_from->indicator(2), $predict_from->subfields_list, 'i' => $faked_chron_date->year, 'j' => $faked_chron_date->month, 'k' => $faked_chron_date->day), $faked_caption);
+ }
+
+ my @predictions = $mfhd->generate_predictions({'base_holding' => $predict_from, 'num_to_predict' => $num_to_predict, 'end_date' => $end_date});
+
+ my $pub_date;
+ my @issuance_values;
+ foreach my $prediction (@predictions) {
+ $pub_date = $_strp_date->parse_datetime($prediction->chron_to_date);
+ if ($faked_chron_date) { # get rid of the chronology portions and restore original caption
+ $prediction->delete_subfield(code => ['i', 'j', 'k']);
+ $prediction = new MFHD::Holding($prediction->seqno, new MARC::Field($prediction->tag, $prediction->indicator(1), $prediction->indicator(2), $prediction->subfields_list), $orig_caption);
+ }
+ push(
+ @issuance_values,
+ {
+ #$link_id,
+ label => $prediction->format,
+ date_published => $pub_date,
+ #date_expected => $date_expected->strftime('%F'),
+ holding_code => [$prediction->indicator(1),$prediction->indicator(2),$prediction->subfields_list],
+ holding_type => $MFHD_NAMES_BY_TAG{$caption->tag},
+ caption_and_pattern => $scap_id
+ }
+ );
+ }
+
+ return @issuance_values;
+}
+
+sub _revive_caption {
+ my $scap = shift;
+
+ my $pattern_code = $scap->pattern_code;
+
+ # build MARC::Field
+ my $pattern_parts = OpenSRF::Utils::JSON->JSON2perl($pattern_code);
+ unshift(@$pattern_parts, $MFHD_TAGS_BY_NAME{$scap->type});
+ my $pattern_field = new MARC::Field(@$pattern_parts);
+
+ # build MFHD::Caption
+ return new MFHD::Caption($pattern_field);
+}
+
+sub _revive_holding {
+ my $holding_code = shift;
+ my $caption_field = shift;
+ my $seqno = shift;
+
+ # build MARC::Field
+ my $holding_parts = OpenSRF::Utils::JSON->JSON2perl($holding_code);
+ my $captag = $caption_field->tag;
+ $captag =~ s/^85/86/;
+ unshift(@$holding_parts, $captag);
+ my $holding_field = new MARC::Field(@$holding_parts);
+
+ # build MFHD::Holding
+ return new MFHD::Holding($seqno, $holding_field, $caption_field);
+}
+
+__PACKAGE__->register_method(
+ method => 'unitize_items',
+ api_name => 'open-ils.serial.receive_items',
+ api_level => 1,
+ argc => 1,
+ signature => {
+ desc => 'Marks an item as received, updates the shelving unit (creating a new shelving unit if needed), and updates the summaries',
+ 'params' => [ {
+ name => 'items',
+ desc => 'array of serial items',
+ type => 'array'
+ },
+ {
+ name => 'barcodes',
+ desc => 'hash of item_ids => barcodes',
+ type => 'hash'
+ },
+ {
+ name => 'call_numbers',
+ desc => 'hash of item_ids => call_numbers',
+ type => 'hash'
+ }
+ ],
+ 'return' => {
+ desc => 'Returns number of received items (num_items) and new unit ID, if applicable (new_unit_id)',
+ type => 'hashref'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'unitize_items',
+ api_name => 'open-ils.serial.bind_items',
+ api_level => 1,
+ argc => 1,
+ signature => {
+ desc => 'Marks an item as bound, updates the shelving unit (creating a new shelving unit if needed)',
+ 'params' => [ {
+ name => 'items',
+ desc => 'array of serial items',
+ type => 'array'
+ },
+ {
+ name => 'barcodes',
+ desc => 'hash of item_ids => barcodes',
+ type => 'hash'
+ },
+ {
+ name => 'call_numbers',
+ desc => 'hash of item_ids => call_numbers',
+ type => 'hash'
+ }
+ ],
+ 'return' => {
+ desc => 'Returns number of bound items (num_items) and new unit ID, if applicable (new_unit_id)',
+ type => 'hashref'
+ }
+ }
+);
+
+# TODO: reset/delete claims information once implemented
+# XXX: deal with emptied call numbers here?
+__PACKAGE__->register_method(
+ method => 'unitize_items',
+ api_name => 'open-ils.serial.reset_items',
+ api_level => 1,
+ argc => 1,
+ signature => {
+ desc => 'Resets the items to Expected, updates the shelving unit (deleting the shelving unit if empty), and updates the summaries',
+ 'params' => [ {
+ name => 'items',
+ desc => 'array of serial items',
+ type => 'array'
+ }
+ ],
+ 'return' => {
+ desc => 'Returns number of reset items (num_items)',
+ type => 'hashref'
+ }
+ }
+);
+
+sub unitize_items {
+ my ($self, $conn, $auth, $items, $barcodes, $call_numbers) = @_;
+
+ my $editor = new_editor("authtoken" => $auth, "xact" => 1);
+ return $editor->die_event unless $editor->checkauth;
+ return $editor->die_event unless $editor->allowed("RECEIVE_SERIAL");
+ $self->api_name =~ /serial\.(\w*)_items/;
+ my $mode = $1;
+
+ my %found_unit_ids;
+ my %found_stream_ids;
+ my %found_types;
+
+ my %stream_ids_by_unit_id;
+
+ my %unit_map;
+ my %sdist_by_unit_id;
+ my %call_number_by_unit_id;
+ my %sdist_by_stream_id;
+
+ my $new_unit_id; # id for '-2' units to share
+ foreach my $item (@$items) {
+ # for debugging only, TODO: delete
+ if (!ref $item) { # hopefully we got an id instead
+ $item = $editor->retrieve_serial_item($item);
+ }
+ # get ids
+ my $unit_id = ref($item->unit) ? $item->unit->id : $item->unit;
+ my $stream_id = ref($item->stream) ? $item->stream->id : $item->stream;
+ my $issuance_id = ref($item->issuance) ? $item->issuance->id : $item->issuance;
+ #TODO: evt on any missing ids
+
+ if ($mode eq 'receive') {
+ $item->date_received('now');
+ $item->status('Received');
+ } elsif ($mode eq 'reset') {
+ # clear date_received
+ $item->clear_date_received;
+ # Set status to 'Expected'
+ $item->status('Expected');
+ # remove from unit
+ $item->clear_unit;
+ }
+
+ # check for types to trigger summary updates
+ my $scap;
+ if (!ref $item->issuance) {
+ my $scaps = $editor->search_serial_caption_and_pattern([{"+siss" => {"id" => $issuance_id}}, { "join" => {"siss" => {}} }]);
+ $scap = $scaps->[0];
+ } elsif (!ref $item->issuance->caption_and_pattern) {
+ $scap = $editor->retrieve_serial_caption_and_pattern($item->issuance->caption_and_pattern);
+ } else {
+ $scap = $editor->issuance->caption_and_pattern;
+ }
+ if (!exists($found_types{$stream_id})) {
+ $found_types{$stream_id} = {};
+ }
+ $found_types{$stream_id}->{$scap->type} = 1;
+
+ # create unit if needed
+ if ($unit_id == -1 or (!$new_unit_id and $unit_id == -2)) { # create unit per item
+ my $unit;
+ my $sdists = $editor->search_serial_distribution([
+ {"+sstr" => {"id" => $stream_id}},
+ {
+ "join" => {"sstr" => {}},
+ "flesh" => 1,
+ "flesh_fields" => {"sdist" => ["subscription"]}
+ }]);
+ $unit = _build_unit($editor, $sdists->[0], $mode);
+ # if _build_unit fails, $unit is an event, so return it
+ if ($U->event_code($unit)) {
+ $editor->rollback;
+ $unit->{"note"} = "Item ID: " . $item->id;
+ return $unit;
+ }
+ $unit->barcode($barcodes->{$item->id}) if exists($barcodes->{$item->id});
+ my $evt = _create_sunit($editor, $unit);
+ return $evt if $evt;
+ if ($unit_id == -2) {
+ $new_unit_id = $unit->id;
+ $unit_id = $new_unit_id;
+ } else {
+ $unit_id = $unit->id;
+ }
+ $item->unit($unit_id);
+
+ # get unit with 'DEFAULT's and save unit, sdist, and call number for later use
+ $unit = $editor->retrieve_serial_unit($unit->id);
+ $unit_map{$unit_id} = $unit;
+ $sdist_by_unit_id{$unit_id} = $sdists->[0];
+ $call_number_by_unit_id{$unit_id} = $call_numbers->{$item->id};
+ $sdist_by_stream_id{$stream_id} = $sdists->[0];
+ } elsif ($unit_id == -2) { # create one unit for all '-2' items
+ $unit_id = $new_unit_id;
+ $item->unit($unit_id);
+ }
+
+ $found_stream_ids{$stream_id} = 1;
+
+ if (defined($unit_id)) {
+ $found_unit_ids{$unit_id} = 1;
+ # save the stream_id for this unit_id
+ # TODO: prevent items from different streams in same unit? (perhaps in interface)
+ $stream_ids_by_unit_id{$unit_id} = $stream_id;
+ }
+
+ my $evt = _update_sitem($editor, undef, $item);
+ return $evt if $evt;
+ }
+
+ # cleanup 'dead' units (units which are now emptied of their items)
+ my $dead_units = $editor->search_serial_unit([{'+sitem' => {'id' => undef}, 'deleted' => 'f'}, {'join' => {'sitem' => {'type' => 'left'}}}]);
+ foreach my $unit (@$dead_units) {
+ _delete_sunit($editor, undef, $unit);
+ delete $found_unit_ids{$unit->id};
+ }
+
+ # deal with unit level contents
+ foreach my $unit_id (keys %found_unit_ids) {
+
+ # get all the needed issuances for unit
+ # TODO remove 'Bindery' from this search (leaving it in for now for backwards compatibility with any current test environment data)
+ my $issuances = $editor->search_serial_issuance([ {"+sitem" => {"unit" => $unit_id, "status" => ["Received", "Bindery"]}}, {"join" => {"sitem" => {}}, "order_by" => {"siss" => "date_published"}} ]);
+ #TODO: evt on search failure
+
+ # retrieve and update unit contents
+ my $sunit;
+ my $sdist;
+ my $call_number_string;
+ my $record_id;
+ # if we just created the unit, we will already have it and the distribution stored, and we will need to assign the call number
+ if (exists $unit_map{$unit_id}) {
+ $sunit = $unit_map{$unit_id};
+ $sdist = $sdist_by_unit_id{$unit_id};
+ $call_number_string = $call_number_by_unit_id{$unit_id};
+ $record_id = $sdist->subscription->record_entry;
+ } else {
+ $sunit = $editor->retrieve_serial_unit($unit_id);
+ $sdist = $editor->search_serial_distribution([{"+sstr" => {"id" => $stream_ids_by_unit_id{$unit_id}}}, { "join" => {"sstr" => {}} }]);
+ $sdist = $sdist->[0];
+ }
+
+ my $evt = _prepare_unit($editor, $sunit, $sdist, $issuances, $call_number_string, $record_id);
+ if ($U->event_code($evt)) {
+ $editor->rollback;
+ return $evt;
+ }
+
+ $evt = _update_sunit($editor, undef, $sunit);
+ if ($U->event_code($evt)) {
+ $editor->rollback;
+ return $evt;
+ }
+ }
+
+ if ($mode ne 'bind') { # the summary holdings do not change when binding
+ # deal with stream level summaries
+ # summaries will be built from the "primary" stream only, that is, the stream with the lowest ID per distribution
+ # (TODO: consider direct designation)
+ my %primary_streams_by_sdist;
+ my %streams_by_sdist;
+
+ # see if we have primary streams, and if so, associate them with their distributions
+ foreach my $stream_id (keys %found_stream_ids) {
+ my $sdist;
+ if (exists $sdist_by_stream_id{$stream_id}) {
+ $sdist = $sdist_by_stream_id{$stream_id};
+ } else {
+ $sdist = $editor->search_serial_distribution([{"+sstr" => {"id" => $stream_id}}, { "join" => {"sstr" => {}} }]);
+ $sdist = $sdist->[0];
+ }
+ my $streams;
+ if (!exists($streams_by_sdist{$sdist->id})) {
+ $streams = $editor->search_serial_stream([{"distribution" => $sdist->id}, {"order_by" => {"sstr" => "id"}}]);
+ $streams_by_sdist{$sdist->id} = $streams;
+ } else {
+ $streams = $streams_by_sdist{$sdist->id};
+ }
+ $primary_streams_by_sdist{$sdist->id} = $streams->[0] if ($stream_id == $streams->[0]->id);
+ }
+
+ # retrieve and update summaries for each affected primary stream's distribution
+ foreach my $sdist_id (keys %primary_streams_by_sdist) {
+ my $stream = $primary_streams_by_sdist{$sdist_id};
+ my $stream_id = $stream->id;
+ # get all the needed issuances for stream
+ # FIXME: search in Bindery/Bound/Not Published? as well as Received
+ foreach my $type (keys %{$found_types{$stream_id}}) {
+ my $issuances = $editor->search_serial_issuance([ {"+sitem" => {"stream" => $stream_id, "status" => "Received"}, "+scap" => {"type" => $type}}, {"join" => {"sitem" => {}, "scap" => {}}, "order_by" => {"siss" => "date_published"}} ]);
+ #TODO: evt on search failure
+ my $evt = _prepare_summaries($editor, $issuances, $sdist_id, $type);
+ if ($U->event_code($evt)) {
+ $editor->rollback;
+ return $evt;
+ }
+ }
+ }
+ }
+
+ $editor->commit;
+ return {'num_items' => scalar @$items, 'new_unit_id' => $new_unit_id};
+}
+
+sub _find_or_create_call_number {
+ my ($e, $lib, $cn_string, $record) = @_;
+
+ my $existing = $e->search_asset_call_number({
+ "owning_lib" => $lib,
+ "label" => $cn_string,
+ "record" => $record,
+ "deleted" => "f"
+ }) or return $e->die_event;
+
+ if (@$existing) {
+ return $existing->[0]->id;
+ } else {
+ return $e->die_event unless
+ $e->allowed("CREATE_VOLUME", $lib);
+
+ my $acn = new Fieldmapper::asset::call_number;
+
+ $acn->creator($e->requestor->id);
+ $acn->editor($e->requestor->id);
+ $acn->record($record);
+ $acn->label($cn_string);
+ $acn->owning_lib($lib);
+
+ $e->create_asset_call_number($acn) or return $e->die_event;
+ return $e->data->id;
+ }
+}
+
+sub _issuances_received {
+ # XXX TODO: Add some caching or something. This is getting called
+ # more often than it has to be.
+ my ($e, $sitem) = @_;
+
+ my $results = $e->json_query({
+ "select" => {"sitem" => ["issuance"]},
+ "from" => {"sitem" => {"sstr" => {}, "siss" => {}}},
+ "where" => {
+ "+sstr" => {"distribution" => $sitem->stream->distribution->id},
+ "+siss" => {"holding_type" => $sitem->issuance->holding_type},
+ "+sitem" => {"date_received" => {"!=" => undef}}
+ },
+ "order_by" => {
+ "siss" => {"date_published" => {"direction" => "asc"}}
+ }
+ }) or return $e->die_event;
+
+ my $uniq = +{map { $_->{"issuance"} => 1 } @$results};
+ return [ map { $e->retrieve_serial_issuance($_) } keys %$uniq ];
+}
+
+# _prepare_unit populates the detailed_contents, summary_contents, and
+# sort_key fields for a given unit based on a given set of issuances
+# Also finds/creates call number as needed
+sub _prepare_unit {
+ my ($e, $sunit, $sdist, $issuances, $call_number_string, $record_id) = @_;
+
+ # Handle call number first if we have one
+ if ($call_number_string) {
+ my $org_unit_id = ref $sdist->holding_lib ? $sdist->holding_lib->id : $sdist->holding_lib;
+ my $real_cn = _find_or_create_call_number(
+ $e, $org_unit_id,
+ $call_number_string, $record_id
+ );
+
+ if ($U->event_code($real_cn)) {
+ return $real_cn;
+ } else {
+ $sunit->call_number($real_cn);
+ }
+ }
+
+ my ($mfhd, $formatted_parts) = _summarize_contents($e, $issuances);
+
+ # special case for single formatted_part (may have summarized version)
+ if (@$formatted_parts == 1) {
+ #TODO: MFHD.pm should have a 'format_summary' method for this
+ }
+
+ $sunit->detailed_contents(
+ join(
+ " ",
+ $sdist->unit_label_prefix,
+ join(", ", @$formatted_parts),
+ $sdist->unit_label_suffix
+ )
+ );
+
+ # TODO: change this when real summary contents are available
+ $sunit->summary_contents($sunit->detailed_contents);
+
+ # Create sort_key by left padding numbers to 6 digits.
+ (my $sort_key = $sunit->detailed_contents) =~
+ s/(\d+)/sprintf '%06d', $1/eg;
+ $sunit->sort_key($sort_key);
+}
+
+# _prepare_summaries populates the generated_coverage field for a given summary
+# type ('basic', 'index', 'supplement') for a given distribution.
+# It also creates the summary if it doesn't yet exist.
+sub _prepare_summaries {
+ my ($e, $issuances, $dist_id, $type) = @_;
+
+ my ($mfhd, $formatted_parts) = _summarize_contents($e, $issuances);
+
+ my $search_method = "search_serial_${type}_summary";
+ my $summary = $e->$search_method([{"distribution" => $dist_id}]);
+
+ my $cu_method = "update";
+
+ if (@$summary) {
+ $summary = $summary->[0];
+ } else {
+ my $class = "Fieldmapper::serial::${type}_summary";
+ $summary = $class->new;
+ $summary->distribution($dist_id);
+ $cu_method = "create";
+ }
+
+ $summary->generated_coverage(join(", ", @$formatted_parts));
+ my $method = "${cu_method}_serial_${type}_summary";
+ return $e->die_event unless $e->$method($summary);
+}
+
+sub _unit_by_iss_and_str {
+ my ($e, $issuance, $stream) = @_;
+
+ my $unit = $e->json_query({
+ "select" => {"sunit" => ["id"]},
+ "from" => {"sitem" => {"sunit" => {}}},
+ "where" => {
+ "+sitem" => {
+ "issuance" => $issuance->id,
+ "stream" => $stream->id
+ }
+ }
+ }) or return $e->die_event;
+ return 0 if not @$unit;
+
+ $e->retrieve_serial_unit($unit->[0]->{"id"}) or $e->die_event;
+}
+
+sub move_previous_unit {
+ my ($e, $prev_iss, $curr_item, $new_loc) = @_;
+
+ my $prev_unit = _unit_by_iss_and_str($e,$prev_iss,$curr_item->stream);
+ return $prev_unit if defined $U->event_code($prev_unit);
+ return 0 if not $prev_unit;
+
+ if ($prev_unit->location != $new_loc) {
+ $prev_unit->location($new_loc);
+ $e->update_serial_unit($prev_unit) or return $e->die_event;
+ }
+ 0;
+}
+
+# _previous_issuance() assumes $existing is an ordered array
+sub _previous_issuance {
+ my ($existing, $issuance) = @_;
+
+ my $last = $existing->[-1];
+ return undef unless $last;
+ return ($last->id == $issuance->id ? $existing->[-2] : $last);
+}
+
+__PACKAGE__->register_method(
+ "method" => "receive_items_one_unit_per",
+ "api_name" => "open-ils.serial.receive_items.one_unit_per",
+ "stream" => 1,
+ "api_level" => 1,
+ "argc" => 3,
+ "signature" => {
+ "desc" => "Marks items in a list as received, creates a new unit for each item if any unit is fleshed on, and updates summaries as needed",
+ "params" => [
+ {
+ "name" => "auth",
+ "desc" => "authtoken",
+ "type" => "string"
+ },
+ {
+ "name" => "items",
+ "desc" => "array of serial items, possibly fleshed with units and definitely fleshed with stream->distribution",
+ "type" => "array"
+ },
+ {
+ "name" => "record",
+ "desc" => "id of bib record these items are associated with
+ (XXX could/should be derived from items)",
+ "type" => "number"
+ }
+ ],
+ "return" => {
+ "desc" => "The item ID for each item successfully received",
+ "type" => "int"
+ }
+ }
+);
+
+sub receive_items_one_unit_per {
+ # XXX This function may be temporary, as it does some of what
+ # unitize_items() does, just in a different way.
+ my ($self, $client, $auth, $items, $record) = @_;
+
+ my $e = new_editor("authtoken" => $auth, "xact" => 1);
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed("RECEIVE_SERIAL");
+
+ my $prev_loc_setting_map = {};
+ my $user_id = $e->requestor->id;
+
+ # Get a list of all the non-virtual field names in a serial::unit for
+ # merging given unit objects with template-built units later.
+ # XXX move this somewhere global so it isn't re-run all the time
+ my $all_unit_fields =
+ $Fieldmapper::fieldmap->{"Fieldmapper::serial::unit"}->{"fields"};
+ my @real_unit_fields = grep {
+ not $all_unit_fields->{$_}->{"virtual"}
+ } keys %$all_unit_fields;
+
+ foreach my $item (@$items) {
+ # Note that we expect a certain fleshing on the items we're getting.
+ my $sdist = $item->stream->distribution;
+
+ # Fetch a list of issuances with received copies already existing
+ # on this distribution (and with the same holding type on the
+ # issuance). This will be used in up to two places: once when building
+ # a summary, once when changing the copy location of the previous
+ # issuance's copy.
+ my $issuances_received = _issuances_received($e, $item);
+ if ($U->event_code($issuances_received)) {
+ $e->rollback;
+ return $issuances_received;
+ }
+
+ # Find out if we need to to deal with previous copy location changing.
+ my $ou = $sdist->holding_lib->id;
+ unless (exists $prev_loc_setting_map->{$ou}) {
+ $prev_loc_setting_map->{$ou} = $U->ou_ancestor_setting_value(
+ $ou, "serial.prev_issuance_copy_location", $e
+ );
+ }
+
+ # If there is a previous copy location setting, we need the previous
+ # issuance, from which we can in turn look up the item attached to the
+ # same stream we're on now.
+ if ($prev_loc_setting_map->{$ou}) {
+ if (my $prev_iss =
+ _previous_issuance($issuances_received, $item->issuance)) {
+
+ # Now we can change the copy location of the previous unit,
+ # if needed.
+ return $e->event if defined $U->event_code(
+ move_previous_unit(
+ $e, $prev_iss, $item, $prev_loc_setting_map->{$ou}
+ )
+ );
+ }
+ }
+
+ # Create unit if given by user
+ if (ref $item->unit) {
+ # detach from the item, as we need to create separately
+ my $user_unit = $item->unit;
+
+ # get a unit based on associated template
+ my $template_unit = _build_unit($e, $sdist, "receive");
+ if ($U->event_code($template_unit)) {
+ $e->rollback;
+ $template_unit->{"note"} = "Item ID: " . $item->id;
+ return $template_unit;
+ }
+
+ # merge built unit with provided unit from user
+ foreach (@real_unit_fields) {
+ unless ($user_unit->$_) {
+ $user_unit->$_($template_unit->$_);
+ }
+ }
+
+ # Treat call number specially: the provided value from the
+ # user will really be a string.
+ my $call_number_string;
+ if ($user_unit->call_number) {
+ $call_number_string = $user_unit->call_number;
+ # clear call number for now (replaced in _prepare_unit)
+ $user_unit->clear_call_number;
+ }
+
+ my $evt = _prepare_unit(
+ $e, $user_unit, $sdist, [$item->issuance],
+ $call_number_string, $record
+ );
+ if ($U->event_code($evt)) {
+ $e->rollback;
+ return $evt;
+ }
+
+ # create/update summary objects related to this distribution
+ # Make sure @$issuances_received contains current item's issuance
+ unless (grep { $_->id == $item->issuance->id } @$issuances_received) {
+ push @$issuances_received, $item->issuance;
+ }
+ $evt = _prepare_summaries($e, $issuances_received, $item->stream->distribution->id, $item->issuance->holding_type);
+ if ($U->event_code($evt)) {
+ $e->rollback;
+ return $evt;
+ }
+
+ # set the incontrovertibles on the unit
+ $user_unit->edit_date("now");
+ $user_unit->create_date("now");
+ $user_unit->editor($user_id);
+ $user_unit->creator($user_id);
+
+ return $e->die_event unless $e->create_serial_unit($user_unit);
+
+ # save reference to new unit
+ $item->unit($e->data->id);
+ }
+
+ # Create notes if given by user
+ if (ref($item->notes) and @{$item->notes}) {
+ foreach my $note (@{$item->notes}) {
+ $note->creator($user_id);
+ $note->create_date("now");
+
+ return $e->die_event unless $e->create_serial_item_note($note);
+ }
+
+ $item->clear_notes; # They're saved; we no longer want them here.
+ }
+
+ # Set the incontrovertibles on the item
+ $item->status("Received");
+ $item->date_received("now");
+ $item->edit_date("now");
+ $item->editor($user_id);
+
+ return $e->die_event unless $e->update_serial_item($item);
+
+ # send client a response
+ $client->respond($item->id);
+ }
+
+ $e->commit or return $e->die_event;
+ undef;
+}
+
+sub _build_unit {
+ my $editor = shift;
+ my $sdist = shift;
+ my $mode = shift;
+ #my $skip_call_number = shift;
+
+ my $attr = $mode . '_unit_template';
+ my $template = $editor->retrieve_asset_copy_template($sdist->$attr) or
+ return new OpenILS::Event("SERIAL_DISTRIBUTION_HAS_NO_COPY_TEMPLATE");
+
+ my @parts = qw( status location loan_duration fine_level age_protect circulate deposit ref holdable deposit_amount price circ_modifier circ_as_type alert_message opac_visible floating mint_condition );
+
+ my $unit = new Fieldmapper::serial::unit;
+ foreach my $part (@parts) {
+ my $value = $template->$part;
+ next if !defined($value);
+ $unit->$part($value);
+ }
+
+ # ignore circ_lib in template, set to distribution holding_lib
+ $unit->circ_lib($sdist->holding_lib);
+ $unit->creator($editor->requestor->id);
+ $unit->editor($editor->requestor->id);
+
+# XXX: this feature has been pushed back until after 2.0 at least
+# unless ($skip_call_number) {
+# $attr = $mode . '_call_number';
+# my $cn = $sdist->$attr or
+# return new OpenILS::Event("SERIAL_DISTRIBUTION_HAS_NO_CALL_NUMBER");
+#
+# $unit->call_number($cn);
+# }
+ $unit->call_number('-1'); # default to the dummy call number
+ $unit->barcode('@@PLACEHOLDER'); # generic unit will start with a generated placeholder barcode
+ $unit->sort_key('');
+ $unit->summary_contents('');
+ $unit->detailed_contents('');
+
+ return $unit;
+}
+
+
+sub _summarize_contents {
+ my $editor = shift;
+ my $issuances = shift;
+
+ # create MFHD record
+ my $mfhd = MFHD->new(MARC::Record->new());
+ my %scaps;
+ my %scap_fields;
+ my @scap_fields_ordered;
+ my $seqno = 1;
+ my $link_id = 1;
+ foreach my $issuance (@$issuances) {
+ my $scap_id = $issuance->caption_and_pattern;
+ next if (!$scap_id); # skip issuances with no caption/pattern
+
+ my $scap;
+ my $scap_field;
+ # if this is the first appearance of this scap, retrieve it and add it to the temporary record
+ if (!exists $scaps{$issuance->caption_and_pattern}) {
+ $scaps{$scap_id} = $editor->retrieve_serial_caption_and_pattern($scap_id);
+ $scap = $scaps{$scap_id};
+ $scap_field = _revive_caption($scap);
+ $scap_fields{$scap_id} = $scap_field;
+ push(@scap_fields_ordered, $scap_field);
+ $scap_field->update('8' => $link_id);
+ $mfhd->append_fields($scap_field);
+ $link_id++;
+ } else {
+ $scap = $scaps{$scap_id};
+ $scap_field = $scap_fields{$scap_id};
+ }
+
+ $mfhd->append_fields(_revive_holding($issuance->holding_code, $scap_field, $seqno));
+ $seqno++;
+ }
+
+ my @formatted_parts;
+ foreach my $scap_field (@scap_fields_ordered) { #TODO: use generic MFHD "summarize" method, once available
+ my @updated_holdings = $mfhd->get_compressed_holdings($scap_field);
+ foreach my $holding (@updated_holdings) {
+ push(@formatted_parts, $holding->format);
+ }
+ }
+
+ return ($mfhd, \@formatted_parts);
+}
+
+##########################################################################
+# note methods
+#
+__PACKAGE__->register_method(
+ method => 'fetch_notes',
+ api_name => 'open-ils.serial.item_note.retrieve.all',
+ signature => q/
+ Returns an array of copy note objects.
+ @param args A named hash of parameters including:
+ authtoken : Required if viewing non-public notes
+ item_id : The id of the item whose notes we want to retrieve
+ pub : True if all the caller wants are public notes
+ @return An array of note objects
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'fetch_notes',
+ api_name => 'open-ils.serial.subscription_note.retrieve.all',
+ signature => q/
+ Returns an array of copy note objects.
+ @param args A named hash of parameters including:
+ authtoken : Required if viewing non-public notes
+ subscription_id : The id of the item whose notes we want to retrieve
+ pub : True if all the caller wants are public notes
+ @return An array of note objects
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'fetch_notes',
+ api_name => 'open-ils.serial.distribution_note.retrieve.all',
+ signature => q/
+ Returns an array of copy note objects.
+ @param args A named hash of parameters including:
+ authtoken : Required if viewing non-public notes
+ distribution_id : The id of the item whose notes we want to retrieve
+ pub : True if all the caller wants are public notes
+ @return An array of note objects
+ /
+);
+
+# TODO: revisit this method to consider replacing cstore direct calls
+sub fetch_notes {
+ my( $self, $connection, $args ) = @_;
+
+ $self->api_name =~ /serial\.(\w*)_note/;
+ my $type = $1;
+
+ my $id = $$args{object_id};
+ my $authtoken = $$args{authtoken};
+ my( $r, $evt);
+
+ if( $$args{pub} ) {
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.serial.'.$type.'_note.search.atomic',
+ { $type => $id, pub => 't' } );
+ } else {
+ # FIXME: restore perm check
+ # ( $r, $evt ) = $U->checksesperm($authtoken, 'VIEW_COPY_NOTES');
+ # return $evt if $evt;
+ return $U->cstorereq(
+ 'open-ils.cstore.direct.serial.'.$type.'_note.search.atomic', {$type => $id} );
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'create_note',
+ api_name => 'open-ils.serial.item_note.create',
+ signature => q/
+ Creates a new item note
+ @param authtoken The login session key
+ @param note The note object to create
+ @return The id of the new note object
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'create_note',
+ api_name => 'open-ils.serial.subscription_note.create',
+ signature => q/
+ Creates a new subscription note
+ @param authtoken The login session key
+ @param note The note object to create
+ @return The id of the new note object
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'create_note',
+ api_name => 'open-ils.serial.distribution_note.create',
+ signature => q/
+ Creates a new distribution note
+ @param authtoken The login session key
+ @param note The note object to create
+ @return The id of the new note object
+ /
+);
+
+sub create_note {
+ my( $self, $connection, $authtoken, $note ) = @_;
+
+ $self->api_name =~ /serial\.(\w*)_note/;
+ my $type = $1;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->event unless $e->checkauth;
+
+ # FIXME: restore permission support
+# my $item = $e->retrieve_serial_item(
+# [
+# $note->item
+# ]
+# );
+#
+# return $e->event unless
+# $e->allowed('CREATE_COPY_NOTE', $item->call_number->owning_lib);
+
+ $note->create_date('now');
+ $note->creator($e->requestor->id);
+ $note->pub( ($U->is_true($note->pub)) ? 't' : 'f' );
+ $note->clear_id;
+
+ my $method = "create_serial_${type}_note";
+ $e->$method($note) or return $e->event;
+ $e->commit;
+ return $note->id;
+}
+
+__PACKAGE__->register_method(
+ method => 'delete_note',
+ api_name => 'open-ils.serial.item_note.delete',
+ signature => q/
+ Deletes an existing item note
+ @param authtoken The login session key
+ @param noteid The id of the note to delete
+ @return 1 on success - Event otherwise.
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'delete_note',
+ api_name => 'open-ils.serial.subscription_note.delete',
+ signature => q/
+ Deletes an existing subscription note
+ @param authtoken The login session key
+ @param noteid The id of the note to delete
+ @return 1 on success - Event otherwise.
+ /
+);
+
+__PACKAGE__->register_method(
+ method => 'delete_note',
+ api_name => 'open-ils.serial.distribution_note.delete',
+ signature => q/
+ Deletes an existing distribution note
+ @param authtoken The login session key
+ @param noteid The id of the note to delete
+ @return 1 on success - Event otherwise.
+ /
+);
+
+sub delete_note {
+ my( $self, $conn, $authtoken, $noteid ) = @_;
+
+ $self->api_name =~ /serial\.(\w*)_note/;
+ my $type = $1;
+
+ my $e = new_editor(xact=>1, authtoken=>$authtoken);
+ return $e->die_event unless $e->checkauth;
+
+ my $method = "retrieve_serial_${type}_note";
+ my $note = $e->$method([
+ $noteid,
+ ]) or return $e->die_event;
+
+# FIXME: restore permissions check
+# if( $note->creator ne $e->requestor->id ) {
+# return $e->die_event unless
+# $e->allowed('DELETE_COPY_NOTE', $note->item->call_number->owning_lib);
+# }
+
+ $method = "delete_serial_${type}_note";
+ $e->$method($note) or return $e->die_event;
+ $e->commit;
+ return 1;
+}
+
+
+##########################################################################
+# subscription methods
+#
+__PACKAGE__->register_method(
+ method => 'fleshed_ssub_alter',
+ api_name => 'open-ils.serial.subscription.fleshed.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more subscriptions and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'subscriptions',
+ desc => 'Array of fleshed subscriptions',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub fleshed_ssub_alter {
+ my( $self, $conn, $auth, $ssubs ) = @_;
+ return 1 unless ref $ssubs;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission check
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $ssub (@$ssubs) {
+
+ my $ssubid = $ssub->id;
+
+ if( $ssub->isdeleted ) {
+ $evt = _delete_ssub( $editor, $override, $ssub);
+ } elsif( $ssub->isnew ) {
+ _cleanse_dates($ssub, ['start_date','end_date']);
+ $evt = _create_ssub( $editor, $ssub );
+ } else {
+ _cleanse_dates($ssub, ['start_date','end_date']);
+ $evt = _update_ssub( $editor, $override, $ssub );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("fleshed subscription-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("subscription-alter: done updating subscription batch");
+ $editor->commit;
+ $logger->info("fleshed subscription-alter successfully updated ".scalar(@$ssubs)." subscriptions");
+ return 1;
+}
+
+sub _delete_ssub {
+ my ($editor, $override, $ssub) = @_;
+ $logger->info("subscription-alter: delete subscription ".OpenSRF::Utils::JSON->perl2JSON($ssub));
+ my $sdists = $editor->search_serial_distribution(
+ { subscription => $ssub->id }, { limit => 1 } ); #TODO: 'deleted' support?
+ my $cps = $editor->search_serial_caption_and_pattern(
+ { subscription => $ssub->id }, { limit => 1 } ); #TODO: 'deleted' support?
+ my $sisses = $editor->search_serial_issuance(
+ { subscription => $ssub->id }, { limit => 1 } ); #TODO: 'deleted' support?
+ return OpenILS::Event->new(
+ 'SERIAL_SUBSCRIPTION_NOT_EMPTY', payload => $ssub->id ) if (@$sdists or @$cps or @$sisses);
+
+ return $editor->event unless $editor->delete_serial_subscription($ssub);
+ return 0;
+}
+
+sub _create_ssub {
+ my ($editor, $ssub) = @_;
+
+ $logger->info("subscription-alter: new subscription ".OpenSRF::Utils::JSON->perl2JSON($ssub));
+ return $editor->event unless $editor->create_serial_subscription($ssub);
+ return 0;
+}
+
+sub _update_ssub {
+ my ($editor, $override, $ssub) = @_;
+
+ $logger->info("subscription-alter: retrieving subscription ".$ssub->id);
+ my $orig_ssub = $editor->retrieve_serial_subscription($ssub->id);
+
+ $logger->info("subscription-alter: original subscription ".OpenSRF::Utils::JSON->perl2JSON($orig_ssub));
+ $logger->info("subscription-alter: updated subscription ".OpenSRF::Utils::JSON->perl2JSON($ssub));
+ return $editor->event unless $editor->update_serial_subscription($ssub);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "fleshed_serial_subscription_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.subscription.fleshed.batch.retrieve"
+);
+
+sub fleshed_serial_subscription_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+# FIXME: permissions?
+ $logger->info("Fetching fleshed subscriptions @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.subscription.search.atomic",
+ { id => $ids },
+ { flesh => 1,
+ flesh_fields => {ssub => [ qw/owning_lib notes/ ]}
+ });
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_sub_tree",
+ authoritative => 1,
+ api_name => "open-ils.serial.subscription_tree.retrieve"
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_sub_tree",
+ api_name => "open-ils.serial.subscription_tree.global.retrieve"
+);
+
+sub retrieve_sub_tree {
+
+ my( $self, $client, $user_session, $docid, @org_ids ) = @_;
+
+ if(ref($org_ids[0])) { @org_ids = @{$org_ids[0]}; }
+
+ $docid = "$docid";
+
+ # TODO: permission support
+ if(!@org_ids and $user_session) {
+ my $user_obj =
+ OpenILS::Application::AppUtils->check_user_session( $user_session ); #throws EX on error
+ @org_ids = ($user_obj->home_ou);
+ }
+
+ if( $self->api_name =~ /global/ ) {
+ return _build_subs_list( { record_entry => $docid } ); # TODO: filter for !deleted, or active?
+
+ } else {
+
+ my @all_subs;
+ for my $orgid (@org_ids) {
+ my $subs = _build_subs_list(
+ { record_entry => $docid, owning_lib => $orgid } );# TODO: filter for !deleted, or active?
+ push( @all_subs, @$subs );
+ }
+
+ return \@all_subs;
+ }
+
+ return undef;
+}
+
+sub _build_subs_list {
+ my $search_hash = shift;
+
+ #$search_hash->{deleted} = 'f';
+ my $e = new_editor();
+
+ my $subs = $e->search_serial_subscription([$search_hash, { 'order_by' => {'ssub' => 'id'} }]);
+
+ my @built_subs;
+
+ for my $sub (@$subs) {
+
+ # TODO: filter on !deleted?
+ my $dists = $e->search_serial_distribution(
+ [{ subscription => $sub->id }, { 'order_by' => {'sdist' => 'label'} }]
+ );
+
+ #$dists = [ sort { $a->label cmp $b->label } @$dists ];
+
+ $sub->distributions($dists);
+
+ # TODO: filter on !deleted?
+ my $issuances = $e->search_serial_issuance(
+ [{ subscription => $sub->id }, { 'order_by' => {'siss' => 'label'} }]
+ );
+
+ #$issuances = [ sort { $a->label cmp $b->label } @$issuances ];
+ $sub->issuances($issuances);
+
+ # TODO: filter on !deleted?
+ my $scaps = $e->search_serial_caption_and_pattern(
+ [{ subscription => $sub->id }, { 'order_by' => {'scap' => 'id'} }]
+ );
+
+ #$scaps = [ sort { $a->id cmp $b->id } @$scaps ];
+ $sub->scaps($scaps);
+ push( @built_subs, $sub );
+ }
+
+ return \@built_subs;
+
+}
+
+__PACKAGE__->register_method(
+ method => "subscription_orgs_for_title",
+ authoritative => 1,
+ api_name => "open-ils.serial.subscription.retrieve_orgs_by_title"
+);
+
+sub subscription_orgs_for_title {
+ my( $self, $client, $record_id ) = @_;
+
+ my $subs = $U->simple_scalar_request(
+ "open-ils.cstore",
+ "open-ils.cstore.direct.serial.subscription.search.atomic",
+ { record_entry => $record_id }); # TODO: filter on !deleted?
+
+ my $orgs = { map {$_->owning_lib => 1 } @$subs };
+ return [ keys %$orgs ];
+}
+
+
+##########################################################################
+# distribution methods
+#
+__PACKAGE__->register_method(
+ method => 'fleshed_sdist_alter',
+ api_name => 'open-ils.serial.distribution.fleshed.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more distributions and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'distributions',
+ desc => 'Array of fleshed distributions',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub fleshed_sdist_alter {
+ my( $self, $conn, $auth, $sdists ) = @_;
+ return 1 unless ref $sdists;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission check
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $sdist (@$sdists) {
+ my $sdistid = $sdist->id;
+
+ if( $sdist->isdeleted ) {
+ $evt = _delete_sdist( $editor, $override, $sdist);
+ } elsif( $sdist->isnew ) {
+ $evt = _create_sdist( $editor, $sdist );
+ } else {
+ $evt = _update_sdist( $editor, $override, $sdist );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("fleshed distribution-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("distribution-alter: done updating distribution batch");
+ $editor->commit;
+ $logger->info("fleshed distribution-alter successfully updated ".scalar(@$sdists)." distributions");
+ return 1;
+}
+
+sub _delete_sdist {
+ my ($editor, $override, $sdist) = @_;
+ $logger->info("distribution-alter: delete distribution ".OpenSRF::Utils::JSON->perl2JSON($sdist));
+ return $editor->event unless $editor->delete_serial_distribution($sdist);
+ return 0;
+}
+
+sub _create_sdist {
+ my ($editor, $sdist) = @_;
+
+ $logger->info("distribution-alter: new distribution ".OpenSRF::Utils::JSON->perl2JSON($sdist));
+ return $editor->event unless $editor->create_serial_distribution($sdist);
+
+ # create summaries too
+ my $summary = new Fieldmapper::serial::basic_summary;
+ $summary->distribution($sdist->id);
+ $summary->generated_coverage('');
+ return $editor->event unless $editor->create_serial_basic_summary($summary);
+ $summary = new Fieldmapper::serial::supplement_summary;
+ $summary->distribution($sdist->id);
+ $summary->generated_coverage('');
+ return $editor->event unless $editor->create_serial_supplement_summary($summary);
+ $summary = new Fieldmapper::serial::index_summary;
+ $summary->distribution($sdist->id);
+ $summary->generated_coverage('');
+ return $editor->event unless $editor->create_serial_index_summary($summary);
+
+ # create a starter stream (TODO: reconsider this)
+ my $stream = new Fieldmapper::serial::stream;
+ $stream->distribution($sdist->id);
+ return $editor->event unless $editor->create_serial_stream($stream);
+
+ return 0;
+}
+
+sub _update_sdist {
+ my ($editor, $override, $sdist) = @_;
+
+ $logger->info("distribution-alter: retrieving distribution ".$sdist->id);
+ my $orig_sdist = $editor->retrieve_serial_distribution($sdist->id);
+
+ $logger->info("distribution-alter: original distribution ".OpenSRF::Utils::JSON->perl2JSON($orig_sdist));
+ $logger->info("distribution-alter: updated distribution ".OpenSRF::Utils::JSON->perl2JSON($sdist));
+ return $editor->event unless $editor->update_serial_distribution($sdist);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "fleshed_serial_distribution_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.distribution.fleshed.batch.retrieve"
+);
+
+sub fleshed_serial_distribution_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+# FIXME: permissions?
+ $logger->info("Fetching fleshed distributions @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.distribution.search.atomic",
+ { id => $ids },
+ { flesh => 1,
+ flesh_fields => {sdist => [ qw/ holding_lib receive_call_number receive_unit_template bind_call_number bind_unit_template streams / ]}
+ });
+}
+
+__PACKAGE__->register_method(
+ method => "retrieve_dist_tree",
+ authoritative => 1,
+ api_name => "open-ils.serial.distribution_tree.retrieve"
+);
+
+__PACKAGE__->register_method(
+ method => "retrieve_dist_tree",
+ api_name => "open-ils.serial.distribution_tree.global.retrieve"
+);
+
+sub retrieve_dist_tree {
+ my( $self, $client, $user_session, $docid, @org_ids ) = @_;
+
+ if(ref($org_ids[0])) { @org_ids = @{$org_ids[0]}; }
+
+ $docid = "$docid";
+
+ # TODO: permission support
+ if(!@org_ids and $user_session) {
+ my $user_obj =
+ OpenILS::Application::AppUtils->check_user_session( $user_session ); #throws EX on error
+ @org_ids = ($user_obj->home_ou);
+ }
+
+ my $e = new_editor();
+
+ if( $self->api_name =~ /global/ ) {
+ return $e->search_serial_distribution([{'+ssub' => { record_entry => $docid }},
+ { flesh => 1,
+ flesh_fields => {sdist => [ qw/ holding_lib receive_call_number receive_unit_template bind_call_number bind_unit_template streams basic_summary supplement_summary index_summary / ]},
+ order_by => {'sdist' => 'id'},
+ 'join' => {'ssub' => {}}
+ }
+ ]); # TODO: filter for !deleted?
+
+ } else {
+ my @all_dists;
+ for my $orgid (@org_ids) {
+ my $dists = $e->search_serial_distribution([{'+ssub' => { record_entry => $docid }, holding_lib => $orgid},
+ { flesh => 1,
+ flesh_fields => {sdist => [ qw/ holding_lib receive_call_number receive_unit_template bind_call_number bind_unit_template streams basic_summary supplement_summary index_summary / ]},
+ order_by => {'sdist' => 'id'},
+ 'join' => {'ssub' => {}}
+ }
+ ]); # TODO: filter for !deleted?
+ push( @all_dists, @$dists ) if $dists;
+ }
+
+ return \@all_dists;
+ }
+
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ method => "distribution_orgs_for_title",
+ authoritative => 1,
+ api_name => "open-ils.serial.distribution.retrieve_orgs_by_title"
+);
+
+sub distribution_orgs_for_title {
+ my( $self, $client, $record_id ) = @_;
+
+ my $dists = $U->cstorereq(
+ "open-ils.cstore.direct.serial.distribution.search.atomic",
+ { '+ssub' => { record_entry => $record_id } },
+ { 'join' => {'ssub' => {}} }); # TODO: filter on !deleted?
+
+ my $orgs = { map {$_->holding_lib => 1 } @$dists };
+ return [ keys %$orgs ];
+}
+
+
+##########################################################################
+# caption and pattern methods
+#
+__PACKAGE__->register_method(
+ method => 'scap_alter',
+ api_name => 'open-ils.serial.caption_and_pattern.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more caption and patterns and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'scaps',
+ desc => 'Array of caption and patterns',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub scap_alter {
+ my( $self, $conn, $auth, $scaps ) = @_;
+ return 1 unless ref $scaps;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission check
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $scap (@$scaps) {
+ my $scapid = $scap->id;
+
+ if( $scap->isdeleted ) {
+ $evt = _delete_scap( $editor, $override, $scap);
+ } elsif( $scap->isnew ) {
+ $evt = _create_scap( $editor, $scap );
+ } else {
+ $evt = _update_scap( $editor, $override, $scap );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("caption_and_pattern-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("caption_and_pattern-alter: done updating caption_and_pattern batch");
+ $editor->commit;
+ $logger->info("caption_and_pattern-alter successfully updated ".scalar(@$scaps)." caption_and_patterns");
+ return 1;
+}
+
+sub _delete_scap {
+ my ($editor, $override, $scap) = @_;
+ $logger->info("caption_and_pattern-alter: delete caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($scap));
+ my $sisses = $editor->search_serial_issuance(
+ { caption_and_pattern => $scap->id }, { limit => 1 } ); #TODO: 'deleted' support?
+ return OpenILS::Event->new(
+ 'SERIAL_CAPTION_AND_PATTERN_HAS_ISSUANCES', payload => $scap->id ) if (@$sisses);
+
+ return $editor->event unless $editor->delete_serial_caption_and_pattern($scap);
+ return 0;
+}
+
+sub _create_scap {
+ my ($editor, $scap) = @_;
+
+ $logger->info("caption_and_pattern-alter: new caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($scap));
+ return $editor->event unless $editor->create_serial_caption_and_pattern($scap);
+ return 0;
+}
+
+sub _update_scap {
+ my ($editor, $override, $scap) = @_;
+
+ $logger->info("caption_and_pattern-alter: retrieving caption_and_pattern ".$scap->id);
+ my $orig_scap = $editor->retrieve_serial_caption_and_pattern($scap->id);
+
+ $logger->info("caption_and_pattern-alter: original caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($orig_scap));
+ $logger->info("caption_and_pattern-alter: updated caption_and_pattern ".OpenSRF::Utils::JSON->perl2JSON($scap));
+ return $editor->event unless $editor->update_serial_caption_and_pattern($scap);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "serial_caption_and_pattern_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.caption_and_pattern.batch.retrieve"
+);
+
+sub serial_caption_and_pattern_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+ $logger->info("Fetching caption_and_patterns @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.caption_and_pattern.search.atomic",
+ { id => $ids }
+ );
+}
+
+##########################################################################
+# stream methods
+#
+__PACKAGE__->register_method(
+ method => 'sstr_alter',
+ api_name => 'open-ils.serial.stream.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more streams and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'sstrs',
+ desc => 'Array of streams',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub sstr_alter {
+ my( $self, $conn, $auth, $sstrs ) = @_;
+ return 1 unless ref $sstrs;
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission check
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $sstr (@$sstrs) {
+ my $sstrid = $sstr->id;
+
+ if( $sstr->isdeleted ) {
+ $evt = _delete_sstr( $editor, $override, $sstr);
+ } elsif( $sstr->isnew ) {
+ $evt = _create_sstr( $editor, $sstr );
+ } else {
+ $evt = _update_sstr( $editor, $override, $sstr );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("stream-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("stream-alter: done updating stream batch");
+ $editor->commit;
+ $logger->info("stream-alter successfully updated ".scalar(@$sstrs)." streams");
+ return 1;
+}
+
+sub _delete_sstr {
+ my ($editor, $override, $sstr) = @_;
+ $logger->info("stream-alter: delete stream ".OpenSRF::Utils::JSON->perl2JSON($sstr));
+ my $sitems = $editor->search_serial_item(
+ { stream => $sstr->id }, { limit => 1 } ); #TODO: 'deleted' support?
+ return OpenILS::Event->new(
+ 'SERIAL_STREAM_HAS_ITEMS', payload => $sstr->id ) if (@$sitems);
+
+ return $editor->event unless $editor->delete_serial_stream($sstr);
+ return 0;
+}
+
+sub _create_sstr {
+ my ($editor, $sstr) = @_;
+
+ $logger->info("stream-alter: new stream ".OpenSRF::Utils::JSON->perl2JSON($sstr));
+ return $editor->event unless $editor->create_serial_stream($sstr);
+ return 0;
+}
+
+sub _update_sstr {
+ my ($editor, $override, $sstr) = @_;
+
+ $logger->info("stream-alter: retrieving stream ".$sstr->id);
+ my $orig_sstr = $editor->retrieve_serial_stream($sstr->id);
+
+ $logger->info("stream-alter: original stream ".OpenSRF::Utils::JSON->perl2JSON($orig_sstr));
+ $logger->info("stream-alter: updated stream ".OpenSRF::Utils::JSON->perl2JSON($sstr));
+ return $editor->event unless $editor->update_serial_stream($sstr);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "serial_stream_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.stream.batch.retrieve"
+);
+
+sub serial_stream_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+ $logger->info("Fetching streams @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.stream.search.atomic",
+ { id => $ids }
+ );
+}
+
+
+##########################################################################
+# summary methods
+#
+__PACKAGE__->register_method(
+ method => 'sum_alter',
+ api_name => 'open-ils.serial.basic_summary.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more summaries and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'sbsums',
+ desc => 'Array of basic summaries',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'sum_alter',
+ api_name => 'open-ils.serial.supplement_summary.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more summaries and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'sbsums',
+ desc => 'Array of supplement summaries',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ method => 'sum_alter',
+ api_name => 'open-ils.serial.index_summary.batch.update',
+ api_level => 1,
+ argc => 2,
+ signature => {
+ desc => 'Receives an array of one or more summaries and updates the database as needed',
+ 'params' => [ {
+ name => 'authtoken',
+ desc => 'Authtoken for current user session',
+ type => 'string'
+ },
+ {
+ name => 'sbsums',
+ desc => 'Array of index summaries',
+ type => 'array'
+ }
+
+ ],
+ 'return' => {
+ desc => 'Returns 1 if successful, event if failed',
+ type => 'mixed'
+ }
+ }
+);
+
+sub sum_alter {
+ my( $self, $conn, $auth, $sums ) = @_;
+ return 1 unless ref $sums;
+
+ $self->api_name =~ /serial\.(\w*)_summary/;
+ my $type = $1;
+
+ my( $reqr, $evt ) = $U->checkses($auth);
+ return $evt if $evt;
+ my $editor = new_editor(requestor => $reqr, xact => 1);
+ my $override = $self->api_name =~ /override/;
+
+# TODO: permission check
+# return $editor->event unless
+# $editor->allowed('UPDATE_COPY', $class->copy_perm_org($vol, $copy));
+
+ for my $sum (@$sums) {
+ my $sumid = $sum->id;
+
+ # XXX: (for now, at least) summaries should be created/deleted by the distribution functions
+ if( $sum->isdeleted ) {
+ $evt = OpenILS::Event->new('SERIAL_SUMMARIES_NOT_INDEPENDENT');
+ } elsif( $sum->isnew ) {
+ $evt = OpenILS::Event->new('SERIAL_SUMMARIES_NOT_INDEPENDENT');
+ } else {
+ $evt = _update_sum( $editor, $override, $sum, $type );
+ }
+ }
+
+ if( $evt ) {
+ $logger->info("${type}_summary-alter failed with event: ".OpenSRF::Utils::JSON->perl2JSON($evt));
+ $editor->rollback;
+ return $evt;
+ }
+ $logger->debug("${type}_summary-alter: done updating ${type}_summary batch");
+ $editor->commit;
+ $logger->info("${type}_summary-alter successfully updated ".scalar(@$sums)." ${type}_summaries");
+ return 1;
+}
+
+sub _update_sum {
+ my ($editor, $override, $sum, $type) = @_;
+
+ $logger->info("${type}_summary-alter: retrieving ${type}_summary ".$sum->id);
+ my $retrieve_method = "retrieve_serial_${type}_summary";
+ my $orig_sum = $editor->$retrieve_method($sum->id);
+
+ $logger->info("${type}_summary-alter: original ${type}_summary ".OpenSRF::Utils::JSON->perl2JSON($orig_sum));
+ $logger->info("${type}_summary-alter: updated ${type}_summary ".OpenSRF::Utils::JSON->perl2JSON($sum));
+ my $update_method = "update_serial_${type}_summary";
+ return $editor->event unless $editor->$update_method($sum);
+ return 0;
+}
+
+__PACKAGE__->register_method(
+ method => "serial_summary_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.basic_summary.batch.retrieve"
+);
+
+__PACKAGE__->register_method(
+ method => "serial_summary_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.supplement_summary.batch.retrieve"
+);
+
+__PACKAGE__->register_method(
+ method => "serial_summary_retrieve_batch",
+ authoritative => 1,
+ api_name => "open-ils.serial.index_summary.batch.retrieve"
+);
+
+sub serial_summary_retrieve_batch {
+ my( $self, $client, $ids ) = @_;
+
+ $self->api_name =~ /serial\.(\w*)_summary/;
+ my $type = $1;
+
+ $logger->info("Fetching ${type}_summaries @$ids");
+ return $U->cstorereq(
+ "open-ils.cstore.direct.serial.".$type."_summary.search.atomic",
+ { id => $ids }
+ );
+}
+
+
+##########################################################################
+# other methods
+#
+__PACKAGE__->register_method(
+ "method" => "bre_by_identifier",
+ "api_name" => "open-ils.serial.biblio.record_entry.by_identifier",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Find instances of biblio.record_entry given a search token" .
+ " that could be a value for any identifier defined in " .
+ "config.metabib_field",
+ "params" => [
+ {"desc" => "Search token", "type" => "string"},
+ {"desc" => "Options: require_subscriptions, add_mvr, is_actual_id" .
+ ", id_list (all boolean)", "type" => "object"}
+ ],
+ "return" => {
+ "desc" => "Any matching BREs, or if the add_mvr option is true, " .
+ "objects with a 'bre' key/value pair, and an 'mvr' " .
+ "key-value pair. BREs have subscriptions fleshed on.",
+ "type" => "object"
+ }
+ }
+);
+
+sub bre_by_identifier {
+ my ($self, $client, $term, $options) = @_;
+
+ return new OpenILS::Event("BAD_PARAMS") unless $term;
+
+ $options ||= {};
+ my $e = new_editor();
+
+ my @ids;
+
+ if ($options->{"is_actual_id"}) {
+ @ids = ($term);
+ } else {
+ my $cmf =
+ $e->search_config_metabib_field({"field_class" => "identifier"})
+ or return $e->die_event;
+
+ my @identifiers = map { $_->name } @$cmf;
+ my $query = join(" || ", map { "id|$_: $term" } @identifiers);
+
+ my $search = create OpenSRF::AppSession("open-ils.search");
+ my $search_result = $search->request(
+ "open-ils.search.biblio.multiclass.query.staff", {}, $query
+ )->gather(1);
+ $search->disconnect;
+
+ # Un-nest results. They tend to look like [[1],[2],[3]] for some reason.
+ @ids = map { @{$_} } @{$search_result->{"ids"}};
+
+ unless (@ids) {
+ $e->disconnect;
+ return undef;
+ }
+
+ if ($options->{"id_list"}) {
+ $e->disconnect;
+ $client->respond($_) foreach (@ids);
+ return undef;
+ }
+ }
+
+ my $bre = $e->search_biblio_record_entry([
+ {"id" => \@ids}, {
+ "flesh" => 2, "flesh_fields" => {
+ "bre" => ["subscriptions"],
+ "ssub" => ["owning_lib"]
+ }
+ }
+ ]) or return $e->die_event;
+
+ if (@$bre && $options->{"require_subscriptions"}) {
+ $bre = [ grep { @{$_->subscriptions} } @$bre ];
+ }
+
+ $e->disconnect;
+
+ if (@$bre) { # re-evaluate after possible grep
+ if ($options->{"add_mvr"}) {
+ $client->respond(
+ {"bre" => $_, "mvr" => _get_mvr($_->id)}
+ ) foreach (@$bre);
+ } else {
+ $client->respond($_) foreach (@$bre);
+ }
+ }
+
+ undef;
+}
+
+__PACKAGE__->register_method(
+ "method" => "get_items_by",
+ "api_name" => "open-ils.serial.items.receivable.by_subscription",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Return all receivable items under a given subscription",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Subscription ID", "type" => "number"},
+ ],
+ "return" => {
+ "desc" => "All receivable items under a given subscription",
+ "type" => "object", "class" => "sitem"
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ "method" => "get_items_by",
+ "api_name" => "open-ils.serial.items.receivable.by_issuance",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Return all receivable items under a given issuance",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Issuance ID", "type" => "number"},
+ ],
+ "return" => {
+ "desc" => "All receivable items under a given issuance",
+ "type" => "object", "class" => "sitem"
+ }
+ }
+);
+
+__PACKAGE__->register_method(
+ "method" => "get_items_by",
+ "api_name" => "open-ils.serial.items.by_issuance",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Return all items under a given issuance",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Issuance ID", "type" => "number"},
+ ],
+ "return" => {
+ "desc" => "All items under a given issuance",
+ "type" => "object", "class" => "sitem"
+ }
+ }
+);
+
+sub get_items_by {
+ my ($self, $client, $auth, $term, $opts) = @_;
+
+ # Not to be used in the json_query, but after limiting by perm check.
+ $opts = {} unless ref $opts eq "HASH";
+ $opts->{"limit"} ||= 10000; # some existing users may want all results
+ $opts->{"offset"} ||= 0;
+ $opts->{"limit"} = int($opts->{"limit"});
+ $opts->{"offset"} = int($opts->{"offset"});
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $by = ($self->api_name =~ /by_(\w+)$/)[0];
+ my $receivable = ($self->api_name =~ /receivable/);
+
+ my %where = (
+ "issuance" => {"issuance" => $term},
+ "subscription" => {"+siss" => {"subscription" => $term}}
+ );
+
+ my $item_rows = $e->json_query(
+ {
+ "select" => {"sitem" => ["id"], "sdist" => ["holding_lib"]},
+ "from" => {
+ "sitem" => {
+ "siss" => {},
+ "sstr" => {"join" => {"sdist" => {}}}
+ }
+ },
+ "where" => {
+ %{$where{$by}}, $receivable ? ("date_received" => undef) : ()
+ },
+ "order_by" => {"sitem" => ["id"]}
+ }
+ ) or return $e->die_event;
+
+ return undef unless @$item_rows;
+
+ my $skipped = 0;
+ my $returned = 0;
+ foreach (@$item_rows) {
+ last if $returned >= $opts->{"limit"};
+ next unless $e->allowed("RECEIVE_SERIAL", $_->{"holding_lib"});
+ if ($skipped < $opts->{"offset"}) {
+ $skipped++;
+ next;
+ }
+
+ $client->respond(
+ $e->retrieve_serial_item([
+ $_->{"id"}, {
+ "flesh" => 3,
+ "flesh_fields" => {
+ "sitem" => [qw/stream issuance unit creator editor/],
+ "sstr" => ["distribution"],
+ "sdist" => ["holding_lib"]
+ }
+ }
+ ])
+ );
+ $returned++;
+ }
+
+ $e->disconnect;
+ undef;
+}
+
+__PACKAGE__->register_method(
+ "method" => "get_receivable_issuances",
+ "api_name" => "open-ils.serial.issuances.receivable",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Return all issuances with receivable items given " .
+ "a subscription ID",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Subscription ID", "type" => "number"},
+ ],
+ "return" => {
+ "desc" => "All issuances with receivable items " .
+ "(but not the items themselves)", "type" => "object"
+ }
+ }
+);
+
+sub get_receivable_issuances {
+ my ($self, $client, $auth, $sub_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ # XXX permissions
+
+ my $issuance_ids = $e->json_query({
+ "select" => {
+ "siss" => [
+ {"transform" => "distinct", "column" => "id"},
+ "date_published"
+ ]
+ },
+ "from" => {"siss" => "sitem"},
+ "where" => {
+ "subscription" => $sub_id,
+ "+sitem" => {"date_received" => undef}
+ },
+ "order_by" => {
+ "siss" => {"date_published" => {"direction" => "asc"}}
+ }
+
+ }) or return $e->die_event;
+
+ $client->respond($e->retrieve_serial_issuance($_->{"id"}))
+ foreach (@$issuance_ids);
+
+ $e->disconnect;
+ undef;
+}
+
+
+__PACKAGE__->register_method(
+ "method" => "get_routing_list_users",
+ "api_name" => "open-ils.serial.routing_list_users.fleshed_and_ordered",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Return all routing list users with reader fleshed " .
+ "(with card and home_ou) for a given stream ID, sorted by pos",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Stream ID (int or array of ints)", "type" => "mixed"},
+ ],
+ "return" => {
+ "desc" => "Stream of routing list users", "type" => "object",
+ "class" => "srlu"
+ }
+ }
+);
+
+sub get_routing_list_users {
+ my ($self, $client, $auth, $stream_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $users = $e->search_serial_routing_list_user([
+ {"stream" => $stream_id}, {
+ "order_by" => {"srlu" => "pos"},
+ "flesh" => 2,
+ "flesh_fields" => {
+ "srlu" => [qw/reader stream/],
+ "au" => [qw/card home_ou/],
+ "sstr" => ["distribution"]
+ }
+ }
+ ]) or return $e->die_event;
+
+ return undef unless @$users;
+
+ # The ADMIN_SERIAL_STREAM permission is used simply to avoid the
+ # need for any new permission. The context OU will be the same
+ # for every result of the above query, so we need only check once.
+ return $e->die_event unless $e->allowed(
+ "ADMIN_SERIAL_STREAM", $users->[0]->stream->distribution->holding_lib
+ );
+
+ $e->disconnect;
+
+ my @users = map { $_->stream($_->stream->id); $_ } @$users;
+ @users = sort { $a->stream cmp $b->stream } @users if
+ ref $stream_id eq "ARRAY";
+
+ $client->respond($_) for @users;
+
+ undef;
+}
+
+
+__PACKAGE__->register_method(
+ "method" => "replace_routing_list_users",
+ "api_name" => "open-ils.serial.routing_list_users.replace",
+ "signature" => {
+ "desc" => "Replace all routing list users on the specified streams " .
+ "with those in the list argument",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "List of srlu objects", "type" => "array"},
+ ],
+ "return" => {
+ "desc" => "event on failure, undef on success"
+ }
+ }
+);
+
+sub replace_routing_list_users {
+ my ($self, $client, $auth, $users) = @_;
+
+ return undef unless ref $users eq "ARRAY";
+
+ if (grep { ref $_ ne "Fieldmapper::serial::routing_list_user" } @$users) {
+ return new OpenILS::Event("BAD_PARAMS", "note" => "Only srlu objects");
+ }
+
+ my $e = new_editor("authtoken" => $auth, "xact" => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my %streams_ok = ();
+ my $pos = 0;
+
+ foreach my $user (@$users) {
+ unless (exists $streams_ok{$user->stream}) {
+ my $stream = $e->retrieve_serial_stream([
+ $user->stream, {
+ "flesh" => 1,
+ "flesh_fields" => {"sstr" => ["distribution"]}
+ }
+ ]) or return $e->die_event;
+ $e->allowed(
+ "ADMIN_SERIAL_STREAM", $stream->distribution->holding_lib
+ ) or return $e->die_event;
+
+ my $to_delete = $e->search_serial_routing_list_user(
+ {"stream" => $user->stream}
+ ) or return $e->die_event;
+
+ $logger->info(
+ "Deleting srlu: [" .
+ join(", ", map { $_->id; } @$to_delete) .
+ "]"
+ );
+
+ foreach (@$to_delete) {
+ $e->delete_serial_routing_list_user($_) or
+ return $e->die_event;
+ }
+
+ $streams_ok{$user->stream} = 1;
+ }
+
+ next if $user->isdeleted;
+
+ $user->clear_id;
+ $user->pos($pos++);
+ $e->create_serial_routing_list_user($user) or return $e->die_event;
+ }
+
+ $e->commit or return $e->die_event;
+ undef;
+}
+
+__PACKAGE__->register_method(
+ "method" => "get_records_with_marc_85x",
+ "api_name"=>"open-ils.serial.caption_and_pattern.find_legacy_by_bib_record",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Return the specified BRE itself and/or any related SRE ".
+ "whenever they have 853-855 tags",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "bib record ID", "type" => "number"},
+ ],
+ "return" => {
+ "desc" => "objects, either bre or sre", "type" => "object"
+ }
+ }
+);
+
+sub get_records_with_marc_85x { # specifically, 853-855
+ my ($self, $client, $auth, $bre_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $bre = $e->search_biblio_record_entry([
+ {"id" => $bre_id, "deleted" => "f"}, {
+ "flesh" => 1,
+ "flesh_fields" => {"bre" => [qw/creator editor owner/]}
+ }
+ ]) or return $e->die_event;
+
+ return undef unless @$bre;
+ $bre = $bre->[0];
+
+ my $record = MARC::Record->new_from_xml($bre->marc);
+ $client->respond($bre) if $record->field("85[3-5]");
+ # XXX Is passing a regex to ->field() an abuse of MARC::Record ?
+
+ my $sres = $e->search_serial_record_entry([
+ {"record" => $bre_id, "deleted" => "f"}, {
+ "flesh" => 1,
+ "flesh_fields" => {"sre" => [qw/creator editor owning_lib/]}
+ }
+ ]) or return $e->die_event;
+
+ $e->disconnect;
+
+ foreach my $sre (@$sres) {
+ $client->respond($sre) if
+ MARC::Record->new_from_xml($sre->marc)->field("85[3-5]");
+ }
+
+ undef;
+}
+
+__PACKAGE__->register_method(
+ "method" => "create_scaps_from_marcxml",
+ "api_name" => "open-ils.serial.caption_and_pattern.create_from_records",
+ "stream" => 1,
+ "signature" => {
+ "desc" => "Create caption and pattern objects from 853-855 tags " .
+ "in MARCXML documents",
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Subscription ID", "type" => "number"},
+ {"desc" => "list of MARCXML documents as strings",
+ "type" => "array"},
+ ],
+ "return" => {
+ "desc" => "Newly created caption and pattern objects",
+ "type" => "object", "class" => "scap"
+ }
+ }
+);
+
+sub create_scaps_from_marcxml {
+ my ($self, $client, $auth, $sub_id, $docs) = @_;
+
+ return undef unless ref $docs eq "ARRAY";
+
+ my $e = new_editor("authtoken" => $auth, "xact" => 1);
+ return $e->die_event unless $e->checkauth;
+
+ # Retrieve the subscription just for perm checking (whether we can create
+ # scaps at the owning lib).
+ my $sub = $e->retrieve_serial_subscription($sub_id) or return $e->die_event;
+ return $e->die_event unless
+ $e->allowed("ADMIN_SERIAL_CAPTION_PATTERN", $sub->owning_lib);
+
+ foreach my $record (map { MARC::Record->new_from_xml($_) } @$docs) {
+ foreach my $field ($record->field("85[3-5]")) {
+ my $scap = new Fieldmapper::serial::caption_and_pattern;
+ $scap->subscription($sub_id);
+ $scap->type($MFHD_NAMES_BY_TAG{$field->tag});
+ $scap->pattern_code(
+ OpenSRF::Utils::JSON->perl2JSON(
+ [ $field->indicator(1), $field->indicator(2),
+ map { @$_ } $field->subfields ] # flattens nested array
+ )
+ );
+ $e->create_serial_caption_and_pattern($scap) or
+ return $e->die_event;
+ $client->respond($e->data);
+ }
+ }
+
+ $e->commit or return $e->die_event;
+ undef;
+}
+
+# All these _clone_foo() functions could possibly have been consolidated into
+# one clever function, but it's faster to get things working this way.
+sub _clone_subscription {
+ my ($sub, $bib_id, $e) = @_;
+
+ # clone sub itself
+ my $new_sub = $sub->clone;
+ $new_sub->record_entry(int $bib_id) if $bib_id;
+ $new_sub->clear_id;
+ $new_sub->clear_distributions;
+ $new_sub->clear_notes;
+ $new_sub->clear_scaps;
+
+ $e->create_serial_subscription($new_sub) or return $e->die_event;
+
+ my $new_sub_id = $e->data->id;
+ # clone dists
+ foreach my $dist (@{$sub->distributions}) {
+ my $r = _clone_distribution($dist, $new_sub_id, $e);
+ return $r if $U->event_code($r);
+ }
+
+ # clone sub notes
+ foreach my $note (@{$sub->notes}) {
+ my $r = _clone_subscription_note($note, $new_sub_id, $e);
+ return $r if $U->event_code($r);
+ }
+
+ # clone scaps
+ foreach my $scap (@{$sub->scaps}) {
+ my $r = _clone_caption_and_pattern($scap, $new_sub_id, $e);
+ return $r if $U->event_code($r);
+ }
+
+ return $new_sub_id;
+}
+
+sub _clone_distribution {
+ my ($dist, $sub_id, $e) = @_;
+
+ my $new_dist = $dist->clone;
+ $new_dist->clear_id;
+ $new_dist->clear_notes;
+ $new_dist->clear_streams;
+ $new_dist->subscription($sub_id);
+
+ $e->create_serial_distribution($new_dist) or return $e->die_event;
+ my $new_dist_id = $e->data->id;
+
+ # clone streams
+ foreach my $stream (@{$dist->streams}) {
+ my $r = _clone_stream($stream, $new_dist_id, $e);
+ return $r if $U->event_code($r);
+ }
+
+ # clone distribution notes
+ foreach my $note (@{$dist->notes}) {
+ my $r = _clone_distribution_note($note, $new_dist_id, $e);
+ return $r if $U->event_code($r);
+ }
+
+ return $new_dist_id;
+}
+
+sub _clone_subscription_note {
+ my ($note, $sub_id, $e) = @_;
+
+ my $new_note = $note->clone;
+ $new_note->clear_id;
+ $new_note->creator($e->requestor->id);
+ $new_note->create_date("now");
+ $new_note->subscription($sub_id);
+
+ $e->create_serial_subscription_note($new_note) or return $e->die_event;
+ return $e->data->id;
+}
+
+sub _clone_caption_and_pattern {
+ my ($scap, $sub_id, $e) = @_;
+
+ my $new_scap = $scap->clone;
+ $new_scap->clear_id;
+ $new_scap->subscription($sub_id);
+
+ $e->create_serial_caption_and_pattern($new_scap) or return $e->die_event;
+ return $e->data->id;
+}
+
+sub _clone_distribution_note {
+ my ($note, $dist_id, $e) = @_;
+
+ my $new_note = $note->clone;
+ $new_note->clear_id;
+ $new_note->creator($e->requestor->id);
+ $new_note->create_date("now");
+ $new_note->distribution($dist_id);
+
+ $e->create_serial_distribution_note($new_note) or return $e->die_event;
+ return $e->data->id;
+}
+
+sub _clone_stream {
+ my ($stream, $dist_id, $e) = @_;
+
+ my $new_stream = $stream->clone;
+ $new_stream->clear_id;
+ $new_stream->clear_routing_list_users;
+ $new_stream->distribution($dist_id);
+
+ $e->create_serial_stream($new_stream) or return $e->die_event;
+ my $new_stream_id = $e->data->id;
+
+ # clone routing list users
+ foreach my $user (@{$stream->routing_list_users}) {
+ my $r = _clone_routing_list_user($user, $new_stream_id, $e);
+ return $r if $U->event_code($r);
+ }
+
+ return $new_stream_id;
+}
+
+sub _clone_routing_list_user {
+ my ($user, $stream_id, $e) = @_;
+
+ my $new_user = $user->clone;
+ $new_user->clear_id;
+ $new_user->stream($stream_id);
+
+ $e->create_serial_routing_list_user($new_user) or return $e->die_event;
+ return $e->data->id;
+}
+
+__PACKAGE__->register_method(
+ "method" => "clone_subscription",
+ "api_name" => "open-ils.serial.subscription.clone",
+ "signature" => {
+ "desc" => q{Clone a subscription, including its attending distributions,
+ streams, captions and patterns, routing list users, distribution
+ notes and subscription notes. Do not include holdings-specific
+ things, like issuances, items, units, summaries. Attach the
+ clone either to the same bib record as the original, or to one
+ specified by ID.},
+ "params" => [
+ {"desc" => "Authtoken", "type" => "string"},
+ {"desc" => "Subscription ID", "type" => "number"},
+ {"desc" => "Bib Record ID (optional)", "type" => "number"}
+ ],
+ "return" => {
+ "desc" => "ID of the new subscription", "type" => "number"
+ }
+ }
+);
+
+sub clone_subscription {
+ my ($self, $client, $auth, $sub_id, $bib_id) = @_;
+
+ my $e = new_editor("authtoken" => $auth, "xact" => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $sub = $e->retrieve_serial_subscription([
+ int $sub_id, {
+ "flesh" => 3,
+ "flesh_fields" => {
+ "ssub" => [qw/distributions notes scaps/],
+ "sdist" => [qw/streams notes/],
+ "sstr" => ["routing_list_users"]
+ }
+ }
+ ]) or return $e->die_event;
+
+ # ADMIN_SERIAL_SUBSCRIPTION will have to be good enough as a
+ # catch-all permisison for this operation.
+ return $e->die_event unless
+ $e->allowed("ADMIN_SERIAL_SUBSCRIPTION", $sub->owning_lib);
+
+ my $result = _clone_subscription($sub, $bib_id, $e);
+
+ return $e->die_event($result) if $U->event_code($result);
+
+ $e->commit or return $e->die_event;
+ return $result;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Storage;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils::Logger qw/:level/;
+
+# Pull this in so we can adjust it's @ISA
+use OpenILS::Application::Storage::CDBI (1);
+use OpenILS::Application::Storage::FTS;
+
+
+# the easy way to get to the logger...
+my $log = "OpenSRF::Utils::Logger";
+
+our $QParser;
+our $WRITE = 0;
+our $IGNORE_XACT_ID_FAILURE = 0;
+
+sub DESTROY {};
+
+sub initialize {
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+
+ $log->debug('Initializing ' . __PACKAGE__ . '...', DEBUG);
+
+ my $db_driver = $conf->config_value( apps => 'open-ils.storage' => app_settings => databases => 'driver');
+ my $driver = "OpenILS::Application::Storage::Driver::$db_driver";
+
+ $log->debug("Attempting to load $driver ...", DEBUG);
+
+ $driver->use;
+ if ($@) {
+ $log->debug( "Can't load $driver! : $@", ERROR );
+ $log->error( "Can't load $driver! : $@");
+ throw OpenSRF::EX::PANIC ( "Can't load $driver! : $@" );
+ }
+
+ $log->debug("$driver loaded successfully", DEBUG);
+
+ # Suck in the method publishing modules
+ @OpenILS::Application::Storage::CDBI::ISA = ( $driver );
+
+ OpenILS::Application::Storage::Publisher->use;
+ if ($@) {
+ $log->debug("FAILURE LOADING Publisher! $@", ERROR);
+ throw OpenSRF::EX::PANIC ( "FAILURE LOADING Publisher! : $@" );
+ }
+
+ $log->debug("We seem to be OK...",DEBUG);
+}
+
+sub child_init {
+
+ $log->debug('Running child_init for ' . __PACKAGE__ . '...', DEBUG);
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+
+ $log->debug('Calling the Driver child_init', DEBUG);
+ OpenILS::Application::Storage::CDBI->child_init(
+ $conf->config_value( apps => 'open-ils.storage' => app_settings => databases => 'database')
+ );
+
+ if (OpenILS::Application::Storage::CDBI->db_Main()) {
+ $log->debug("Success initializing driver!", DEBUG);
+
+ my $db_driver = $conf->config_value( apps => 'open-ils.storage' => app_settings => databases => 'driver');
+ $QParser = 'OpenILS::Application::Storage::Driver::'.$db_driver.'::QueryParser';
+ $QParser->use;
+
+ if($@) {
+ $log->debug( "Can't load $QParser! : $@", ERROR );
+ $log->error( "Can't load $QParser! : $@");
+ } else {
+ return 1;
+ }
+ }
+
+ $log->debug("FAILURE initializing driver!", ERROR);
+ return 0;
+}
+
+sub begin_xaction {
+ my $self = shift;
+ my $client = shift;
+
+ local $WRITE = 1;
+
+ $log->debug(" XACT --> 'BEGIN'ing transaction for session ".$client->session->session_id,DEBUG);
+ try {
+ OpenILS::Application::Storage::CDBI->db_Main->begin_work;
+ $client->session->session_data( xact_id => $client->session->session_id );
+ } catch Error with {
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Could not BEGIN transaction!",
+ );
+ };
+ return 1;
+
+}
+__PACKAGE__->register_method(
+ method => 'begin_xaction',
+ api_name => 'open-ils.storage.transaction.begin',
+ api_level => 1,
+ argc => 0,
+);
+
+sub savepoint_placeholder {
+ return 1;
+}
+__PACKAGE__->register_method(
+ method => 'savepoint_placeholder',
+ api_name => 'open-ils.storage.savepoint.set',
+ api_level => 1,
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ method => 'savepoint_placeholder',
+ api_name => 'open-ils.storage.savepoint.release',
+ api_level => 1,
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ method => 'savepoint_placeholder',
+ api_name => 'open-ils.storage.savepoint.rollback',
+ api_level => 1,
+ argc => 1,
+);
+
+sub commit_xaction {
+ my $self = shift;
+ my $client = shift;
+
+ local $WRITE = 1;
+
+ try {
+ OpenILS::Application::Storage::CDBI->db_Main->commit;
+ $client->session->session_data( xact_id => '' );
+ } catch Error with {
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Could not COMMIT transaction!",
+ );
+ };
+ return 1;
+}
+__PACKAGE__->register_method(
+ method => 'commit_xaction',
+ api_name => 'open-ils.storage.transaction.commit',
+ api_level => 1,
+ argc => 0,
+);
+
+
+sub current_xact {
+ my $self = shift;
+ my $client = shift;
+
+ return $client->session->session_data( 'xact_id' );
+}
+__PACKAGE__->register_method(
+ method => 'current_xact',
+ api_name => 'open-ils.storage.transaction.current',
+ api_level => 1,
+ argc => 0,
+);
+
+sub rollback_xaction {
+ my $self = shift;
+ my $client = shift;
+
+ local $WRITE = 1;
+
+ $log->debug(" XACT --> 'ROLLBACK'ing transaction for session ".$client->session->session_id,DEBUG);
+ $client->session->session_data( xact_id => '' );
+ return OpenILS::Application::Storage::CDBI->db_Main->rollback;
+}
+__PACKAGE__->register_method(
+ method => 'rollback_xaction',
+ api_name => 'open-ils.storage.transaction.rollback',
+ api_level => 1,
+ argc => 0,
+);
+
+
+sub _cdbi2Hash {
+ my $self = shift;
+ my $obj = shift;
+ return { map { ( $_ => $obj->$_ ) } ($obj->columns('All')) };
+}
+
+sub _cdbi_list2AoH {
+ my $self = shift;
+ my @objs = @_;
+ return [ map { $self->_cdbi2Hash($_) } @objs ];
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::CDBI;
+use UNIVERSAL::require;
+BEGIN {
+ 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
+}
+use base qw/Class::DBI/;
+use Class::DBI::AbstractSearch;
+
+use OpenILS::Application::Storage::CDBI::actor;
+use OpenILS::Application::Storage::CDBI::action;
+use OpenILS::Application::Storage::CDBI::booking;
+use OpenILS::Application::Storage::CDBI::asset;
+use OpenILS::Application::Storage::CDBI::serial;
+use OpenILS::Application::Storage::CDBI::authority;
+use OpenILS::Application::Storage::CDBI::biblio;
+use OpenILS::Application::Storage::CDBI::config;
+use OpenILS::Application::Storage::CDBI::metabib;
+use OpenILS::Application::Storage::CDBI::money;
+use OpenILS::Application::Storage::CDBI::permission;
+use OpenILS::Application::Storage::CDBI::container;
+
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw(:level);
+use OpenSRF::EX qw/:try/;
+
+our $VERSION = 1;
+my $log = 'OpenSRF::Utils::Logger';
+
+if ($Class::DBI::VERSION gt '3.0.1') {
+ $log->error("Your version of Class::DBI, $Class::DBI::VERSION, is too new and incompatible with Evergreen. You will need to downgrade to version 3.0.1 or install Class::DBI::Frozen::301");
+ die("Your version of Class::DBI, $Class::DBI::VERSION, is too new and incompatible with Evergreen. You will need to downgrade to version 3.0.1 or install Class::DBI::Frozen::301");
+}
+
+sub child_init {
+ my $self = shift;
+
+ $log->debug("Creating ImaDBI Querys", DEBUG);
+ __PACKAGE__->set_sql( 'OILSFastSearch', <<" SQL", 'Main');
+ SELECT %s
+ FROM %s
+ WHERE %s = ?
+ SQL
+
+ __PACKAGE__->set_sql( 'OILSFastOrderedSearchLike', <<" SQL", 'Main');
+ SELECT %s
+ FROM %s
+ WHERE %s LIKE ?
+ ORDER BY %s
+ SQL
+
+ __PACKAGE__->set_sql( 'OILSFastOrderedSearch', <<" SQL", 'Main');
+ SELECT %s
+ FROM %s
+ WHERE %s = ?
+ ORDER BY %s
+ SQL
+
+ $log->debug("Calling Driver child_init", DEBUG);
+ $self->SUPER::child_init(@_);
+
+}
+
+sub fast_flesh_sth {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $field = shift;
+ my $value = shift;
+ my $order = shift;
+ my $like = shift;
+
+
+ if (!(defined($order) and ref($order) and ref($order) eq 'HASH')) {
+ if (defined($value) and ref($value) and ref($value) eq 'HASH') {
+ $order = $value;
+ $value = undef;
+ } else {
+ $order = { order_by => $class->columns('Primary') }
+ }
+ }
+
+ unless (defined $value) {
+ $value = $field;
+ ($field) = $class->columns('Primary');
+ }
+
+ unless (defined $field) {
+ ($field) = $class->columns('Primary');
+ }
+
+ unless ($order->{order_by}) {
+ $order = { order_by => $class->columns('Primary') }
+ }
+
+ my $fm_class = 'Fieldmapper::'.$class;
+ my $field_list = join ',', $class->columns('Essential');
+
+ my $sth;
+ if (!$like) {
+ $sth = $class->sql_OILSFastOrderedSearch( $field_list, $class->table, $field, $order->{order_by});
+ } else {
+ $sth = $class->sql_OILSFastOrderedSearchLike( $field_list, $class->table, $field, $order->{order_by});
+ }
+ $sth->execute($value);
+ return $sth;
+}
+
+sub fast_flesh {
+ my $self = shift;
+ return map $class->construct($_), $self->fast_flesh_sth(@_)->fetchall_hash;
+}
+
+sub fast_fieldmapper {
+ my $self = shift;
+ my $id = shift;
+ my $col = shift;
+ my $like = shift;
+ my $options = shift;
+ my $class = ref($self) || $self;
+ my $fm_class = 'Fieldmapper::'.$class;
+ my @fms;
+ $log->debug("fast_fieldmapper() ==> Retrieving $fm_class", INTERNAL);
+ if ($like < 2) {
+ for my $hash ($self->fast_flesh_sth( $col, "$id", { order_by => $col }, $like )->fetchall_hash) {
+ my $fm = $fm_class->new;
+ for my $field ( $fm_class->real_fields ) {
+ $fm->$field( $$hash{$field} );
+ }
+ push @fms, $fm;
+ }
+ } else {
+ my $search_type = 'search';
+ if ($like == 2) {
+ $search_type = 'search_fts'
+ } elsif ($like == 3) {
+ $search_type = 'search_regex'
+ }
+
+ for my $obj ($class->$search_type({ $col => $id}, $options)) {
+ push @fms, $obj->to_fieldmapper;
+ }
+ }
+ return @fms;
+}
+
+sub retrieve {
+ my $self = shift;
+ my $arg = shift;
+ if (ref($arg) &&
+ (UNIVERSAL::isa($arg => 'Fieldmapper') ||
+ UNIVERSAL::isa($arg => 'Class::DBI')) ) {
+ my ($col) = $self->primary_column;
+ $log->debug("Using field $col as the primary key", INTERNAL);
+ $arg = $arg->$col;
+ } elsif (ref $arg) {
+ my ($col) = $self->primary_column;
+ $log->debug("Using field $col as the primary key", INTERNAL);
+ $arg = $arg->{$col};
+ }
+
+ $log->debug("Retrieving $self with $arg", INTERNAL);
+ my $rec;
+ try {
+ $rec = $self->SUPER::retrieve("$arg");
+ } catch Error with {
+ $log->debug("Could not retrieve $self with $arg! -- ".shift(), DEBUG);
+ return undef;
+ };
+ return $rec;
+}
+
+sub to_fieldmapper {
+ my $obj = shift;
+ my $class = ref($obj) || $obj;
+
+ my $fm_class = 'Fieldmapper::'.$class;
+ my $fm = $fm_class->new;
+
+ if (ref($obj)) {
+ for my $field ( $fm->real_fields ) {
+ $fm->$field( ''.$obj->$field );
+ }
+ }
+
+ return $fm;
+}
+
+sub merge {
+ my $self = shift;
+ my $search = shift;
+ my $arg = shift;
+
+ delete $$arg{$_} for (keys %$search);
+
+ $log->debug("CDBI->merge: \$search is $search (".ref($search)." : ".join(',',map{"$_ => $$search{$_}"}keys(%$search)).")",DEBUG);
+ $log->debug("CDBI->merge: \$arg is $arg (".ref($arg)." : ".join(',',map{"$_ => $$arg{$_}"}keys(%$arg)).")",DEBUG);
+
+ my @objs = ($self);
+ @objs = $self->search_where($search) unless (ref $self);
+
+ if (@objs == 1) {
+ $objs[0]->update($arg);
+ return $objs[0];
+ } elsif (@objs == 0) {
+ return $self->create({%$search,%$arg});
+ } else {
+ throw OpenSRF::EX::WARN ("Non-unique search key for merge. Perhaps you meant to use remote_update?");
+ }
+}
+
+sub remote_update {
+ my $self = shift;
+ my $search = shift;
+ my $arg = shift;
+
+ delete $$arg{$_} for (keys %$search);
+
+ $log->debug("CDBI->remote_update: \$search is $search (".ref($search)." : ".join(',',map{"$_ => $$search{$_}"}keys(%$search)).")",DEBUG);
+ $log->debug("CDBI->remote_update: \$arg is $arg (".ref($arg)." : ".join(',',map{"$_ => $$arg{$_}"}keys(%$arg)).")",DEBUG);
+
+# my @objs = $self->search_where($search);
+# throw OpenSRF::EX::WARN ("No objects found for remote_update. Perhaps you meant to use merge?")
+# if (@objs == 0);
+
+# $_->update($arg) for (@objs);
+# return scalar(@objs);
+
+ my @finds = sort keys %$search;
+ my @sets = sort keys %$arg;
+
+ my @find_vals = @$search{@finds};
+ my @set_vals = @$arg{@sets};
+
+ my $sql = 'UPDATE %s SET %s WHERE %s';
+
+ my $table = $self->table;
+ my $set = join(', ', map { "$_=?" } @sets);
+ my $where = join(', ', map { "$_=?" } @finds);
+
+ my $sth = $self->db_Main->prepare(sprintf($sql, $table, $set, $where));
+ $sth->execute(@set_vals,@find_vals);
+ return $sth->rows;
+
+}
+
+sub create {
+ my $self = shift;
+ my $arg = shift;
+
+ $log->debug("CDBI->create: \$arg is $arg (".ref($arg)." : ".OpenSRF::Utils::JSON->perl2JSON($arg).")",DEBUG);
+
+ if (ref($arg) && UNIVERSAL::isa($arg => 'Fieldmapper')) {
+ return $self->create_from_fieldmapper($arg,@_);
+ }
+
+ return $self->SUPER::create($arg,@_);
+}
+
+sub create_from_fieldmapper {
+ my $obj = shift;
+ my $fm = shift;
+ my @params = @_;
+
+ $log->debug("Creating node of type ".ref($fm), DEBUG);
+
+ my $class = ref($obj) || $obj;
+ my ($primary) = $class->columns('Primary');
+
+ if (ref($fm) &&UNIVERSAL::isa($fm => 'Fieldmapper')) {
+ my %hash = map { defined $fm->$_ ?
+ ($_ => $fm->$_) :
+ ()
+ } grep { $_ ne $primary } $class->columns('Essential');
+
+ if ($class->find_column( 'last_xact_id' )) {
+ if ($OpenILS::Application::Storage::IGNORE_XACT_ID_FAILURE) {
+ $hash{last_xact_id} = 'unknown.'.time.'.'.$$.'.'.rand($$);
+ } else {
+ my $xact_id = $class->current_xact_id;
+ throw Error unless ($xact_id);
+ $hash{last_xact_id} = $xact_id;
+ }
+ }
+
+ return $class->create( \%hash, @params );
+ } else {
+ return undef;
+ }
+}
+
+sub delete {
+ my $self = shift;
+ my $arg = shift;
+ my $orig = $self;
+
+ my $class = ref($self) || $self;
+
+ $self = $self->retrieve($arg) if (!ref($self));
+ unless (defined $self) {
+ $log->debug("ARG! Couldn't retrieve record ".$arg->id, DEBUG);
+ throw OpenSRF::EX::WARN ("ARG! Couldn't retrieve record ");
+ }
+
+ if ($class->find_column( 'last_xact_id' )) {
+ my $xact_id = $self->current_xact_id;
+
+ throw Error ("Deleting from $class requires a transaction be established")
+ unless ($xact_id);
+
+ throw Error ("The row you are attempting to delete has been changed since you read it")
+ unless ( $orig->last_xact_id eq $self->last_xact_id);
+
+ $self->last_xact_id( $class->current_xact_id );
+ $self->SUPER::update;
+ }
+
+ $self->SUPER::delete;
+
+ return 1;
+}
+
+sub debug_object {
+ my $obj = shift;
+ my $string = '';
+
+ $string .= "Object type:\t".ref($obj)."\n";
+ $string .= "Object string:\t$obj\n";
+
+ if (ref($obj) && UNIVERSAL::isa($obj => 'Fieldmapper')) {
+ $string .= "Object fields:\n";
+ for my $col ($obj->real_fields()) {
+ $string .= "\t$col\t=> ".$obj->$col."\n";
+ }
+ } elsif (ref($obj) && UNIVERSAL::isa($obj => 'Class::DBI')) {
+ $string .= "Object cols:\n";
+ for my $col ($obj->columns('All')) {
+ $string .= "\t$col\t=> ".$obj->$col."\n";
+ }
+ } elsif (ref($obj) && UNIVERSAL::isa($obj => 'HASH')) {
+ $string .= "Object keys and vals:\n";
+ for my $col (keys %$obj) {
+ $string .= "\t$col\t=> $$obj{$col}\n";
+ }
+ }
+
+ $string .= "\n";
+
+ $log->debug($string,DEBUG);
+}
+
+
+sub update {
+ my $self = shift;
+ my $arg = shift;
+
+ $log->debug("Attempting to update using $arg", DEBUG) if ($arg);
+
+ if (ref($arg)) {
+ $self = $self->modify_from_fieldmapper($arg);
+ unless (defined $self) {
+ $log->debug("Modification of $arg seems to have failed....", DEBUG);
+ return undef;
+ }
+ }
+
+ $log->debug("Calling Class::DBI->update on modified object $self", DEBUG);
+
+ #debug_object($self);
+
+ return $self->SUPER::update if ($self->is_changed);
+ return 0;
+}
+
+sub modify_from_fieldmapper {
+ my $obj = shift;
+ my $fm = shift;
+ my $orig = $obj;
+
+ #debug_object($obj);
+ #debug_object($fm);
+
+ $log->debug("Modifying object using fieldmapper", DEBUG);
+
+ my $class = ref($obj) || $obj;
+ my ($primary) = $class->columns('Primary');
+
+
+ if (!ref($obj)) {
+ $obj = $class->retrieve($fm);
+ #debug_object($obj);
+ unless ($obj) {
+ $log->debug("Retrieve of $class using $fm (".$fm->id.") failed! -- ".shift(), ERROR);
+ throw OpenSRF::EX::WARN ("No $class with id of ".$fm->id."!!");
+ }
+ }
+
+ my %hash;
+
+ if (ref($fm) and UNIVERSAL::isa($fm => 'Fieldmapper')) {
+ %hash = map { ($_ => $fm->$_) } grep { $_ ne $primary } $class->columns('Essential');
+ delete $hash{passwd} if ($fm->isa('Fieldmapper::actor::user'));
+ } else {
+ %hash = %{$fm};
+ }
+
+ my $au = $obj->autoupdate;
+ $obj->autoupdate(0);
+
+ #debug_object($obj);
+
+ for my $field ( keys %hash ) {
+ $obj->$field( $hash{$field} ) if ($obj->$field ne $hash{$field});
+ $log->debug("Setting field $field on $obj to $hash{$field}",INTERNAL);
+ }
+
+ if ($class->find_column( 'last_xact_id' ) and $obj->is_changed) {
+ my ($xact_id) = OpenILS::Application::Storage->method_lookup('open-ils.storage.transaction.current')->run();
+ throw Error ("Updating $class requires a transaction be established")
+ unless ($xact_id);
+ throw Error ("The row you are attempting to delete has been changed since you read it")
+ unless ( $fm->last_xact_id eq $obj->last_xact_id);
+ $obj->last_xact_id( $xact_id );
+ } else {
+ $obj->autoupdate($au)
+ }
+
+ return $obj;
+}
+
+
+
+ #-------------------------------------------------------------------------------
+ actor::user->has_a( home_ou => 'actor::org_unit' );
+ actor::user->has_a( card => 'actor::card' );
+ actor::user->has_a( standing => 'config::standing' );
+ actor::user->has_a( profile => 'permission::grp_tree' );
+ actor::user->has_a( mailing_address => 'actor::user_address' );
+ actor::user->has_a( billing_address => 'actor::user_address' );
+ actor::user->has_a( ident_type => 'config::identification_type' );
+ actor::user->has_a( ident_type2 => 'config::identification_type' );
+ actor::user->has_a( net_access_level => 'config::net_access_level' );
+
+ actor::user_address->has_a( usr => 'actor::user' );
+
+ actor::card->has_a( usr => 'actor::user' );
+
+ actor::workstation->has_a( owning_lib => 'actor::org_unit' );
+ actor::org_unit::closed_date->has_a( org_unit => 'actor::org_unit' );
+ actor::org_unit_setting->has_a( org_unit => 'actor::org_unit' );
+
+ actor::usr_note->has_a( usr => 'actor::user' );
+ actor::user->has_many( notes => 'actor::usr_note' );
+
+ actor::user_standing_penalty->has_a( usr => 'actor::user' );
+ actor::user->has_many( standing_penalties => 'actor::user_standing_penalty' );
+
+ actor::org_unit->has_a( parent_ou => 'actor::org_unit' );
+ actor::org_unit->has_a( ou_type => 'actor::org_unit_type' );
+ actor::org_unit->has_a( ill_address => 'actor::org_address' );
+ actor::org_unit->has_a( holds_address => 'actor::org_address' );
+ actor::org_unit->has_a( mailing_address => 'actor::org_address' );
+ actor::org_unit->has_a( billing_address => 'actor::org_address' );
+ actor::org_unit->has_many( children => 'actor::org_unit' => 'parent_ou' );
+ actor::org_unit->has_many( workstations => 'actor::workstation' );
+ actor::org_unit->has_many( closed_dates => 'actor::org_unit::closed_date' );
+ actor::org_unit->has_many( settings => 'actor::org_unit_setting' );
+ #actor::org_unit->might_have( hours_of_operation => 'actor::org_unit::hours_of_operation' );
+
+ actor::org_unit_type->has_a( parent => 'actor::org_unit_type' );
+ actor::org_unit_type->has_many( children => 'actor::org_unit_type' => 'parent' );
+
+ actor::org_address->has_a( org_unit => 'actor::org_unit' );
+ actor::org_unit->has_many( addresses => 'actor::org_address' );
+
+ action::transit_copy->has_a( source => 'actor::org_unit' );
+ action::transit_copy->has_a( dest => 'actor::org_unit' );
+ action::transit_copy->has_a( copy_status => 'config::copy_status' );
+
+ action::hold_transit_copy->has_a( source => 'actor::org_unit' );
+ action::hold_transit_copy->has_a( dest => 'actor::org_unit' );
+ action::hold_transit_copy->has_a( copy_status => 'config::copy_status' );
+ action::hold_transit_copy->has_a( hold => 'action::hold_request' );
+
+ action::hold_request->has_many( transits => 'action::hold_transit_copy' );
+
+ actor::stat_cat_entry->has_a( stat_cat => 'actor::stat_cat' );
+ actor::stat_cat->has_a( owner => 'actor::org_unit' );
+ actor::stat_cat->has_many( entries => 'actor::stat_cat_entry' );
+ actor::stat_cat_entry_user_map->has_a( stat_cat => 'actor::stat_cat' );
+ actor::stat_cat_entry_user_map->has_a( stat_cat_entry => 'actor::stat_cat_entry' );
+ actor::stat_cat_entry_user_map->has_a( target_usr => 'actor::user' );
+
+ asset::stat_cat_entry->has_a( stat_cat => 'asset::stat_cat' );
+ asset::stat_cat->has_a( owner => 'actor::org_unit' );
+ asset::stat_cat->has_many( entries => 'asset::stat_cat_entry' );
+ asset::stat_cat_entry_copy_map->has_a( stat_cat => 'asset::stat_cat' );
+ asset::stat_cat_entry_copy_map->has_a( stat_cat_entry => 'asset::stat_cat_entry' );
+ asset::stat_cat_entry_copy_map->has_a( owning_copy => 'asset::copy' );
+
+ action::survey_response->has_a( usr => 'actor::user' );
+ action::survey_response->has_a( survey => 'action::survey' );
+ action::survey_response->has_a( question => 'action::survey_question' );
+ action::survey_response->has_a( answer => 'action::survey_answer' );
+
+ action::survey_question->has_a( survey => 'action::survey' );
+
+ action::survey_answer->has_a( question => 'action::survey_question' );
+
+ asset::copy_note->has_a( owning_copy => 'asset::copy' );
+ asset::copy_note->has_a( creator => 'actor::user' );
+
+ actor::user->has_many( stat_cat_entries => [ 'actor::stat_cat_entry_user_map' => 'stat_cat_entry' ] );
+ actor::user->has_many( stat_cat_entry_user_maps => 'actor::stat_cat_entry_user_map' );
+
+ asset::copy->has_many( stat_cat_entries => [ 'asset::stat_cat_entry_copy_map' => 'stat_cat_entry' ] );
+ asset::copy->has_many( stat_cat_entry_copy_maps => 'asset::stat_cat_entry_copy_map' );
+
+ asset::copy->has_a( call_number => 'asset::call_number' );
+ asset::copy->has_a( creator => 'actor::user' );
+ asset::copy->has_a( editor => 'actor::user' );
+ asset::copy->has_a( status => 'config::copy_status' );
+ asset::copy->has_a( location => 'asset::copy_location' );
+ asset::copy->has_a( circ_lib => 'actor::org_unit' );
+
+ serial::unit->has_a( call_number => 'asset::call_number' );
+ serial::unit->has_a( creator => 'actor::user' );
+ serial::unit->has_a( editor => 'actor::user' );
+ serial::unit->has_a( status => 'config::copy_status' );
+ serial::unit->has_a( location => 'asset::copy_location' );
+ serial::unit->has_a( circ_lib => 'actor::org_unit' );
+
+ serial::item->has_a( unit => 'serial::unit' );
+ serial::item->has_a( issuance => 'serial::issuance' );
+ serial::item->has_a( uri => 'asset::uri' );
+
+ serial::unit->has_many( items => 'serial::item' );
+
+ serial::issuance->has_a( subscription => 'serial::subscription' );
+ serial::issuance->has_many( items => 'serial::item' );
+
+ serial::subscription->has_a( record_entry => 'biblio::record_entry' );
+ serial::subscription->has_many( issuances => 'serial::issuance' );
+
+ asset::call_number_note->has_a( call_number => 'asset::call_number' );
+
+ asset::call_number->has_a( record => 'biblio::record_entry' );
+ asset::call_number->has_a( creator => 'actor::user' );
+ asset::call_number->has_a( editor => 'actor::user' );
+ asset::call_number->has_a( owning_lib => 'actor::org_unit' );
+
+ authority::record_note->has_a( record => 'authority::record_entry' );
+ biblio::record_note->has_a( record => 'biblio::record_entry' );
+
+ authority::record_entry->has_a( creator => 'actor::user' );
+ authority::record_entry->has_a( editor => 'actor::user' );
+ biblio::record_entry->has_a( creator => 'actor::user' );
+ biblio::record_entry->has_a( editor => 'actor::user' );
+
+ metabib::metarecord->has_a( master_record => 'biblio::record_entry' );
+
+ authority::record_descriptor->has_a( record => 'authority::record_entry' );
+ metabib::record_descriptor->has_a( record => 'biblio::record_entry' );
+
+ authority::full_rec->has_a( record => 'authority::record_entry' );
+ metabib::full_rec->has_a( record => 'biblio::record_entry' );
+
+ metabib::title_field_entry->has_a( source => 'biblio::record_entry' );
+ metabib::title_field_entry->has_a( field => 'config::metabib_field' );
+
+ metabib::identifier_field_entry->has_a( source => 'biblio::record_entry' );
+ metabib::identifier_field_entry->has_a( field => 'config::metabib_field' );
+
+ metabib::author_field_entry->has_a( source => 'biblio::record_entry' );
+ metabib::author_field_entry->has_a( field => 'config::metabib_field' );
+
+ metabib::subject_field_entry->has_a( source => 'biblio::record_entry' );
+ metabib::subject_field_entry->has_a( field => 'config::metabib_field' );
+
+ metabib::keyword_field_entry->has_a( source => 'biblio::record_entry' );
+ metabib::keyword_field_entry->has_a( field => 'config::metabib_field' );
+
+ metabib::series_field_entry->has_a( source => 'biblio::record_entry' );
+ metabib::series_field_entry->has_a( field => 'config::metabib_field' );
+
+ metabib::metarecord_source_map->has_a( metarecord => 'metabib::metarecord' );
+ metabib::metarecord_source_map->has_a( source => 'biblio::record_entry' );
+
+ action::circulation->has_a( usr => 'actor::user' );
+ actor::user->has_many( circulations => 'action::circulation' => 'usr' );
+
+ booking::resource_attr_map->has_a( resource => 'booking::resource' );
+
+ booking::resource->has_a( owner => 'actor::org_unit' );
+ booking::resource->has_a( type => 'booking::resource_type' );
+ booking::resource_type->has_a( owner => 'actor::org_unit' );
+
+ booking::reservation->has_a( usr => 'actor::user' );
+ actor::user->has_many( reservations => 'booking::reservation' => 'usr' );
+
+ action::circulation->has_a( circ_staff => 'actor::user' );
+ actor::user->has_many( performed_circulations => 'action::circulation' => 'circ_staff' );
+
+ action::circulation->has_a( checkin_staff => 'actor::user' );
+ actor::user->has_many( checkins => 'action::circulation' => 'checkin_staff' );
+
+ action::circulation->has_a( target_copy => 'asset::copy' );
+ asset::copy->has_many( circulations => 'action::circulation' => 'target_copy' );
+ serial::unit->has_many( circulations => 'action::circulation' => 'target_copy' );
+
+ booking::reservation->has_a( pickup_lib => 'actor::org_unit' );
+
+ action::circulation->has_a( circ_lib => 'actor::org_unit' );
+ actor::org_unit->has_many( circulations => 'action::circulation' => 'circ_lib' );
+
+ action::circulation->has_a( checkin_lib => 'actor::org_unit' );
+ actor::org_unit->has_many( checkins => 'action::circulation' => 'checkin_lib' );
+
+ money::billable_transaction->has_a( usr => 'actor::user' );
+ #money::billable_transaction->might_have( circulation => 'action::circulation' );
+ #money::billable_transaction->might_have( grocery => 'money::grocery' );
+ actor::user->has_many( billable_transactions => 'action::circulation' => 'usr' );
+
+
+ #-------------------------------------------------------------------------------
+ actor::user->has_many( survey_responses => 'action::survey_response' );
+ actor::user->has_many( addresses => 'actor::user_address' );
+ actor::user->has_many( cards => 'actor::card' );
+
+ actor::org_unit->has_many( users => 'actor::user' );
+
+ action::survey->has_many( questions => 'action::survey_question' );
+ action::survey->has_many( responses => 'action::survey_response' );
+
+ action::survey_question->has_many( answers => 'action::survey_answer' );
+ action::survey_question->has_many( responses => 'action::survey_response' );
+
+ action::survey_answer->has_many( responses => 'action::survey_response' );
+
+ asset::copy->has_many( notes => 'asset::copy_note' );
+ asset::call_number->has_many( copies => 'asset::copy' );
+ asset::call_number->has_many( notes => 'asset::call_number_note' );
+
+ authority::record_entry->has_many( record_descriptor => 'authority::record_descriptor' );
+ authority::record_entry->has_many( notes => 'authority::record_note' );
+
+ biblio::record_entry->has_many( record_descriptor => 'metabib::record_descriptor' );
+ biblio::record_entry->has_many( notes => 'biblio::record_note' );
+ biblio::record_entry->has_many( call_numbers => 'asset::call_number' );
+ biblio::record_entry->has_many( full_record_entries => 'metabib::full_rec' );
+ biblio::record_entry->has_many( title_field_entries => 'metabib::title_field_entry' );
+ biblio::record_entry->has_many( identifier_field_entries => 'metabib::identifier_field_entry' );
+ biblio::record_entry->has_many( author_field_entries => 'metabib::author_field_entry' );
+ biblio::record_entry->has_many( subject_field_entries => 'metabib::subject_field_entry' );
+ biblio::record_entry->has_many( keyword_field_entries => 'metabib::keyword_field_entry' );
+ biblio::record_entry->has_many( series_field_entries => 'metabib::series_field_entry' );
+
+ metabib::metarecord->has_many( source_records => [ 'metabib::metarecord_source_map' => 'source'] );
+ biblio::record_entry->has_many( metarecords => [ 'metabib::metarecord_source_map' => 'metarecord'] );
+
+ money::billing->has_a( xact => 'money::billable_transaction' );
+ money::payment->has_a( xact => 'money::billable_transaction' );
+
+ money::billable_transaction->has_many( billings => 'money::billing' );
+ money::billable_transaction->has_many( payments => 'money::payment' );
+
+ action::circulation->has_many( billings => 'money::billing' => 'xact' );
+ action::circulation->has_many( payments => 'money::payment' => 'xact' );
+ #action::circulation->might_have( billable_transaction => 'money::billable_transaction' );
+ #action::open_circulation->might_have( circulation => 'action::circulation' );
+
+ booking::reservation->has_many( billings => 'money::billing' => 'xact' );
+ booking::reservation->has_many( payments => 'money::payment' => 'xact' );
+
+ action::in_house_use->has_a( org_unit => 'actor::org_unit' );
+ action::in_house_use->has_a( staff => 'actor::user' );
+ action::in_house_use->has_a( item => 'asset::copy' );
+
+ action::non_cataloged_circulation->has_a( circ_lib => 'actor::org_unit' );
+ action::non_cataloged_circulation->has_a( item_type => 'config::non_cataloged_type' );
+ action::non_cataloged_circulation->has_a( patron => 'actor::user' );
+ action::non_cataloged_circulation->has_a( staff => 'actor::user' );
+
+ money::grocery->has_many( billings => 'money::billing' => 'xact' );
+ money::grocery->has_many( payments => 'money::payment' => 'xact' );
+ #money::grocery->might_have( billable_transaction => 'money::billable_transaction' );
+
+ #money::payment->might_have( cash_payment => 'money::cash_payment' );
+ #money::payment->might_have( check_payment => 'money::check_payment' );
+ #money::payment->might_have( credit_card_payment => 'money::credit_card_payment' );
+ #money::payment->might_have( forgive_payment => 'money::forgive_payment' );
+ #money::payment->might_have( work_payment => 'money::work_payment' );
+ #money::payment->might_have( credit_payment => 'money::credit_payment' );
+
+ money::cash_payment->has_a( xact => 'money::billable_transaction' );
+ money::cash_payment->has_a( accepting_usr => 'actor::user' );
+ #money::cash_payment->might_have( payment => 'money::payment' );
+
+ money::check_payment->has_a( xact => 'money::billable_transaction' );
+ money::check_payment->has_a( accepting_usr => 'actor::user' );
+ #money::check_payment->might_have( payment => 'money::payment' );
+
+ money::credit_card_payment->has_a( xact => 'money::billable_transaction' );
+ money::credit_card_payment->has_a( accepting_usr => 'actor::user' );
+ #money::credit_card_payment->might_have( payment => 'money::payment' );
+
+ money::forgive_payment->has_a( xact => 'money::billable_transaction' );
+ money::forgive_payment->has_a( accepting_usr => 'actor::user' );
+ #money::forgive_payment->might_have( payment => 'money::payment' );
+
+ money::work_payment->has_a( xact => 'money::billable_transaction' );
+ money::work_payment->has_a( accepting_usr => 'actor::user' );
+ #money::work_payment->might_have( payment => 'money::payment' );
+
+ money::goods_payment->has_a( xact => 'money::billable_transaction' );
+ money::goods_payment->has_a( accepting_usr => 'actor::user' );
+ #money::goods_payment->might_have( payment => 'money::payment' );
+
+ money::credit_payment->has_a( xact => 'money::billable_transaction' );
+ money::credit_payment->has_a( accepting_usr => 'actor::user' );
+ #money::credit_payment->might_have( payment => 'money::payment' );
+
+ permission::grp_tree->has_a( parent => 'permission::grp_tree' );
+ permission::grp_tree->has_many( children => 'permission::grp_tree' => 'parent' );
+
+ permission::grp_perm_map->has_a( grp => 'permission::grp_tree' );
+ permission::grp_perm_map->has_a( perm => 'permission::perm_list' );
+ permission::grp_perm_map->has_a( depth => 'actor::org_unit_type' );
+
+ permission::usr_perm_map->has_a( usr => 'actor::user' );
+ permission::usr_perm_map->has_a( perm => 'permission::perm_list' );
+ permission::usr_perm_map->has_a( depth => 'actor::org_unit_type' );
+
+ permission::usr_grp_map->has_a( usr => 'actor::user' );
+ permission::usr_grp_map->has_a( grp => 'permission::grp_tree' );
+
+ action::hold_notification->has_a( hold => 'action::hold_request' );
+
+ action::hold_copy_map->has_a( hold => 'action::hold_request' );
+ action::hold_copy_map->has_a( target_copy => 'asset::copy' );
+
+ action::unfulfilled_hold_list->has_a( current_copy => 'asset::copy' );
+ action::unfulfilled_hold_list->has_a( hold => 'action::hold_request' );
+ action::unfulfilled_hold_list->has_a( circ_lib => 'actor::org_unit' );
+
+ action::hold_request->has_a( current_copy => 'asset::copy' );
+ action::hold_request->has_a( requestor => 'actor::user' );
+ action::hold_request->has_a( usr => 'actor::user' );
+ action::hold_request->has_a( fulfillment_staff => 'actor::user' );
+ action::hold_request->has_a( pickup_lib => 'actor::org_unit' );
+ action::hold_request->has_a( request_lib => 'actor::org_unit' );
+ action::hold_request->has_a( fulfillment_lib => 'actor::org_unit' );
+ action::hold_request->has_a( selection_ou => 'actor::org_unit' );
+
+ action::hold_request->has_many( notifications => 'action::hold_notification' );
+ action::hold_request->has_many( eligible_copies => [ 'action::hold_copy_map' => 'target_copy' ] );
+
+ asset::copy->has_many( holds => [ 'action::hold_copy_map' => 'hold' ] );
+ serial::unit->has_many( holds => [ 'action::hold_copy_map' => 'hold' ] );
+
+ container::biblio_record_entry_bucket->has_a( owner => 'actor::user' );
+ container::biblio_record_entry_bucket_item->has_a( bucket => 'container::biblio_record_entry_bucket' );
+ container::biblio_record_entry_bucket_item->has_a( target_biblio_record_entry => 'biblio::record_entry' );
+ container::biblio_record_entry_bucket->has_many( items => 'container::biblio_record_entry_bucket_item' );
+
+ container::user_bucket->has_a( owner => 'actor::user' );
+ container::user_bucket_item->has_a( bucket => 'container::user_bucket' );
+ container::user_bucket_item->has_a( target_user => 'actor::user' );
+ container::user_bucket->has_many( items => 'container::user_bucket_item' );
+
+ container::call_number_bucket->has_a( owner => 'actor::user' );
+ container::call_number_bucket_item->has_a( bucket => 'container::call_number_bucket' );
+ container::call_number_bucket_item->has_a( target_call_number => 'asset::call_number' );
+ container::call_number_bucket->has_many( items => 'container::call_number_bucket_item' );
+
+ container::copy_bucket->has_a( owner => 'actor::user' );
+ container::copy_bucket_item->has_a( bucket => 'container::copy_bucket' );
+ container::copy_bucket_item->has_a( target_copy => 'asset::copy' );
+ container::copy_bucket->has_many( items => 'container::copy_bucket_item' );
+
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::CDBI::action;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package action;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+
+package action::in_house_use;
+use base qw/action/;
+__PACKAGE__->table('action_in_house_use');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/item staff org_unit use_time/);
+#-------------------------------------------------------------------------------
+
+package action::non_cat_in_house_use;
+use base qw/action/;
+__PACKAGE__->table('action_non_cat_in_house_use');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/item_type staff org_unit use_time/);
+#-------------------------------------------------------------------------------
+
+package action::non_cataloged_circulation;
+use base qw/action/;
+__PACKAGE__->table('action_non_cataloged_circulation');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/patron staff circ_lib item_type circ_time/);
+#-------------------------------------------------------------------------------
+
+package action::survey;
+use base qw/action/;
+__PACKAGE__->table('action_survey');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name description owner start_date
+ end_date usr_summary opac poll required/);
+#-------------------------------------------------------------------------------
+
+package action::survey_question;
+use base qw/action/;
+__PACKAGE__->table('action_survey_question');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/survey question/);
+#-------------------------------------------------------------------------------
+
+
+package action::survey_answer;
+use base qw/action/;
+__PACKAGE__->table('action_survey_answer');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/question answer/);
+#-------------------------------------------------------------------------------
+
+package action::survey_response;
+use base qw/action/;
+__PACKAGE__->table('action_survey_response');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/response_group_id usr survey question
+ answer answer_date effective_date/);
+#-------------------------------------------------------------------------------
+
+package action::circulation;
+use base qw/action/;
+__PACKAGE__->table('action_circulation');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr target_copy circ_lib
+ duration duration_rule renewal_remaining
+ recurring_fine_rule recurring_fine stop_fines
+ max_fine max_fine_rule fine_interval
+ stop_fines xact_finish due_date opac_renewal
+ checkin_staff circ_staff circ_lib checkin_lib
+ stop_fines_time checkin_time desk_renewal
+ phone_renewal create_time/);
+
+#-------------------------------------------------------------------------------
+
+package action::open_circulation;
+use base qw/action/;
+__PACKAGE__->table('action_open_circulation');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr target_copy circ_lib
+ duration duration_rule renewal_remaining
+ recurring_fine_rule recurring_fine stop_fines
+ max_fine max_fine_rule fine_interval
+ stop_fines xact_finish due_date opac_renewal
+ checkin_staff circ_staff circ_lib checkin_lib
+ stop_fines_time checkin_time desk_renewal
+ phone_renewal/);
+
+#-------------------------------------------------------------------------------
+
+package action::hold_request;
+use base qw/action/;
+__PACKAGE__->table('action_hold_request');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/request_time capture_time fulfillment_time
+ prev_check_time expire_time requestor usr cancel_cause
+ hold_type holdable_formats target cancel_time shelf_time
+ phone_notify email_notify selection_depth cancel_note
+ pickup_lib current_copy request_lib frozen thaw_date mint_condition
+ fulfillment_staff fulfillment_lib selection_ou cut_in_line/);
+
+#-------------------------------------------------------------------------------
+
+package action::hold_notification;
+use base qw/action/;
+__PACKAGE__->table('action_hold_notification');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/hold method notify_time note notify_staff/);
+
+#-------------------------------------------------------------------------------
+
+package action::hold_copy_map;
+use base qw/action/;
+__PACKAGE__->table('action_hold_copy_map');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/hold target_copy/);
+
+#-------------------------------------------------------------------------------
+
+package action::hold_transit_copy;
+use base qw/action/;
+__PACKAGE__->table('action_hold_transit_copy');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/source dest persistant_transfer target_copy
+ source_send_time dest_recv_time prev_hop prev_dest
+ copy_status hold/);
+
+#-------------------------------------------------------------------------------
+
+package action::reservation_transit_copy;
+use base qw/action/;
+__PACKAGE__->table('action_reservation_transit_copy');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/source dest persistant_transfer target_copy
+ source_send_time dest_recv_time prev_hop prev_dest
+ copy_status reservation/);
+
+#-------------------------------------------------------------------------------
+
+package action::transit_copy;
+use base qw/action/;
+__PACKAGE__->table('action_transit_copy');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/source dest persistant_transfer target_copy
+ source_send_time dest_recv_time prev_hop prev_dest
+ copy_status/);
+
+#-------------------------------------------------------------------------------
+
+package action::unfulfilled_hold_list;
+use base qw/action/;
+__PACKAGE__->table('action_unfulfilled_hold_list');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/hold current_copy circ_lib fail_time /);
+
+#-------------------------------------------------------------------------------
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::actor;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package actor;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package actor::user;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_usr' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/usrname email first_given_name
+ second_given_name family_name billing_address
+ claims_returned_count home_ou dob deleted juvenile
+ active master_account ident_type ident_value
+ ident_type2 ident_value2 net_access_level alias
+ photo_url create_date expire_date credit_forward_balance
+ super_user usrgroup passwd card last_xact_id
+ standing barred profile prefix suffix alert_message
+ day_phone evening_phone other_phone mailing_address/ );
+
+#-------------------------------------------------------------------------------
+package actor::usr_org_unit_opt_in;
+use base qw/actor/;
+__PACKAGE__->table( 'actor_usr_org_unit_opt_in' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/org_unit usr staff opt_in_ts opt_in_ws/ );
+
+#-------------------------------------------------------------------------------
+package actor::org_unit_proximity;
+use base qw/actor/;
+__PACKAGE__->table( 'actor_org_unit_proximity' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/from_org to_org prox/ );
+
+#-------------------------------------------------------------------------------
+package actor::usr_note;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_usr_note' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/usr title creator create_date value pub/ );
+
+#-------------------------------------------------------------------------------
+package actor::workstation;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_workstation' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/name owning_lib/);
+
+#-------------------------------------------------------------------------------
+package actor::user_standing_penalty;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_user_standing_penalty' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/usr penalty_type/);
+
+#-------------------------------------------------------------------------------
+package actor::user_setting;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_user_setting' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/usr name value/);
+
+#-------------------------------------------------------------------------------
+package actor::org_unit_type;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_org_unit_type' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/name opac_label depth parent can_have_vols can_have_users/);
+
+#-------------------------------------------------------------------------------
+package actor::org_unit;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_org_unit' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/parent_ou ou_type mailing_address billing_address
+ ill_address holds_address shortname name email phone opac_visible fiscal_calendar/);
+
+#-------------------------------------------------------------------------------
+package actor::org_unit::hours_of_operation;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_hours_of_operation' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/dow_0_open dow_0_close dow_1_open dow_1_close dow_2_open dow_2_close
+ dow_3_open dow_3_close dow_4_open dow_4_close dow_5_open dow_5_close
+ dow_6_open dow_6_close/);
+
+#-------------------------------------------------------------------------------
+package actor::org_unit::closed_date;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_org_unit_closed' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/org_unit close_start close_end reason/);
+
+
+#-------------------------------------------------------------------------------
+package actor::org_unit_setting;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_org_unit_setting' );
+__PACKAGE__->columns( Primary => qw/id/);
+__PACKAGE__->columns( Essential => qw/org_unit name value/);
+
+
+#-------------------------------------------------------------------------------
+package actor::stat_cat;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_stat_cat' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/owner name opac_visible usr_summary/ );
+
+#-------------------------------------------------------------------------------
+package actor::stat_cat_entry;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_stat_cat_entry' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/stat_cat owner value/ );
+
+#-------------------------------------------------------------------------------
+package actor::stat_cat_entry_user_map;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_stat_cat_entry_usr_map' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/stat_cat stat_cat_entry target_usr/ );
+
+#-------------------------------------------------------------------------------
+package actor::card;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_card' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/usr barcode active/ );
+
+#-------------------------------------------------------------------------------
+package actor::user_access_entry;
+use base qw/actor/;
+#-------------------------------------------------------------------------------
+package actor::perm_group;
+use base qw/actor/;
+#-------------------------------------------------------------------------------
+package actor::permission;
+use base qw/actor/;
+#-------------------------------------------------------------------------------
+package actor::perm_group_permission_map;
+use base qw/actor/;
+#-------------------------------------------------------------------------------
+package actor::perm_group_user_map;
+use base qw/actor/;
+#-------------------------------------------------------------------------------
+package actor::user_address;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_usr_address' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/valid address_type usr street1 street2
+ city county state country post_code
+ within_city_limits/ );
+
+#-------------------------------------------------------------------------------
+package actor::org_address;
+use base qw/actor/;
+
+__PACKAGE__->table( 'actor_org_address' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/valid address_type org_unit street1 street2
+ city county state country post_code/ );
+
+#-------------------------------------------------------------------------------
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::asset;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package asset;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package asset::copy_location;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_copy_location' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/name owning_lib holdable hold_verify opac_visible circulate label_prefix label_suffix/ );
+
+#-------------------------------------------------------------------------------
+package asset::copy_location_order;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_copy_location_order' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/location org position/ );
+
+#-------------------------------------------------------------------------------
+package asset::call_number_class;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_call_number_class' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/name normalizer field/ );
+
+#-------------------------------------------------------------------------------
+package asset::call_number;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_call_number' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/record label creator create_date editor
+ edit_date record label owning_lib deleted label_class label_sortkey/ );
+
+#-------------------------------------------------------------------------------
+package asset::call_number_note;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_call_number_note' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/call_number title creator create_date value pub/ );
+
+#-------------------------------------------------------------------------------
+package asset::copy;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_copy' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/call_number barcode creator create_date editor
+ edit_date copy_number status loan_duration circ_lib dummy_isbn
+ fine_level circulate deposit price ref opac_visible
+ circ_as_type circ_modifier deposit_amount location mint_condition
+ holdable dummy_title dummy_author deleted alert_message
+ age_protect floating cost status_changed_time/ );
+
+#-------------------------------------------------------------------------------
+package asset::stat_cat;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_stat_cat' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/owner name opac_visible required/ );
+
+#-------------------------------------------------------------------------------
+package asset::stat_cat_entry;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_stat_cat_entry' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/stat_cat owner value/ );
+
+#-------------------------------------------------------------------------------
+package asset::stat_cat_entry_copy_map;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_stat_cat_entry_copy_map' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/stat_cat stat_cat_entry owning_copy/ );
+
+#-------------------------------------------------------------------------------
+package asset::copy_note;
+use base qw/asset/;
+
+__PACKAGE__->table( 'asset_copy_note' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/owning_copy title creator create_date value pub/ );
+
+#-------------------------------------------------------------------------------
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::authority;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package authority;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package authority::record_entry;
+use base qw/authority/;
+
+authority::record_entry->table( 'authority_record_entry' );
+authority::record_entry->columns( Primary => qw/id/ );
+authority::record_entry->columns( Essential => qw/creator editor
+ create_date edit_date source active
+ deleted marc last_xact_id/ );
+
+#-------------------------------------------------------------------------------
+package authority::record_note;
+use base qw/authority/;
+
+authority::record_note->table( 'authority_record_note' );
+authority::record_note->columns( Primary => qw/id/ );
+authority::record_note->columns( Essential => qw/record value creator
+ editor create_date edit_date/ );
+#-------------------------------------------------------------------------------
+package authority::full_rec;
+use base qw/authority/;
+
+authority::full_rec->table( 'authority_full_rec' );
+authority::full_rec->columns( Primary => qw/id/ );
+authority::full_rec->columns( Essential => qw/record tag ind1 ind2 subfield value/ );
+
+#-------------------------------------------------------------------------------
+package authority::record_descriptor;
+use base qw/authority/;
+#use OpenILS::Application::Storage::CDBI::asset;
+
+authority::record_descriptor->table( 'authority_rec_descriptor' );
+authority::record_descriptor->columns( Primary => qw/id/ );
+authority::record_descriptor->columns( Essential => qw/record record_status
+ char_encoding/ );
+
+#-------------------------------------------------------------------------------
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::biblio;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package biblio;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package biblio::record_entry;
+use base qw/biblio/;
+
+biblio::record_entry->table( 'biblio_record_entry' );
+biblio::record_entry->columns( Essential => qw/id tcn_source tcn_value creator editor
+ create_date edit_date source active quality owner share_depth
+ deleted marc last_xact_id fingerprint/ );
+
+#-------------------------------------------------------------------------------
+package biblio::record_note;
+use base qw/biblio/;
+
+biblio::record_note->table( 'biblio_record_note' );
+biblio::record_note->columns( Essential => qw/id record value creator
+ editor create_date edit_date pub/ );
+#-------------------------------------------------------------------------------
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::booking;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package booking;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+
+package booking::resource_type;
+use base qw/booking/;
+__PACKAGE__->table('booking_resource_type');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name fine_interval fine_amount
+ max_fine owner catalog_item record transferable elbow_room/);
+
+#-------------------------------------------------------------------------------
+
+package booking::resource;
+use base qw/booking/;
+__PACKAGE__->table('booking_resource');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/owner type overbook barcode deposit
+ deposit_amount user_fee/);
+
+#-------------------------------------------------------------------------------
+
+package booking::reservation;
+use base qw/booking/;
+__PACKAGE__->table('booking_reservation');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr current_resource
+ fine_amount max_fine fine_interval xact_finish
+ capture_staff pickup_lib request_time start_time end_time
+ capture_time cancel_time pickup_time return_time
+ booking_interval target_resource_type target_resource
+ current_resource request_lib/);
+
+#-------------------------------------------------------------------------------
+
+package booking::resource_attr_map;
+use base qw/booking/;
+__PACKAGE__->table('booking_resource_attr_map');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/resource resource_attr value/);
+
+#-------------------------------------------------------------------------------
+
+package booking::reservation_attr_value_map;
+use base qw/booking/;
+__PACKAGE__->table('booking_reservation_attr_value_map');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/reservation attr_value/);
+
+#-------------------------------------------------------------------------------
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::config;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package config;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+
+package config::non_cataloged_type;
+use base qw/config/;
+__PACKAGE__->table('config_non_cataloged_type');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/owning_lib name circ_duration in_house/);
+#-------------------------------------------------------------------------------
+
+package config::standing;
+use base qw/config/;
+__PACKAGE__->table('config_standing');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/value/);
+#-------------------------------------------------------------------------------
+
+package config::bib_source;
+use base qw/config/;
+__PACKAGE__->table('config_bib_source');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/quality source transcendant/);
+#-------------------------------------------------------------------------------
+
+package config::metabib_field;
+use base qw/config/;
+__PACKAGE__->table('config_metabib_field');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/field_class name xpath weight format search_field facet_field/);
+#-------------------------------------------------------------------------------
+
+package config::identification_type;
+use base qw/config/;
+__PACKAGE__->table('config_identification_type');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name/);
+#-------------------------------------------------------------------------------
+
+package config::rules::circ_duration;
+use base qw/config/;
+__PACKAGE__->table('config_rule_circ_duration');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name extended normal shrt max_renewals/);
+#-------------------------------------------------------------------------------
+
+package config::rules::max_fine;
+use base qw/config/;
+__PACKAGE__->table('config_rule_max_fine');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name amount is_percent/);
+#-------------------------------------------------------------------------------
+
+package config::rules::recurring_fine;
+use base qw/config/;
+__PACKAGE__->table('config_rule_recurring_fine');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name high normal low recurrence_interval/);
+#-------------------------------------------------------------------------------
+
+package config::rules::age_hold_protect;
+use base qw/config/;
+__PACKAGE__->table('config_rule_age_hold_protect');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name age prox/);
+#-------------------------------------------------------------------------------
+
+package config::copy_status;
+use base qw/config/;
+__PACKAGE__->table('config_copy_status');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name holdable opac_visible/);
+#-------------------------------------------------------------------------------
+
+package config::net_access_level;
+use base qw/config/;
+__PACKAGE__->table('config_net_access_level');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/name/);
+#-------------------------------------------------------------------------------
+
+package config::audience_map;
+use base qw/config/;
+__PACKAGE__->table('config_audience_map');
+__PACKAGE__->columns(Primary => 'code');
+__PACKAGE__->columns(Essential => qw/value description/);
+#-------------------------------------------------------------------------------
+
+package config::lit_form_map;
+use base qw/config/;
+__PACKAGE__->table('config_lit_form_map');
+__PACKAGE__->columns(Primary => 'code');
+__PACKAGE__->columns(Essential => qw/value description/);
+#-------------------------------------------------------------------------------
+
+package config::item_form_map;
+use base qw/config/;
+__PACKAGE__->table('config_lit_form_map');
+__PACKAGE__->columns(Primary => 'code');
+__PACKAGE__->columns(Essential => qw/value/);
+#-------------------------------------------------------------------------------
+
+package config::item_type_map;
+use base qw/config/;
+__PACKAGE__->table('config_lit_form_map');
+__PACKAGE__->columns(Primary => 'code');
+__PACKAGE__->columns(Essential => qw/value/);
+#-------------------------------------------------------------------------------
+
+package config::language_map;
+use base qw/config/;
+__PACKAGE__->table('config_language_map');
+__PACKAGE__->columns(Primary => 'code');
+__PACKAGE__->columns(Essential => qw/value/);
+#-------------------------------------------------------------------------------
+
+package config::i18n_locale;
+use base qw/config/;
+__PACKAGE__->table('config_i18n_locale');
+__PACKAGE__->columns(Primary => 'code');
+__PACKAGE__->columns(Essential => qw/marc_code name description/);
+#-------------------------------------------------------------------------------
+
+package config::i18n_core;
+use base qw/config/;
+__PACKAGE__->table('config_i18n_core');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/fq_field identity_value translation string/);
+#-------------------------------------------------------------------------------
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::container;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package container;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package container::user_bucket;
+use base qw/container/;
+
+container::user_bucket->table( 'container_user_bucket' );
+container::user_bucket->columns( Primary => qw/id/ );
+container::user_bucket->columns( Essential => qw/owner name btype pub/ );
+
+#-------------------------------------------------------------------------------
+package container::user_bucket_item;
+use base qw/container/;
+
+container::user_bucket_item->table( 'container_user_bucket_item' );
+container::user_bucket_item->columns( Primary => qw/id/ );
+container::user_bucket_item->columns( Essential => qw/bucket target_user/ );
+
+#-------------------------------------------------------------------------------
+package container::copy_bucket;
+use base qw/container/;
+
+container::copy_bucket->table( 'container_copy_bucket' );
+container::copy_bucket->columns( Primary => qw/id/ );
+container::copy_bucket->columns( Essential => qw/owner name btype pub/ );
+
+#-------------------------------------------------------------------------------
+package container::copy_bucket_item;
+use base qw/container/;
+
+container::copy_bucket_item->table( 'container_copy_bucket_item' );
+container::copy_bucket_item->columns( Primary => qw/id/ );
+container::copy_bucket_item->columns( Essential => qw/bucket target_copy/ );
+
+#-------------------------------------------------------------------------------
+package container::biblio_record_entry_bucket;
+use base qw/container/;
+
+container::biblio_record_entry_bucket->table( 'container_biblio_record_entry_bucket' );
+container::biblio_record_entry_bucket->columns( Primary => qw/id/ );
+container::biblio_record_entry_bucket->columns( Essential => qw/owner name btype pub/ );
+
+#-------------------------------------------------------------------------------
+package container::biblio_record_entry_bucket_item;
+use base qw/container/;
+
+container::biblio_record_entry_bucket_item->table( 'container_biblio_record_entry_bucket_item' );
+container::biblio_record_entry_bucket_item->columns( Primary => qw/id/ );
+container::biblio_record_entry_bucket_item->columns( Essential => qw/bucket target_biblio_record_entry/ );
+
+#-------------------------------------------------------------------------------
+package container::call_number_bucket;
+use base qw/container/;
+
+container::call_number_bucket->table( 'container_call_number_bucket' );
+container::call_number_bucket->columns( Primary => qw/id/ );
+container::call_number_bucket->columns( Essential => qw/owner name btype pub/ );
+
+#-------------------------------------------------------------------------------
+package container::call_number_bucket_item;
+use base qw/container/;
+
+container::call_number_bucket_item->table( 'container_call_number_bucket_item' );
+container::call_number_bucket_item->columns( Primary => qw/id/ );
+container::call_number_bucket_item->columns( Essential => qw/bucket target_call_number/ );
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::metabib;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package metabib;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package metabib::metarecord;
+use base qw/metabib/;
+
+metabib::metarecord->table( 'metabib_metarecord' );
+metabib::metarecord->columns( Primary => qw/id/ );
+metabib::metarecord->columns( Essential => qw/fingerprint master_record mods/ );
+
+#-------------------------------------------------------------------------------
+package metabib::identifier_field_entry;
+use base qw/metabib/;
+
+metabib::identifier_field_entry->table( 'metabib_identifier_field_entry' );
+metabib::identifier_field_entry->columns( Primary => qw/id/ );
+metabib::identifier_field_entry->columns( Essential => qw/field value source/ );
+
+
+#-------------------------------------------------------------------------------
+package metabib::title_field_entry;
+use base qw/metabib/;
+
+metabib::title_field_entry->table( 'metabib_title_field_entry' );
+metabib::title_field_entry->columns( Primary => qw/id/ );
+metabib::title_field_entry->columns( Essential => qw/field value source/ );
+
+
+#-------------------------------------------------------------------------------
+package metabib::author_field_entry;
+use base qw/metabib/;
+
+metabib::author_field_entry->table( 'metabib_author_field_entry' );
+metabib::author_field_entry->columns( Primary => qw/id/ );
+metabib::author_field_entry->columns( Essential => qw/field value source/ );
+
+
+#-------------------------------------------------------------------------------
+package metabib::subject_field_entry;
+use base qw/metabib/;
+
+metabib::subject_field_entry->table( 'metabib_subject_field_entry' );
+metabib::subject_field_entry->columns( Primary => qw/id/ );
+metabib::subject_field_entry->columns( Essential => qw/field value source/ );
+
+
+#-------------------------------------------------------------------------------
+package metabib::keyword_field_entry;
+use base qw/metabib/;
+
+metabib::keyword_field_entry->table( 'metabib_keyword_field_entry' );
+metabib::keyword_field_entry->columns( Primary => qw/id/ );
+metabib::keyword_field_entry->columns( Essential => qw/field value source/ );
+
+#-------------------------------------------------------------------------------
+package metabib::series_field_entry;
+use base qw/metabib/;
+
+metabib::series_field_entry->table( 'metabib_series_field_entry' );
+metabib::series_field_entry->columns( Primary => qw/id/ );
+metabib::series_field_entry->columns( Essential => qw/field value source/ );
+
+#-------------------------------------------------------------------------------
+package metabib::metarecord_source_map;
+use base qw/metabib/;
+
+metabib::metarecord_source_map->table( 'metabib_metarecord_source_map' );
+metabib::metarecord_source_map->columns( Primary => qw/id/ );
+metabib::metarecord_source_map->columns( Essential => qw/metarecord source/ );
+
+#-------------------------------------------------------------------------------
+package metabib::full_rec;
+use base qw/metabib/;
+
+metabib::full_rec->table( 'metabib_full_rec' );
+metabib::full_rec->columns( Primary => qw/id/ );
+metabib::full_rec->columns( Essential => qw/record tag ind1 ind2 subfield value/ );
+
+#-------------------------------------------------------------------------------
+package metabib::record_descriptor;
+use base qw/metabib/;
+#use OpenILS::Application::Storage::CDBI::asset;
+
+metabib::record_descriptor->table( 'metabib_rec_descriptor' );
+metabib::record_descriptor->columns( Primary => qw/id/ );
+metabib::record_descriptor->columns( Essential => qw/record item_type item_form bib_level
+ control_type char_encoding enc_level lit_form vr_format
+ cat_form pub_status item_lang audience type_mat date1 date2/ );
+
+#-------------------------------------------------------------------------------
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::money;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package money;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+
+package money::collections_tracker;
+use base qw/money/;
+__PACKAGE__->table('money_collections_tracker');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/usr collector location enter_time/);
+#-------------------------------------------------------------------------------
+
+package money::billable_transaction;
+use base qw/money/;
+__PACKAGE__->table('money_billable_xact');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr xact_finish unrecovered/);
+#-------------------------------------------------------------------------------
+
+package money::grocery;
+use base qw/money/;
+__PACKAGE__->table('money_grocery');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr billing_location note xact_finish/);
+#-------------------------------------------------------------------------------
+
+package money::open_user_summary;
+use base qw/money/;
+__PACKAGE__->table('money_open_user_summary');
+__PACKAGE__->columns(Primary => 'usr');
+__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
+#-------------------------------------------------------------------------------
+
+package money::user_summary;
+use base qw/money/;
+__PACKAGE__->table('money_user_summary');
+__PACKAGE__->columns(Primary => 'usr');
+__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
+#-------------------------------------------------------------------------------
+
+package money::open_user_circulation_summary;
+use base qw/money/;
+__PACKAGE__->table('money_open_user_circulation_summary');
+__PACKAGE__->columns(Primary => 'usr');
+__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
+#-------------------------------------------------------------------------------
+
+package money::user_circulation_summary;
+use base qw/money/;
+__PACKAGE__->table('money_user_circulation_summary');
+__PACKAGE__->columns(Primary => 'usr');
+__PACKAGE__->columns(Essential => qw/total_paid total_owed balance_owed/);
+#-------------------------------------------------------------------------------
+
+package money::open_billable_transaction_summary;
+use base qw/money/;
+__PACKAGE__->table('money_open_billable_transaction_summary');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr xact_finish total_paid
+ last_payment_ts total_owed last_billing_ts
+ balance_owed xact_type last_billing_note last_billing_type
+ last_payment_note last_payment_type/);
+#-------------------------------------------------------------------------------
+
+package money::billable_transaction_summary;
+use base qw/money/;
+__PACKAGE__->table('money_billable_transaction_summary');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact_start usr xact_finish total_paid
+ last_payment_ts total_owed last_billing_ts
+ balance_owed xact_type last_billing_note last_billing_type
+ last_payment_note last_payment_type/);
+#-------------------------------------------------------------------------------
+
+package money::billing;
+use base qw/money/;
+__PACKAGE__->table('money_billing');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount billing_ts billing_type note
+ voided voider void_time btype/);
+#-------------------------------------------------------------------------------
+
+package money::payment;
+use base qw/money/;
+__PACKAGE__->table('money_payment');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount payment_ts payment_type note voided/);
+#-------------------------------------------------------------------------------
+
+package money::desk_payment;
+use base qw/money/;
+__PACKAGE__->table('money_desk_payment');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount payment_ts voided amount_collected accepting_usr cash_drawer payment_type note/);
+#-------------------------------------------------------------------------------
+
+package money::cash_payment;
+use base qw/money/;
+__PACKAGE__->table('money_cash_payment');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount payment_ts cash_drawer accepting_usr amount_collected note/);
+#-------------------------------------------------------------------------------
+
+package money::check_payment;
+use base qw/money/;
+__PACKAGE__->table('money_check_payment');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount payment_ts cash_drawer check_number accepting_usr amount_collected note/);
+#-------------------------------------------------------------------------------
+
+package money::credit_card_payment;
+use base qw/money/;
+__PACKAGE__->table('money_credit_card_payment');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount payment_ts cash_drawer
+ accepting_usr amount_collected cc_type
+ cc_number expire_month expire_year
+ approval_code note/);
+#-------------------------------------------------------------------------------
+
+package money::forgive_payment;
+use base qw/money/;
+__PACKAGE__->table('money_forgive_payment');
+__PACKAGE__->columns(Primary => 'id');
+__PACKAGE__->columns(Essential => qw/xact amount payment_ts accepting_usr amount_collected note/);
+#-------------------------------------------------------------------------------
+
+package money::work_payment;
+use base qw/money::forgive_payment/;
+__PACKAGE__->table('money_work_payment');
+#-------------------------------------------------------------------------------
+
+package money::goods_payment;
+use base qw/money::forgive_payment/;
+__PACKAGE__->table('money_goods_payment');
+#-------------------------------------------------------------------------------
+
+package money::credit_payment;
+use base qw/money::forgive_payment/;
+__PACKAGE__->table('money_credit_payment');
+
+#-------------------------------------------------------------------------------
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::permission;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package permission;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package permission::perm_list;
+use base qw/permission/;
+__PACKAGE__->table('permission_perm_list');
+__PACKAGE__->columns(Primary => qw/id/);
+__PACKAGE__->columns(Essential => qw/code description/);
+#-------------------------------------------------------------------------------
+package permission::grp_tree;
+use base qw/permission/;
+__PACKAGE__->table('permission_grp_tree');
+__PACKAGE__->columns(Primary => qw/id/);
+__PACKAGE__->columns(Essential => qw/name parent description perm_interval
+ application_perm usergroup hold_priority/);
+#-------------------------------------------------------------------------------
+package permission::usr_grp_map;
+use base qw/permission/;
+__PACKAGE__->table('permission_usr_grp_map');
+__PACKAGE__->columns(Primary => qw/id/);
+__PACKAGE__->columns(Essential => qw/usr grp/);
+#-------------------------------------------------------------------------------
+package permission::usr_perm_map;
+use base qw/permission/;
+__PACKAGE__->table('permission_usr_perm_map');
+__PACKAGE__->columns(Primary => qw/id/);
+__PACKAGE__->columns(Essential => qw/usr perm depth grantable/);
+#-------------------------------------------------------------------------------
+package permission::grp_perm_map;
+use base qw/permission/;
+__PACKAGE__->table('permission_grp_perm_map');
+__PACKAGE__->columns(Primary => qw/id/);
+__PACKAGE__->columns(Essential => qw/grp perm depth grantable/);
+#-------------------------------------------------------------------------------
+package permission::usr_work_ou_map;
+use base qw/permission/;
+__PACKAGE__->table('permission_usr_work_ou_map');
+__PACKAGE__->columns(Primary => qw/id/);
+__PACKAGE__->columns(Essential => qw/usr work_ou/);
+#-------------------------------------------------------------------------------
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::CDBI::serial;
+our $VERSION = 1;
+
+#-------------------------------------------------------------------------------
+package serial;
+use base qw/OpenILS::Application::Storage::CDBI/;
+#-------------------------------------------------------------------------------
+package serial::subscription;
+use base qw/serial/;
+
+__PACKAGE__->table( 'serial_subscription' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/record_entry start_date end_date
+ expected_date_offset owning_lib/ );
+
+#-------------------------------------------------------------------------------
+package serial::issuance;
+use base qw/serial/;
+
+__PACKAGE__->table( 'serial_issuance' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/creator editor create_date edit_date
+ subscription label date_published
+ caption_and_pattern holding_code
+ holding_type holding_link_id/ );
+
+#-------------------------------------------------------------------------------
+package serial::item;
+use base qw/serial/;
+
+__PACKAGE__->table( 'serial_item' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/creator editor create_date edit_date
+ issuance stream unit uri date_expected
+ date_received/ );
+
+#-------------------------------------------------------------------------------
+package serial::unit;
+use base qw/serial/;
+
+__PACKAGE__->table( 'serial_unit' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/call_number barcode creator create_date editor
+ edit_date copy_number status loan_duration circ_lib
+ fine_level circulate deposit price ref opac_visible dummy_isbn
+ circ_as_type circ_modifier deposit_amount location mint_condition
+ holdable dummy_title dummy_author deleted alert_message
+ age_protect floating summary_contents detailed_contents/ );
+
+#-------------------------------------------------------------------------------
+package serial::record_entry;
+use base qw/serial/;
+
+__PACKAGE__->table( 'serial_record_entry' );
+__PACKAGE__->columns( Primary => qw/id/ );
+__PACKAGE__->columns( Essential => qw/active record create_date creator
+ deleted edit_date editor id last_xact_id marc source
+ owning_lib/ );
+
+
+1;
+
--- /dev/null
+
+{ # The driver package itself just needs a db_Main method (or db_Slaves if
+ #Class::DBI::Replication is in use) for Class::DBI to call.
+ #
+ # Any other fixups can go in here too... Also, the drivers should subclass the
+ # DBI driver that they are wrapping, or provide a 'quote()' method that calls
+ # the DBD::xxx::quote() method on FTI's behalf.
+ #
+ # The dirver MUST be a subclass of Class::DBI(::Replication) and
+ # OpenILS::Application::Storage.
+ #-------------------------------------------------------------------------------
+ package OpenILS::Application::Storage::Driver::Pg;
+ use OpenILS::Application::Storage::Driver::Pg::cdbi;
+ use OpenILS::Application::Storage::Driver::Pg::fts;
+ use OpenILS::Application::Storage::Driver::Pg::storage;
+ use OpenILS::Application::Storage::Driver::Pg::dbi;
+ use UNIVERSAL::require;
+ BEGIN {
+ 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
+ }
+ use base qw/Class::DBI OpenILS::Application::Storage/;
+ use DBI;
+ use OpenSRF::EX qw/:try/;
+ use OpenSRF::DomainObject::oilsResponse;
+ use OpenSRF::Utils::Logger qw/:level/;
+ my $log = 'OpenSRF::Utils::Logger';
+
+ __PACKAGE__->set_sql( retrieve_limited => 'SELECT * FROM __TABLE__ ORDER BY id LIMIT ?' );
+ __PACKAGE__->set_sql( copy_start => 'COPY %s (%s) FROM STDIN;' );
+ __PACKAGE__->set_sql( copy_end => '\.' );
+
+ my $master_db;
+ my @slave_dbs;
+ my $_db_params;
+
+ sub db_Handles {
+ return ($master_db, @slave_dbs);
+ }
+
+ sub child_init {
+ my $self = shift;
+ $_db_params = shift;
+
+ $log->debug("Running child_init inside ".__PACKAGE__, INTERNAL);
+
+ $_db_params = [ $_db_params ] unless (ref($_db_params) eq 'ARRAY');
+
+ my %attrs = ( %{$self->_default_attributes},
+ RootClass => 'DBIx::ContextualFetch',
+ ShowErrorStatement => 1,
+ RaiseError => 1,
+ AutoCommit => 1,
+ PrintError => 1,
+ Taint => 1,
+ #TraceLevel => "1|SQL",
+ pg_enable_utf8 => 1,
+ pg_server_prepare => 0,
+ FetchHashKeyName => 'NAME_lc',
+ ChopBlanks => 1,
+ );
+
+ my $master = shift @$_db_params;
+ $$master{port} ||= '5432';
+ $$master{host} ||= 'localhost';
+ $$master{db} ||= 'openils';
+
+ $log->debug("Attempting to connect to $$master{db} at $$master{host}", INFO);
+
+ try {
+ $master_db = DBI->connect(
+ "dbi:Pg:".
+ "host=$$master{host};".
+ "port=$$master{port};".
+ "dbname=$$master{db}",
+ $$master{user},
+ $$master{pw},
+ \%attrs)
+ || do { sleep(1);
+ DBI->connect(
+ "dbi:Pg:".
+ "host=$$master{host};".
+ "port=$$master{port};".
+ "dbname=$$master{db}",
+ $$master{user},
+ $$master{pw},
+ \%attrs) }
+ || throw OpenSRF::EX::ERROR
+ ("Couldn't connect to $$master{db}".
+ " on $$master{host}::$$master{port}".
+ " as $$master{user}!!");
+ } catch Error with {
+ my $e = shift;
+ $log->debug("Error connecting to database:\n\t$e\n\t$DBI::errstr", ERROR);
+ throw $e;
+ };
+
+ $log->debug("Connected to MASTER db $$master{db} at $$master{host}", INFO);
+
+ $master_db->do("SET NAMES '$$master{client_encoding}';") if ($$master{client_encoding});
+
+ for my $db (@$_db_params) {
+ try {
+ push @slave_dbs, DBI->connect("dbi:Pg:host=$$db{host};port=$$db{port};dbname=$$db{db}",$$db{user},$$db{pw}, \%attrs)
+ || do { sleep(1); DBI->connect("dbi:Pg:host=$$db{host};port=$$db{port};dbname=$$db{db}",$$db{user},$$db{pw}, \%attrs) }
+ || throw OpenSRF::EX::ERROR
+ ("Couldn't connect to $$db{db}".
+ " on $$db{host}::$$db{port}".
+ " as $$db{user}!!");
+ } catch Error with {
+ my $e = shift;
+ $log->debug("Error connecting to database:\n\t$e\n\t$DBI::errstr", ERROR);
+ throw $e;
+ };
+
+ $slave_dbs[-1]->do("SET NAMES '$$db{client_encoding}';") if ($$master{client_encoding});
+
+ $log->debug("Connected to MASTER db '$$master{db} at $$master{host}", INFO);
+ }
+
+ $log->debug("All is well on the western front", INTERNAL);
+ }
+
+ sub db_Main {
+ my $self = shift;
+ return $master_db if ($self->current_xact_session || $OpenILS::Application::Storage::WRITE);
+ return $master_db unless (@slave_dbs);
+ return ($master_db, @slave_dbs)[rand(scalar(@slave_dbs))];
+ }
+
+ sub quote {
+ my $self = shift;
+ return $self->db_Main->quote(@_)
+ }
+
+# sub tsearch2_trigger {
+# my $self = shift;
+# return unless ($self->value);
+# $self->index_vector(
+# $self->db_Slaves->selectrow_array(
+# "SELECT to_tsvector('default',?);",
+# {},
+# $self->value
+# )
+# );
+# }
+
+ my $_xact_session;
+
+ sub current_xact_session {
+ my $self = shift;
+ if (defined($_xact_session)) {
+ return $_xact_session;
+ }
+ return undef;
+ }
+
+ sub current_xact_is_auto {
+ my $self = shift;
+ my $auto = shift;
+ if (defined($_xact_session) and ref($_xact_session)) {
+ if (defined $auto) {
+ $_xact_session->session_data(autocommit => $auto);
+ }
+ return $_xact_session->session_data('autocommit');
+ }
+ }
+
+ sub current_xact_id {
+ my $self = shift;
+ if (defined($_xact_session) and ref($_xact_session)) {
+ return $_xact_session->session_id;
+ }
+ return undef;
+ }
+
+ sub set_xact_session {
+ my $self = shift;
+ my $ses = shift;
+ if (!defined($ses)) {
+ return undef;
+ }
+ $_xact_session = $ses;
+ return $_xact_session;
+ }
+
+ sub unset_xact_session {
+ my $self = shift;
+ my $ses = $_xact_session;
+ undef $_xact_session;
+ return $ses;
+ }
+
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Driver::Pg::QueryParser;
+use OpenILS::Application::Storage::QueryParser;
+use base 'QueryParser';
+use OpenSRF::Utils::JSON;
+use OpenILS::Application::AppUtils;
+my $U = 'OpenILS::Application::AppUtils';
+
+sub quote_value {
+ my $self = shift;
+ my $value = shift;
+
+ if ($value =~ /^\d/) { # may have to use non-$ quoting
+ $value =~ s/'/''/g;
+ $value =~ s/\\/\\\\/g;
+ return "E'$value'";
+ }
+ return "\$_$$\$$value\$_$$\$";
+}
+
+sub quote_phrase_value {
+ my $self = shift;
+ my $value = shift;
+
+ my $left_anchored = $value =~ m/^\^/;
+ my $right_anchored = $value =~ m/\$$/;
+ $value =~ s/\^// if $left_anchored;
+ $value =~ s/\$$// if $right_anchored;
+ $value =~ quotemeta($value);
+ $value = '^' . $value if $left_anchored;
+ $value = "$value\$" if $right_anchored;
+ return $self->quote_value($value);
+}
+
+sub init {
+ my $class = shift;
+
+}
+
+sub default_preferred_language {
+ my $self = shift;
+ my $lang = shift;
+
+ $self->custom_data->{default_preferred_language} = $lang if ($lang);
+ return $self->custom_data->{default_preferred_language};
+}
+
+sub default_preferred_language_multiplier {
+ my $self = shift;
+ my $lang = shift;
+
+ $self->custom_data->{default_preferred_language_multiplier} = $lang if ($lang);
+ return $self->custom_data->{default_preferred_language_multiplier};
+}
+
+sub simple_plan {
+ my $self = shift;
+
+ return 0 unless $self->parse_tree;
+ return 0 if @{$self->parse_tree->filters};
+ return 0 if @{$self->parse_tree->modifiers};
+ for my $node ( @{ $self->parse_tree->query_nodes } ) {
+ return 0 if (!ref($node) && $node eq '|');
+ next unless (ref($node));
+ return 0 if ($node->isa('QueryParser::query_plan'));
+ }
+
+ return 1;
+}
+
+sub toSQL {
+ my $self = shift;
+ return $self->parse_tree->toSQL;
+}
+
+sub facet_field_id_map {
+ my $self = shift;
+ my $map = shift;
+
+ $self->custom_data->{facet_field_id_map} ||= {};
+ $self->custom_data->{facet_field_id_map} = $map if ($map);
+ return $self->custom_data->{facet_field_id_map};
+}
+
+sub add_facet_field_id_map {
+ my $self = shift;
+ my $class = shift;
+ my $field = shift;
+ my $id = shift;
+ my $weight = shift;
+
+ $self->add_facet_field( $class => $field );
+ $self->facet_field_id_map->{by_id}{$id} = { classname => $class, field => $field, weight => $weight };
+ $self->facet_field_id_map->{by_class}{$class}{$field} = $id;
+
+ return {
+ by_id => { $id => { classname => $class, field => $field, weight => $weight } },
+ by_class => { $class => { $field => $id } }
+ };
+}
+
+sub facet_field_class_by_id {
+ my $self = shift;
+ my $id = shift;
+
+ return $self->facet_field_id_map->{by_id}{$id};
+}
+
+sub facet_field_ids_by_class {
+ my $self = shift;
+ my $class = shift;
+ my $field = shift;
+
+ return undef unless ($class);
+
+ if ($field) {
+ return [$self->facet_field_id_map->{by_class}{$class}{$field}];
+ }
+
+ return [values( %{ $self->facet_field_id_map->{by_class}{$class} } )];
+}
+
+sub search_field_id_map {
+ my $self = shift;
+ my $map = shift;
+
+ $self->custom_data->{search_field_id_map} ||= {};
+ $self->custom_data->{search_field_id_map} = $map if ($map);
+ return $self->custom_data->{search_field_id_map};
+}
+
+sub add_search_field_id_map {
+ my $self = shift;
+ my $class = shift;
+ my $field = shift;
+ my $id = shift;
+ my $weight = shift;
+
+ $self->add_search_field( $class => $field );
+ $self->search_field_id_map->{by_id}{$id} = { classname => $class, field => $field, weight => $weight };
+ $self->search_field_id_map->{by_class}{$class}{$field} = $id;
+
+ return {
+ by_id => { $id => { classname => $class, field => $field, weight => $weight } },
+ by_class => { $class => { $field => $id } }
+ };
+}
+
+sub search_field_class_by_id {
+ my $self = shift;
+ my $id = shift;
+
+ return $self->search_field_id_map->{by_id}{$id};
+}
+
+sub search_field_ids_by_class {
+ my $self = shift;
+ my $class = shift;
+ my $field = shift;
+
+ return undef unless ($class);
+
+ if ($field) {
+ return [$self->search_field_id_map->{by_class}{$class}{$field}];
+ }
+
+ return [values( %{ $self->search_field_id_map->{by_class}{$class} } )];
+}
+
+sub relevance_bumps {
+ my $self = shift;
+ my $bumps = shift;
+
+ $self->custom_data->{rel_bumps} ||= {};
+ $self->custom_data->{rel_bumps} = $bumps if ($bumps);
+ return $self->custom_data->{rel_bumps};
+}
+
+sub find_relevance_bumps {
+ my $self = shift;
+ my $class = shift;
+ my $field = shift;
+
+ return $self->relevance_bumps->{$class}{$field};
+}
+
+sub add_relevance_bump {
+ my $self = shift;
+ my $class = shift;
+ my $field = shift;
+ my $type = shift;
+ my $multiplier = shift;
+ my $active = shift;
+
+ $active = 1 if (!defined($active));
+
+ $self->relevance_bumps->{$class}{$field}{$type} = { multiplier => $multiplier, active => $active };
+
+ return { $class => { $field => { $type => { multiplier => $multiplier, active => $active } } } };
+}
+
+
+sub initialize_search_field_id_map {
+ my $self = shift;
+ my $cmf_list = shift;
+
+ for my $cmf (@$cmf_list) {
+ __PACKAGE__->add_search_field_id_map( $cmf->field_class, $cmf->name, $cmf->id, $cmf->weight ) if ($U->is_true($cmf->search_field));
+ __PACKAGE__->add_facet_field_id_map( $cmf->field_class, $cmf->name, $cmf->id, $cmf->weight ) if ($U->is_true($cmf->facet_field));
+ }
+
+ return $self->search_field_id_map;
+}
+
+sub initialize_aliases {
+ my $self = shift;
+ my $cmsa_list = shift;
+
+ for my $cmsa (@$cmsa_list) {
+ if (!$cmsa->field) {
+ __PACKAGE__->add_search_class_alias( $cmsa->field_class, $cmsa->alias );
+ } else {
+ my $c = $self->search_field_class_by_id( $cmsa->field );
+ __PACKAGE__->add_search_field_alias( $cmsa->field_class, $c->{field}, $cmsa->alias );
+ }
+ }
+}
+
+sub initialize_relevance_bumps {
+ my $self = shift;
+ my $sra_list = shift;
+
+ for my $sra (@$sra_list) {
+ my $c = $self->search_field_class_by_id( $sra->field );
+ __PACKAGE__->add_relevance_bump( $c->{classname}, $c->{field}, $sra->bump_type, $sra->multiplier );
+ }
+
+ return $self->relevance_bumps;
+}
+
+sub initialize_normalizers {
+ my $self = shift;
+ my $tree = shift; # open-ils.cstore.direct.config.metabib_field_index_norm_map.search.atomic { "id" : { "!=" : null } }, { "flesh" : 1, "flesh_fields" : { "cmfinm" : ["norm"] }, "order_by" : [{ "class" : "cmfinm", "field" : "pos" }] }
+
+ for my $cmfinm ( @$tree ) {
+ my $field_info = $self->search_field_class_by_id( $cmfinm->field );
+ __PACKAGE__->add_query_normalizer( $field_info->{classname}, $field_info->{field}, $cmfinm->norm->func, OpenSRF::Utils::JSON->JSON2perl($cmfinm->params) );
+ }
+}
+
+our $_complete = 0;
+sub initialization_complete {
+ return $_complete;
+}
+
+sub initialize {
+ my $self = shift;
+ my %args = @_;
+
+ return $_complete if ($_complete);
+
+ $self->initialize_search_field_id_map( $args{config_metabib_field} )
+ if ($args{config_metabib_field});
+
+ $self->initialize_aliases( $args{config_metabib_search_alias} )
+ if ($args{config_metabib_search_alias});
+
+ $self->initialize_relevance_bumps( $args{search_relevance_adjustment} )
+ if ($args{search_relevance_adjustment});
+
+ $self->initialize_normalizers( $args{config_metabib_field_index_norm_map} )
+ if ($args{config_metabib_field_index_norm_map});
+
+ $_complete = 1 if (
+ $args{config_metabib_field_index_norm_map} &&
+ $args{search_relevance_adjustment} &&
+ $args{config_metabib_search_alias} &&
+ $args{config_metabib_field}
+ );
+
+ return $_complete;
+}
+
+sub TEST_SETUP {
+
+ __PACKAGE__->add_search_field_id_map( series => seriestitle => 1 => 1 );
+
+ __PACKAGE__->add_search_field_id_map( series => seriestitle => 1 => 1 );
+ __PACKAGE__->add_relevance_bump( series => seriestitle => first_word => 1.5 );
+ __PACKAGE__->add_relevance_bump( series => seriestitle => full_match => 20 );
+
+ __PACKAGE__->add_search_field_id_map( title => abbreviated => 2 => 1 );
+ __PACKAGE__->add_relevance_bump( title => abbreviated => first_word => 1.5 );
+ __PACKAGE__->add_relevance_bump( title => abbreviated => full_match => 20 );
+
+ __PACKAGE__->add_search_field_id_map( title => translated => 3 => 1 );
+ __PACKAGE__->add_relevance_bump( title => translated => first_word => 1.5 );
+ __PACKAGE__->add_relevance_bump( title => translated => full_match => 20 );
+
+ __PACKAGE__->add_search_field_id_map( title => proper => 6 => 1 );
+ __PACKAGE__->add_query_normalizer( title => proper => 'naco_normalize' );
+ __PACKAGE__->add_relevance_bump( title => proper => first_word => 1.5 );
+ __PACKAGE__->add_relevance_bump( title => proper => full_match => 20 );
+ __PACKAGE__->add_relevance_bump( title => proper => word_order => 10 );
+
+ __PACKAGE__->add_search_field_id_map( author => coporate => 7 => 1 );
+ __PACKAGE__->add_relevance_bump( author => coporate => first_word => 1.5 );
+ __PACKAGE__->add_relevance_bump( author => coporate => full_match => 20 );
+
+ __PACKAGE__->add_facet_field_id_map( author => personal => 8 => 1 );
+
+ __PACKAGE__->add_search_field_id_map( author => personal => 8 => 1 );
+ __PACKAGE__->add_relevance_bump( author => personal => first_word => 1.5 );
+ __PACKAGE__->add_relevance_bump( author => personal => full_match => 20 );
+ __PACKAGE__->add_query_normalizer( author => personal => 'naco_normalize' );
+ __PACKAGE__->add_query_normalizer( author => personal => 'split_date_range' );
+
+ __PACKAGE__->add_facet_field_id_map( subject => topic => 14 => 1 );
+
+ __PACKAGE__->add_search_field_id_map( subject => topic => 14 => 1 );
+ __PACKAGE__->add_relevance_bump( subject => topic => first_word => 1 );
+ __PACKAGE__->add_relevance_bump( subject => topic => full_match => 1 );
+
+ __PACKAGE__->add_search_field_id_map( subject => complete => 16 => 1 );
+ __PACKAGE__->add_relevance_bump( subject => complete => first_word => 1 );
+ __PACKAGE__->add_relevance_bump( subject => complete => full_match => 1 );
+
+ __PACKAGE__->add_search_field_id_map( keyword => keyword => 15 => 1 );
+ __PACKAGE__->add_relevance_bump( keyword => keyword => first_word => 1 );
+ __PACKAGE__->add_relevance_bump( keyword => keyword => full_match => 1 );
+
+
+ __PACKAGE__->add_search_class_alias( keyword => 'kw' );
+ __PACKAGE__->add_search_class_alias( title => 'ti' );
+ __PACKAGE__->add_search_class_alias( author => 'au' );
+ __PACKAGE__->add_search_class_alias( author => 'name' );
+ __PACKAGE__->add_search_class_alias( author => 'dc.contributor' );
+ __PACKAGE__->add_search_class_alias( subject => 'su' );
+ __PACKAGE__->add_search_class_alias( subject => 'bib.subject(?:Title|Place|Occupation)' );
+ __PACKAGE__->add_search_class_alias( series => 'se' );
+ __PACKAGE__->add_search_class_alias( keyword => 'dc.identifier' );
+
+ __PACKAGE__->add_query_normalizer( author => corporate => 'naco_normalize' );
+ __PACKAGE__->add_query_normalizer( keyword => keyword => 'naco_normalize' );
+
+ __PACKAGE__->add_search_field_alias( subject => name => 'bib.subjectName' );
+
+}
+
+__PACKAGE__->default_search_class( 'keyword' );
+
+__PACKAGE__->add_search_filter( 'audience' );
+__PACKAGE__->add_search_filter( 'vr_format' );
+__PACKAGE__->add_search_filter( 'format' );
+__PACKAGE__->add_search_filter( 'item_type' );
+__PACKAGE__->add_search_filter( 'item_form' );
+__PACKAGE__->add_search_filter( 'lit_form' );
+__PACKAGE__->add_search_filter( 'locations' );
+__PACKAGE__->add_search_filter( 'site' );
+__PACKAGE__->add_search_filter( 'lasso' );
+__PACKAGE__->add_search_filter( 'my_lasso' );
+__PACKAGE__->add_search_filter( 'depth' );
+__PACKAGE__->add_search_filter( 'sort' );
+__PACKAGE__->add_search_filter( 'language' );
+__PACKAGE__->add_search_filter( 'preferred_language' );
+__PACKAGE__->add_search_filter( 'preferred_language_weight' );
+__PACKAGE__->add_search_filter( 'preferred_language_multiplier' );
+__PACKAGE__->add_search_filter( 'statuses' );
+__PACKAGE__->add_search_filter( 'bib_level' );
+__PACKAGE__->add_search_filter( 'before' );
+__PACKAGE__->add_search_filter( 'after' );
+__PACKAGE__->add_search_filter( 'between' );
+__PACKAGE__->add_search_filter( 'during' );
+__PACKAGE__->add_search_filter( 'offset' );
+__PACKAGE__->add_search_filter( 'limit' );
+__PACKAGE__->add_search_filter( 'core_limit' );
+__PACKAGE__->add_search_filter( 'check_limit' );
+__PACKAGE__->add_search_filter( 'skip_check' );
+__PACKAGE__->add_search_filter( 'superpage' );
+__PACKAGE__->add_search_filter( 'superpage_size' );
+__PACKAGE__->add_search_filter( 'estimation_strategy' );
+
+__PACKAGE__->add_search_modifier( 'available' );
+__PACKAGE__->add_search_modifier( 'descending' );
+__PACKAGE__->add_search_modifier( 'ascending' );
+__PACKAGE__->add_search_modifier( 'metarecord' );
+__PACKAGE__->add_search_modifier( 'metabib' );
+__PACKAGE__->add_search_modifier( 'staff' );
+
+
+#-------------------------------
+package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan;
+use base 'QueryParser::query_plan';
+use OpenSRF::Utils::Logger qw($logger);
+use Data::Dumper;
+
+sub toSQL {
+ my $self = shift;
+
+ my %filters;
+ my ($format) = $self->find_filter('format');
+ if ($format) {
+ my ($t,$f) = split('-', $format->args->[0]);
+ $self->new_filter( item_type => [ split '', $t ] ) if ($t);
+ $self->new_filter( item_form => [ split '', $f ] ) if ($f);
+ }
+
+ for my $f ( qw/preferred_language preferred_language_multiplier preferred_language_weight core_limit check_limit skip_check superpage superpage_size/ ) {
+ my $col = $f;
+ $col = 'preferred_language_multiplier' if ($f eq 'preferred_language_weight');
+ my ($filter) = $self->find_filter($f);
+ if ($filter and @{$filter->args}) {
+ $filters{$col} = $filter->args->[0];
+ }
+ }
+
+ $self->QueryParser->superpage($filters{superpage}) if ($filters{superpage});
+ $self->QueryParser->superpage_size($filters{superpage_size}) if ($filters{superpage_size});
+ $self->QueryParser->core_limit($filters{core_limit}) if ($filters{core_limit});
+
+ $logger->debug("Query plan:\n".Dumper($self));
+
+ my $flat_plan = $self->flatten;
+
+ # generate the relevance ranking
+ my $rel = "AVG(\n\t\t(" . join(")+\n\t\t(", @{$$flat_plan{rank_list}}) . ")\n\t)";
+
+ # find any supplied sort option
+ my ($sort_filter) = $self->find_filter('sort');
+ if ($sort_filter) {
+ $sort_filter = $sort_filter->args->[0];
+ } else {
+ $sort_filter = 'rel';
+ }
+
+ if (($filters{preferred_language} || $self->QueryParser->default_preferred_language) && ($filters{preferred_language_multiplier} || $self->QueryParser->default_preferred_language_multiplier)) {
+ my $pl = $self->QueryParser->quote_value( $filters{preferred_language} ? $filters{preferred_language} : $self->QueryParser->default_preferred_language );
+ my $plw = $filters{preferred_language_multiplier} ? $filters{preferred_language_multiplier} : $self->QueryParser->default_preferred_language_multiplier;
+ $rel = "($rel * COALESCE( NULLIF( FIRST(mrd.item_lang) = $pl , FALSE )::INT * $plw, 1))";
+ }
+ $rel .= '::NUMERIC';
+
+ for my $f ( qw/audience vr_format item_type item_form lit_form language bib_level/ ) {
+ my $col = $f;
+ $col = 'item_lang' if ($f eq 'language');
+ $filters{$f} = '';
+ my ($filter) = $self->find_filter($f);
+ if ($filter) {
+ $filters{$f} = "AND mrd.$col in (" . join(",",map { $self->QueryParser->quote_value($_) } @{$filter->args}) . ")";
+ }
+ }
+
+ my $audience = $filters{audience};
+ my $vr_format = $filters{vr_format};
+ my $item_type = $filters{item_type};
+ my $item_form = $filters{item_form};
+ my $lit_form = $filters{lit_form};
+ my $language = $filters{language};
+ my $bib_level = $filters{bib_level};
+
+ my $rank = $rel;
+
+ my $desc = 'ASC';
+ $desc = 'DESC' if ($self->find_modifier('descending'));
+
+ if ($sort_filter eq 'rel') { # relevance ranking flips sort dir
+ if ($desc eq 'ASC') {
+ $desc = 'DESC';
+ } else {
+ $desc = 'ASC';
+ }
+ } else {
+ if ($sort_filter eq 'title') {
+ $rank = "FIRST((SELECT frt.value FROM metabib.full_rec frt WHERE frt.record = m.source AND frt.tag = 'tnf' AND frt.subfield = 'a' LIMIT 1))";
+ } elsif ($sort_filter eq 'pubdate') {
+ $rank = "FIRST(mrd.date1)::NUMERIC";
+ } elsif ($sort_filter eq 'create_date') {
+ $rank = "FIRST((SELECT create_date FROM biblio.record_entry rbr WHERE rbr.id = m.source))";
+ } elsif ($sort_filter eq 'edit_date') {
+ $rank = "FIRST((SELECT edit_date FROM biblio.record_entry rbr WHERE rbr.id = m.source))";
+ } elsif ($sort_filter eq 'author') {
+ $rank = "FIRST((SELECT fra.value FROM metabib.full_rec fra WHERE fra.record = m.source AND fra.tag LIKE '1%' AND fra.subfield = 'a' ORDER BY fra.tag LIMIT 1))";
+ } else {
+ # default to rel ranking
+ $rank = $rel;
+ }
+ }
+
+ my $key = 'm.source';
+ $key = 'm.metarecord' if (grep {$_->name eq 'metarecord' or $_->name eq 'metabib'} @{$self->modifiers});
+
+ my ($before) = $self->find_filter('before');
+ my ($after) = $self->find_filter('after');
+ my ($during) = $self->find_filter('during');
+ my ($between) = $self->find_filter('between');
+
+ if ($before and @{$before->args} == 1) {
+ $before = "AND mrd.date1 <= " . $self->QueryParser->quote_value($before->args->[0]);
+ } else {
+ $before = '';
+ }
+
+ if ($after and @{$after->args} == 1) {
+ $after = "AND mrd.date1 >= " . $self->QueryParser->quote_value($after->args->[0]);
+ } else {
+ $after = '';
+ }
+
+ if ($during and @{$during->args} == 1) {
+ $during = "AND " . $self->QueryParser->quote_value($during->args->[0]) . " BETWEEN mrd.date1 AND mrd.date2";
+ } else {
+ $during = '';
+ }
+
+ if ($between and @{$between->args} == 2) {
+ $between = "AND mrd.date1 BETWEEN " . $self->QueryParser->quote_value($between->args->[0]) . " AND " . $self->QueryParser->quote_value($between->args->[1]);
+ } else {
+ $between = '';
+ }
+
+ my $core_limit = $self->QueryParser->core_limit || 25000;
+
+ my $sql = <<SQL;
+SELECT $key AS id,
+ ARRAY_ACCUM(DISTINCT m.source) AS records,
+ $rel AS rel,
+ $rank AS rank,
+ FIRST(mrd.date1) AS tie_break
+ FROM metabib.metarecord_source_map m
+ JOIN metabib.rec_descriptor mrd ON (m.source = mrd.record)
+ $$flat_plan{from}
+ WHERE 1=1
+ $before
+ $after
+ $during
+ $between
+ $audience
+ $vr_format
+ $item_type
+ $item_form
+ $lit_form
+ $language
+ $bib_level
+ AND $$flat_plan{where}
+ GROUP BY 1
+ ORDER BY 4 $desc NULLS LAST, 5 DESC NULLS LAST, 3 DESC
+ LIMIT $core_limit
+SQL
+
+ warn $sql if $self->QueryParser->debug;
+ return $sql;
+
+}
+
+
+sub rel_bump {
+ my $self = shift;
+ my $node = shift;
+ my $bump = shift;
+ my $multiplier = shift;
+
+ my $only_atoms = $node->only_atoms;
+ return '' if (!@$only_atoms);
+
+ if ($bump eq 'first_word') {
+ return " /* first_word */ COALESCE(NULLIF( (naco_normalize(".$node->table_alias.".value) ~ ('^'||naco_normalize(".$self->QueryParser->quote_value($only_atoms->[0]->content)."))), FALSE )::INT * $multiplier, 1)";
+ } elsif ($bump eq 'full_match') {
+ return " /* full_match */ COALESCE(NULLIF( (naco_normalize(".$node->table_alias.".value) ~ ('^'||".
+ join( "||' '||", map { "naco_normalize(".$self->QueryParser->quote_value($_->content).")" } @$only_atoms )."||'\$')), FALSE )::INT * $multiplier, 1)";
+ } elsif ($bump eq 'word_order') {
+ return " /* word_order */ COALESCE(NULLIF( (naco_normalize(".$node->table_alias.".value) ~ (".
+ join( "||'.*'||", map { "naco_normalize(".$self->QueryParser->quote_value($_->content).")" } @$only_atoms ).")), FALSE )::INT * $multiplier, 1)";
+ }
+
+ return '';
+}
+
+sub flatten {
+ my $self = shift;
+
+ my $from = shift || '';
+ my $where = shift || '(';
+
+ my @rank_list;
+ for my $node ( @{$self->query_nodes} ) {
+ if (ref($node)) {
+ if ($node->isa( 'QueryParser::query_plan::node' )) {
+
+ unless (@{$node->only_atoms}) {
+ push @rank_list, '1';
+ $where .= 'TRUE';
+ next;
+ }
+
+ my $table = $node->table;
+ my $talias = $node->table_alias;
+
+ my $node_rank = $node->rank . " * ${talias}.weight";
+
+ my $core_limit = $self->QueryParser->core_limit || 25000;
+ $from .= "\n\tLEFT JOIN (\n\t\tSELECT fe.*, fe_weight.weight, x.tsq /* search */\n\t\t FROM $table AS fe";
+ $from .= "\n\t\t\tJOIN config.metabib_field AS fe_weight ON (fe_weight.id = fe.field)";
+ $from .= "\n\t\t\tJOIN (SELECT ".$node->tsquery ." AS tsq ) AS x ON (fe.index_vector @@ x.tsq)";
+
+ my @bump_fields;
+ if (@{$node->fields} > 0) {
+ @bump_fields = @{$node->fields};
+
+ my @field_ids;
+ push(@field_ids, $self->QueryParser->search_field_ids_by_class( $node->classname, $_ )->[0]) for (@bump_fields);
+ $from .= "\n\t\t\tWHERE fe_weight.id IN (". join(',', @field_ids) .")";
+
+ } else {
+ @bump_fields = @{$self->QueryParser->search_fields->{$node->classname}};
+ }
+
+ ###$from .= "\n\t\tLIMIT $core_limit";
+ $from .= "\n\t) AS $talias ON (m.source = ${talias}.source)";
+
+
+ my %used_bumps;
+ for my $field ( @bump_fields ) {
+ my $bumps = $self->QueryParser->find_relevance_bumps( $node->classname => $field );
+ for my $b (keys %$bumps) {
+ next if (!$$bumps{$b}{active});
+ next if ($used_bumps{$b});
+ $used_bumps{$b} = 1;
+
+ next if ($$bumps{$b}{multiplier} == 1); # optimization to remove unneeded bumps
+
+ my $bump_case = $self->rel_bump( $node, $b, $$bumps{$b}{multiplier} );
+ $node_rank .= "\n\t\t\t\t * " . $bump_case if ($bump_case);
+ }
+ }
+
+ $where .= '(' . $talias . ".id IS NOT NULL";
+ $where .= ' AND ' . join(' AND ', map {"${talias}.value ~* ".$self->QueryParser->quote_phrase_value($_)} @{$node->phrases}) if (@{$node->phrases});
+ $where .= ')';
+
+ push @rank_list, $node_rank;
+
+ } elsif ($node->isa( 'QueryParser::query_plan::facet' )) {
+
+ my $table = $node->table;
+ my $talias = $node->table_alias;
+
+ my @field_ids;
+ if (@{$node->fields} > 0) {
+ push(@field_ids, $self->QueryParser->facet_field_ids_by_class( $node->classname, $_ )->[0]) for (@{$node->fields});
+ } else {
+ @field_ids = @{ $self->QueryParser->facet_field_ids_by_class( $node->classname ) };
+ }
+
+ $from .= "\n\tJOIN /* facet */ metabib.facet_entry $talias ON (\n\t\tm.source = ${talias}.source\n\t\t".
+ "AND SUBSTRING(${talias}.value,1,1024) IN (" . join(",", map { $self->QueryParser->quote_value($_) } @{$node->values}) . ")\n\t\t".
+ "AND ${talias}.field IN (". join(',', @field_ids) . ")\n\t)";
+
+ $where .= 'TRUE';
+
+ } else {
+ my $subnode = $node->flatten;
+
+ push(@rank_list, @{$$subnode{rank_list}});
+ $from .= $$subnode{from};
+ $where .= "($$subnode{where})";
+ }
+ } else {
+ $where .= ' AND ' if ($node eq '&');
+ $where .= ' OR ' if ($node eq '|');
+ # ... stitching the WHERE together ...
+ }
+ }
+
+ return { rank_list => \@rank_list, from => $from, where => $where.')' };
+
+}
+
+
+#-------------------------------
+package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::filter;
+use base 'QueryParser::query_plan::filter';
+
+#-------------------------------
+package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::facet;
+use base 'QueryParser::query_plan::facet';
+
+sub classname {
+ my $self = shift;
+ my ($classname) = split '\|', $self->name;
+ return $classname;
+}
+
+sub table {
+ my $self = shift;
+ return 'metabib.' . $self->classname . '_field_entry';
+}
+
+sub fields {
+ my $self = shift;
+ my ($classname,@fields) = split '\|', $self->name;
+ return \@fields;
+}
+
+sub table_alias {
+ my $self = shift;
+
+ my $table_alias = "$self";
+ $table_alias =~ s/^.*\(0(x[0-9a-fA-F]+)\)$/$1/go;
+ $table_alias .= '_' . $self->name;
+ $table_alias =~ s/\|/_/go;
+
+ return $table_alias;
+}
+
+
+#-------------------------------
+package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::modifier;
+use base 'QueryParser::query_plan::modifier';
+
+#-------------------------------
+package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::node::atom;
+use base 'QueryParser::query_plan::node::atom';
+
+sub sql {
+ my $self = shift;
+ my $sql = shift;
+
+ $self->{sql} = $sql if ($sql);
+
+ return $self->{sql} if ($self->{sql});
+ return $self->buildSQL;
+}
+
+sub buildSQL {
+ my $self = shift;
+
+ my $classname = $self->node->classname;
+
+ my $normalizers = $self->node->plan->QueryParser->query_normalizers( $classname );
+ my $fields = $self->node->fields;
+
+ $fields = $self->node->plan->QueryParser->search_fields->{$classname} if (!@$fields);
+
+ my %norms;
+ my $pos = 0;
+ for my $field (@$fields) {
+ for my $nfield (keys %$normalizers) {
+ for my $nizer ( @{$$normalizers{$nfield}} ) {
+ if ($field eq $nfield) {
+ if (!exists($norms{$nizer->{function}})) {
+ $norms{$nizer->{function}} = {p=>$pos++,n=>$nizer};
+ }
+ }
+ }
+ }
+ }
+
+ my $sql = $self->node->plan->QueryParser->quote_value($self->content);
+
+ for my $n ( map { $$_{n} } sort { $$a{p} <=> $$b{p} } values %norms ) {
+ $sql = join(', ', $sql, map { $self->node->plan->QueryParser->quote_value($_) } @{ $n->{params} });
+ $sql = $n->{function}."($sql)";
+ }
+
+ my $prefix = $self->prefix || '';
+ my $suffix = $self->suffix || '';
+
+ $prefix = "'$prefix' ||" if $prefix;
+ my $suffix_op = ":$suffix" if $suffix;
+ my $suffix_after = "|| '$suffix_op'" if $suffix;
+
+ $sql = "to_tsquery('$classname', COALESCE(NULLIF($prefix '(' || btrim(regexp_replace($sql,E'(?:\\\\s+|:)','$suffix_op&','g'),'&|') $suffix_after || ')', '()'), ''))";
+
+ return $self->sql($sql);
+}
+
+#-------------------------------
+package OpenILS::Application::Storage::Driver::Pg::QueryParser::query_plan::node;
+use base 'QueryParser::query_plan::node';
+
+sub only_atoms {
+ my $self = shift;
+
+ my $atoms = $self->query_atoms;
+ my @only_atoms;
+ for my $a (@$atoms) {
+ push(@only_atoms, $a) if (ref($a) && $a->isa('QueryParser::query_plan::node::atom'));
+ }
+
+ return \@only_atoms;
+}
+
+sub table {
+ my $self = shift;
+ my $table = shift;
+ $self->{table} = $table if ($table);
+ return $self->{table} if $self->{table};
+ return $self->table( 'metabib.' . $self->classname . '_field_entry' );
+}
+
+sub table_alias {
+ my $self = shift;
+ my $table_alias = shift;
+ $self->{table_alias} = $table_alias if ($table_alias);
+ return $self->{table_alias} if ($self->{table_alias});
+
+ $table_alias = "$self";
+ $table_alias =~ s/^.*\(0(x[0-9a-fA-F]+)\)$/$1/go;
+ $table_alias .= '_' . $self->requested_class;
+ $table_alias =~ s/\|/_/go;
+
+ return $self->table_alias( $table_alias );
+}
+
+sub tsquery {
+ my $self = shift;
+ return $self->{tsquery} if ($self->{tsquery});
+
+ for my $atom (@{$self->query_atoms}) {
+ if (ref($atom)) {
+ $self->{tsquery} .= "\n\t\t\t" .$atom->sql;
+ } else {
+ $self->{tsquery} .= $atom x 2;
+ }
+ }
+
+ return $self->{tsquery};
+}
+
+sub rank {
+ my $self = shift;
+ return $self->{rank} if ($self->{rank});
+ return $self->{rank} = 'rank(' . $self->table_alias . '.index_vector, ' . $self->table_alias . '.tsq)';
+}
+
+
+1;
+
--- /dev/null
+{ # Based on the change to Class::DBI in OpenILS::Application::Storage. This will
+ # allow us to use TSearch2 via a simple cdbi "search" interface.
+ #-------------------------------------------------------------------------------
+ use UNIVERSAL::require;
+ BEGIN {
+ 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
+ }
+ package Class::DBI;
+
+ sub search_fts {
+ my $self = shift;
+ my @args = @_;
+
+ if (ref($args[-1]) eq 'HASH' && @args > 1) {
+ $args[-1]->{_placeholder} = "to_tsquery('default',?)";
+ } else {
+ push @args, {_placeholder => "to_tsquery('default',?)"};
+ }
+
+ $self->_do_search("@@" => @args);
+ }
+
+ sub search_regex {
+ my $self = shift;
+ my @args = @_;
+ $self->_do_search("~*" => @args);
+ }
+
+ sub search_ilike {
+ my $self = shift;
+ my @args = @_;
+ $self->_do_search("ILIKE" => @args);
+ }
+
+}
+
+1;
--- /dev/null
+{
+
+ #-------------------------------------------------------------------------------
+ package container::user_bucket;
+
+ container::user_bucket->table( 'container.user_bucket' );
+ container::user_bucket->sequence( 'container.user_bucket_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::user_bucket_item;
+
+ container::user_bucket_item->table( 'container.user_bucket_item' );
+ container::user_bucket_item->sequence( 'container.user_bucket_item_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::copy_bucket;
+
+ container::copy_bucket->table( 'container.copy_bucket' );
+ container::copy_bucket->sequence( 'container.copy_bucket_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::copy_bucket_item;
+
+ container::copy_bucket_item->table( 'container.copy_bucket_item' );
+ container::copy_bucket_item->sequence( 'container.copy_bucket_item_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::call_number_bucket;
+
+ container::call_number_bucket->table( 'container.call_number_bucket' );
+ container::call_number_bucket->sequence( 'container.call_number_bucket_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::call_number_bucket_item;
+
+ container::call_number_bucket_item->table( 'container.call_number_bucket_item' );
+ container::call_number_bucket_item->sequence( 'container.call_number_bucket_item_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::biblio_record_entry_bucket;
+
+ container::biblio_record_entry_bucket->table( 'container.biblio_record_entry_bucket' );
+ container::biblio_record_entry_bucket->sequence( 'container.biblio_record_entry_bucket_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package container::biblio_record_entry_bucket_item;
+
+ container::biblio_record_entry_bucket_item->table( 'container.biblio_record_entry_bucket_item' );
+ container::biblio_record_entry_bucket_item->sequence( 'container.biblio_record_entry_bucket_item_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::grocery;
+
+ money::grocery->table( 'money.grocery' );
+ money::grocery->sequence( 'money.billable_xact_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::collections_tracker;
+
+ money::collections_tracker->table( 'money.collections_tracker' );
+ money::collections_tracker->sequence( 'money.collections_tracker_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::billable_transaction;
+
+ money::billable_transaction->table( 'money.billable_xact' );
+ money::billable_transaction->sequence( 'money.billable_xact_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::billing;
+
+ money::billing->table( 'money.billing' );
+ money::billing->sequence( 'money.billing_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::desk_payment;
+
+ money::desk_payment->table( 'money.desk_payment_view' );
+
+ #---------------------------------------------------------------------
+ package money::payment;
+
+ money::payment->table( 'money.payment_view' );
+
+ #---------------------------------------------------------------------
+ package money::cash_payment;
+
+ money::cash_payment->table( 'money.cash_payment' );
+ money::cash_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::check_payment;
+
+ money::check_payment->table( 'money.check_payment' );
+ money::check_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::credit_payment;
+
+ money::credit_payment->table( 'money.credit_payment' );
+ money::credit_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::credit_card_payment;
+
+ money::credit_card_payment->table( 'money.credit_card_payment' );
+ money::credit_card_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::work_payment;
+
+ money::work_payment->table( 'money.work_payment' );
+ money::work_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::goods_payment;
+
+ money::goods_payment->table( 'money.goods_payment' );
+ money::goods_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::forgive_payment;
+
+ money::forgive_payment->table( 'money.forgive_payment' );
+ money::forgive_payment->sequence( 'money.payment_id_seq' );
+
+ #---------------------------------------------------------------------
+ package money::open_billable_transaction_summary;
+
+ money::open_billable_transaction_summary->table( 'money.open_billable_xact_summary' );
+
+ #---------------------------------------------------------------------
+ package money::billable_transaction_summary;
+
+ money::billable_transaction_summary->table( 'money.billable_xact_summary' );
+
+ #---------------------------------------------------------------------
+ package money::open_user_summary;
+
+ money::open_user_summary->table( 'money.open_usr_summary' );
+
+ #---------------------------------------------------------------------
+ package money::user_summary;
+
+ money::user_summary->table( 'money.usr_summary' );
+
+ #---------------------------------------------------------------------
+ package money::open_user_circulation_summary;
+
+ money::open_user_circulation_summary->table( 'money.open_usr_circulation_summary' );
+
+ #---------------------------------------------------------------------
+ package money::user_circulation_summary;
+
+ money::user_circulation_summary->table( 'money.usr_circulation_summary' );
+
+ #---------------------------------------------------------------------
+ package action::circulation;
+
+ action::circulation->table( 'action.circulation' );
+ action::circulation->sequence( 'money.billable_xact_id_seq' );
+
+ #---------------------------------------------------------------------
+ package booking::resource_type;
+
+ booking::resource_type->table( 'booking.resource_type' );
+ booking::resource_type->sequence( 'booking.resource_type_id_seq' );
+
+ #---------------------------------------------------------------------
+ package booking::resource;
+
+ booking::resource->table( 'booking.resource' );
+ booking::resource->sequence( 'booking.resource_id_seq' );
+
+ #---------------------------------------------------------------------
+ package booking::reservation;
+
+ booking::reservation->table( 'booking.reservation' );
+ booking::reservation->sequence( 'money.billable_xact_id_seq' );
+
+ #---------------------------------------------------------------------
+ package booking::reservation_attr_value_map;
+
+ booking::reservation_attr_value_map->table( 'booking.reservation_attr_value_map' );
+ booking::reservation_attr_value_map->sequence( 'booking.reservation_attr_value_map_id_seq' );
+
+ #---------------------------------------------------------------------
+ package booking::resource_attr_map;
+
+ booking::resource_attr_map->table( 'booking.resource_attr_map' );
+ booking::resource_attr_map->sequence( 'booking.resource_attr_map_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::non_cat_in_house_use;
+
+ action::non_cat_in_house_use->table( 'action.non_cat_in_house_use' );
+ action::non_cat_in_house_use->sequence( 'action.non_cat_in_house_use_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::in_house_use;
+
+ action::in_house_use->table( 'action.in_house_use' );
+ action::in_house_use->sequence( 'action.in_house_use_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::non_cataloged_circulation;
+
+ action::non_cataloged_circulation->table( 'action.non_cataloged_circulation' );
+ action::non_cataloged_circulation->sequence( 'action.non_cataloged_circulation_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::open_circulation;
+
+ action::open_circulation->table( 'action.open_circulation' );
+
+ #---------------------------------------------------------------------
+ package action::survey;
+
+ action::survey->table( 'action.survey' );
+ action::survey->sequence( 'action.survey_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::survey_question;
+
+ action::survey_question->table( 'action.survey_question' );
+ action::survey_question->sequence( 'action.survey_question_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::survey_answer;
+
+ action::survey_answer->table( 'action.survey_answer' );
+ action::survey_answer->sequence( 'action.survey_answer_id_seq' );
+
+ #---------------------------------------------------------------------
+ package action::survey_response;
+
+ action::survey_response->table( 'action.survey_response' );
+ action::survey_response->sequence( 'action.survey_response_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::non_cataloged_type;
+
+ config::non_cataloged_type->table( 'config.non_cataloged_type' );
+ config::non_cataloged_type->sequence( 'config.non_cataloged_type_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::copy_status;
+
+ config::copy_status->table( 'config.copy_status' );
+ config::copy_status->sequence( 'config.copy_status_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::rules::circ_duration;
+
+ config::rules::circ_duration->table( 'config.rule_circ_duration' );
+ config::rules::circ_duration->sequence( 'config.rule_circ_duration_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::rules::age_hold_protect;
+
+ config::rules::age_hold_protect->table( 'config.rule_age_hold_protect' );
+ config::rules::age_hold_protect->sequence( 'config.rule_age_hold_protect_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::rules::max_fine;
+
+ config::rules::max_fine->table( 'config.rule_max_fine' );
+ config::rules::max_fine->sequence( 'config.rule_max_fine_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::rules::recurring_fine;
+
+ config::rules::recurring_fine->table( 'config.rule_recurring_fine' );
+ config::rules::recurring_fine->sequence( 'config.rule_recurring_fine_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::net_access_level;
+
+ config::net_access_level->table( 'config.net_access_level' );
+ config::net_access_level->sequence( 'config.net_access_level_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::standing;
+
+ config::standing->table( 'config.standing' );
+ config::standing->sequence( 'config.standing_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::metabib_field;
+
+ config::metabib_field->table( 'config.metabib_field' );
+ config::metabib_field->sequence( 'config.metabib_field_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::bib_source;
+
+ config::bib_source->table( 'config.bib_source' );
+ config::bib_source->sequence( 'config.bib_source_id_seq' );
+
+ #---------------------------------------------------------------------
+ package config::identification_type;
+
+ config::identification_type->table( 'config.identification_type' );
+ config::identification_type->sequence( 'config.identification_type_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::call_number_note;
+
+ asset::call_number_note->table( 'asset.call_number_note' );
+ asset::call_number_note->sequence( 'asset.call_number_note_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::copy_note;
+
+ asset::copy_note->table( 'asset.copy_note' );
+ asset::copy_note->sequence( 'asset.copy_note_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::call_number;
+
+ asset::call_number->table( 'asset.call_number' );
+ asset::call_number->sequence( 'asset.call_number_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::call_number_class;
+
+ asset::call_number_class->table( 'asset.call_number_class' );
+ asset::call_number_class->sequence( 'asset.call_number_class_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::copy_location_order;
+
+ asset::copy_location_order->table( 'asset.copy_location_order' );
+ asset::copy_location_order->sequence( 'asset.copy_location_order_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::copy_location;
+
+ asset::copy_location->table( 'asset.copy_location' );
+ asset::copy_location->sequence( 'asset.copy_location_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::copy;
+
+ asset::copy->table( 'asset.copy' );
+ asset::copy->sequence( 'asset.copy_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::stat_cat;
+
+ asset::stat_cat->table( 'asset.stat_cat' );
+ asset::stat_cat->sequence( 'asset.stat_cat_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::stat_cat_entry;
+
+ asset::stat_cat_entry->table( 'asset.stat_cat_entry' );
+ asset::stat_cat_entry->sequence( 'asset.stat_cat_entry_id_seq' );
+
+ #---------------------------------------------------------------------
+ package asset::stat_cat_entry_copy_map;
+
+ asset::stat_cat_entry_copy_map->table( 'asset.stat_cat_entry_copy_map' );
+ asset::stat_cat_entry_copy_map->sequence( 'asset.stat_cat_entry_copy_map_id_seq' );
+
+ #---------------------------------------------------------------------
+ package authority::record_entry;
+
+ authority::record_entry->table( 'authority.record_entry' );
+ authority::record_entry->sequence( 'authority.record_entry_id_seq' );
+
+ #---------------------------------------------------------------------
+ package biblio::record_entry;
+
+ biblio::record_entry->table( 'biblio.record_entry' );
+ biblio::record_entry->sequence( 'biblio.record_entry_id_seq' );
+
+ #---------------------------------------------------------------------
+ #package biblio::record_marc;
+ #
+ #biblio::record_marc->table( 'biblio.record_marc' );
+ #biblio::record_marc->sequence( 'biblio.record_marc_id_seq' );
+ #
+ #---------------------------------------------------------------------
+ package authority::record_note;
+
+ authority::record_note->table( 'authority.record_note' );
+ authority::record_note->sequence( 'authority.record_note_id_seq' );
+
+ #---------------------------------------------------------------------
+ package biblio::record_note;
+
+ biblio::record_note->table( 'biblio.record_note' );
+ biblio::record_note->sequence( 'biblio.record_note_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::workstation;
+
+ actor::workstation->table( 'actor.workstation' );
+ actor::workstation->sequence( 'actor.workstation_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::user;
+
+ actor::user->table( 'actor.usr' );
+ actor::user->sequence( 'actor.usr_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::org_unit::closed_date;
+
+ actor::org_unit::closed_date->table( 'actor.org_unit_closed' );
+ actor::org_unit::closed_date->sequence( 'actor.org_unit_closed_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::org_unit_setting;
+
+ actor::org_unit_setting->table( 'actor.org_unit_setting' );
+ actor::org_unit_setting->sequence( 'actor.org_unit_setting_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::user_standing_penalty;
+
+ actor::user_standing_penalty->table( 'actor.usr_standing_penalty' );
+ actor::user_standing_penalty->sequence( 'actor.usr_standing_penalty_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::user_setting;
+
+ actor::user_setting->table( 'actor.usr_setting' );
+ actor::user_setting->sequence( 'actor.usr_setting_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::user_address;
+
+ actor::user_address->table( 'actor.usr_address' );
+ actor::user_address->sequence( 'actor.usr_address_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::org_address;
+
+ actor::org_address->table( 'actor.org_address' );
+ actor::org_address->sequence( 'actor.org_address_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::usr_org_unit_opt_in;
+
+ actor::usr_org_unit_opt_in->table( 'actor.usr_org_unit_opt_in' );
+ actor::usr_org_unit_opt_in->sequence( 'actor.usr_org_unit_opt_in_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::org_unit_proximity;
+
+ actor::org_unit_proximity->table( 'actor.org_unit_proximity' );
+ actor::org_unit_proximity->sequence( 'actor.org_unit_proximity_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::org_unit_type;
+
+ actor::org_unit_type->table( 'actor.org_unit_type' );
+ actor::org_unit_type->sequence( 'actor.org_unit_type_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::org_unit::hours_of_operation;
+
+ actor::org_unit::hours_of_operation->table( 'actor.hours_of_operation' );
+
+ #---------------------------------------------------------------------
+ package actor::org_unit;
+
+ actor::org_unit->table( 'actor.org_unit' );
+ actor::org_unit->sequence( 'actor.org_unit_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::stat_cat;
+
+ actor::stat_cat->table( 'actor.stat_cat' );
+ actor::stat_cat->sequence( 'actor.stat_cat_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::stat_cat_entry;
+
+ actor::stat_cat_entry->table( 'actor.stat_cat_entry' );
+ actor::stat_cat_entry->sequence( 'actor.stat_cat_entry_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::stat_cat_entry_user_map;
+
+ actor::stat_cat_entry_user_map->table( 'actor.stat_cat_entry_usr_map' );
+ actor::stat_cat_entry_user_map->sequence( 'actor.stat_cat_entry_usr_map_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::card;
+
+ actor::card->table( 'actor.card' );
+ actor::card->sequence( 'actor.card_id_seq' );
+
+ #---------------------------------------------------------------------
+ package actor::usr_note;
+
+ actor::usr_note->table( 'actor.usr_note' );
+ actor::usr_note->sequence( 'actor.usr_note_id_seq' );
+
+ #---------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::metarecord;
+
+ metabib::metarecord->table( 'metabib.metarecord' );
+ metabib::metarecord->sequence( 'metabib.metarecord_id_seq' );
+
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::identifier_field_entry;
+
+ metabib::identifier_field_entry->table( 'metabib.identifier_field_entry' );
+ metabib::identifier_field_entry->sequence( 'metabib.identifier_field_entry_id_seq' );
+ metabib::identifier_field_entry->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::title_field_entry;
+
+ metabib::title_field_entry->table( 'metabib.title_field_entry' );
+ metabib::title_field_entry->sequence( 'metabib.title_field_entry_id_seq' );
+ metabib::title_field_entry->columns( 'FTS' => 'index_vector' );
+
+# metabib::title_field_entry->add_trigger(
+# before_create => \&OpenILS::Application::Storage::Driver::Pg::tsearch2_trigger
+# );
+# metabib::title_field_entry->add_trigger(
+# before_update => \&OpenILS::Application::Storage::Driver::Pg::tsearch2_trigger
+# );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::author_field_entry;
+
+ metabib::author_field_entry->table( 'metabib.author_field_entry' );
+ metabib::author_field_entry->sequence( 'metabib.author_field_entry_id_seq' );
+ metabib::author_field_entry->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::subject_field_entry;
+
+ metabib::subject_field_entry->table( 'metabib.subject_field_entry' );
+ metabib::subject_field_entry->sequence( 'metabib.subject_field_entry_id_seq' );
+ metabib::subject_field_entry->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::keyword_field_entry;
+
+ metabib::keyword_field_entry->table( 'metabib.keyword_field_entry' );
+ metabib::keyword_field_entry->sequence( 'metabib.keyword_field_entry_id_seq' );
+ metabib::keyword_field_entry->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+ package metabib::series_field_entry;
+
+ metabib::series_field_entry->table( 'metabib.series_field_entry' );
+ metabib::series_field_entry->sequence( 'metabib.series_field_entry_id_seq' );
+ metabib::series_field_entry->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ #package metabib::title_field_entry_source_map;
+
+ #metabib::title_field_entry_source_map->table( 'metabib.title_field_entry_source_map' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ #package metabib::author_field_entry_source_map;
+
+ #metabib::author_field_entry_source_map->table( 'metabib.author_field_entry_source_map' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ #package metabib::subject_field_entry_source_map;
+
+ #metabib::subject_field_entry_source_map->table( 'metabib.subject_field_entry_source_map' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ #package metabib::keyword_field_entry_source_map;
+
+ #metabib::keyword_field_entry_source_map->table( 'metabib.keyword_field_entry_source_map' );
+
+ #-------------------------------------------------------------------------------
+
+ #-------------------------------------------------------------------------------
+ package metabib::metarecord_source_map;
+
+ metabib::metarecord_source_map->table( 'metabib.metarecord_source_map' );
+ metabib::metarecord_source_map->sequence( 'metabib.metarecord_source_map_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package authority::record_descriptor;
+
+ authority::record_descriptor->table( 'authority.rec_descriptor' );
+ authority::record_descriptor->sequence( 'authority.rec_descriptor_id_seq' );
+
+ #-------------------------------------------------------------------------------
+ package metabib::record_descriptor;
+
+ metabib::record_descriptor->table( 'metabib.rec_descriptor' );
+ metabib::record_descriptor->sequence( 'metabib.rec_descriptor_id_seq' );
+
+ #-------------------------------------------------------------------------------
+
+
+ #-------------------------------------------------------------------------------
+ package authority::full_rec;
+
+ authority::full_rec->table( 'authority.full_rec' );
+ authority::full_rec->sequence( 'authority.full_rec_id_seq' );
+ authority::full_rec->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+ package metabib::full_rec;
+
+ metabib::full_rec->table( 'metabib.full_rec' );
+ metabib::full_rec->sequence( 'metabib.full_rec_id_seq' );
+ metabib::full_rec->columns( 'FTS' => 'index_vector' );
+
+ #-------------------------------------------------------------------------------
+
+ package permission::perm_list;
+
+ permission::perm_list->sequence( 'permission.perm_list_id_seq' );
+ permission::perm_list->table('permission.perm_list');
+
+ #-------------------------------------------------------------------------------
+
+ package permission::grp_tree;
+
+ permission::grp_tree->sequence( 'permission.grp_tree_id_seq' );
+ permission::grp_tree->table('permission.grp_tree');
+
+ #-------------------------------------------------------------------------------
+
+ package permission::usr_grp_map;
+
+ permission::usr_grp_map->sequence( 'permission.usr_grp_map_id_seq' );
+ permission::usr_grp_map->table('permission.usr_grp_map');
+
+ #-------------------------------------------------------------------------------
+
+ package permission::usr_work_ou_map;
+ permission::usr_work_ou_map->sequence('permission.usr_work_ou_map_id_seq');
+ permission::usr_work_ou_map->table('permission.usr_work_ou_map');
+
+ #-------------------------------------------------------------------------------
+
+ package permission::usr_perm_map;
+
+ permission::usr_perm_map->sequence( 'permission.usr_perm_map_id_seq' );
+ permission::usr_perm_map->table('permission.usr_perm_map');
+
+ #-------------------------------------------------------------------------------
+
+ package permission::grp_perm_map;
+
+ permission::grp_perm_map->sequence( 'permission.grp_perm_map_id_seq' );
+ permission::grp_perm_map->table('permission.grp_perm_map');
+
+ #-------------------------------------------------------------------------------
+
+ package action::hold_request;
+
+ action::hold_request->sequence( 'action.hold_request_id_seq' );
+ action::hold_request->table('action.hold_request');
+
+ #-------------------------------------------------------------------------------
+
+ package action::hold_notification;
+
+ action::hold_notification->sequence( 'action.hold_notification_id_seq' );
+ action::hold_notification->table('action.hold_notification');
+
+ #-------------------------------------------------------------------------------
+
+ package action::hold_copy_map;
+
+ action::hold_copy_map->sequence( 'action.hold_copy_map_id_seq' );
+ action::hold_copy_map->table('action.hold_copy_map');
+
+ #-------------------------------------------------------------------------------
+
+ package action::hold_transit_copy;
+
+ action::hold_transit_copy->sequence( 'action.transit_copy_id_seq' );
+ action::hold_transit_copy->table('action.hold_transit_copy');
+
+ #-------------------------------------------------------------------------------
+
+ package action::reservation_transit_copy;
+
+ action::reservation_transit_copy->sequence( 'action.transit_copy_id_seq' );
+ action::reservation_transit_copy->table('action.reservation_transit_copy');
+
+ #-------------------------------------------------------------------------------
+
+ package action::transit_copy;
+
+ action::transit_copy->sequence( 'action.transit_copy_id_seq' );
+ action::transit_copy->table('action.transit_copy');
+
+ #-------------------------------------------------------------------------------
+
+ package action::unfulfilled_hold_list;
+
+ action::unfulfilled_hold_list->sequence( 'action.unfulfilled_hold_list_id_seq' );
+ action::unfulfilled_hold_list->table('action.unfulfilled_hold_list');
+
+ #-------------------------------------------------------------------------------
+
+ package serial::subscription;
+
+ serial::subscription->sequence( 'serial.subscription_id_seq' );
+ serial::subscription->table('serial.subscription');
+
+ #-------------------------------------------------------------------------------
+
+ package serial::issuance;
+
+ serial::issuance->sequence( 'serial.issuance_id_seq' );
+ serial::issuance->table('serial.issuance');
+
+ #-------------------------------------------------------------------------------
+
+ package serial::item;
+
+ serial::item->sequence( 'serial.item_id_seq' );
+ serial::item->table('serial.item');
+
+ #-------------------------------------------------------------------------------
+
+ package serial::unit;
+
+ serial::unit->sequence( 'asset.copy_id_seq' );
+ serial::unit->table('serial.unit');
+
+ #-------------------------------------------------------------------------------
+
+ package config::language_map;
+ config::language_map->table('config.language_map');
+
+ #-------------------------------------------------------------------------------
+
+ package config::i18n_locale;
+ config::i18n_locale->table('config.i18n_locale');
+
+ #-------------------------------------------------------------------------------
+
+ package config::i18n_core;
+ config::i18n_core->sequence( 'config.i18n_core_id_seq' );
+ config::i18n_core->table('config.i18n_core');
+
+ #-------------------------------------------------------------------------------
+
+ package config::item_form_map;
+ config::item_form_map->table('config.item_form_map');
+
+ #-------------------------------------------------------------------------------
+
+ package config::lit_form_map;
+ config::lit_form_map->table('config.lit_form_map');
+
+ #-------------------------------------------------------------------------------
+
+ package config::item_type_map;
+ config::item_type_map->table('config.item_type_map');
+
+ #-------------------------------------------------------------------------------
+ package config::audience_map;
+ config::audience_map->table('config.audience_map');
+
+ #-------------------------------------------------------------------------------
+
+
+}
+
+for my $class ( qw/
+ biblio::record_entry
+ metabib::metarecord
+ metabib::title_field_entry
+ metabib::author_field_entry
+ metabib::subject_field_entry
+ metabib::keyword_field_entry
+ metabib::series_field_entry
+ metabib::metarecord_source_map
+ metabib::record_descriptor
+ metabib::full_rec
+ authority::record_descriptor
+ authority::full_rec
+ / ) {
+
+ (my $method_class = $class) =~ s/::/./go;
+
+ for my $type ( qw/create create_start create_push create_finish/ ) {
+ my ($name,$part) = split('_', $type);
+
+ my $apiname = "open-ils.storage.direct.$method_class.batch.$name";
+ $apiname .= ".$part" if ($part);
+
+ OpenILS::Application::Storage->register_method(
+ api_name => $apiname,
+ method => "copy_$type",
+ api_level => 1,
+ 'package' => 'OpenILS::Application::Storage',
+ cdbi => $class,
+ );
+ }
+}
+
+
+1;
--- /dev/null
+{ # Every driver needs to provide a 'compile()' method to OpenILS::Application::Storage::FTS.
+ # If that driver wants to support FTI, that is...
+ #-------------------------------------------------------------------------------
+ package OpenILS::Application::Storage::FTS;
+ use OpenSRF::Utils::Logger qw/:level/;
+ use Unicode::Normalize;
+ my $log = 'OpenSRF::Utils::Logger';
+
+ sub compile {
+ my $self = shift;
+ my $class = shift;
+ my $term = NFD(shift());
+
+ $log->debug("Raw term: $term",DEBUG);
+ $log->debug("Search class: $class",DEBUG);
+
+ $term =~ s/\&//go;
+ $term =~ s/\|//go;
+
+ $self = ref($self) || $self;
+ $self = bless {} => $self;
+ $self->{class} = $class;
+
+ $term =~ s/(\pM+)//gos;
+ $term =~ s/(\b\.\b)//gos;
+
+ # hack to normalize ratio-like strings
+ while ($term =~ /\b\d{1}:[, ]?\d+(?:[ ,]\d+[^:])+/o) {
+ $term = $` . join ('', split(/[, ]/, $&)) . $';
+ }
+
+ $self->decompose($term);
+
+ my $newterm = '';
+ $newterm = join('&', $self->words) if ($self->words);
+
+ if (@{$self->nots}) {
+ $newterm = '('.$newterm.')&' if ($newterm);
+ $newterm .= '!('. join('|', $self->nots) . ')';
+ }
+
+ $log->debug("Compiled term is [$newterm]", DEBUG);
+ $newterm = OpenILS::Application::Storage::Driver::Pg->quote($newterm);
+ $log->debug("Quoted term is [$newterm]", DEBUG);
+
+ $self->{fts_query} = ["to_tsquery('$$self{class}',$newterm)"];
+ $self->{fts_query_nots} = [];
+ $self->{fts_op} = '@@';
+ $self->{text_col} = shift;
+ $self->{fts_col} = shift;
+
+ return $self;
+ }
+
+ sub sql_where_clause {
+ my $self = shift;
+ my $column = $self->fts_col;
+ my @output;
+
+ my @ranks;
+ for my $fts ( $self->fts_query ) {
+ push @output, join(' ', $self->fts_col, $self->{fts_op}, $fts);
+ push @ranks, "rank($column, $fts)";
+ }
+ $self->{fts_rank} = \@ranks;
+
+ my $phrase_match = $self->sql_exact_phrase_match();
+ return join(' AND ', @output) . $phrase_match;
+ }
+
+ sub sql_exact_phrase_match {
+ my $self = shift;
+ my $column = $self->text_col;
+ my $output = '';
+ for my $phrase ( $self->phrases ) {
+ $phrase =~ s/\*/\\*/go;
+ $phrase =~ s/\./\\./go;
+ $phrase =~ s/'/\\'/go;
+ $phrase =~ s/\s+/\\s+/go;
+ $log->debug("Adding phrase [$phrase] to the match list", DEBUG);
+ $output .= " AND $column ~* \$\$(^|\\W+)$phrase(\\W+|\$)\$\$";
+ }
+ $log->debug("Phrase list is [$output]", DEBUG);
+ return $output;
+ }
+
+}
+
+1;
--- /dev/null
+
+{
+ package OpenILS::Application::Storage;
+ use OpenSRF::Utils::Logger;
+
+ our $NOPRIMARY = 0;
+ my $log = 'OpenSRF::Utils::Logger';
+ my $pg = 'OpenILS::Application::Storage::Driver::Pg';
+
+ sub child_exit {
+ $_->disconnect for $pg->db_Handles;
+ }
+
+ sub current_xact {
+ my $self = shift;
+ my $client = shift;
+ return $pg->current_xact_id;
+ }
+ __PACKAGE__->register_method(
+ method => 'current_xact',
+ api_name => 'open-ils.storage.transaction.current',
+ api_level => 1,
+ argc => 0,
+ );
+
+
+ sub pg_begin_xaction {
+ my $self = shift;
+ my $client = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ if (my $old_xact = $pg->current_xact_session) {
+ if ($pg->current_xact_is_auto) {
+ $log->debug("Commiting old autocommit transaction with Open-ILS XACT-ID [$old_xact]", INFO);
+ $self->method_lookup("open-ils.storage.transaction.commit")->run();
+ } else {
+ $log->debug("Rolling back old NON-autocommit transaction with Open-ILS XACT-ID [$old_xact]", INFO);
+ $self->method_lookup("open-ils.storage.transaction.rollback")->run();
+ throw OpenSRF::DomainObject::oilsException->new(
+ statusCode => 500,
+ status => "Previous transaction rolled back!",
+ );
+ }
+ }
+
+ $pg->set_xact_session( $client->session );
+ my $xact_id = $pg->current_xact_id;
+
+ $log->debug("Beginning a new transaction with Open-ILS XACT-ID [$xact_id]", INFO);
+
+ my $dbh = OpenILS::Application::Storage::CDBI->db_Main;
+
+ try {
+ $dbh->begin_work;
+
+ } catch Error with {
+ my $e = shift;
+ $log->debug("Failed to begin a new transaction with Open-ILS XACT-ID [$xact_id]: ".$e, INFO);
+ throw $e;
+ };
+
+
+ my $death_cb = $client->session->register_callback(
+ death => sub {
+ __PACKAGE__->pg_rollback_xaction;
+ }
+ );
+
+ $log->debug("Registered 'death' callback [$death_cb] for new transaction with Open-ILS XACT-ID [$xact_id]", DEBUG);
+
+ $client->session->session_data( death_cb => $death_cb );
+
+ if ($self->api_name =~ /autocommit$/o) {
+ $pg->current_xact_is_auto(1);
+ my $dc_cb = $client->session->register_callback(
+ disconnect => sub {
+ my $ses = shift;
+ $ses->unregister_callback(death => $death_cb);
+ __PACKAGE__->pg_commit_xaction;
+ }
+ );
+ $log->debug("Registered 'disconnect' callback [$dc_cb] for new transaction with Open-ILS XACT-ID [$xact_id]", DEBUG);
+ if ($client and $client->session) {
+ $client->session->session_data( disconnect_cb => $dc_cb );
+ }
+ }
+
+ return 1;
+
+ }
+ __PACKAGE__->register_method(
+ method => 'pg_begin_xaction',
+ api_name => 'open-ils.storage.transaction.begin',
+ api_level => 1,
+ argc => 0,
+ );
+ __PACKAGE__->register_method(
+ method => 'pg_begin_xaction',
+ api_name => 'open-ils.storage.transaction.begin.autocommit',
+ api_level => 1,
+ argc => 0,
+ );
+
+ sub pg_commit_xaction {
+ my $self = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $xact_id = $pg->current_xact_id;
+
+ my $success = 1;
+ try {
+ $log->debug("Committing transaction with Open-ILS XACT-ID [$xact_id]", INFO) if ($xact_id);
+ my $dbh = OpenILS::Application::Storage::CDBI->db_Main;
+ $dbh->commit;
+
+ } catch Error with {
+ my $e = shift;
+ $log->debug("Failed to commit transaction with Open-ILS XACT-ID [$xact_id]: ".$e, INFO);
+ $success = 0;
+ };
+
+ $pg->current_xact_session->unregister_callback( death =>
+ $pg->current_xact_session->session_data( 'death_cb' )
+ ) if ($pg->current_xact_session);
+
+ if ($pg->current_xact_is_auto) {
+ $pg->current_xact_session->unregister_callback( disconnect =>
+ $pg->current_xact_session->session_data( 'disconnect_cb' )
+ );
+ }
+
+ $pg->unset_xact_session;
+
+ return $success;
+
+ }
+ __PACKAGE__->register_method(
+ method => 'pg_commit_xaction',
+ api_name => 'open-ils.storage.transaction.commit',
+ api_level => 1,
+ argc => 0,
+ );
+
+ sub pg_rollback_xaction {
+ my $self = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $xact_id = $pg->current_xact_id;
+
+ my $success = 1;
+ try {
+ my $dbh = OpenILS::Application::Storage::CDBI->db_Main;
+ $log->debug("Rolling back a transaction with Open-ILS XACT-ID [$xact_id]", INFO);
+ $dbh->rollback;
+
+ } catch Error with {
+ my $e = shift;
+ $log->debug("Failed to roll back transaction with Open-ILS XACT-ID [$xact_id]: ".$e, INFO);
+ $success = 0;
+ };
+
+ $pg->current_xact_session->unregister_callback( death =>
+ $pg->current_xact_session->session_data( 'death_cb' )
+ ) if ($pg->current_xact_session);
+
+ if ($pg->current_xact_is_auto) {
+ $pg->current_xact_session->unregister_callback( disconnect =>
+ $pg->current_xact_session->session_data( 'disconnect_cb' )
+ );
+ }
+
+ $pg->unset_xact_session;
+
+ return $success;
+ }
+ __PACKAGE__->register_method(
+ method => 'pg_rollback_xaction',
+ api_name => 'open-ils.storage.transaction.rollback',
+ api_level => 1,
+ argc => 0,
+ );
+
+ sub set_savepoint {
+ my $self = shift;
+ my $client = shift;
+ my $sp = shift || 'osrf_savepoint';
+ return OpenILS::Application::Storage::CDBI->db_Main->pg_savepoint($sp);
+ }
+ __PACKAGE__->register_method(
+ method => 'set_savepoint',
+ api_name => 'open-ils.storage.savepoint.set',
+ api_level => 1,
+ argc => 1,
+ );
+
+ sub release_savepoint {
+ my $self = shift;
+ my $client = shift;
+ my $sp = shift || 'osrf_savepoint';
+ return OpenILS::Application::Storage::CDBI->db_Main->pg_release($sp);
+ }
+ __PACKAGE__->register_method(
+ method => 'release_savepoint',
+ api_name => 'open-ils.storage.savepoint.release',
+ api_level => 1,
+ argc => 1,
+ );
+
+ sub rollback_to_savepoint {
+ my $self = shift;
+ my $client = shift;
+ my $sp = shift || 'osrf_savepoint';
+ return OpenILS::Application::Storage::CDBI->db_Main->pg_rollback_to($sp);
+ }
+ __PACKAGE__->register_method(
+ method => 'rollback_to_savepoint',
+ api_name => 'open-ils.storage.savepoint.rollback',
+ api_level => 1,
+ argc => 1,
+ );
+
+
+ sub copy_create_start {
+ my $self = shift;
+ my $client = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ #return undef unless ($pg->current_xact_session);
+
+ my @cols = $self->{cdbi}->columns('Essential');
+ if ($NOPRIMARY) {
+ my ($p) = $self->{cdbi}->columns('Primary');
+ @cols = grep { $_ ne $p } @cols;
+ }
+
+ my $col_list = join ',', @cols;
+
+ $log->debug('Starting COPY import for '.$self->{cdbi}->table." ($col_list)", DEBUG);
+ $self->{cdbi}->sql_copy_start($self->{cdbi}->table, $col_list)->execute;
+
+ return 1;
+ }
+
+ sub copy_create_push {
+ my $self = shift;
+ my $client = shift;
+ my @fm_nodes = @_;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ #return undef unless ($pg->current_xact_session);
+
+ my @cols = $self->{cdbi}->columns('Essential');
+ if ($NOPRIMARY) {
+ my ($p) = $self->{cdbi}->columns('Primary');
+ @cols = grep { $_ ne $p } @cols;
+ }
+
+ my $dbh = $self->{cdbi}->db_Main;
+ for my $node ( @fm_nodes ) {
+ next unless ($node);
+ my $line = join("\t", map { defined($node->$_()) ? $node->$_() : '\N' } @cols);
+ $log->debug("COPY line: [$line]",DEBUG);
+ $dbh->pg_putline($line."\n");
+ }
+
+ return scalar(@fm_nodes);
+ }
+
+ sub copy_create_finish {
+ my $self = shift;
+ my $client = shift;
+ my @fm_nodes = @_;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ #return undef unless ($pg->current_xact_session);
+
+ my $dbh = $self->{cdbi}->db_Main;
+
+ $dbh->pg_endcopy || $log->debug("Could not end COPY with pg_endcopy", WARN);
+
+ $log->debug('COPY import for '.$self->{cdbi}->table." ($col_list) complete", DEBUG);
+
+ return 1;
+ }
+
+ sub copy_create {
+ my $self = shift;
+ my $client = shift;
+ my @fm_nodes = @_;
+
+ local $NOPRIMARY = 1;
+
+ copy_create_start( $self => $client );
+ copy_create_push( $self => $client => @fm_nodes );
+ copy_create_finish( $self => $client );
+
+ return scalar(@fm_nodes);
+ }
+
+ sub autoprimary {
+ my $class = shift;
+ my $val = shift;
+ $NOPRIMARY = $val if (defined $val);
+ return $NOPRIMARY;
+ }
+
+}
+
+1;
--- /dev/null
+use OpenSRF::Utils::Logger qw/:level/;
+my $log = 'OpenSRF::Utils::Logger';
+
+#-------------------------------------------------------------------------------
+package OpenILS::Application::Storage::FTS;
+use OpenSRF::Utils::Logger qw/:level/;
+use Parse::RecDescent;
+use OpenILS::Utils::Normalize qw( naco_normalize );
+
+my $_default_grammar_parser = new Parse::RecDescent ( <<'GRAMMAR' );
+
+<autotree>
+
+search_expression: or_expr(s) | and_expr(s) | expr(s)
+or_expr: lexpr '||' rexpr
+and_expr: lexpr '&&' rexpr
+lexpr: expr
+rexpr: expr
+expr: phrase(s) | group(s) | word(s)
+joiner: '||' | '&&'
+phrase: '"' token(s) '"'
+group : '(' search_expression ')'
+word: numeric_range | negative_token | token
+negative_token: '-' .../\D+/ token
+token: /[-\w]+/
+numeric_range: /\d+-\d*/
+
+GRAMMAR
+
+sub compile {
+
+ $log->debug("You must override me somewhere, or I will make searching really slow!!!!",ERROR);;
+
+ my $self = shift;
+ my $class = shift;
+ my $term = shift;
+
+ $self = ref($self) || $self;
+ $self = bless {} => $self;
+
+ $self->decompose($term);
+
+ for my $part ( $self->words, $self->phrases ) {
+ $part = OpenILS::Application::Storage::CDBI->quote($part);
+ push @{ $self->{ fts_query } }, "'\%$part\%'";
+ }
+
+ for my $part ( $self->nots ) {
+ $part = OpenILS::Application::Storage::CDBI->quote($part);
+ push @{ $self->{ fts_query_not } }, "'\%$part\%'";
+ }
+}
+
+sub decompose {
+ my $self = shift;
+ my $term = shift;
+ my $parser = shift || $_default_grammar_parser;
+
+ $term =~ s/:/ /go;
+ $term =~ s/\s+--\s+/ /go;
+ $term =~ s/(?:&[^;]+;)//go;
+ $term =~ s/\s+/ /go;
+ $term =~ s/(^|\s+)-(\w+)/$1!$2/go;
+ $term =~ s/\b(\+)(\w+)/$2/go;
+ $term =~ s/^\s*\b(.+)\b\s*$/$1/o;
+ $term =~ s/(\d{4})-(\d{4})/$1 $2/go;
+ #$term =~ s/^(?:an?|the)\b(.*)/$1/o;
+
+ $log->debug("Stripped search term string is [$term]",DEBUG);
+
+ my $parsetree = $parser->search_expression( $term );
+ my @words = $term =~ /\b((?<!!)\w+)\b/go;
+ my @nots = $term =~ /\b(?<=!)(\w+)\b/go;
+
+ $log->debug("Stripped words are[".join(', ',@words)."]",DEBUG);
+ $log->debug("Stripped nots are[".join(', ',@nots)."]",DEBUG);
+
+ my @parts;
+ while ($term =~ s/ ((?<!\\)"{1}) (.*?) ((?<!\\)"){1} //x) {
+ my $part = $2;
+ $part =~ s/^\s*//o;
+ $part =~ s/\s*$//o;
+ next unless $part;
+ push @parts, lc($part);
+ }
+
+ $self->{ fts_op } = 'ILIKE';
+ $self->{ fts_col } = $self->{ text_col } = 'value';
+ $self->{ raw } = $term;
+ $self->{ parsetree } = $parsetree;
+ $self->{ words } = \@words;
+ $self->{ nots } = \@nots;
+ $self->{ phrases } = \@parts;
+
+ return $self;
+}
+
+sub fts_query_not {
+ my $self = shift;
+ return wantarray ? @{ $self->{fts_query_not} } : $self->{fts_query_not};
+}
+
+sub fts_rank {
+ my $self = shift;
+ return wantarray ? @{ $self->{fts_rank} } : $self->{fts_rank};
+}
+
+sub fts_query {
+ my $self = shift;
+ return wantarray ? @{ $self->{fts_query} } : $self->{fts_query};
+}
+
+sub raw {
+ my $self = shift;
+ return $self->{raw};
+}
+
+sub parse_tree {
+ my $self = shift;
+ return $self->{parsetree};
+}
+
+sub fts_col {
+ my $self = shift;
+ return $self->{fts_col};
+}
+
+sub text_col {
+ my $self = shift;
+ return $self->{text_col};
+}
+
+sub phrases {
+ my $self = shift;
+ return wantarray ? @{ $self->{phrases} } : $self->{phrases};
+}
+
+sub words {
+ my $self = shift;
+ return wantarray ? @{ $self->{words} } : $self->{words};
+}
+
+sub nots {
+ my $self = shift;
+ return wantarray ? @{ $self->{nots} } : $self->{nots};
+}
+
+sub sql_exact_phrase_match {
+ my $self = shift;
+ my $column = $self->text_col;
+ my $output = '';
+ for my $phrase ( $self->phrases ) {
+ $phrase =~ s/%/\\%/go;
+ $phrase =~ s/_/\\_/go;
+ $phrase =~ s/'/\\'/go;
+ $log->debug("Adding phrase [$phrase] to the match list", DEBUG);
+ $output .= " AND $column ILIKE '\%$phrase\%'";
+ }
+ $log->debug("Phrase list is [$output]", DEBUG);
+ return $output;
+}
+
+sub sql_exact_word_bump {
+ my $self = shift;
+ my $bump = shift || '0.1';
+
+ my $column = $self->text_col;
+ my $output = '';
+ for my $word ( $self->words ) {
+ $word =~ s/%/\\%/go;
+ $word =~ s/_/\\_/go;
+ $word =~ s/'/''/go;
+ $log->debug("Adding word [$word] to the relevancy bump list", DEBUG);
+ $output .= " + CASE WHEN $column ILIKE '\%$word\%' THEN $bump ELSE 0 END";
+ }
+ $log->debug("Word bump list is [$output]", DEBUG);
+ return $output;
+}
+
+sub sql_where_clause {
+ my $self = shift;
+ my @output;
+
+ for my $fts ( $self->fts_query ) {
+ push @output, join(' ', $self->fts_col, $self->{fts_op}, $fts);
+ }
+
+ for my $fts ( $self->fts_query_not ) {
+ push @output, 'NOT (' . join(' ', $self->fts_col, $self->{fts_op}, $fts) . ')';
+ }
+
+ my $phrase_match = $self->sql_exact_phrase_match();
+ return join(' AND ', @output);
+}
+
+#-------------------------------------------------------------------------------
+use UNIVERSAL::require;
+BEGIN {
+ 'Class::DBI::Frozen::301'->use or 'Class::DBI'->use or die $@;
+}
+
+package Class::DBI;
+
+{
+ no warnings;
+ no strict;
+ sub _do_search {
+ my ($proto, $search_type, @args) = @_;
+ my $class = ref $proto || $proto;
+
+ my (@cols, @vals);
+ my $search_opts = (@args > 1 and ref($args[-1]) eq 'HASH') ? pop @args : {};
+
+ @args = %{ $args[0] } if ref $args[0] eq "HASH";
+
+ $search_opts->{offset} = int($search_opts->{page} - 1) * int($search_opts->{page_size}) if ($search_opts->{page_size});
+ $search_opts->{_placeholder} ||= '?';
+
+ my @frags;
+ while (my ($col, $val) = splice @args, 0, 2) {
+ my $column = $class->find_column($col)
+ || (List::Util::first { $_->accessor eq $col } $class->columns)
+ || $class->_croak("$col is not a column of $class");
+
+ if (!defined($val)) {
+ push @frags, "$col IS NULL";
+ } elsif (ref($val) and ref($val) eq 'ARRAY') {
+ push @frags, "$col IN (".join(',',map{'?'}@$val).")";
+ for my $v (@$val) {
+ push @vals, ''.$class->_deflated_column($column, $v);
+ }
+ } else {
+ push @frags, "$col $search_type $$search_opts{_placeholder}";
+ push @vals, $class->_deflated_column($column, $val);
+ }
+ }
+
+ my $frag = join " AND ", @frags;
+
+ $frag .= " ORDER BY $search_opts->{order_by}"
+ if $search_opts->{order_by};
+ $frag .= " LIMIT $search_opts->{limit}"
+ if $search_opts->{limit};
+ $frag .= " OFFSET $search_opts->{offset}"
+ if ($search_opts->{limit} && defined($search_opts->{offset}));
+
+ return $class->sth_to_objects($class->sql_Retrieve($frag), \@vals);
+ }
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::Publisher;
+use base qw/OpenILS::Application::Storage/;
+our $VERSION = 1;
+
+use Digest::MD5 qw/md5_hex/;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenILS::Utils::Fieldmapper;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+
+sub register_method {
+ my $class = shift;
+ my %args = @_;
+ my %dup_args = %args;
+
+ $class = ref($class) || $class;
+
+ $args{package} ||= $class;
+ __PACKAGE__->SUPER::register_method( %args );
+
+ if (exists($dup_args{cachable}) and $dup_args{cachable}) {
+ (my $name = $dup_args{api_name}) =~ s/^open-ils\.storage/open-ils.storage.cachable/o;
+ if ($name ne $dup_args{api_name}) {
+ $dup_args{real_api_name} = $dup_args{api_name};
+ $dup_args{method} = 'cachable_wrapper';
+ $dup_args{api_name} = $name;
+ $dup_args{package} = __PACKAGE__;
+ __PACKAGE__->SUPER::register_method( %dup_args );
+ }
+ }
+
+ if ($dup_args{real_api_name} =~ /^open-ils\.storage\.direct\..+\.search.+/o ||
+ $dup_args{api_name} =~ /^open-ils\.storage\.direct\..+\.search.+/o) {
+ $dup_args{api_name} = $dup_args{real_api_name} if ($dup_args{real_api_name});
+
+ (my $name = $dup_args{api_name}) =~ s/\.direct\./.id_list./o;
+
+ $dup_args{notes} = $dup_args{real_api_name};
+ $dup_args{real_api_name} = $dup_args{api_name};
+ $dup_args{method} = 'search_ids';
+ $dup_args{api_name} = $name;
+ $dup_args{package} = __PACKAGE__;
+
+ __PACKAGE__->SUPER::register_method( %dup_args );
+ }
+}
+
+sub cachable_wrapper {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my %cache_args = (
+ limit => 100,
+ offset => 0,
+ timeout => 7200,
+ cache_page_size => 1000,
+ );
+
+ my @real_args;
+ my $key_string = $self->api_name;
+ for (my $ind = 0; $ind < scalar(@args); $ind++) {
+ if ( $args[$ind] eq 'limit' ||
+ $args[$ind] eq 'offset' ||
+ $args[$ind] eq 'cache_page_size' ||
+ $args[$ind] eq 'timeout' ) {
+
+ my $key_ind = $ind;
+ $ind++;
+ my $value_ind = $ind;
+ $cache_args{$args[$key_ind]} = $args[$value_ind];
+ $log->debug("Cache limiter value for $args[$key_ind] is $args[$value_ind]", INTERNAL);
+ next;
+ }
+ $key_string .= $args[$ind];
+ $log->debug("Partial cache key value is $args[$ind]", INTERNAL);
+ push @real_args, $args[$ind];
+ }
+
+ my $cache_page = int($cache_args{offset} / $cache_args{cache_page_size});
+ my $cache_key;
+ { use bytes;
+ $cache_key = md5_hex($key_string.$cache_page);
+ }
+
+ $log->debug("Key string for cache lookup is $key_string -> $cache_key", DEBUG);
+ $log->debug("Cache page is $cache_page", DEBUG);
+
+ my $cached_res = OpenSRF::Utils::Cache->new->get_cache( $cache_key );
+ if (defined $cached_res) {
+ $log->debug("Found ".scalar(@$cached_res)." records in the cache", INFO);
+ $log->debug("Values from cache: ".join(', ', @$cached_res), INTERNAL);
+ my $start = int($cache_args{offset} - ($cache_page * $cache_args{cache_page_size}));
+ my $end = int($start + $cache_args{limit} - 1);
+ $log->debug("Responding with values from ".$start.' to '.$end,DEBUG);
+ $client->respond( $_ ) for ( grep { defined } @$cached_res[ $start .. $end ]);
+ return undef;
+ }
+
+ my $method = $self->method_lookup($self->{real_api_name});
+ my @res = $method->run(@real_args);
+
+
+ $client->respond( $_ ) for ( grep { defined } @res[$cache_args{offset} .. int($cache_args{offset} + $cache_args{limit} - 1)] );
+
+ $log->debug("Saving values from ".int($cache_page * $cache_args{cache_page_size})." to ".
+ int(($cache_page + 1) * $cache_args{cache_page_size}). "to the cache", INTERNAL);
+ try {
+ OpenSRF::Utils::Cache->new->put_cache(
+ $cache_key =>
+ [@res[int($cache_page * $cache_args{cache_page_size}) .. int(($cache_page + 1) * $cache_args{cache_page_size}) ]] =>
+ OpenSRF::Utils->interval_to_seconds( $cache_args{timeout} )
+ );
+ } catch Error with {
+ my $e = shift;
+ $log->error("Cache seems to be down, $e");
+ };
+
+ return undef;
+}
+
+sub random_object {
+ my $self = shift;
+ my $client = shift;
+
+ my $cdbi = $self->{cdbi};
+ my $table = $cdbi->table;
+ my $sql = <<" SQL";
+ SELECT id
+ FROM $table
+ WHERE id IN (( SELECT (RANDOM() * (SELECT MAX(id) FROM $table))::INT LIMIT 1 ));
+ SQL
+
+ my $trys = 100;
+ while ($trys--) {
+
+ my $id = $cdbi->db_Main->selectcol_arrayref($sql);
+ next unless (@$id);
+
+ return ($cdbi->fast_fieldmapper(@$id))[0];
+ }
+ return undef;
+}
+
+sub retrieve_node {
+ my $self = shift;
+ my $client = shift;
+ my @ids = @_;
+
+ my $cdbi = $self->{cdbi};
+
+ for my $id ( @ids ) {
+ next unless ($id);
+
+ my ($rec) = $cdbi->fast_fieldmapper($id);
+ if ($self->api_name !~ /batch/o) {
+ return $rec if ($rec);
+ }
+ $client->respond($rec);
+ }
+ return undef;
+}
+
+sub search_ids {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my @res = $self->method_lookup($self->{real_api_name})->run(@args);
+
+ if (ref($res[0]) eq 'ARRAY') {
+ return [ map { $_->id } @{ $res[0] } ];
+ }
+
+ $client->respond($_) for ( map { $_->id } @res );
+ return undef;
+}
+
+sub search_where {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ if (ref($args[0]) eq 'HASH') {
+ if ($args[1]) {
+ $args[1]{limit_dialect} = $self->{cdbi}->db_Main;
+ } else {
+ $args[1] = {limit_dialect => $self->{cdbi}->db_Main };
+ }
+ } else {
+ $args[0] = { @args };
+ $args[1] = {limit_dialect => $self->{cdbi} };
+ }
+
+ my $cdbi = $self->{cdbi};
+
+ for my $obj ($cdbi->search_where(@args)) {
+ next unless ref($obj);
+ $client->respond( $obj->to_fieldmapper );
+ }
+ return undef;
+}
+
+sub search {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ my $cdbi = $self->{cdbi};
+
+ (my $search_type = $self->api_name) =~ s/.*\.(search[^.]*).*/$1/o;
+
+ for my $obj ($cdbi->$search_type(@args)) {
+ next unless ref($obj);
+ $client->respond( $obj->to_fieldmapper );
+ }
+ return undef;
+}
+
+sub search_one_field {
+ my $self = shift;
+ my $client = shift;
+ my @args = @_;
+
+ (my $field = $self->api_name) =~ s/.*\.([^\.]+)$/$1/o;
+
+ return search( $self, $client, $field, @args );
+}
+
+sub old_search_one_field {
+ my $self = shift;
+ my $client = shift;
+ my @terms = @_;
+
+ (my $search_type = $self->api_name) =~ s/.*\.(search[^.]*).*/$1/o;
+ (my $col = $self->api_name) =~ s/.*\.$search_type\.([^.]+).*/$1/;
+ my $cdbi = $self->{cdbi};
+
+ my $like = 0;
+ $like = 1 if ($search_type =~ /like$/o);
+ $like = 2 if ($search_type =~ /fts$/o);
+ $like = 3 if ($search_type =~ /regex$/o);
+
+ for my $term (@terms) {
+ $log->debug("Searching $cdbi for $col using type $search_type, value '$term'",DEBUG);
+ if (@terms == 1) {
+ return [ $cdbi->fast_fieldmapper($term,$col,$like) ];
+ }
+ $client->respond( [ $cdbi->fast_fieldmapper($term,$col,$like) ] );
+ }
+ return undef;
+}
+
+
+sub create_node {
+ my $self = shift;
+ my $client = shift;
+ my $node = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $cdbi = $self->{cdbi};
+
+ my $success;
+ try {
+ my $rec = $cdbi->create($node);
+ $success = $rec->id if ($rec);
+ } catch Error with {
+ $success = 0;
+ };
+
+ return $success;
+}
+
+sub update_node {
+ my $self = shift;
+ my $client = shift;
+ my $node = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $cdbi = $self->{cdbi};
+
+ return $cdbi->update($node);
+}
+
+sub mass_delete {
+ my $self = shift;
+ my $client = shift;
+ my $search = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $where = 'WHERE ';
+
+ my $cdbi = $self->{cdbi};
+ my $table = $cdbi->table;
+
+ my @keys = sort keys %$search;
+
+ my @binds;
+ my @wheres;
+ for my $col ( @keys ) {
+ if (ref($$search{$col}) and ref($$search{$col}) =~ /ARRAY/o) {
+ push @wheres, "$col IN (" . join(',', map { '?' } @{ $$search{$col} }) . ')';
+ push @binds, map { "$_" } @{ $$search{$col} };
+ } else {
+ push @wheres, "$col = ?";
+ push @binds, $$search{$col};
+ }
+ }
+ $where .= join ' AND ', @wheres;
+
+ my $delete = "DELETE FROM $table $where";
+
+ $log->debug("Performing MASS deletion : $delete",DEBUG);
+
+ my $dbh = $cdbi->db_Main;
+ my $success = 1;
+ try {
+ my $sth = $dbh->prepare($delete);
+ $sth->execute( @binds );
+ $sth->finish;
+ $log->debug("MASS Delete succeeded",DEBUG);
+ } catch Error with {
+ $log->debug("MASS Delete FAILED : ".shift(),DEBUG);
+ $success = 0;
+ };
+ return $success;
+}
+
+sub remote_update_node {
+ my $self = shift;
+ my $client = shift;
+ my $keys = shift;
+ my $vals = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $cdbi = $self->{cdbi};
+
+ my $success = 1;
+ try {
+ $success = $cdbi->remote_update($keys,$vals);
+ } catch Error with {
+ $success = 0;
+ };
+ return $success;
+}
+
+sub merge_node {
+ my $self = shift;
+ my $client = shift;
+ my $keys = shift;
+ my $vals = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $cdbi = $self->{cdbi};
+
+ my $success = 1;
+ try {
+ $success = $cdbi->merge($keys,$vals)->id;
+ } catch Error with {
+ $success = 0;
+ };
+ return $success;
+}
+
+sub delete_node {
+ my $self = shift;
+ my $client = shift;
+ my $node = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $cdbi = $self->{cdbi};
+
+ my $success = 1;
+ try {
+ $success = $cdbi->delete($node);
+ } catch Error with {
+ $success = 0;
+ };
+ return $success;
+}
+
+sub batch_call {
+ my $self = shift;
+ my $client = shift;
+ my @nodes = @_;
+
+ my $unwrap = $self->{unwrap};
+
+ my $cdbi = $self->{cdbi};
+ my $api_name = $self->api_name;
+ (my $single_call_api_name = $api_name) =~ s/batch\.//o;
+
+ $log->debug("Default $api_name looking up $single_call_api_name...",INTERNAL);
+ my $method = $self->method_lookup($single_call_api_name);
+
+ my @success;
+ while ( my $node = shift(@nodes) ) {
+ my ($res) = $method->run( ($unwrap ? (@$node) : ($node)) );
+ push(@success, 1) if ($res >= 0);
+ }
+
+ my $insert_total = 0;
+ $insert_total += $_ for (@success);
+
+ return $insert_total;
+}
+
+
+# --------------------- End of generic methods -----------------------
+
+
+for my $pkg ( qw/actor action asset biblio config metabib authority money permission container/ ) {
+ "OpenILS::Application::Storage::Publisher::$pkg"->use;
+ if ($@) {
+ $log->debug("ARG! Couldn't load $pkg class Publisher: $@", ERROR);
+ throw OpenSRF::EX::ERROR ("ARG! Couldn't load $pkg class Publisher: $@");
+ }
+}
+
+for my $fmclass ( (Fieldmapper->classes) ) {
+
+ $log->debug("Generating methods for Fieldmapper class $fmclass", DEBUG);
+
+ next if ($fmclass->is_virtual);
+
+ (my $cdbi = $fmclass) =~ s/^Fieldmapper:://o;
+ (my $class = $cdbi) =~ s/::.*//o;
+ (my $api_class = $cdbi) =~ s/::/./go;
+ my $registration_class = __PACKAGE__ . "::$class";
+ my $api_prefix = 'open-ils.storage.direct.'.$api_class;
+
+ # Create the search methods
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search',
+ method => 'search',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ );
+ }
+
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_where' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_where',
+ method => 'search_where',
+ api_level => 1,
+ stream => 1,
+ argc => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ );
+ }
+
+=comment
+
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_like' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_like',
+ method => 'search',
+ api_level => 1,
+ stream => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ argc => 2,
+ );
+ }
+
+ if (\&Class::DBI::search_fts and $cdbi->columns('FTS')) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_fts' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_fts',
+ method => 'search',
+ api_level => 1,
+ stream => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ argc => 2,
+ );
+ }
+ }
+
+ if (\&Class::DBI::search_regex) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_regex' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_regex',
+ method => 'search',
+ api_level => 1,
+ stream => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ argc => 2,
+ );
+ }
+ }
+
+ if (\&Class::DBI::search_ilike) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_ilike' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_ilike',
+ method => 'search',
+ api_level => 1,
+ stream => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ argc => 2,
+ );
+ }
+ }
+
+=cut
+
+ # Create the random method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.random' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.random',
+ method => 'random_object',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 0,
+ );
+ }
+
+ # Create the retrieve method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.retrieve' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.retrieve',
+ method => 'retrieve_node',
+ api_level => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ argc => 1,
+ );
+ }
+
+ # Create the batch retrieve method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.retrieve' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.batch.retrieve',
+ method => 'retrieve_node',
+ api_level => 1,
+ stream => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ argc => 1,
+ );
+ }
+
+ for my $field ($fmclass->real_fields) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search.'.$field ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search.'.$field,
+ method => 'search_one_field',
+ api_level => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ stream => 1,
+ argc => 1,
+ );
+ }
+
+=comment
+
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_like.'.$field ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_like.'.$field,
+ method => 'search_one_field',
+ api_level => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ stream => 1,
+ argc => 1,
+ );
+ }
+ if (\&Class::DBI::search_fts and grep { $field eq $_ } $cdbi->columns('FTS')) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_fts.'.$field ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_fts.'.$field,
+ method => 'search_one_field',
+ api_level => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ stream => 1,
+ argc => 1,
+ );
+ }
+ }
+ if (\&Class::DBI::search_regex) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_regex.'.$field ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_regex.'.$field,
+ method => 'search_one_field',
+ api_level => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ stream => 1,
+ argc => 1,
+ );
+ }
+ }
+ if (\&Class::DBI::search_ilike) {
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.search_ilike.'.$field ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.search_ilike.'.$field,
+ method => 'search_one_field',
+ api_level => 1,
+ cdbi => $cdbi,
+ cachable => 1,
+ stream => 1,
+ argc => 1,
+ );
+ }
+ }
+
+=cut
+
+ }
+
+
+ unless ($fmclass->is_readonly) {
+ # Create the create method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.create' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.create',
+ method => 'create_node',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the batch create method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.create' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.batch.create',
+ method => 'batch_call',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the update method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.update' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.update',
+ method => 'update_node',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the batch update method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.update' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.batch.update',
+ method => 'batch_call',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the delete method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.delete' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.delete',
+ method => 'delete_node',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the batch delete method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.delete' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.batch.delete',
+ method => 'batch_call',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the merge method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.merge' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.merge',
+ method => 'merge_node',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the batch merge method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.merge' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.batch.merge',
+ method => 'batch_call',
+ unwrap => 1,
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the remote_update method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.remote_update' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.remote_update',
+ method => 'remote_update_node',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the batch remote_update method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.batch.remote_update' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.batch.remote_update',
+ method => 'batch_call',
+ api_level => 1,
+ unwrap => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+
+ # Create the search-based mass delete method
+ unless ( __PACKAGE__->is_registered( $api_prefix.'.mass_delete' ) ) {
+ __PACKAGE__->register_method(
+ api_name => $api_prefix.'.mass_delete',
+ method => 'mass_delete',
+ api_level => 1,
+ cdbi => $cdbi,
+ argc => 1,
+ );
+ }
+ }
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::action;
+use parent qw/OpenILS::Application::Storage::Publisher/;
+use strict;
+use warnings;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::JSON;
+use OpenSRF::AppSession;
+use OpenSRF::EX qw/:try/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::PermitHold;
+use DateTime;
+use DateTime::Format::ISO8601;
+use OpenILS::Utils::Penalty;
+
+sub isTrue {
+ my $v = shift;
+ return 1 if ($v == 1);
+ return 1 if ($v =~ /^t/io);
+ return 1 if ($v =~ /^y/io);
+ return 0;
+}
+
+my $parser = DateTime::Format::ISO8601->new;
+my $log = 'OpenSRF::Utils::Logger';
+
+sub open_noncat_circs {
+ my $self = shift;
+ my $client = shift;
+ my $user = shift;
+
+ my $a = action::non_cataloged_circulation->table;
+ my $c = config::non_cataloged_type->table;
+
+ my $sql = <<" SQL";
+ SELECT a.id
+ FROM $a a
+ JOIN $c c ON (a.item_type = c.id)
+ WHERE a.circ_time + c.circ_duration > current_timestamp
+ AND a.patron = ?
+ SQL
+
+ return action::non_cataloged_circulation->db_Main->selectcol_arrayref($sql, {}, $user);
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.open_non_cataloged_circulation.user',
+ method => 'open_noncat_circs',
+ api_level => 1,
+ argc => 1,
+);
+
+
+sub ou_hold_requests {
+ my $self = shift;
+ my $client = shift;
+ my $ou = shift;
+
+ my $h_table = action::hold_request->table;
+ my $c_table = asset::copy->table;
+ my $o_table = actor::org_unit->table;
+
+ my $SQL = <<" SQL";
+ SELECT h.id
+ FROM $h_table h
+ JOIN $c_table cp ON (cp.id = h.current_copy)
+ JOIN $o_table ou ON (ou.id = cp.circ_lib)
+ WHERE ou.id = ?
+ AND h.capture_time IS NULL
+ AND h.cancel_time IS NULL
+ AND (h.expire_time IS NULL OR h.expire_time > NOW())
+ ORDER BY h.request_time
+ SQL
+
+ my $sth = action::hold_request->db_Main->prepare_cached($SQL);
+ $sth->execute($ou);
+
+ $client->respond($_) for (
+ map {
+ $self
+ ->method_lookup('open-ils.storage.direct.action.hold_request.retrieve')
+ ->run($_)
+ } map {
+ $_->[0]
+ } @{ $sth->fetchall_arrayref }
+ );
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.targeted_hold_request.org_unit',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ method => 'ou_hold_requests',
+);
+
+
+sub overdue_circs {
+ my $grace = shift;
+ my $upper_interval = shift || '1 millennium';
+ my $idlist = shift;
+
+ my $c_t = action::circulation->table;
+
+ if ($grace && $grace =~ /^\d+$/o) {
+ $grace = " - ($grace * (fine_interval))";
+ } else {
+ $grace = '';
+ }
+
+ my $sql = <<" SQL";
+ SELECT *
+ FROM $c_t
+ WHERE stop_fines IS NULL
+ AND due_date < ( CURRENT_TIMESTAMP $grace)
+ AND fine_interval < ?::INTERVAL
+ SQL
+
+ my $sth = action::circulation->db_Main->prepare_cached($sql);
+ $sth->execute($upper_interval);
+
+ my @circs = map { $idlist ? $_->{id} : action::circulation->construct($_) } $sth->fetchall_hash;
+
+ $c_t = booking::reservation->table;
+ $sql = <<" SQL";
+ SELECT *
+ FROM $c_t
+ WHERE return_time IS NULL
+ AND end_time < ( CURRENT_TIMESTAMP $grace)
+ AND fine_interval IS NOT NULL
+ AND cancel_time IS NULL
+ SQL
+
+ $sth = action::circulation->db_Main->prepare_cached($sql);
+ $sth->execute();
+
+ push @circs, map { $idlist ? $_->{id} : booking::reservation->construct($_) } $sth->fetchall_hash;
+
+ return @circs;
+}
+
+sub complete_reshelving {
+ my $self = shift;
+ my $client = shift;
+ my $window = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ throw OpenSRF::EX::InvalidArg ("I need an interval of more than 0 seconds!")
+ unless (interval_to_seconds( $window ));
+
+ my $setting = actor::org_unit_setting->table;
+ my $circ = action::circulation->table;
+ my $cp = asset::copy->table;
+ my $atc = action::transit_copy->table;
+
+ my $sql = <<" SQL";
+ UPDATE $cp
+ SET status = 0
+ WHERE id IN (
+ SELECT id
+ FROM (SELECT cp.id, MAX(circ.checkin_time), MAX(trans.dest_recv_time)
+ FROM $cp cp
+ JOIN $circ circ ON (circ.target_copy = cp.id)
+ LEFT JOIN $atc trans ON (trans.target_copy = cp.id)
+ LEFT JOIN $setting setting
+ ON (cp.circ_lib = setting.org_unit AND setting.name = 'circ.reshelving_complete.interval')
+ WHERE circ.checkin_time IS NOT NULL
+ AND cp.status = 7
+ GROUP BY 1
+ HAVING (
+ ( ( MAX(circ.checkin_time) > MAX(trans.dest_recv_time) or MAX(trans.dest_recv_time) IS NULL )
+ AND MAX(circ.checkin_time) < NOW() - CAST( COALESCE( BTRIM( FIRST(setting.value),'"' ), ? ) AS INTERVAL) )
+ OR
+ ( MAX(trans.dest_recv_time) > MAX(circ.checkin_time)
+ AND MAX(trans.dest_recv_time) < NOW() - CAST( COALESCE( BTRIM( FIRST(setting.value),'"' ), ? ) AS INTERVAL) )
+ )
+ ) AS foo
+ UNION ALL
+ SELECT cp.id
+ FROM $cp cp
+ LEFT JOIN $setting setting
+ ON (cp.circ_lib = setting.org_unit AND setting.name = 'circ.reshelving_complete.interval')
+ LEFT JOIN $circ circ ON (circ.target_copy = cp.id)
+ WHERE cp.status = 7
+ AND circ.id IS NULL
+ AND cp.create_date < NOW() - CAST( COALESCE( BTRIM( setting.value,'"' ), ? ) AS INTERVAL)
+ )
+ SQL
+ my $sth = action::circulation->db_Main->prepare_cached($sql);
+ $sth->execute($window, $window, $window);
+
+ return $sth->rows;
+
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.circulation.reshelving.complete',
+ api_level => 1,
+ argc => 1,
+ method => 'complete_reshelving',
+);
+
+sub mark_longoverdue {
+ my $self = shift;
+ my $client = shift;
+ my $window = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ throw OpenSRF::EX::InvalidArg ("I need an interval of more than 0 seconds!")
+ unless (interval_to_seconds( $window ));
+
+ my $setting = actor::org_unit_setting->table;
+ my $circ = action::circulation->table;
+
+ my $sql = <<" SQL";
+ UPDATE $circ
+ SET stop_fines = 'LONGOVERDUE',
+ stop_fines_time = now()
+ WHERE id IN (
+ SELECT circ.id
+ FROM $circ circ
+ LEFT JOIN $setting setting
+ ON (circ.circ_lib = setting.org_unit AND setting.name = 'circ.long_overdue.interval')
+ WHERE circ.checkin_time IS NULL AND (stop_fines IS NULL OR stop_fines NOT IN ('LOST','LONGOVERDUE'))
+ AND AGE(circ.due_date) > CAST( COALESCE( BTRIM( setting.value,'"' ), ? ) AS INTERVAL)
+ )
+ SQL
+
+ my $sth = action::circulation->db_Main->prepare_cached($sql);
+ $sth->execute($window);
+
+ return $sth->rows;
+
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.circulation.long_overdue',
+ api_level => 1,
+ argc => 1,
+ method => 'mark_longoverdue',
+);
+
+sub auto_thaw_frozen_holds {
+ my $self = shift;
+ my $client = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $holds = action::hold_request->table;
+
+ my $sql = "UPDATE $holds SET frozen = FALSE WHERE frozen IS TRUE AND thaw_date < NOW();";
+
+ my $sth = action::hold_request->db_Main->prepare_cached($sql);
+ $sth->execute();
+
+ return $sth->rows;
+
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.hold_request.thaw_expired_frozen',
+ api_level => 1,
+ stream => 0,
+ argc => 0,
+ method => 'auto_thaw_frozen_holds',
+);
+
+sub grab_overdue {
+ my $self = shift;
+ my $client = shift;
+ my $grace = shift || '';
+
+ my $idlist = $self->api_name =~/id_list/o ? 1 : 0;
+
+ $client->respond( $idlist ? $_ : $_->to_fieldmapper ) for ( overdue_circs($grace, '', $idlist) );
+
+ return undef;
+
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.circulation.overdue',
+ api_level => 1,
+ stream => 1,
+ method => 'grab_overdue',
+ signature => q/
+ Return list of overdue circulations and reservations to be used for fine generation.
+ Despite the name, this is not a generic method for retrieving all overdue loans,
+ as it excludes loans that have already hit the maximum fine limit.
+/,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.circulation.overdue.id_list',
+ api_level => 1,
+ stream => 1,
+ method => 'grab_overdue',
+);
+
+sub nearest_hold {
+ my $self = shift;
+ my $client = shift;
+ my $here = shift;
+ my $cp = shift;
+ my $limit = int(shift()) || 10;
+ my $age = shift() || '0 seconds';
+ my $fifo = shift();
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $holdsort = isTrue($fifo) ?
+ "pgt.hold_priority, CASE WHEN h.cut_in_line IS TRUE THEN 0 ELSE 1 END, h.request_time, h.selection_depth DESC, p.prox " :
+ "p.prox, pgt.hold_priority, CASE WHEN h.cut_in_line IS TRUE THEN 0 ELSE 1 END, h.selection_depth DESC, h.request_time ";
+
+ my $ids = action::hold_request->db_Main->selectcol_arrayref(<<" SQL", {}, $here, $cp, $age);
+ SELECT h.id
+ FROM action.hold_request h
+ JOIN actor.org_unit_proximity p ON (p.from_org = ? AND p.to_org = h.pickup_lib)
+ JOIN action.hold_copy_map hm ON (hm.hold = h.id)
+ JOIN actor.usr au ON (au.id = h.usr)
+ JOIN permission.grp_tree pgt ON (au.profile = pgt.id)
+ WHERE hm.target_copy = ?
+ AND (AGE(NOW(),h.request_time) >= CAST(? AS INTERVAL) OR p.prox = 0)
+ AND h.capture_time IS NULL
+ AND h.cancel_time IS NULL
+ AND (h.expire_time IS NULL OR h.expire_time > NOW())
+ AND h.frozen IS FALSE
+ ORDER BY $holdsort
+ LIMIT $limit
+ SQL
+
+ $client->respond( $_ ) for ( @$ids );
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.hold_request.nearest_hold',
+ api_level => 1,
+ stream => 1,
+ method => 'nearest_hold',
+);
+
+sub targetable_holds {
+ my $self = shift;
+ my $client = shift;
+ my $check_expire = shift;
+
+ $check_expire ||= '12h';
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ # json_query can *almost* represent this query, but can't
+ # handle the CASE statement or the interval arithmetic
+ my $query = <<" SQL";
+ SELECT ahr.id, mmsm.metarecord
+ FROM action.hold_request ahr
+ JOIN reporter.hold_request_record USING (id)
+ JOIN metabib.metarecord_source_map mmsm ON (bib_record = source)
+ WHERE capture_time IS NULL
+ AND (prev_check_time IS NULL or prev_check_time < (NOW() - ?::interval))
+ AND fulfillment_time IS NULL
+ AND cancel_time IS NULL
+ AND NOT frozen
+ ORDER BY CASE WHEN ahr.hold_type = 'F' THEN 0 ELSE 1 END, selection_depth DESC, request_time;
+ SQL
+ my $sth = action::hold_request->db_Main->prepare_cached($query);
+ $sth->execute($check_expire);
+
+ $client->respond( $_ ) for ( $sth->fetchall_arrayref );
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.hold_request.targetable_holds.id_list',
+ api_level => 1,
+ stream => 1,
+ method => 'targetable_holds',
+ signature => q/
+ Returns ordered list of hold request and metarecord IDs
+ for all hold requests that are available for initial targeting
+ or retargeting.
+ @param check interval
+ @return list of pairs of hold request and metarecord IDs
+/,
+);
+
+sub next_resp_group_id {
+ my $self = shift;
+ my $client = shift;
+
+ # XXX This is not replication safe!!!
+
+ my ($id) = action::survey->db_Main->selectrow_array(<<" SQL");
+ SELECT NEXTVAL('action.survey_response_group_id_seq'::TEXT)
+ SQL
+ return $id;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.survey_response.next_group_id',
+ api_level => 1,
+ method => 'next_resp_group_id',
+);
+
+sub patron_circ_summary {
+ my $self = shift;
+ my $client = shift;
+ my $id = ''.shift();
+
+ return undef unless ($id);
+ my $c_table = action::circulation->table;
+ my $b_table = money::billing->table;
+
+ $log->debug("Retrieving patron summary for id $id", DEBUG);
+
+ my $select = <<" SQL";
+ SELECT COUNT(DISTINCT c.id), SUM( COALESCE(b.amount,0) )
+ FROM $c_table c
+ LEFT OUTER JOIN $b_table b ON (c.id = b.xact AND b.voided = FALSE)
+ WHERE c.usr = ?
+ AND c.xact_finish IS NULL
+ AND (
+ c.stop_fines NOT IN ('CLAIMSRETURNED','LOST')
+ OR c.stop_fines IS NULL
+ )
+ SQL
+
+ return action::survey->db_Main->selectrow_arrayref($select, {}, $id);
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.circulation.patron_summary',
+ api_level => 1,
+ method => 'patron_circ_summary',
+);
+
+#XXX Fix stored proc calls
+sub find_local_surveys {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = action::survey->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
+ SQL
+
+ my $sth = action::survey->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.survey.all',
+ api_level => 1,
+ stream => 1,
+ method => 'find_local_surveys',
+);
+
+#XXX Fix stored proc calls
+sub find_opac_surveys {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = action::survey->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
+ AND s.opac IS TRUE;
+ SQL
+
+ my $sth = action::survey->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.survey.opac',
+ api_level => 1,
+ stream => 1,
+ method => 'find_opac_surveys',
+);
+
+sub hold_pull_list {
+ my $self = shift;
+ my $client = shift;
+ my $ou = shift;
+ my $limit = shift || 10;
+ my $offset = shift || 0;
+
+ return undef unless ($ou);
+ my $h_table = action::hold_request->table;
+ my $a_table = asset::copy->table;
+ my $ord_table = asset::copy_location_order->table;
+
+ my $idlist = 1 if ($self->api_name =~/id_list/o);
+ my $count = 1 if ($self->api_name =~/count$/o);
+
+ my $status_filter = '';
+ $status_filter = 'AND a.status IN (0,7)' if ($self->api_name =~/status_filtered/o);
+
+ my $select = <<" SQL";
+ SELECT h.*
+ FROM $h_table h
+ JOIN $a_table a ON (h.current_copy = a.id)
+ LEFT JOIN $ord_table ord ON (a.location = ord.location AND a.circ_lib = ord.org)
+ WHERE a.circ_lib = ?
+ AND h.capture_time IS NULL
+ AND h.cancel_time IS NULL
+ AND (h.expire_time IS NULL OR h.expire_time > NOW())
+ $status_filter
+ ORDER BY CASE WHEN ord.position IS NOT NULL THEN ord.position ELSE 999 END, h.request_time
+ LIMIT $limit
+ OFFSET $offset
+ SQL
+
+ if ($count) {
+ $select = <<" SQL";
+ SELECT count(*)
+ FROM $h_table h
+ JOIN $a_table a ON (h.current_copy = a.id)
+ WHERE a.circ_lib = ?
+ AND h.capture_time IS NULL
+ AND h.cancel_time IS NULL
+ AND (h.expire_time IS NULL OR h.expire_time > NOW())
+ $status_filter
+ SQL
+ }
+
+ my $sth = action::survey->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ if ($count) {
+ $client->respond( $sth->fetchall_arrayref()->[0][0] );
+ } elsif ($idlist) {
+ $client->respond( $_->{id} ) for ( $sth->fetchall_hash );
+ } else {
+ $client->respond( $_->to_fieldmapper ) for ( map { action::hold_request->construct($_) } $sth->fetchall_hash );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.action.hold_request.pull_list.current_copy_circ_lib.count',
+ api_level => 1,
+ stream => 1,
+ signature => [
+ "Returns a count of holds for a specific library's pull list.",
+ [ [org_unit => "The library's org id", "number"] ],
+ ['A count of holds for the stated library to pull ', 'number']
+ ],
+ method => 'hold_pull_list',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.action.hold_request.pull_list.current_copy_circ_lib.status_filtered.count',
+ api_level => 1,
+ stream => 1,
+ signature => [
+ "Returns a status filtered count of holds for a specific library's pull list.",
+ [ [org_unit => "The library's org id", "number"] ],
+ ['A status filtered count of holds for the stated library to pull ', 'number']
+ ],
+ method => 'hold_pull_list',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib',
+ api_level => 1,
+ stream => 1,
+ signature => [
+ "Returns the hold ids for a specific library's pull list.",
+ [ [org_unit => "The library's org id", "number"],
+ [limit => 'An optional page size, defaults to 10', 'number'],
+ [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
+ ],
+ ['A list of holds for the stated library to pull for', 'array']
+ ],
+ method => 'hold_pull_list',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.action.hold_request.pull_list.search.current_copy_circ_lib',
+ api_level => 1,
+ stream => 1,
+ signature => [
+ "Returns the holds for a specific library's pull list.",
+ [ [org_unit => "The library's org id", "number"],
+ [limit => 'An optional page size, defaults to 10', 'number'],
+ [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
+ ],
+ ['A list of holds for the stated library to pull for', 'array']
+ ],
+ method => 'hold_pull_list',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.action.hold_request.pull_list.id_list.current_copy_circ_lib.status_filtered',
+ api_level => 1,
+ stream => 1,
+ signature => [
+ "Returns the hold ids for a specific library's pull list that are definitely in that library, based on status.",
+ [ [org_unit => "The library's org id", "number"],
+ [limit => 'An optional page size, defaults to 10', 'number'],
+ [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
+ ],
+ ['A list of holds for the stated library to pull for', 'array']
+ ],
+ method => 'hold_pull_list',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.action.hold_request.pull_list.search.current_copy_circ_lib.status_filtered',
+ api_level => 1,
+ stream => 1,
+ signature => [
+ "Returns the holds for a specific library's pull list that are definitely in that library, based on status.",
+ [ [org_unit => "The library's org id", "number"],
+ [limit => 'An optional page size, defaults to 10', 'number'],
+ [offset => 'Offset for paging, defaults to 0, 0 based', 'number'],
+ ],
+ ['A list of holds for the stated library to pull for', 'array']
+ ],
+ method => 'hold_pull_list',
+);
+
+sub find_optional_surveys {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = action::survey->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
+ AND s.required IS FALSE;
+ SQL
+
+ my $sth = action::survey->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.survey.optional',
+ api_level => 1,
+ stream => 1,
+ method => 'find_optional_surveys',
+);
+
+sub find_required_surveys {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = action::survey->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
+ AND s.required IS TRUE;
+ SQL
+
+ my $sth = action::survey->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.survey.required',
+ api_level => 1,
+ stream => 1,
+ method => 'find_required_surveys',
+);
+
+sub find_usr_summary_surveys {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = action::survey->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE CURRENT_TIMESTAMP BETWEEN s.start_date AND s.end_date
+ AND s.usr_summary IS TRUE;
+ SQL
+
+ my $sth = action::survey->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { action::survey->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.survey.usr_summary',
+ api_level => 1,
+ stream => 1,
+ method => 'find_usr_summary_surveys',
+);
+
+sub seconds_to_interval_hash {
+ my $interval = shift;
+ my $limit = shift || 's';
+ $limit =~ s/^(.)/$1/o;
+
+ my %output;
+
+ my ($y,$ym,$M,$Mm,$w,$wm,$d,$dm,$h,$hm,$m,$mm,$s);
+ my ($year, $month, $week, $day, $hour, $minute, $second) =
+ ('years','months','weeks','days', 'hours', 'minutes', 'seconds');
+
+ if ($y = int($interval / (60 * 60 * 24 * 365))) {
+ $output{$year} = $y;
+ $ym = $interval % (60 * 60 * 24 * 365);
+ } else {
+ $ym = $interval;
+ }
+ return %output if ($limit eq 'y');
+
+ if ($M = int($ym / ((60 * 60 * 24 * 365)/12))) {
+ $output{$month} = $M;
+ $Mm = $ym % ((60 * 60 * 24 * 365)/12);
+ } else {
+ $Mm = $ym;
+ }
+ return %output if ($limit eq 'M');
+
+ if ($w = int($Mm / 604800)) {
+ $output{$week} = $w;
+ $wm = $Mm % 604800;
+ } else {
+ $wm = $Mm;
+ }
+ return %output if ($limit eq 'w');
+
+ if ($d = int($wm / 86400)) {
+ $output{$day} = $d;
+ $dm = $wm % 86400;
+ } else {
+ $dm = $wm;
+ }
+ return %output if ($limit eq 'd');
+
+ if ($h = int($dm / 3600)) {
+ $output{$hour} = $h;
+ $hm = $dm % 3600;
+ } else {
+ $hm = $dm;
+ }
+ return %output if ($limit eq 'h');
+
+ if ($m = int($hm / 60)) {
+ $output{$minute} = $m;
+ $mm = $hm % 60;
+ } else {
+ $mm = $hm;
+ }
+ return %output if ($limit eq 'm');
+
+ if ($s = int($mm)) {
+ $output{$second} = $s;
+ } else {
+ $output{$second} = 0 unless (keys %output);
+ }
+ return %output;
+}
+
+
+sub generate_fines {
+ my $self = shift;
+ my $client = shift;
+ my $grace = shift;
+ my $circ = shift;
+ my $overbill = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my @circs;
+ if ($circ) {
+ push @circs,
+ action::circulation->search_where( { id => $circ, stop_fines => undef } ),
+ booking::reservation->search_where( { id => $circ, return_time => undef, cancel_time => undef } );
+ } else {
+ push @circs, overdue_circs($grace);
+ }
+
+ my %hoo = map { ( $_->id => $_ ) } actor::org_unit::hours_of_operation->retrieve_all;
+
+ my $penalty = OpenSRF::AppSession->create('open-ils.penalty');
+ for my $c (@circs) {
+
+ my $ctype = ref($c);
+ $ctype =~ s/^.+::(\w+)$/$1/;
+
+ my $due_date_method = 'due_date';
+ my $target_copy_method = 'target_copy';
+ my $circ_lib_method = 'circ_lib';
+ my $recurring_fine_method = 'recurring_fine';
+ my $is_reservation = 0;
+ if ($ctype eq 'reservation') {
+ $is_reservation = 1;
+ $due_date_method = 'end_time';
+ $target_copy_method = 'current_resource';
+ $circ_lib_method = 'pickup_lib';
+ $recurring_fine_method = 'fine_amount';
+ next unless ($c->fine_interval);
+ }
+
+ try {
+ if ($self->method_lookup('open-ils.storage.transaction.current')->run) {
+ $log->debug("Cleaning up after previous transaction\n");
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run;
+ }
+ $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
+ $log->info(
+ sprintf("Processing %s %d...",
+ ($is_reservation ? "reservation" : "circ"), $c->id
+ )
+ );
+
+
+ my $due_dt = $parser->parse_datetime( cleanse_ISO8601( $c->$due_date_method ) );
+
+ my $due = $due_dt->epoch;
+ my $now = time;
+
+ my $fine_interval = $c->fine_interval;
+ $fine_interval =~ s/(\d{2}):(\d{2}):(\d{2})/$1 h $2 m $3 s/o;
+ $fine_interval = interval_to_seconds( $fine_interval );
+
+ if ( $is_reservation and $fine_interval >= interval_to_seconds('1d') ) {
+ my $tz_offset_s = 0;
+ if ($due_dt->strftime('%z') =~ /(-|\+)(\d{2}):?(\d{2})/) {
+ $tz_offset_s = $1 . interval_to_seconds( "${2}h ${3}m");
+ }
+
+ $due -= ($due % $fine_interval) + $tz_offset_s;
+ $now -= ($now % $fine_interval) + $tz_offset_s;
+ }
+
+ $client->respond(
+ "ARG! Overdue $ctype ".$c->id.
+ " for item ".$c->$target_copy_method.
+ " (user ".$c->usr.").\n".
+ "\tItem was due on or before: ".localtime($due)."\n");
+
+ my @fines = money::billing->search_where(
+ { xact => $c->id,
+ btype => 1,
+ billing_ts => { '>' => $c->$due_date_method } },
+ { order_by => 'billing_ts DESC'}
+ );
+
+ my $f_idx = 0;
+ my $fine = $fines[$f_idx] if (@fines);
+ if ($overbill) {
+ $fine = $fines[++$f_idx] while ($fine and $fine->voided);
+ }
+
+ my $current_fine_total = 0;
+ $current_fine_total += int($_->amount * 100) for (grep { $_ and !$_->voided } @fines);
+
+ my $last_fine;
+ if ($fine) {
+ $client->respond( "Last billing time: ".$fine->billing_ts." (clensed format: ".cleanse_ISO8601( $fine->billing_ts ).")");
+ $last_fine = $parser->parse_datetime( cleanse_ISO8601( $fine->billing_ts ) )->epoch;
+ } else {
+ $log->info( "Potential first billing for circ ".$c->id );
+ $last_fine = $due;
+
+ if (0) {
+ if (my $h = $hoo{$c->$circ_lib_method}) {
+
+ $log->info( "Circ lib has an hours-of-operation entry" );
+ # find the day after the due date...
+ $due_dt = $due_dt->add( days => 1 );
+
+ # get the day of the week for that day...
+ my $dow = $due_dt->day_of_week_0;
+ my $dow_open = "dow_${dow}_open";
+ my $dow_close = "dow_${dow}_close";
+
+ my $count = 0;
+ while ( $h->$dow_open eq '00:00:00' and $h->$dow_close eq '00:00:00' ) {
+ # if the circ lib is closed, add a day to the grace period...
+
+ $grace++;
+ $log->info( "Grace period for circ ".$c->id." extended to $grace intervals" );
+ $log->info( "Day of week $dow open $dow_open, close $dow_close" );
+
+ $due_dt = $due_dt->add( days => 1 );
+ $dow = $due_dt->day_of_week_0;
+ $dow_open = "dow_${dow}_open";
+ $dow_close = "dow_${dow}_close";
+
+ $count++;
+
+ # and check for up to a week
+ last if ($count > 6);
+ }
+ }
+ }
+ }
+
+ next if ($last_fine > $now);
+ my $pending_fine_count = int( ($now - $last_fine) / $fine_interval );
+
+ # Generate fines for the interval we are currently inside, when the fine interval is some multiple of 1d
+ $pending_fine_count++ if ($fine_interval && ($fine_interval % 86400 == 0));
+
+ if ( $last_fine == $due # we have no fines yet
+ && $grace # and we have a grace period
+ && $pending_fine_count <= $grace # and we seem to be inside that period
+ && $now < $due + $fine_interval * $grace # and some date math bares that out, then
+ ) {
+ $client->respond( "Still inside grace period of: ". seconds_to_interval( $fine_interval * $grace)."\n" );
+ $log->info( "Circ ".$c->id." is still inside grace period of: $grace [". seconds_to_interval( $fine_interval * $grace).']' );
+ next;
+ }
+
+ $client->respond( "\t$pending_fine_count pending fine(s)\n" );
+ next unless ($pending_fine_count);
+
+ my $recurring_fine = int($c->$recurring_fine_method * 100);
+ my $max_fine = int($c->max_fine * 100);
+
+ my ($latest_billing_ts, $latest_amount) = ('',0);
+ for (my $bill = 1; $bill <= $pending_fine_count; $bill++) {
+
+ if ($current_fine_total >= $max_fine) {
+ $c->update({stop_fines => 'MAXFINES', stop_fines_time => 'now'}) if ($ctype eq 'circulation');
+ $client->respond(
+ "\tMaximum fine level of ".$c->max_fine.
+ " reached for this $ctype.\n".
+ "\tNo more fines will be generated.\n" );
+ last;
+ }
+
+ # XXX Use org time zone (or default to 'local') once we have the ou setting built for that
+ my $billing_ts = DateTime->from_epoch( epoch => $last_fine, time_zone => 'local' );
+ my $current_bill_count = $bill;
+ while ( $current_bill_count ) {
+ $billing_ts->add( seconds_to_interval_hash( $fine_interval ) );
+ $current_bill_count--;
+ }
+
+ my $dow = $billing_ts->day_of_week_0();
+ my $dow_open = "dow_${dow}_open";
+ my $dow_close = "dow_${dow}_close";
+
+ if (my $h = $hoo{$c->$circ_lib_method}) {
+ next if ( $h->$dow_open eq '00:00:00' and $h->$dow_close eq '00:00:00');
+ }
+
+ my $timestamptz = $billing_ts->strftime('%FT%T%z');
+ my @cl = actor::org_unit::closed_date->search_where(
+ { close_start => { '<=' => $timestamptz },
+ close_end => { '>=' => $timestamptz },
+ org_unit => $c->$circ_lib_method }
+ );
+ next if (@cl);
+
+ $current_fine_total += $recurring_fine;
+ $latest_amount += $recurring_fine;
+ $latest_billing_ts = $timestamptz;
+
+ money::billing->create(
+ { xact => ''.$c->id,
+ note => "System Generated Overdue Fine",
+ billing_type => "Overdue materials",
+ btype => 1,
+ amount => sprintf('%0.2f', $recurring_fine/100),
+ billing_ts => $timestamptz,
+ }
+ );
+
+ }
+
+ $client->respond( "\t\tAdding fines totaling $latest_amount for overdue up to $latest_billing_ts\n" )
+ if ($latest_billing_ts and $latest_amount);
+
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+
+ if(1) {
+
+ # Caluclate penalties inline
+ OpenILS::Utils::Penalty->calculate_penalties(
+ undef, $c->usr->to_fieldmapper->id.'', $c->$circ_lib_method->to_fieldmapper->id.'');
+
+ } else {
+
+ # Calculate penalties with an aysnc call to the penalty server. This approach
+ # may lead to duplicate penalties since multiple penalty processes for a
+ # given user may be running at the same time. Leave this here for reference
+ # in case we later find that asyc calls are needed in some environments.
+ $penalty->request(
+ 'open-ils.penalty.patron_penalty.calculate',
+ { patronid => ''.$c->usr,
+ context_org => ''.$c->$circ_lib_method,
+ update => 1,
+ background => 1,
+ }
+ )->gather(1);
+ }
+
+ } catch Error with {
+ my $e = shift;
+ $client->respond( "Error processing overdue $ctype [".$c->id."]:\n\n$e\n" );
+ $log->error("Error processing overdue $ctype [".$c->id."]:\n$e\n");
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run;
+ throw $e if ($e =~ /IS NOT CONNECTED TO THE NETWORK/o);
+ };
+ }
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.circulation.overdue.generate_fines',
+ api_level => 1,
+ stream => 1,
+ method => 'generate_fines',
+);
+
+
+
+sub new_hold_copy_targeter {
+ my $self = shift;
+ my $client = shift;
+ my $check_expire = shift;
+ my $one_hold = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ $self->{target_weight} = {};
+ $self->{max_loops} = {};
+
+ my $holds;
+
+ try {
+ if ($one_hold) {
+ $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
+ $holds = [ action::hold_request->search_where( { id => $one_hold, fulfillment_time => undef, cancel_time => undef } ) ];
+ } elsif ( $check_expire ) {
+
+ # what's the retarget time threashold?
+ my $time = time;
+ $check_expire ||= '12h';
+ $check_expire = interval_to_seconds( $check_expire );
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time() - $check_expire);
+ $year += 1900;
+ $mon += 1;
+ my $expire_threshold = sprintf(
+ '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d-00',
+ $year, $mon, $mday, $hour, $min, $sec
+ );
+
+ # find all the holds holds needing retargeting
+ $holds = [ action::hold_request->search_where(
+ { capture_time => undef,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ frozen => 'f',
+ prev_check_time => { '<=' => $expire_threshold },
+ },
+ { order_by => 'CASE WHEN hold_type = \'F\' THEN 0 ELSE 1 END, selection_depth DESC, request_time,prev_check_time' } ) ];
+
+ # find all the holds holds needing first time targeting
+ push @$holds, action::hold_request->search(
+ capture_time => undef,
+ fulfillment_time => undef,
+ prev_check_time => undef,
+ frozen => 'f',
+ cancel_time => undef,
+ { order_by => 'CASE WHEN hold_type = \'F\' THEN 0 ELSE 1 END, selection_depth DESC, request_time' } );
+ } else {
+
+ # find all the holds holds needing first time targeting ONLY
+ $holds = [ action::hold_request->search(
+ capture_time => undef,
+ fulfillment_time => undef,
+ prev_check_time => undef,
+ cancel_time => undef,
+ frozen => 'f',
+ { order_by => 'CASE WHEN hold_type = \'F\' THEN 0 ELSE 1 END, selection_depth DESC, request_time' } ) ];
+ }
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve uncaptured hold requests:\n\n$e\n";
+ };
+
+ my @closed = actor::org_unit::closed_date->search_where(
+ { close_start => { '<=', 'now' },
+ close_end => { '>=', 'now' } }
+ );
+
+ if ($check_expire) {
+
+ # $check_expire, if it exists, was already converted to seconds
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time() + $check_expire);
+ $year += 1900;
+ $mon += 1;
+
+ my $next_check_time = sprintf(
+ '%s-%0.2d-%0.2dT%0.2d:%0.2d:%0.2d-00',
+ $year, $mon, $mday, $hour, $min, $sec
+ );
+
+
+ my @closed_at_next = actor::org_unit::closed_date->search_where(
+ { close_start => { '<=', $next_check_time },
+ close_end => { '>=', $next_check_time } }
+ );
+
+ my @new_closed;
+ for my $c_at_n (@closed_at_next) {
+ if (grep { ''.$_->org_unit eq ''.$c_at_n->org_unit } @closed) {
+ push @new_closed, $c_at_n;
+ }
+ }
+ @closed = @new_closed;
+ }
+
+ my @successes;
+ my $actor = OpenSRF::AppSession->create('open-ils.actor');
+
+ for my $hold (@$holds) {
+ try {
+ #start a transaction if needed
+ if ($self->method_lookup('open-ils.storage.transaction.current')->run) {
+ $log->debug("Cleaning up after previous transaction\n");
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run;
+ }
+ $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
+ $log->info("Processing hold ".$hold->id."...\n");
+
+ #first, re-fetch the hold, to make sure it's not captured already
+ $hold->remove_from_object_index();
+ $hold = action::hold_request->retrieve( $hold->id );
+
+ die "OK\n" if (!$hold or $hold->capture_time or $hold->cancel_time);
+
+ # remove old auto-targeting maps
+ my @oldmaps = action::hold_copy_map->search( hold => $hold->id );
+ $_->delete for (@oldmaps);
+
+ if ($hold->expire_time) {
+ my $ex_time = $parser->parse_datetime( cleanse_ISO8601( $hold->expire_time ) );
+ if ( DateTime->compare($ex_time, DateTime->now) < 0 ) {
+
+ # cancel cause = un-targeted expiration
+ $hold->update( { cancel_time => 'now', cancel_cause => 1 } );
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+
+ # tell A/T the hold was cancelled
+ my $fm_hold = $hold->to_fieldmapper;
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate',
+ 'hold_request.cancel.expire_no_target', $fm_hold, $fm_hold->pickup_lib);
+
+ die "OK\n";
+ }
+ }
+
+ my $all_copies = [];
+
+ # find filters for MR holds
+ my ($types, $formats, $lang);
+ if (defined($hold->holdable_formats)) {
+ ($types, $formats, $lang) = split '-', $hold->holdable_formats;
+ }
+
+ # find all the potential copies
+ if ($hold->hold_type eq 'M') {
+ for my $r ( map
+ {$_->record}
+ metabib::record_descriptor
+ ->search(
+ record => [
+ map {
+ isTrue($_->deleted) ? () : ($_->id)
+ } metabib::metarecord->retrieve($hold->target)->source_records
+ ],
+ ( $types ? (item_type => [split '', $types]) : () ),
+ ( $formats ? (item_form => [split '', $formats]) : () ),
+ ( $lang ? (item_lang => $lang) : () ),
+ )
+ ) {
+ my ($rtree) = $self
+ ->method_lookup( 'open-ils.storage.biblio.record_entry.ranged_tree')
+ ->run( $r->id, $hold->selection_ou, $hold->selection_depth );
+
+ for my $cn ( @{ $rtree->call_numbers } ) {
+ push @$all_copies,
+ asset::copy->search_where(
+ { id => [map {$_->id} @{ $cn->copies }],
+ deleted => 'f' }
+ ) if ($cn && @{ $cn->copies });
+ }
+ }
+ } elsif ($hold->hold_type eq 'T') {
+ my ($rtree) = $self
+ ->method_lookup( 'open-ils.storage.biblio.record_entry.ranged_tree')
+ ->run( $hold->target, $hold->selection_ou, $hold->selection_depth );
+
+ unless ($rtree) {
+ push @successes, { hold => $hold->id, eligible_copies => 0, error => 'NO_RECORD' };
+ die "OK\n";
+ }
+
+ for my $cn ( @{ $rtree->call_numbers } ) {
+ push @$all_copies,
+ asset::copy->search_where(
+ { id => [map {$_->id} @{ $cn->copies }],
+ deleted => 'f' }
+ ) if ($cn && @{ $cn->copies });
+ }
+ } elsif ($hold->hold_type eq 'V') {
+ my ($vtree) = $self
+ ->method_lookup( 'open-ils.storage.asset.call_number.ranged_tree')
+ ->run( $hold->target, $hold->selection_ou, $hold->selection_depth );
+
+ push @$all_copies,
+ asset::copy->search_where(
+ { id => [map {$_->id} @{ $vtree->copies }],
+ deleted => 'f' }
+ ) if ($vtree && @{ $vtree->copies });
+
+ } elsif ($hold->hold_type eq 'I') {
+ my ($itree) = $self
+ ->method_lookup( 'open-ils.storage.serial.issuance.ranged_tree')
+ ->run( $hold->target, $hold->selection_ou, $hold->selection_depth );
+
+ push @$all_copies,
+ asset::copy->search_where(
+ { id => [map {$_->unit->id} @{ $itree->items }],
+ deleted => 'f' }
+ ) if ($itree && @{ $itree->items });
+
+ } elsif ($hold->hold_type eq 'C' || $hold->hold_type eq 'R' || $hold->hold_type eq 'F') {
+ my $_cp = asset::copy->retrieve($hold->target);
+ push @$all_copies, $_cp if $_cp;
+ }
+
+ # trim unholdables
+ @$all_copies = grep { isTrue($_->status->holdable) &&
+ isTrue($_->location->holdable) &&
+ isTrue($_->holdable) &&
+ !isTrue($_->deleted) &&
+ isTrue($hold->mint_condition) ? isTrue($_->mint_condition) : 1
+ } @$all_copies;
+
+ # let 'em know we're still working
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ # if we have no copies ...
+ if (!ref $all_copies || !@$all_copies) {
+ $log->info("\tNo copies available for targeting at all!\n");
+ push @successes, { hold => $hold->id, eligible_copies => 0, error => 'NO_COPIES' };
+
+ $hold->update( { prev_check_time => 'today', current_copy => undef } );
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+ die "OK\n";
+ }
+
+ my $copy_count = @$all_copies;
+
+ # map the potentials, so that we can pick up checkins
+ # XXX Loop-based targeting may require that /only/ copies from this loop should be added to
+ # XXX the potentials list. If this is the cased, hold_copy_map creation will move down further.
+ $log->debug( "\tMapping ".scalar(@$all_copies)." potential copies for hold ".$hold->id);
+ action::hold_copy_map->create( { hold => $hold->id, target_copy => $_->id } ) for (@$all_copies);
+
+ #$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ my @good_copies;
+ for my $c (@$all_copies) {
+ # current target
+ next if ($c->id eq $hold->current_copy);
+
+ # circ lib is closed
+ next if ( grep { ''.$_->org_unit eq ''.$c->circ_lib } @closed );
+
+ # target of another hold
+ next if (action::hold_request
+ ->search_where(
+ { current_copy => $c->id,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ )
+ );
+
+ # we passed all three, keep it
+ push @good_copies, $c if ($c);
+ #$client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+ }
+
+ $log->debug("\t".scalar(@good_copies)." (non-current) copies available for targeting...");
+
+ my $old_best = $hold->current_copy;
+ $hold->update({ current_copy => undef }) if ($old_best);
+
+ if (!scalar(@good_copies)) {
+ $log->info("\tNo (non-current) copies eligible to fill the hold.");
+ if ( $old_best && grep { ''.$old_best->id eq ''.$_->id } @$all_copies ) {
+ # the old copy is still available
+ $log->debug("\tPushing current_copy back onto the targeting list");
+ push @good_copies, $old_best;
+ } else {
+ # oops, old copy is not available
+ $log->debug("\tcurrent_copy is no longer available for targeting... NEXT HOLD, PLEASE!");
+ $hold->update( { prev_check_time => 'today' } );
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+ push @successes, { hold => $hold->id, eligible_copies => 0, error => 'NO_TARGETS' };
+ die "OK\n";
+ }
+ }
+
+ my $pu_lib = ''.$hold->pickup_lib;
+
+ my $prox_list = [];
+ $$prox_list[0] =
+ [
+ grep {
+ ''.$_->circ_lib eq $pu_lib &&
+ ( $_->status == 0 || $_->status == 7 )
+ } @good_copies
+ ];
+
+ $all_copies = [grep { $_->status == 0 || $_->status == 7 } grep {''.$_->circ_lib ne $pu_lib } @good_copies];
+ # $all_copies is now a list of copies not at the pickup library
+
+ my $best = choose_nearest_copy($hold, $prox_list);
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ if (!$best) {
+ $log->debug("\tNothing at the pickup lib, looking elsewhere among ".scalar(@$all_copies)." copies");
+
+ $self->{max_loops}{$pu_lib} = $actor->request(
+ 'open-ils.actor.ou_setting.ancestor_default' => $pu_lib => 'circ.holds.max_org_unit_target_loops'
+ )->gather(1);
+
+ if (defined($self->{max_loops}{$pu_lib})) {
+ $self->{max_loops}{$pu_lib} = $self->{max_loops}{$pu_lib}{value};
+
+ my %circ_lib_map = map { (''.$_->circ_lib => 1) } @$all_copies;
+ my $circ_lib_list = [keys %circ_lib_map];
+
+ my $cstore = OpenSRF::AppSession->create('open-ils.cstore');
+
+ # Grab the "biggest" loop for this hold so far
+ my $current_loop = $cstore->request(
+ 'open-ils.cstore.json_query',
+ { distinct => 1,
+ select => { aufhmxl => ['max'] },
+ from => 'aufhmxl',
+ where => { hold => $hold->id}
+ }
+ )->gather(1);
+
+ $current_loop = $current_loop->{max} if ($current_loop);
+ $current_loop ||= 1;
+
+ my $exclude_list = $cstore->request(
+ 'open-ils.cstore.json_query.atomic',
+ { distinct => 1,
+ select => { aufhol => ['circ_lib'] },
+ from => 'aufhol',
+ where => { hold => $hold->id}
+ }
+ )->gather(1);
+
+ my @keepers;
+ if ($exclude_list && @$exclude_list) {
+ $exclude_list = [map {$_->{circ_lib}} @$exclude_list];
+ # check to see if we've used up every library in the potentials list
+ for my $l ( @$circ_lib_list ) {
+ my $keep = 1;
+ for my $ex ( @$exclude_list ) {
+ if ($ex eq $l) {
+ $keep = 0;
+ last;
+ }
+ }
+ push(@keepers, $l) if ($keep);
+ }
+ } else {
+ @keepers = @$circ_lib_list;
+ }
+
+ $current_loop++ if (!@keepers);
+
+ if ($self->{max_loops}{$pu_lib} && $self->{max_loops}{$pu_lib} >= $current_loop) {
+ # We haven't exceeded max_loops yet
+ my @keeper_copies;
+ for my $cp ( @$all_copies ) {
+ push(@keeper_copies, $cp) if ( grep { $_ eq ''.$cp->circ_lib } @keepers );
+ }
+ $all_copies = [@keeper_copies];
+ } else {
+ # We have, and should remove potentials and cancel the hold
+ my @oldmaps = action::hold_copy_map->search( hold => $hold->id );
+ $_->delete for (@oldmaps);
+
+ # cancel cause = un-targeted expiration
+ $hold->update( { cancel_time => 'now', cancel_cause => 1 } );
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+
+ # tell A/T the hold was cancelled
+ my $fm_hold = $hold->to_fieldmapper;
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate',
+ 'hold_request.cancel.expire_no_target', $fm_hold, $fm_hold->pickup_lib);
+
+ die "OK\n";
+ }
+ }
+
+ $prox_list = create_prox_list( $self, $pu_lib, $all_copies );
+
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ $best = choose_nearest_copy($hold, $prox_list);
+ }
+
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+ if ($old_best) {
+ # hold wasn't fulfilled, record the fact
+
+ $log->info("\tHold was not (but should have been) fulfilled by ".$old_best->id);
+ action::unfulfilled_hold_list->create(
+ { hold => ''.$hold->id,
+ current_copy => ''.$old_best->id,
+ circ_lib => ''.$old_best->circ_lib,
+ });
+ }
+
+ if ($best) {
+ $hold->update( { current_copy => ''.$best->id, prev_check_time => 'now' } );
+ $log->debug("\tUpdating hold [".$hold->id."] with new 'current_copy' [".$best->id."] for hold fulfillment.");
+ } elsif (
+ $old_best &&
+ !action::hold_request
+ ->search_where(
+ { current_copy => $old_best->id,
+ fulfillment_time => undef,
+ cancel_time => undef,
+ }
+ )
+ ) {
+ $hold->update( { prev_check_time => 'now', current_copy => ''.$old_best->id } );
+ $log->debug( "\tRetargeting the previously targeted copy [".$old_best->id."]" );
+ } else {
+ $hold->update( { prev_check_time => 'now' } );
+ $log->info( "\tThere were no targetable copies for the hold" );
+ process_recall($actor, $log, $hold, \@good_copies);
+ }
+
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+ $log->info("\tProcessing of hold ".$hold->id." complete.");
+
+ push @successes,
+ { hold => $hold->id,
+ old_target => ($old_best ? $old_best->id : undef),
+ eligible_copies => $copy_count,
+ target => ($best ? $best->id : undef) };
+
+ } otherwise {
+ my $e = shift;
+ if ($e !~ /^OK/o) {
+ $log->error("Processing of hold failed: $e");
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run;
+ throw $e if ($e =~ /IS NOT CONNECTED TO THE NETWORK/o);
+ }
+ };
+ }
+
+ return \@successes;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.action.hold_request.copy_targeter',
+ api_level => 1,
+ method => 'new_hold_copy_targeter',
+);
+
+sub process_recall {
+ my ($actor, $log, $hold, $good_copies) = @_;
+
+ # Bail early if we don't have required settings to avoid spurious requests
+ my ($recall_threshold, $return_interval, $fine_rules);
+
+ my $rv = $actor->request(
+ 'open-ils.actor.ou_setting.ancestor_default', ''.$hold->pickup_lib, 'circ.holds.recall_threshold'
+ )->gather(1);
+
+ if (!$rv) {
+ $log->info("Recall threshold was not set; bailing out on hold ".$hold->id." processing.");
+ return;
+ }
+ $recall_threshold = $rv->{value};
+
+ $rv = $actor->request(
+ 'open-ils.actor.ou_setting.ancestor_default', ''.$hold->pickup_lib, 'circ.holds.recall_return_interval'
+ )->gather(1);
+
+ if (!$rv) {
+ $log->info("Recall return interval was not set; bailing out on hold ".$hold->id." processing.");
+ return;
+ }
+ $return_interval = $rv->{value};
+
+ $rv = $actor->request(
+ 'open-ils.actor.ou_setting.ancestor_default', ''.$hold->pickup_lib, 'circ.holds.recall_fine_rules'
+ )->gather(1);
+
+ if ($rv) {
+ $fine_rules = $rv->{value};
+ }
+
+ $log->info("Recall threshold: $recall_threshold; return interval: $return_interval");
+
+ # We want checked out copies (status = 1) at the hold pickup lib
+ my $all_copies = [grep { $_->status == 1 } grep {''.$_->circ_lib eq ''.$hold->pickup_lib } @$good_copies];
+
+ my @copy_ids = map { $_->id } @$all_copies;
+
+ $log->info("Found " . scalar(@$all_copies) . " eligible checked-out copies for recall");
+
+ my $return_date = DateTime->now(time_zone => 'local')->add(seconds => interval_to_seconds($return_interval))->iso8601();
+
+ # Iterate over the checked-out copies to find a copy with a
+ # loan period longer than the recall threshold:
+ my $circs = [ action::circulation->search_where(
+ { target_copy => \@copy_ids, checkin_time => undef, duration => { '>' => $recall_threshold } },
+ { order_by => 'due_date ASC' }
+ )];
+
+ # If we have a candidate copy, then:
+ if (scalar(@$circs)) {
+ my $circ = $circs->[0];
+ $log->info("Recalling circ ID : " . $circ->id);
+
+ # Give the user a new due date of either a full recall threshold,
+ # or the return interval, whichever is further in the future
+ my $threshold_date = DateTime::Format::ISO8601->parse_datetime(cleanse_ISO8601($circ->xact_start))->add(seconds => interval_to_seconds($recall_threshold))->iso8601();
+ if (DateTime->compare(DateTime::Format::ISO8601->parse_datetime($threshold_date), DateTime::Format::ISO8601->parse_datetime($return_date)) == 1) {
+ $return_date = $threshold_date;
+ }
+
+ my $update_fields = {
+ due_date => $return_date,
+ renewal_remaining => 0,
+ };
+
+ # If the OU hasn't defined new fine rules for recalls, keep them
+ # as they were
+ if ($fine_rules) {
+ $log->info("Apply recall fine rules: $fine_rules");
+ my $rules = OpenSRF::Utils::JSON->JSON2perl($fine_rules);
+ $update_fields->{recurring_fine} = $rules->[0];
+ $update_fields->{fine_interval} = $rules->[1];
+ $update_fields->{max_fine} = $rules->[2];
+ }
+
+ # Adjust circ for current user
+ $circ->update($update_fields);
+
+ # Create trigger event for notifying current user
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'circ.recall.target', $circ->to_fieldmapper(), $circ->circ_lib->id);
+ }
+
+ $log->info("Processing of hold ".$hold->id." for recall is now complete.");
+}
+
+sub reservation_targeter {
+ my $self = shift;
+ my $client = shift;
+ my $one_reservation = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $reservations;
+
+ try {
+ if ($one_reservation) {
+ $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
+ $reservations = [ booking::reservation->search_where( { id => $one_reservation, capture_time => undef, cancel_time => undef } ) ];
+ } else {
+
+ # find all the reservations needing targeting
+ $reservations = [
+ booking::reservation->search_where(
+ { current_resource => undef,
+ cancel_time => undef,
+ start_time => { '>' => 'now' }
+ },
+ { order_by => 'start_time' }
+ )
+ ];
+ }
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve reservation requests:\n\n$e\n";
+ };
+
+ my @successes = ();
+ for my $bresv (@$reservations) {
+ try {
+ #start a transaction if needed
+ if ($self->method_lookup('open-ils.storage.transaction.current')->run) {
+ $log->debug("Cleaning up after previous transaction\n");
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run;
+ }
+ $self->method_lookup('open-ils.storage.transaction.begin')->run( $client );
+ $log->info("Processing reservation ".$bresv->id."...\n");
+
+ #first, re-fetch the hold, to make sure it's not captured already
+ $bresv->remove_from_object_index();
+ $bresv = booking::reservation->retrieve( $bresv->id );
+
+ die "OK\n" if (!$bresv or $bresv->capture_time or $bresv->cancel_time);
+
+ my $end_time = $parser->parse_datetime( cleanse_ISO8601( $bresv->end_time ) );
+ if (DateTime->compare($end_time, DateTime->now) < 0) {
+
+ # cancel cause = un-targeted expiration
+ $bresv->update( { cancel_time => 'now' } );
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+
+ # tell A/T the reservation was cancelled
+ my $fm_bresv = $bresv->to_fieldmapper;
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate',
+ 'booking.reservation.cancel.expire_no_target', $fm_bresv, $fm_bresv->pickup_lib);
+
+ die "OK\n";
+ }
+
+ my $possible_resources;
+
+ # find all the potential resources
+ if (!$bresv->target_resource) {
+ my $filter = { type => $bresv->target_resource_type };
+ my $attr_maps = [ booking::reservation_attr_value_map->search( reservation => $bresv->id) ];
+
+ $filter->{attribute_values} = [ map { $_->attr_value } @$attr_maps ] if (@$attr_maps);
+
+ $filter->{available} = [$bresv->start_time, $bresv->end_time];
+ my $ses = OpenSRF::AppSession->create('open-ils.booking');
+ $possible_resources = $ses->request('open-ils.booking.resources.filtered_id_list', undef, $filter)->gather(1);
+ } else {
+ $possible_resources = $bresv->target_resource;
+ }
+
+ my $all_resources = [ booking::resource->search( id => $possible_resources ) ];
+ @$all_resources = grep { isTrue($_->type->transferable) || $_->owner.'' eq $bresv->pickup_lib.'' } @$all_resources;
+
+
+ my @good_resources = ();
+ my %conflicts = ();
+ for my $res (@$all_resources) {
+ unless (isTrue($res->type->catalog_item)) {
+ push @good_resources, $res;
+ next;
+ }
+
+ my $copy = [ asset::copy->search( deleted => 'f', barcode => $res->barcode )]->[0];
+
+ unless ($copy) {
+ push @good_resources, $res;
+ next;
+ }
+
+ if ($copy->status->id == 0 || $copy->status->id == 7) {
+ push @good_resources, $res;
+ next;
+ }
+
+ if ($copy->status->id == 1) {
+ my $circs = [ action::circulation->search_where(
+ {target_copy => $copy->id, checkin_time => undef },
+ { order_by => 'id DESC' }
+ ) ];
+
+ if (@$circs) {
+ my $due_date = $circs->[0]->due_date;
+ $due_date = $parser->parse_datetime( cleanse_ISO8601( $due_date ) );
+ my $start_time = $parser->parse_datetime( cleanse_ISO8601( $bresv->start_time ) );
+ if (DateTime->compare($start_time, $due_date) < 0) {
+ $conflicts{$res->id} = $circs->[0]->to_fieldmapper;
+ next;
+ }
+
+ push @good_resources, $res;
+ }
+
+ next;
+ }
+
+ push @good_resources, $res if (isTrue($copy->status->holdable));
+ }
+
+ # let 'em know we're still working
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ # if we have no copies ...
+ if (!@good_resources) {
+ $log->info("\tNo resources available for targeting at all!\n");
+ push @successes, { reservation => $bresv->id, eligible_copies => 0, error => 'NO_COPIES', conflicts => \%conflicts };
+
+
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+ die "OK\n";
+ }
+
+ $log->debug("\t".scalar(@good_resources)." resources available for targeting...");
+
+ my $prox_list = [];
+ $$prox_list[0] =
+ [
+ grep {
+ $_->owner == $bresv->pickup_lib
+ } @good_resources
+ ];
+
+ $all_resources = [grep {$_->owner != $bresv->pickup_lib } @good_resources];
+ # $all_copies is now a list of copies not at the pickup library
+
+ my $best = shift @good_resources;
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ if (!$best) {
+ $log->debug("\tNothing at the pickup lib, looking elsewhere among ".scalar(@$all_resources)." resources");
+
+ $prox_list =
+ map { $_->[1] }
+ sort { $a->[0] <=> $b->[0] }
+ map {
+ [ actor::org_unit_proximity->search_where(
+ { from_org => $bresv->pickup_lib.'', to_org => $_->owner.'' }
+ )->[0]->prox,
+ $_
+ ]
+ } @$all_resources;
+
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ $best = shift @$prox_list
+ }
+
+ if ($best) {
+ $bresv->update( { current_resource => ''.$best->id } );
+ $log->debug("\tUpdating reservation [".$bresv->id."] with new 'current_resource' [".$best->id."] for reservation fulfillment.");
+ }
+
+ $self->method_lookup('open-ils.storage.transaction.commit')->run;
+ $log->info("\tProcessing of bresv ".$bresv->id." complete.");
+
+ push @successes,
+ { reservation => $bresv->id,
+ current_resource => ($best ? $best->id : undef) };
+
+ } otherwise {
+ my $e = shift;
+ if ($e !~ /^OK/o) {
+ $log->error("Processing of bresv failed: $e");
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run;
+ throw $e if ($e =~ /IS NOT CONNECTED TO THE NETWORK/o);
+ }
+ };
+ }
+
+ return \@successes;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.booking.reservation.resource_targeter',
+ api_level => 1,
+ method => 'reservation_targeter',
+);
+
+my $locations;
+my $statuses;
+my %cache = (titles => {}, cns => {});
+
+sub copy_hold_capture {
+ my $self = shift;
+ my $hold = shift;
+ my $cps = shift;
+
+ if (!defined($cps)) {
+ try {
+ $cps = [ asset::copy->search( id => $hold->target ) ];
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve initial volume list:\n\n$e\n";
+ };
+ }
+
+ my @copies = grep { $_->holdable } @$cps;
+
+ for (my $i = 0; $i < @$cps; $i++) {
+ next unless $$cps[$i];
+
+ my $cn = $cache{cns}{$copies[$i]->call_number};
+ my $rec = $cache{titles}{$cn->record};
+ $copies[$i] = undef if ($copies[$i] && !grep{ $copies[$i]->status eq $_->id}@$statuses);
+ $copies[$i] = undef if ($copies[$i] && !grep{ $copies[$i]->location eq $_->id}@$locations);
+ $copies[$i] = undef if (
+ !$copies[$i] ||
+ !$self->{user_filter}->request(
+ 'open-ils.circ.permit_hold',
+ $hold->to_fieldmapper, do {
+ my $cp_fm = $copies[$i]->to_fieldmapper;
+ $cp_fm->circ_lib( $copies[$i]->circ_lib->to_fieldmapper );
+ $cp_fm->location( $copies[$i]->location->to_fieldmapper );
+ $cp_fm->status( $copies[$i]->status->to_fieldmapper );
+ $cp_fm;
+ },
+ { title => $rec->to_fieldmapper,
+ usr => actor::user->retrieve($hold->usr)->to_fieldmapper,
+ requestor => actor::user->retrieve($hold->requestor)->to_fieldmapper,
+ })->gather(1)
+ );
+ $self->{client}->status( new OpenSRF::DomainObject::oilsContinueStatus );
+ }
+
+ @copies = grep { $_ } @copies;
+
+ my $count = @copies;
+
+ return unless ($count);
+
+ action::hold_copy_map->search( hold => $hold->id )->delete_all;
+
+ my @maps;
+ $self->{client}->respond( "\tMapping ".scalar(@copies)." eligable copies for hold ".$hold->id."\n");
+ for my $c (@copies) {
+ push @maps, action::hold_copy_map->create( { hold => $hold->id, target_copy => $c->id } );
+ }
+ $self->{client}->respond( "\tA total of ".scalar(@maps)." mapping were created for hold ".$hold->id."\n");
+
+ return \@copies;
+}
+
+
+sub choose_nearest_copy {
+ my $hold = shift;
+ my $prox_list = shift;
+
+ for my $p ( 0 .. int( scalar(@$prox_list) - 1) ) {
+ next unless (ref $$prox_list[$p]);
+
+ my @capturable = @{ $$prox_list[$p] };
+ next unless (@capturable);
+
+ my $rand = int(rand(scalar(@capturable)));
+ my %seen = ();
+ while (my ($c) = splice(@capturable, $rand, 1)) {
+ return $c if !exists($seen{$c->id}) && ( OpenILS::Utils::PermitHold::permit_copy_hold(
+ { title => $c->call_number->record->to_fieldmapper,
+ title_descriptor => $c->call_number->record->record_descriptor->next->to_fieldmapper,
+ patron => $hold->usr->to_fieldmapper,
+ copy => $c->to_fieldmapper,
+ requestor => $hold->requestor->to_fieldmapper,
+ request_lib => $hold->request_lib->to_fieldmapper,
+ pickup_lib => $hold->pickup_lib->id,
+ retarget => 1
+ }
+ ));
+ $seen{$c->id}++;
+
+ last unless(@capturable);
+ $rand = int(rand(scalar(@capturable)));
+ }
+ }
+}
+
+sub create_prox_list {
+ my $self = shift;
+ my $lib = shift;
+ my $copies = shift;
+
+ my $actor = OpenSRF::AppSession->create('open-ils.actor');
+
+ my @prox_list;
+ for my $cp (@$copies) {
+ my ($prox) = $self->method_lookup('open-ils.storage.asset.copy.proximity')->run( $cp, $lib );
+ next unless (defined($prox));
+
+ my $copy_circ_lib = ''.$cp->circ_lib;
+ # Fetch the weighting value for hold targeting, defaulting to 1
+ $self->{target_weight}{$copy_circ_lib} ||= $actor->request(
+ 'open-ils.actor.ou_setting.ancestor_default' => $copy_circ_lib.'' => 'circ.holds.org_unit_target_weight'
+ )->gather(1);
+ $self->{target_weight}{$copy_circ_lib} = $self->{target_weight}{$copy_circ_lib}{value} if (ref $self->{target_weight}{$copy_circ_lib});
+ $self->{target_weight}{$copy_circ_lib} ||= 1;
+
+ $prox_list[$prox] = [] unless defined($prox_list[$prox]);
+ for my $w ( 1 .. $self->{target_weight}{$copy_circ_lib} ) {
+ push @{$prox_list[$prox]}, $cp;
+ }
+ }
+ return \@prox_list;
+}
+
+sub volume_hold_capture {
+ my $self = shift;
+ my $hold = shift;
+ my $vols = shift;
+
+ if (!defined($vols)) {
+ try {
+ $vols = [ asset::call_number->search( id => $hold->target ) ];
+ $cache{cns}{$_->id} = $_ for (@$vols);
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve initial volume list:\n\n$e\n";
+ };
+ }
+
+ my @v_ids = map { $_->id } @$vols;
+
+ my $cp_list;
+ try {
+ $cp_list = [ asset::copy->search( call_number => \@v_ids ) ];
+
+ } catch Error with {
+ my $e = shift;
+ warn "Could not retrieve copy list:\n\n$e\n";
+ };
+
+ $self->copy_hold_capture($hold,$cp_list) if (ref $cp_list and @$cp_list);
+}
+
+sub title_hold_capture {
+ my $self = shift;
+ my $hold = shift;
+ my $titles = shift;
+
+ if (!defined($titles)) {
+ try {
+ $titles = [ biblio::record_entry->search( id => $hold->target ) ];
+ $cache{titles}{$_->id} = $_ for (@$titles);
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve initial title list:\n\n$e\n";
+ };
+ }
+
+ my @t_ids = map { $_->id } @$titles;
+ my $cn_list;
+ try {
+ ($cn_list) = $self->method_lookup('open-ils.storage.direct.asset.call_number.search.record.atomic')->run( \@t_ids );
+
+ } catch Error with {
+ my $e = shift;
+ warn "Could not retrieve volume list:\n\n$e\n";
+ };
+
+ $cache{cns}{$_->id} = $_ for (@$cn_list);
+
+ $self->volume_hold_capture($hold,$cn_list) if (ref $cn_list and @$cn_list);
+}
+
+sub metarecord_hold_capture {
+ my $self = shift;
+ my $hold = shift;
+
+ my $titles;
+ try {
+ $titles = [ metabib::metarecord_source_map->search( metarecord => $hold->target) ];
+
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve initial title list:\n\n$e\n";
+ };
+
+ try {
+ my @recs = map {$_->record} metabib::record_descriptor->search( record => $titles, item_type => [split '', $hold->holdable_formats] );
+
+ $titles = [ biblio::record_entry->search( id => \@recs ) ];
+
+ } catch Error with {
+ my $e = shift;
+ die "Could not retrieve format-pruned title list:\n\n$e\n";
+ };
+
+
+ $cache{titles}{$_->id} = $_ for (@$titles);
+ $self->title_hold_capture($hold,$titles) if (ref $titles and @$titles);
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::actor;
+use base qw/OpenILS::Application::Storage/;
+use OpenILS::Application::Storage::CDBI::actor;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::Utils qw/:datetime/;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::SettingsClient;
+
+use DateTime;
+use DateTime::Format::ISO8601;
+use DateTime::Set;
+use DateTime::SpanSet;
+
+
+my $_dt_parser = DateTime::Format::ISO8601->new;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub new_usergroup_id {
+ return actor::user->db_Main->selectrow_array("select nextval('actor.usr_usrgroup_seq'::regclass)");
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.group_id.new',
+ api_level => 1,
+ method => 'new_usergroup_id',
+);
+
+sub juv_to_adult {
+ my $self = shift;
+ my $client = shift;
+ my $adult_age = shift;
+
+ my $sql = <<" SQL";
+ UPDATE actor.usr
+ SET juvenile = FALSE
+ WHERE AGE(dob) > ?::INTERVAL;
+ SQL
+
+ my $sth = actor::user->db_Main->prepare_cached($sql);
+ $sth->execute($adult_age);
+
+ return $sth->rows;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.juvenile_to_adult',
+ api_level => 1,
+ method => 'juv_to_adult',
+);
+
+sub usr_total_owed {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+
+ my $sql = <<" SQL";
+ SELECT x.usr,
+ SUM(COALESCE((SELECT SUM(b.amount) FROM money.billing b WHERE b.voided IS FALSE AND b.xact = x.id),0.0)) -
+ SUM(COALESCE((SELECT SUM(p.amount) FROM money.payment p WHERE p.voided IS FALSE AND p.xact = x.id),0.0))
+ FROM money.billable_xact x
+ WHERE x.usr = ? AND x.xact_finish IS NULL
+ GROUP BY 1
+ SQL
+
+ my (undef,$val) = actor::user->db_Main->selectrow_array($sql, {}, $usr);
+
+ return $val;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.total_owed',
+ api_level => 1,
+ method => 'usr_total_owed',
+);
+
+sub usr_breakdown_out {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+
+ $self->method_lookup('open-ils.storage.transaction.begin')->run($client);
+
+ my $out_sql = <<" SQL";
+ SELECT id
+ FROM action.circulation
+ WHERE usr = ?
+ AND checkin_time IS NULL
+ AND ( (fine_interval >= '1 day' AND due_date >= 'today')
+ OR (fine_interval < '1 day' AND due_date > 'now' ))
+ AND (stop_fines IS NULL
+ OR stop_fines NOT IN ('LOST','CLAIMSRETURNED','LONGOVERDUE'))
+ SQL
+
+ my $out = actor::user->db_Main->selectcol_arrayref($out_sql, {}, $usr);
+
+ my $od_sql = <<" SQL";
+ SELECT id
+ FROM action.circulation
+ WHERE usr = ?
+ AND checkin_time IS NULL
+ AND ( (fine_interval >= '1 day' AND due_date < 'today')
+ OR (fine_interval < '1 day' AND due_date < 'now' ))
+ AND (stop_fines IS NULL
+ OR stop_fines NOT IN ('LOST','CLAIMSRETURNED','LONGOVERDUE'))
+ SQL
+
+ my $od = actor::user->db_Main->selectcol_arrayref($od_sql, {}, $usr);
+
+ my $lost_sql = <<" SQL";
+ SELECT id
+ FROM action.circulation
+ WHERE usr = ? AND checkin_time IS NULL AND xact_finish IS NULL AND stop_fines = 'LOST'
+ SQL
+
+ my $lost = actor::user->db_Main->selectcol_arrayref($lost_sql, {}, $usr);
+
+ my $cl_sql = <<" SQL";
+ SELECT id
+ FROM action.circulation
+ WHERE usr = ? AND checkin_time IS NULL AND stop_fines = 'CLAIMSRETURNED'
+ SQL
+
+ my $cl = actor::user->db_Main->selectcol_arrayref($cl_sql, {}, $usr);
+
+ my $lo_sql = <<" SQL";
+ SELECT id
+ FROM action.circulation
+ WHERE usr = ? AND checkin_time IS NULL AND stop_fines = 'LONGOVERDUE'
+ SQL
+
+ my $lo = actor::user->db_Main->selectcol_arrayref($lo_sql, {}, $usr);
+
+ $self->method_lookup('open-ils.storage.transaction.rollback')->run($client);
+
+ if ($self->api_name =~/count$/o) {
+ return { total => scalar(@$out) + scalar(@$od) + scalar(@$lost) + scalar(@$cl) + scalar(@$lo),
+ out => scalar(@$out),
+ overdue => scalar(@$od),
+ lost => scalar(@$lost),
+ claims_returned => scalar(@$cl),
+ long_overdue => scalar(@$lo),
+ };
+ }
+
+ return { out => $out,
+ overdue => $od,
+ lost => $lost,
+ claims_returned => $cl,
+ long_overdue => $lo,
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.checked_out',
+ api_level => 1,
+ method => 'usr_breakdown_out',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.checked_out.count',
+ api_level => 1,
+ method => 'usr_breakdown_out',
+);
+
+sub usr_total_out {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+
+ my $sql = <<" SQL";
+ SELECT count(*)
+ FROM action.circulation
+ WHERE usr = ? AND checkin_time IS NULL
+ SQL
+
+ my ($val) = actor::user->db_Main->selectrow_array($sql, {}, $usr);
+
+ return $val;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.total_out',
+ api_level => 1,
+ method => 'usr_total_out',
+);
+
+sub calc_proximity {
+ my $self = shift;
+ my $client = shift;
+
+ local $OpenILS::Application::Storage::WRITE = 1;
+
+ my $delete_sql = <<" SQL";
+ DELETE FROM actor.org_unit_proximity;
+ SQL
+
+ my $insert_sql = <<" SQL";
+ INSERT INTO actor.org_unit_proximity (from_org, to_org, prox)
+ SELECT l.id,
+ r.id,
+ actor.org_unit_proximity(l.id,r.id)
+ FROM actor.org_unit l,
+ actor.org_unit r;
+ SQL
+
+ actor::org_unit_proximity->db_Main->do($delete_sql);
+ actor::org_unit_proximity->db_Main->do($insert_sql);
+
+ return 1;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.org_unit.refresh_proximity',
+ api_level => 1,
+ method => 'calc_proximity',
+);
+
+sub make_hoo_spanset {
+ my $hoo = shift;
+ return undef unless $hoo;
+
+ my $today = shift || DateTime->now;
+
+ my $tz = OpenSRF::AppSession->create('open-ils.actor')->request(
+ 'open-ils.actor.ou_setting.ancestor_default' => $hoo->id.'' => 'org_unit.timezone'
+ )->gather(1) || DateTime::TimeZone->new( name => 'local' )->name;
+
+ my $current_dow = $today->day_of_week_0;
+
+ my $spanset = DateTime::SpanSet->empty_set;
+ for my $d ( 0 .. 6 ) {
+
+ my $omethod = 'dow_'.$d.'_open';
+ my $cmethod = 'dow_'.$d.'_close';
+
+ my $open = interval_to_seconds($hoo->$omethod());
+ my $close = interval_to_seconds($hoo->$cmethod());
+
+ next if ($open == $close && $open == 0);
+
+ my $dow_offset = ($d - $current_dow) * $one_day;
+ $close += $one_day if ($close <= $open);
+
+ $spanset = $spanset->union(
+ DateTime::Span->new(
+ start => $today->clone->add( seconds => $dow_offset + $open ),
+ end => $today->clone->add( seconds => $dow_offset + $close )
+ )
+ );
+ }
+
+ return $spanset->complement;
+}
+
+sub make_closure_spanset {
+ my $closures = shift;
+ return undef unless $closures;
+
+ my $spanset = DateTime::SpanSet->empty_set;
+ for my $k ( keys %$closures ) {
+ my $c = $$closures{$k};
+
+ $spanset = $spanset->union(
+ DateTime::Span->new(
+ start => $_dt_parser->parse_datetime(cleanse_ISO8601($c->{close_start})),
+ end => $_dt_parser->parse_datetime(cleanse_ISO8601($c->{close_end}))
+ )
+ );
+ }
+
+ return $spanset;
+}
+
+sub new_org_closed_overlap {
+ my $self = shift;
+ my $client = shift;
+ my $ou = shift;
+ my $date = shift;
+ my $direction = shift || 0;
+ my $no_hoo = shift || 0;
+
+ return undef unless ($date && $ou);
+
+ # we're given a date and a direction, find any closures that contain the date
+ my $t = actor::org_unit::closed_date->table;
+ my $sql = <<" SQL";
+ SELECT *
+ FROM $t
+ WHERE close_end > ?
+ AND org_unit = ?
+ ORDER BY close_start ASC, close_end DESC
+ LIMIT 1
+ SQL
+
+ $date = cleanse_ISO8601($date);
+
+ my $target_date = $_dt_parser->parse_datetime( $date );
+ my ($begin, $end) = ($target_date, $target_date);
+
+ # create a spanset from the closures that contain the $date
+ my $closure_spanset = make_closure_spanset(
+ actor::org_unit::closed_date->db_Main->selectall_hashref( $sql, 'id', {}, $date, $ou )
+ );
+
+ if ($closure_spanset && $closure_spanset->intersects( $target_date )) {
+ my $closure_intersection = $closure_spanset->intersection( $target_date );
+ $begin = $closure_intersection->min;
+ $end = $closure_intersection->max;
+
+ if ( $direction <= 0 ) {
+ $begin->subtract( minutes => 1 );
+
+ while ( my $_b = new_org_closed_overlap($self, $client, $ou, $begin->strftime('%FT%T%z'), -1, 1 ) ) {
+ $begin = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
+ }
+ }
+
+ if ( $direction >= 0 ) {
+ $end->add( minutes => 1 );
+
+ while ( my $_a = new_org_closed_overlap($self, $client, $ou, $end->strftime('%FT%T%z'), 1, 1 ) ) {
+ $end = $_dt_parser->parse_datetime( cleanse_ISO8601($_a->{end}) );
+ }
+ }
+ }
+
+ if ( !$no_hoo ) {
+
+ my $begin_hoo = make_hoo_spanset(actor::org_unit::hours_of_operation->retrieve($ou), $begin);
+ my $end_hoo = make_hoo_spanset(actor::org_unit::hours_of_operation->retrieve($ou), $end );
+
+
+ if ( $begin_hoo && $direction <= 0 && $begin_hoo->intersects($begin) ) {
+ my $hoo_intersection = $begin_hoo->intersection( $begin );
+ $begin = $hoo_intersection->min;
+ $begin->subtract( minutes => 1 );
+
+ while ( my $_b = new_org_closed_overlap($self, $client, $ou, $begin->strftime('%FT%T%z'), -1 ) ) {
+ $begin = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
+ }
+ }
+
+ if ( $end_hoo && $direction >= 0 && $end_hoo->intersects($end) ) {
+ my $hoo_intersection = $end_hoo->intersection( $end );
+ $end = $hoo_intersection->max;
+ $end->add( minutes => 1 );
+
+
+ while ( my $_b = new_org_closed_overlap($self, $client, $ou, $end->strftime('%FT%T%z'), -1 ) ) {
+ $end = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{end}) );
+ }
+ }
+ }
+
+ my $start = $begin->strftime('%FT%T%z');
+ my $stop = $end->strftime('%FT%T%z');
+
+ return undef if ($start eq $stop);
+ return { start => $start, end => $stop };
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.org_unit.closed_date.overlap',
+ api_level => 0,
+ method => 'new_org_closed_overlap',
+);
+
+sub org_closed_overlap {
+ my $self = shift;
+ my $client = shift;
+ my $ou = shift;
+ my $date = shift;
+ my $direction = shift || 0;
+ my $no_hoo = shift || 0;
+
+ return undef unless ($date && $ou);
+
+ my $t = actor::org_unit::closed_date->table;
+ my $sql = <<" SQL";
+ SELECT *
+ FROM $t
+ WHERE ? between close_start and close_end
+ AND org_unit = ?
+ ORDER BY close_start ASC, close_end DESC
+ LIMIT 1
+ SQL
+
+ $date = cleanse_ISO8601($date);
+ my ($begin, $end) = ($date,$date);
+
+ my $hoo = actor::org_unit::hours_of_operation->retrieve($ou);
+
+ if (my $closure = actor::org_unit::closed_date->db_Main->selectrow_hashref( $sql, {}, $date, $ou )) {
+ $begin = cleanse_ISO8601($closure->{close_start});
+ $end = cleanse_ISO8601($closure->{close_end});
+
+ if ( $direction <= 0 ) {
+ $before = $_dt_parser->parse_datetime( $begin );
+ $before->subtract( minutes => 1 );
+
+ while ( my $_b = org_closed_overlap($self, $client, $ou, $before->strftime('%FT%T%z'), -1, 1 ) ) {
+ $before = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
+ }
+ $begin = cleanse_ISO8601($before->strftime('%FT%T%z'));
+ }
+
+ if ( $direction >= 0 ) {
+ $after = $_dt_parser->parse_datetime( $end );
+ $after->add( minutes => 1 );
+
+ while ( my $_a = org_closed_overlap($self, $client, $ou, $after->strftime('%FT%T%z'), 1, 1 ) ) {
+ $after = $_dt_parser->parse_datetime( cleanse_ISO8601($_a->{end}) );
+ }
+ $end = cleanse_ISO8601($after->strftime('%FT%T%z'));
+ }
+ }
+
+ if ( !$no_hoo ) {
+ if ( $hoo ) {
+
+ if ( $direction <= 0 ) {
+ my $begin_dow = $_dt_parser->parse_datetime( $begin )->day_of_week_0;
+ my $begin_open_meth = "dow_".$begin_dow."_open";
+ my $begin_close_meth = "dow_".$begin_dow."_close";
+
+ my $count = 1;
+ while ($hoo->$begin_open_meth eq '00:00:00' and $hoo->$begin_close_meth eq '00:00:00') {
+ $begin = cleanse_ISO8601($_dt_parser->parse_datetime( $begin )->subtract( days => 1)->strftime('%FT%T%z'));
+ $begin_dow++;
+ $begin_dow %= 7;
+ $count++;
+ last if ($count > 6);
+ $begin_open_meth = "dow_".$begin_dow."_open";
+ $begin_close_meth = "dow_".$begin_dow."_close";
+ }
+
+ if (my $closure = actor::org_unit::closed_date->db_Main->selectrow_hashref( $sql, {}, $begin, $ou )) {
+ $before = $_dt_parser->parse_datetime( $begin );
+ $before->subtract( minutes => 1 );
+ while ( my $_b = org_closed_overlap($self, $client, $ou, $before->strftime('%FT%T%z'), -1 ) ) {
+ $before = $_dt_parser->parse_datetime( cleanse_ISO8601($_b->{start}) );
+ }
+ }
+ }
+
+ if ( $direction >= 0 ) {
+ my $end_dow = $_dt_parser->parse_datetime( $end )->day_of_week_0;
+ my $end_open_meth = "dow_".$end_dow."_open";
+ my $end_close_meth = "dow_".$end_dow."_close";
+
+ $count = 1;
+ while ($hoo->$end_open_meth eq '00:00:00' and $hoo->$end_close_meth eq '00:00:00') {
+ $end = cleanse_ISO8601($_dt_parser->parse_datetime( $end )->add( days => 1)->strftime('%FT%T%z'));
+ $end_dow++;
+ $end_dow %= 7;
+ $count++;
+ last if ($count > 6);
+ $end_open_meth = "dow_".$end_dow."_open";
+ $end_close_meth = "dow_".$end_dow."_close";
+ }
+
+ if (my $closure = actor::org_unit::closed_date->db_Main->selectrow_hashref( $sql, {}, $end, $ou )) {
+ $after = $_dt_parser->parse_datetime( $end );
+ $after->add( minutes => 1 );
+
+ while ( my $_a = org_closed_overlap($self, $client, $ou, $after->strftime('%FT%T%z'), 1 ) ) {
+ $after = $_dt_parser->parse_datetime( cleanse_ISO8601($_a->{end}) );
+ }
+ $end = cleanse_ISO8601($after->strftime('%FT%T%z'));
+ }
+ }
+
+ }
+ }
+
+ if ($begin eq $date && $end eq $date) {
+ return undef;
+ }
+
+ return { start => $begin, end => $end };
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.org_unit.closed_date.overlap',
+ api_level => 1,
+ method => 'org_closed_overlap',
+);
+
+sub user_by_barcode {
+ my $self = shift;
+ my $client = shift;
+ my @barcodes = shift;
+
+ return undef unless @barcodes;
+
+ for my $card ( actor::card->search( { barcode => @barcodes } ) ) {
+ next unless $card;
+ if (@barcodes == 1) {
+ return $card->usr->to_fieldmapper;
+ }
+ $client->respond( $card->usr->to_fieldmapper);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.actor.user.search.barcode',
+ api_level => 1,
+ method => 'user_by_barcode',
+ stream => 1,
+ cachable => 1,
+);
+
+sub lost_barcodes {
+ my $self = shift;
+ my $client = shift;
+
+ my $c = actor::card->table;
+ my $p = actor::user->table;
+
+ my $sql = "SELECT c.barcode FROM $c c JOIN $p p ON (c.usr = p.id) WHERE p.card <> c.id";
+
+ my $list = actor::user->db_Main->selectcol_arrayref($sql);
+ for my $bc ( @$list ) {
+ $client->respond($bc);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.lost_barcodes',
+ api_level => 1,
+ stream => 1,
+ method => 'lost_barcodes',
+ signature => <<' NOTE',
+ Returns an array of barcodes that belong to lost cards.
+ @return array of barcodes
+ NOTE
+);
+
+sub expired_barcodes {
+ my $self = shift;
+ my $client = shift;
+
+ my $c = actor::card->table;
+ my $p = actor::user->table;
+
+ my $sql = "SELECT c.barcode FROM $c c JOIN $p p ON (c.usr = p.id) WHERE p.expire_date < CURRENT_DATE";
+
+ my $list = actor::user->db_Main->selectcol_arrayref($sql);
+ for my $bc ( @$list ) {
+ $client->respond($bc);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.expired_barcodes',
+ api_level => 1,
+ stream => 1,
+ method => 'expired_barcodes',
+ signature => <<' NOTE',
+ Returns an array of barcodes that are currently expired.
+ @return array of barcodes
+ NOTE
+);
+
+sub barred_barcodes {
+ my $self = shift;
+ my $client = shift;
+
+ my $c = actor::card->table;
+ my $p = actor::user->table;
+
+ my $sql = "SELECT c.barcode FROM $c c JOIN $p p ON (c.usr = p.id) WHERE p.barred IS TRUE";
+
+ my $list = actor::user->db_Main->selectcol_arrayref($sql);
+ for my $bc ( @$list ) {
+ $client->respond($bc);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.barred_barcodes',
+ api_level => 1,
+ stream => 1,
+ method => 'barred_barcodes',
+ signature => <<' NOTE',
+ Returns an array of barcodes that are currently barred.
+ @return array of barcodes
+ NOTE
+);
+
+sub penalized_barcodes {
+ my $self = shift;
+ my $client = shift;
+
+ my $c = actor::card->table;
+ my $p = actor::user_standing_penalty->table;
+
+ my $sql = <<" SQL";
+ SELECT DISTINCT c.barcode
+ FROM $c c
+ JOIN $p p USING (usr)
+ JOIN config.standing_penalty csp ON (csp.id = p.standing_penalty)
+ WHERE csp.block_list IS NOT NULL
+ AND p.set_date < CURRENT_DATE
+ AND (p.stop_date IS NULL OR p.stop_date > CURRENT_DATE);
+ SQL
+
+ my $list = actor::user->db_Main->selectcol_arrayref($sql);
+ for my $bc ( @$list ) {
+ $client->respond($bc);
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.penalized_barcodes',
+ api_level => 1,
+ stream => 1,
+ method => 'penalized_barcodes',
+ signature => <<' NOTE',
+ Returns an array of barcodes that have blocking penalties.
+ @return array of barcodes
+ NOTE
+);
+
+
+sub patron_search {
+ my $self = shift;
+ my $client = shift;
+ my $search = shift;
+ my $limit = shift || 1000;
+ my $sort = shift;
+ my $inactive = shift;
+ my $ws_ou = shift;
+ my $ws_ou_depth = shift || 0;
+
+ my $penalty_sort = 0;
+
+ my $strict_opt_in = OpenSRF::Utils::SettingsClient->new->config_value( share => user => 'opt_in' );
+
+ $sort = ['family_name','first_given_name'] unless ($$sort[0]);
+ push @$sort,'id';
+
+ if ($$sort[0] eq 'penalties') {
+ shift @$sort;
+ $penalty_sort = 1;
+ }
+
+ # group 0 = user
+ # group 1 = address
+ # group 2 = phone, ident
+ # group 3 = barcode
+
+ my $usr = join ' AND ', map { "LOWER(CAST($_ AS text)) ~ ?" } grep { ''.$$search{$_}{group} eq '0' } keys %$search;
+ my @usrv = map { "^$$search{$_}{value}" } grep { ''.$$search{$_}{group} eq '0' } keys %$search;
+
+ my $addr = join ' AND ', map { "LOWER(CAST($_ AS text)) ~ ?" } grep { ''.$$search{$_}{group} eq '1' } keys %$search;
+ my @addrv = map { "^$$search{$_}{value}" } grep { ''.$$search{$_}{group} eq '1' } keys %$search;
+
+ my $pv = $$search{phone}{value};
+ my $iv = $$search{ident}{value};
+ my $nv = $$search{name}{value};
+ my $cv = $$search{card}{value};
+
+ my $card = '';
+ if ($cv) {
+ $card = 'JOIN (SELECT DISTINCT usr FROM actor.card WHERE LOWER(barcode) LIKE ?||\'%\') AS card ON (card.usr = users.id)';
+ unshift(@usrv, $cv);
+ }
+
+ my $phone = '';
+ my @ps;
+ my @phonev;
+ if ($pv) {
+ for my $p ( qw/day_phone evening_phone other_phone/ ) {
+ push @ps, "LOWER($p) ~ ?";
+ push @phonev, "^$pv";
+ }
+ $phone = '(' . join(' OR ', @ps) . ')';
+ }
+
+ my $ident = '';
+ my @is;
+ my @identv;
+ if ($iv) {
+ for my $i ( qw/ident_value ident_value2/ ) {
+ push @is, "LOWER($i) ~ ?";
+ push @identv, "^$iv";
+ }
+ $ident = '(' . join(' OR ', @is) . ')';
+ }
+
+ my $name = '';
+ my @ns;
+ my @namev;
+ if (0 && $nv) {
+ for my $n ( qw/first_given_name second_given_name family_name/ ) {
+ push @ns, "LOWER($n) ~ ?";
+ push @namev, "^$nv";
+ }
+ $name = '(' . join(' OR ', @ns) . ')';
+ }
+
+ my $usr_where = join ' AND ', grep { $_ } ($usr,$phone,$ident,$name);
+ my $addr_where = $addr;
+
+
+ my $u_table = actor::user->table;
+ my $a_table = actor::user_address->table;
+ my $opt_in_table = actor::usr_org_unit_opt_in->table;
+ my $ou_table = actor::org_unit->table;
+
+ my $u_select = "SELECT id as id FROM $u_table u WHERE $usr_where";
+ my $a_select = "SELECT u.id as id FROM $a_table a JOIN $u_table u ON (u.mailing_address = a.id OR u.billing_address = a.id) WHERE $addr_where";
+
+ my $clone_select = '';
+
+ #$clone_select = "JOIN (SELECT cu.id as id FROM $a_table ca ".
+ # "JOIN $u_table cu ON (cu.mailing_address = ca.id OR cu.billing_address = ca.id) ".
+ # "WHERE $addr_where) AS clone ON (clone.id = users.id)" if ($addr_where);
+
+ my $select = '';
+ if ($usr_where) {
+ if ($addr_where) {
+ $select = "$u_select INTERSECT $a_select";
+ } else {
+ $select = $u_select;
+ }
+ } elsif ($addr_where) {
+ $select = "$a_select";
+ }
+
+ return undef if (!$select && !$card);
+
+ my $order_by = join ', ', map { 'LOWER(CAST(users.'. (split / /,$_)[0] . ' AS text)) ' . (split / /,$_)[1] } @$sort;
+ my $distinct_list = join ', ', map { 'LOWER(CAST(users.'. (split / /,$_)[0] . ' AS text))' } @$sort;
+ my $group_list = $distinct_list;
+
+ if ($inactive) {
+ $inactive = '';
+ } else {
+ $inactive = 'AND users.active = TRUE';
+ }
+
+ if (!$ws_ou) { # XXX This should be required!!
+ $ws_ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
+ }
+
+ my $opt_in_join = '';
+ my $opt_in_where = '';
+ if (lc($strict_opt_in) eq 'true') {
+ $opt_in_join = "LEFT JOIN $opt_in_table oi ON (oi.org_unit = $ws_ou AND users.id = oi.usr)";
+ $opt_in_where = "AND (oi.id IS NOT NULL OR users.home_ou = $ws_ou)";
+ }
+
+ my $penalty_join = '';
+ if ($penalty_sort) {
+ $distinct_list = 'COUNT(penalties.id), ' . $distinct_list;
+ $order_by = 'COUNT(penalties.id) DESC, ' . $order_by;
+ unshift @$sort, 'COUNT(penalties.id)';
+ $penalty_join = <<" SQL";
+ LEFT JOIN actor.usr_standing_penalty penalties
+ ON (users.id = penalties.usr AND (penalties.stop_date IS NULL OR penalties.stop_date > NOW()))
+ SQL
+ }
+
+ my $descendants = "actor.org_unit_descendants($ws_ou, $ws_ou_depth)";
+
+ $select = "JOIN ($select) AS search ON (search.id = users.id)" if ($select);
+ $select = <<" SQL";
+ SELECT $distinct_list
+ FROM $u_table AS users $card
+ JOIN $descendants d ON (d.id = users.home_ou)
+ $select
+ $opt_in_join
+ $clone_select
+ $penalty_join
+ WHERE users.deleted = FALSE
+ $inactive
+ $opt_in_where
+ GROUP BY $group_list
+ ORDER BY $order_by
+ LIMIT $limit
+ SQL
+
+ return actor::user->db_Main->selectcol_arrayref($select, {Columns=>[scalar(@$sort)]}, map {lc($_)} (@usrv,@phonev,@identv,@namev,@addrv));
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.user.crazy_search',
+ api_level => 1,
+ method => 'patron_search',
+);
+
+sub org_unit_list {
+ my $self = shift;
+ my $client = shift;
+
+ my $select =<<" SQL";
+ SELECT *
+ FROM actor.org_unit
+ ORDER BY CASE WHEN parent_ou IS NULL THEN 0 ELSE 1 END, name;
+ SQL
+
+ my $sth = actor::org_unit->db_Main->prepare_cached($select);
+ $sth->execute;
+
+ $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.actor.org_unit.retrieve.all',
+ api_level => 1,
+ stream => 1,
+ method => 'org_unit_list',
+);
+
+sub org_unit_type_list {
+ my $self = shift;
+ my $client = shift;
+
+ my $select =<<" SQL";
+ SELECT *
+ FROM actor.org_unit_type
+ ORDER BY depth, name;
+ SQL
+
+ my $sth = actor::org_unit_type->db_Main->prepare_cached($select);
+ $sth->execute;
+
+ $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit_type->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.actor.org_unit_type.retrieve.all',
+ api_level => 1,
+ stream => 1,
+ method => 'org_unit_type_list',
+);
+
+sub org_unit_full_path {
+ my $self = shift;
+ my $client = shift;
+ my @binds = @_;
+
+ return undef unless (@binds);
+
+ my $func = 'actor.org_unit_full_path(?)';
+ $func = 'actor.org_unit_full_path(?,?)' if (@binds > 1);
+
+ my $sth = actor::org_unit->db_Main->prepare_cached("SELECT * FROM $func");
+ $sth->execute(@binds);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.org_unit.full_path',
+ api_level => 1,
+ stream => 1,
+ method => 'org_unit_full_path',
+);
+
+sub org_unit_ancestors {
+ my $self = shift;
+ my $client = shift;
+ my $id = shift;
+
+ return undef unless ($id);
+
+ my $func = 'actor.org_unit_ancestors(?)';
+
+ my $sth = actor::org_unit->db_Main->prepare_cached(<<" SQL");
+ SELECT f.*
+ FROM $func f
+ JOIN actor.org_unit_type t ON (f.ou_type = t.id)
+ ORDER BY t.depth, f.name;
+ SQL
+ $sth->execute(''.$id);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.org_unit.ancestors',
+ api_level => 1,
+ stream => 1,
+ method => 'org_unit_ancestors',
+);
+
+sub org_unit_descendants {
+ my $self = shift;
+ my $client = shift;
+ my $id = shift;
+ my $depth = shift;
+
+ return undef unless ($id);
+
+ my $func = 'actor.org_unit_descendants(?)';
+ if (defined $depth) {
+ $func = 'actor.org_unit_descendants(?,?)';
+ }
+
+ my $sth = actor::org_unit->db_Main->prepare_cached("SELECT * FROM $func");
+ $sth->execute(''.$id, ''.$depth) if (defined $depth);
+ $sth->execute(''.$id) unless (defined $depth);
+
+ $client->respond( $_->to_fieldmapper ) for ( map { actor::org_unit->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.actor.org_unit.descendants',
+ api_level => 1,
+ stream => 1,
+ method => 'org_unit_descendants',
+);
+
+sub fleshed_actor_stat_cat {
+ my $self = shift;
+ my $client = shift;
+ my @list = @_;
+
+ @list = ($list[0]) unless ($self->api_name =~ /batch/o);
+
+ for my $sc (@list) {
+ my $cat = actor::stat_cat->retrieve($sc);
+ next unless ($cat);
+
+ my $sc_fm = $cat->to_fieldmapper;
+ $sc_fm->entries( [ map { $_->to_fieldmapper } $cat->entries ] );
+
+ $client->respond( $sc_fm );
+
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.actor.stat_cat.retrieve',
+ api_level => 1,
+ argc => 1,
+ method => 'fleshed_actor_stat_cat',
+);
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.actor.stat_cat.retrieve.batch',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ method => 'fleshed_actor_stat_cat',
+);
+
+#XXX Fix stored proc calls
+sub ranged_actor_stat_cat_all {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = actor::stat_cat->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ ORDER BY name
+ SQL
+
+ $fleshed = 0;
+ $fleshed = 1 if ($self->api_name =~ /fleshed/o);
+
+ my $sth = actor::stat_cat->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ for my $sc ( map { actor::stat_cat->construct($_) } $sth->fetchall_hash ) {
+ my $sc_fm = $sc->to_fieldmapper;
+ $sc_fm->entries(
+ [ $self->method_lookup( 'open-ils.storage.ranged.actor.stat_cat_entry.search.stat_cat' )->run($ou,$sc->id) ]
+ ) if ($fleshed);
+ $client->respond( $sc_fm );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ranged.fleshed.actor.stat_cat.all',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ method => 'ranged_actor_stat_cat_all',
+);
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ranged.actor.stat_cat.all',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ method => 'ranged_actor_stat_cat_all',
+);
+
+#XXX Fix stored proc calls
+sub ranged_actor_stat_cat_entry {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+ my $sc = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = actor::stat_cat_entry->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE stat_cat = ?
+ ORDER BY name
+ SQL
+
+ my $sth = actor::stat_cat->db_Main->prepare_cached($select);
+ $sth->execute($ou,$sc);
+
+ for my $sce ( map { actor::stat_cat_entry->construct($_) } $sth->fetchall_hash ) {
+ $client->respond( $sce->to_fieldmapper );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ranged.actor.stat_cat_entry.search.stat_cat',
+ api_level => 1,
+ stream => 1,
+ method => 'ranged_actor_stat_cat_entry',
+);
+
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::asset;
+use base qw/OpenILS::Application::Storage/;
+#use OpenILS::Application::Storage::CDBI::asset;
+#use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils::JSON;
+
+#
+
+my $log = 'OpenSRF::Utils::Logger';
+
+use MARC::Record;
+use MARC::File::XML;
+
+sub circ_count {
+ my $self = shift;
+ my $client = shift;
+ my $copy = shift;
+ my $granularity = shift;
+
+ my $c_table = action::circulation->table;
+
+ if (lc($granularity) eq 'year') {
+ $granularity = ", to_char(xact_start, 'YYYY') as when";
+ } elsif (lc($granularity) eq 'month') {
+ $granularity = ", to_char(xact_start, 'YYYY-MM') as when";
+ } elsif (lc($granularity) eq 'day') {
+ $granularity = ", to_char(xact_start, 'YYYY-MM-DD') as when";
+ } else {
+ $granularity = ", 'total' as when";
+ }
+
+ my $SQL = <<" SQL";
+ SELECT COUNT(*) as count $granularity
+ FROM $c_table
+ WHERE target_copy = ?
+ SQL
+
+
+ if ($granularity !~ /total/o) {
+ $SQL .= ' GROUP BY 2 ORDER BY 2';
+ }
+
+ $log->debug("Circ count SQL [$SQL]", DEBUG);
+
+ return action::circulation->db_Main->selectall_hashref($SQL, 'when', {}, $copy);
+}
+__PACKAGE__->register_method(
+ method => 'circ_count',
+ api_name => 'open-ils.storage.asset.copy.circ_count',
+ argc => 1,
+);
+
+
+#our $_default_subfield_map = {
+# call_number => $cn,
+# barcode => $bc,
+# owning_lib => $ol,
+# circulating_lib => $cl,
+# copy_location => $sl,
+# copy_number => $num,
+# price => $pr,
+# status => $loc,
+# create_date => $date,
+#
+# legacy_item_type => $it,
+# legacy_item_cat_1 => $ic1,
+# legacy_item_cat_2 => $ic2,
+#};
+
+my %org_cache;
+
+sub import_xml_holdings {
+ my $self = shift;
+ my $client = shift;
+ my $editor = shift;
+ my $record = shift;
+ my $xml = shift;
+ my $tag = shift;
+ my $map = shift;
+ my $date_format = shift || 'mm/dd/yyyy';
+
+ ($record) = biblio::record_entry->search_where($record);
+
+ return 0 unless ($record);
+
+ my $r = MARC::Record->new_from_xml($xml);
+
+ my $count = 0;
+ for my $f ( $r->fields( $tag ) ) {
+ next unless ($f->subfield( $map->{owning_lib} ));
+
+ my ($ol,$cl);
+
+ try {
+ $ol =
+ $org_cache{ $f->subfield( $map->{owning_lib} ) }
+ || actor::org_unit->search( shortname => $f->subfield( $map->{owning_lib} ) )->next->id;
+
+ $org_cache{ $f->subfield( $map->{owning_lib} ) } = $ol;
+ } otherwise {
+ $log->debug('Could not find library with shortname ['.$f->subfield( $map->{owning_lib} ).'] : '. shift(), ERROR);
+ $log->info('Failed holdings tag: ['.OpenSRF::Utils::JSON->perl2JSON( $f ).']');
+ };
+
+ try {
+ $cl =
+ $org_cache{ $f->subfield( $map->{circulating_lib} ) }
+ || actor::org_unit->search( shortname => $f->subfield( $map->{circulating_lib} ) )->next->id;
+
+ $org_cache{ $f->subfield( $map->{circulating_lib} ) } = $cl;
+ } otherwise {
+ $log->debug('Could not find library with shortname ['.$f->subfield( $map->{circulating_lib} ).'] : '. shift(), ERROR);
+ $log->info('Failed holdings tag: ['.OpenSRF::Utils::JSON->perl2JSON( $f ).']');
+ };
+
+ next unless ($ol && $cl);
+
+ my $cn;
+ try {
+ $cn = asset::call_number->find_or_create(
+ { label => $f->subfield( $map->{call_number} ),
+ owning_lib => $ol,
+ record => $record->id,
+ creator => $editor,
+ editor => $editor,
+ }
+ );
+ } otherwise {
+ $log->debug('Could not find or create callnumber ['.$f->subfield( $map->{call_number} )."] on record $record : ". shift(), ERROR);
+ $log->info('Failed holdings tag: ['.OpenSRF::Utils::JSON->perl2JSON( $f ).']');
+ };
+
+ next unless ($cn);
+
+ my $create_date = $f->subfield( $map->{create_date} );
+
+ my ($m,$d,$y);
+ if ($date_format eq 'mm/dd/yyyy') {
+ ($m,$d,$y) = split '/', $create_date;
+
+ } elsif ($date_format eq 'dd/mm/yyyy') {
+ ($d,$m,$y) = split '/', $create_date;
+
+ } elsif ($date_format eq 'mm-dd-yyyy') {
+ ($m,$d,$y) = split '-', $create_date;
+
+ } elsif ($date_format eq 'dd-mm-yyyy') {
+ ($d,$m,$y) = split '-', $create_date;
+
+ } elsif ($date_format eq 'yyyy-mm-dd') {
+ ($y,$m,$d) = split '-', $create_date;
+
+ } elsif ($date_format eq 'yyyy/mm/dd') {
+ ($y,$m,$d) = split '/', $create_date;
+ }
+
+ if ($y == 0) {
+ (undef,undef,undef,$d,$m,$y) = localtime;
+ $m++;
+ $y+=1900;
+ }
+
+ my $price = $f->subfield( $map->{price} );
+ $price =~ s/[^0-9\.]+//gso;
+ $price ||= '0.00';
+
+ try {
+ $cn->add_to_copies(
+ { circ_lib => $cl,
+ copy_number => $f->subfield( $map->{copy_number} ),
+ price => $price,
+ barcode => $f->subfield( $map->{barcode} ),
+ loan_duration => 2,
+ fine_level => 2,
+ creator => $editor,
+ editor => $editor,
+ create_date => sprintf('%04d-%02d-%02d',$y,$m,$d),
+ }
+ );
+ $count++;
+ } otherwise {
+ $log->debug('Could not create copy ['.$f->subfield( $map->{barcode} ).'] : '. shift(), ERROR);
+ };
+ }
+
+ return $count;
+}
+__PACKAGE__->register_method(
+ method => 'import_xml_holdings',
+ api_name => 'open-ils.storage.asset.holdings.import.xml',
+ argc => 5,
+ stream => 0,
+);
+
+# XXX
+# see /home/miker/cn_browse-test.sql for page up and down sql ...
+# XXX
+
+sub cn_browse_pagedown {
+ my $self = shift;
+ my $client = shift;
+
+ my %args = @_;
+
+ my $cn = uc($args{label});
+ my $org = $args{org_unit};
+ my $depth = $args{depth};
+ my $boundry_id = $args{boundry_id};
+ my $size = $args{page_size} || 20;
+ $size = int($size);
+
+ my $table = asset::call_number->table;
+
+ my $descendants = "actor.org_unit_descendants($org)";
+ if (defined $depth) {
+ $descendants = "actor.org_unit_descendants($org,$depth)";
+ }
+
+ my $orgs = join(',', @{ asset::call_number->db_Main->selectcol_arrayref("SELECT DISTINCT id FROM $descendants;") });
+
+ my $sql = <<" SQL";
+ select
+ cn.label,
+ cn.owning_lib,
+ cn.record,
+ cn.id
+ from
+ $table cn
+ where
+ not deleted
+ and (oils_text_as_bytea(label) > ? or ( cn.id > ? and oils_text_as_bytea(label) = ? ))
+ and owning_lib in ($orgs)
+ order by oils_text_as_bytea(label), 4, 2
+ limit $size;
+ SQL
+
+ my $sth = asset::call_number->db_Main->prepare($sql);
+ $sth->execute($cn, $boundry_id, $cn);
+ while ( my @row = $sth->fetchrow_array ) {
+ $client->respond([@row]);
+ }
+ $sth->finish;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'cn_browse_pagedown',
+ api_name => 'open-ils.storage.asset.call_number.browse.page_down',
+ argc => 4,
+ stream => 1,
+);
+
+sub cn_browse_pageup {
+ my $self = shift;
+ my $client = shift;
+
+ my %args = @_;
+
+ my $cn = uc($args{label});
+ my $org = $args{org_unit};
+ my $depth = $args{depth};
+ my $boundry_id = $args{boundry_id};
+ my $size = $args{page_size} || 20;
+ $size = int($size);
+
+ my $table = asset::call_number->table;
+
+ my $descendants = "actor.org_unit_descendants($org)";
+ if (defined $depth) {
+ $descendants = "actor.org_unit_descendants($org,$depth)";
+ }
+
+ my $orgs = join(',', @{ asset::call_number->db_Main->selectcol_arrayref("SELECT DISTINCT id FROM $descendants;") });
+
+ my $sql = <<" SQL";
+ select * from (
+ select
+ cn.label,
+ cn.owning_lib,
+ cn.record,
+ cn.id
+ from
+ $table cn
+ where
+ not deleted
+ and (oils_text_as_bytea(label) < ? or ( cn.id < ? and oils_text_as_bytea(label) = ? ))
+ and owning_lib in ($orgs)
+ order by oils_text_as_bytea(label) desc, 4 desc, 2 desc
+ limit $size
+ ) as bar
+ order by 1,4,2;
+ SQL
+
+ my $sth = asset::call_number->db_Main->prepare($sql);
+ $sth->execute($cn, $boundry_id, $cn);
+ while ( my @row = $sth->fetchrow_array ) {
+ $client->respond([@row]);
+ }
+ $sth->finish;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'cn_browse_pageup',
+ api_name => 'open-ils.storage.asset.call_number.browse.page_up',
+ argc => 4,
+ stream => 1,
+);
+
+sub cn_browse_target {
+ my $self = shift;
+ my $client = shift;
+
+ my %args = @_;
+
+ my $cn = uc($args{label});
+ my $org = $args{org_unit};
+ my $depth = $args{depth};
+ my $size = $args{page_size} || 20;
+ my $topsize = $size / 2;
+ $topsize = int($topsize);
+ $bottomsize = $size - $topsize;
+
+ my $table = asset::call_number->table;
+
+ my $descendants = "actor.org_unit_descendants($org)";
+ if (defined $depth) {
+ $descendants = "actor.org_unit_descendants($org,$depth)";
+ }
+
+ my $orgs = join(',', @{ asset::call_number->db_Main->selectcol_arrayref("SELECT DISTINCT id FROM $descendants;") });
+
+ my $top_sql = <<" SQL";
+ select * from (
+ select
+ cn.label,
+ cn.owning_lib,
+ cn.record,
+ cn.id
+ from
+ $table cn
+ where
+ not deleted
+ and oils_text_as_bytea(label) < ?
+ and owning_lib in ($orgs)
+ order by oils_text_as_bytea(label) desc, 4 desc, 2 desc
+ limit $topsize
+ ) as bar
+ order by 1,4,2;
+ SQL
+
+ my $bottom_sql = <<" SQL";
+ select
+ cn.label,
+ cn.owning_lib,
+ cn.record,
+ cn.id
+ from
+ $table cn
+ where
+ not deleted
+ and oils_text_as_bytea(label) >= ?
+ and owning_lib in ($orgs)
+ order by oils_text_as_bytea(label),4,2
+ limit $bottomsize;
+ SQL
+
+ my $sth = asset::call_number->db_Main->prepare($top_sql);
+ $sth->execute($cn);
+ while ( my @row = $sth->fetchrow_array ) {
+ $client->respond([@row]);
+ }
+ $sth->finish;
+
+ $sth = asset::call_number->db_Main->prepare($bottom_sql);
+ $sth->execute($cn);
+ while ( my @row = $sth->fetchrow_array ) {
+ $client->respond([@row]);
+ }
+ $sth->finish;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'cn_browse_target',
+ api_name => 'open-ils.storage.asset.call_number.browse.target',
+ argc => 4,
+ stream => 1,
+);
+
+
+sub copy_proximity {
+ my $self = shift;
+ my $client = shift;
+
+ my $cp = shift;
+ my $org = shift;
+
+ return unless ($cp && $org);
+
+ $cp = asset::copy->retrieve($cp) unless (ref($cp));
+
+ return unless $cp;
+ my $ol = $cp->circ_lib;
+
+ return (actor::org_unit_proximity->search( from_org => "$ol", to_org => "$org"))[0]->prox;
+}
+__PACKAGE__->register_method(
+ method => 'copy_proximity',
+ api_name => 'open-ils.storage.asset.copy.proximity',
+ argc => 2,
+ stream => 1,
+);
+
+sub asset_copy_location_all {
+ my $self = shift;
+ my $client = shift;
+
+ for my $rec ( asset::copy_location->retrieve_all ) {
+ $client->respond( $rec->to_fieldmapper );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'asset_copy_location_all',
+ api_name => 'open-ils.storage.direct.asset.copy_location.retrieve.all',
+ argc => 0,
+ stream => 1,
+);
+
+# XXX arg, with the descendancy SPs...
+sub ranged_asset_copy_location {
+ my $self = shift;
+ my $client = shift;
+ my @binds = @_;
+
+ my $ctable = asset::copy_location->table;
+
+ my $descendants = defined($binds[1]) ?
+ "actor.org_unit_full_path(?, ?)" :
+ "actor.org_unit_full_path(?)" ;
+
+
+ my $sql = <<" SQL";
+ SELECT DISTINCT c.*
+ FROM $ctable c
+ JOIN $descendants d
+ ON (d.id = c.owning_lib)
+ ORDER BY name
+ SQL
+
+ my $sth = asset::copy_location->db_Main->prepare($sql);
+ $sth->execute(@binds);
+
+ while ( my $rec = $sth->fetchrow_hashref ) {
+
+ my $cnct = new Fieldmapper::asset::copy_location;
+ map {$cnct->$_($$rec{$_})} keys %$rec;
+ $client->respond( $cnct );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'ranged_asset_copy_location',
+ api_name => 'open-ils.storage.ranged.asset.copy_location.retrieve',
+ argc => 1,
+ stream => 1,
+);
+
+
+sub fleshed_copy {
+ my $self = shift;
+ my $client = shift;
+ my @ids = @_;
+
+ return undef unless (@ids);
+
+ @ids = ($ids[0]) unless ($self->api_name =~ /batch/o);
+
+ for my $id ( @ids ) {
+ next unless $id;
+ my $cp = asset::copy->retrieve($id);
+ next unless $cp;
+
+ my $cp_fm = $cp->to_fieldmapper;
+ $cp_fm->circ_lib( $cp->circ_lib->to_fieldmapper );
+ $cp_fm->location( $cp->location->to_fieldmapper );
+ $cp_fm->status( $cp->status->to_fieldmapper );
+ $cp_fm->stat_cat_entries( [ map { $_->to_fieldmapper } $cp->stat_cat_entries ] );
+
+ $client->respond( $cp_fm );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.asset.copy.batch.retrieve',
+ method => 'fleshed_copy',
+ argc => 1,
+ stream => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.asset.copy.retrieve',
+ method => 'fleshed_copy',
+ argc => 1,
+);
+
+sub fleshed_copy_by_barcode {
+ my $self = shift;
+ my $client = shift;
+ my $bc = ''.shift;
+
+ my ($cp) = asset::copy->search( { barcode => $bc } );
+
+ return undef unless ($cp);
+
+ my $cp_fm = $cp->to_fieldmapper;
+ $cp_fm->circ_lib( $cp->circ_lib->to_fieldmapper );
+ $cp_fm->location( $cp->location->to_fieldmapper );
+ $cp_fm->status( $cp->status->to_fieldmapper );
+
+ return $cp_fm;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.asset.copy.search.barcode',
+ method => 'fleshed_copy_by_barcode',
+ argc => 1,
+ stream => 1,
+);
+
+
+#XXX Fix stored proc calls
+sub fleshed_asset_stat_cat {
+ my $self = shift;
+ my $client = shift;
+ my @list = @_;
+
+ @list = ($list[0]) unless ($self->api_name =~ /batch/o);
+ for my $sc (@list) {
+ my $cat = asset::stat_cat->retrieve($sc);
+
+ next unless ($cat);
+
+ my $sc_fm = $cat->to_fieldmapper;
+ $sc_fm->entries( [ map { $_->to_fieldmapper } $cat->entries ] );
+ $client->respond( $sc_fm );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.asset.stat_cat.retrieve',
+ api_level => 1,
+ method => 'fleshed_asset_stat_cat',
+);
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.asset.stat_cat.retrieve.batch',
+ api_level => 1,
+ stream => 1,
+ method => 'fleshed_asset_stat_cat',
+);
+
+
+#XXX Fix stored proc calls
+sub ranged_asset_stat_cat {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = asset::stat_cat->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ ORDER BY name
+ SQL
+
+ $fleshed = 0;
+ $fleshed = 1 if ($self->api_name =~ /fleshed/o);
+
+ my $sth = asset::stat_cat->db_Main->prepare_cached($select);
+ $sth->execute($ou);
+
+ for my $sc ( map { asset::stat_cat->construct($_) } $sth->fetchall_hash ) {
+ my $sc_fm = $sc->to_fieldmapper;
+ $sc_fm->entries(
+ [ $self->method_lookup( 'open-ils.storage.ranged.asset.stat_cat_entry.search.stat_cat' )->run($ou,$sc->id) ]
+ ) if ($fleshed);
+ $client->respond( $sc_fm );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ranged.fleshed.asset.stat_cat.all',
+ api_level => 1,
+ stream => 1,
+ method => 'ranged_asset_stat_cat',
+);
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ranged.asset.stat_cat.all',
+ api_level => 1,
+ stream => 1,
+ method => 'ranged_asset_stat_cat',
+);
+
+
+#XXX Fix stored proc calls
+sub multiranged_asset_stat_cat {
+ my $self = shift;
+ my $client = shift;
+ my $ous = shift;
+
+ return undef unless (defined($ous) and @$ous);
+ my $s_table = asset::stat_cat->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ WHERE s.owner IN ( XXX )
+ ORDER BY name
+ SQL
+
+ my $collector = ' INTERSECT ';
+ my $entry_method = 'open-ils.storage.multiranged.intersect.asset.stat_cat_entry.search.stat_cat';
+ if ($self->api_name =~ /union/o) {
+ $collector = ' UNION ';
+ $entry_method = 'open-ils.storage.multiranged.union.asset.stat_cat_entry.search.stat_cat';
+ }
+
+ my $binds = join($collector, map { 'SELECT id FROM actor.org_unit_full_path(?)' } grep {defined} @$ous);
+ $select =~ s/XXX/$binds/so;
+
+ $fleshed = 0;
+ $fleshed = 1 if ($self->api_name =~ /fleshed/o);
+
+ my $sth = asset::stat_cat->db_Main->prepare_cached($select);
+ $sth->execute(map { "$_" } grep {defined} @$ous);
+
+ for my $sc ( map { asset::stat_cat->construct($_) } $sth->fetchall_hash ) {
+ my $sc_fm = $sc->to_fieldmapper;
+ $sc_fm->entries(
+ [ $self->method_lookup( $entry_method )->run($ous, $sc->id) ]
+ ) if ($fleshed);
+ $client->respond( $sc_fm );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.multiranged.intersect.fleshed.asset.stat_cat.all',
+ api_level => 1,
+ stream => 1,
+ method => 'multiranged_asset_stat_cat',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.multiranged.union.fleshed.asset.stat_cat.all',
+ api_level => 1,
+ stream => 1,
+ method => 'multiranged_asset_stat_cat',
+);
+
+#XXX Fix stored proc calls
+sub ranged_asset_stat_cat_entry {
+ my $self = shift;
+ my $client = shift;
+ my $ou = ''.shift();
+ my $sc = ''.shift();
+
+ return undef unless ($ou);
+ my $s_table = asset::stat_cat_entry->table;
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ JOIN actor.org_unit_full_path(?) p ON (p.id = s.owner)
+ WHERE stat_cat = ?
+ ORDER BY name
+ SQL
+
+ my $sth = asset::stat_cat->db_Main->prepare_cached($select);
+ $sth->execute($ou,$sc);
+
+ for my $sce ( map { asset::stat_cat_entry->construct($_) } $sth->fetchall_hash ) {
+ $client->respond( $sce->to_fieldmapper );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ranged.asset.stat_cat_entry.search.stat_cat',
+ api_level => 1,
+ stream => 1,
+ method => 'ranged_asset_stat_cat_entry',
+);
+
+#XXX Fix stored proc calls
+sub multiranged_asset_stat_cat_entry {
+ my $self = shift;
+ my $client = shift;
+ my $ous = shift;
+ my $sc = ''.shift();
+
+ return undef unless (defined($ous) and @$ous);
+ my $s_table = asset::stat_cat_entry->table;
+
+ my $collector = ' INTERSECT ';
+ $collector = ' UNION ' if ($self->api_name =~ /union/o);
+
+ my $select = <<" SQL";
+ SELECT s.*
+ FROM $s_table s
+ WHERE s.owner IN ( XXX ) and s.stat_cat = ?
+ ORDER BY value
+ SQL
+
+ my $binds = join($collector, map { 'SELECT id FROM actor.org_unit_full_path(?)' } grep {defined} @$ous);
+ $select =~ s/XXX/$binds/so;
+
+ my $sth = asset::stat_cat->db_Main->prepare_cached($select);
+ $sth->execute(map {"$_"} @$ous,$sc);
+
+ for my $sce ( map { asset::stat_cat_entry->construct($_) } $sth->fetchall_hash ) {
+ $client->respond( $sce->to_fieldmapper );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.multiranged.intersect.asset.stat_cat_entry.search.stat_cat',
+ api_level => 1,
+ stream => 1,
+ method => 'multiranged_asset_stat_cat_entry',
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.multiranged.union.asset.stat_cat_entry.search.stat_cat',
+ api_level => 1,
+ stream => 1,
+ method => 'multiranged_asset_stat_cat_entry',
+);
+
+
+sub cn_ranged_tree {
+ my $self = shift;
+ my $client = shift;
+ my $cn = shift;
+ my $ou = shift;
+ my $depth = shift || 0;
+
+ my $ou_list =
+ actor::org_unit
+ ->db_Main
+ ->selectcol_arrayref(
+ 'SELECT id FROM actor.org_unit_descendants(?,?)',
+ {},
+ $ou,
+ $depth
+ );
+
+ return undef unless ($ou_list and @$ou_list);
+
+ $cn = asset::call_number->retrieve( $cn );
+ return undef unless ($cn);
+ return undef if ($cn->deleted);
+
+ my $call_number = $cn->to_fieldmapper;
+ $call_number->copies([]);
+
+ $call_number->record( $cn->record->to_fieldmapper );
+ $call_number->record->fixed_fields( $cn->record->record_descriptor->next->to_fieldmapper );
+
+ for my $cp ( $cn->copies(circ_lib => $ou_list) ) {
+ next if ($cp->deleted);
+ my $copy = $cp->to_fieldmapper;
+ $copy->status( $cp->status->to_fieldmapper );
+ $copy->location( $cp->location->to_fieldmapper );
+
+ push @{ $call_number->copies }, $copy;
+ }
+
+ return $call_number;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.asset.call_number.ranged_tree',
+ method => 'cn_ranged_tree',
+ argc => 1,
+ api_level => 1,
+);
+
+
+# XXX Since this is all we need in open-ils.storage for serial stuff ATM, just
+# XXX putting it here instead of creating a whole new file.
+sub issuance_ranged_tree {
+ my $self = shift;
+ my $client = shift;
+ my $iss = shift;
+ my $ou = shift;
+ my $depth = shift || 0;
+
+ my $ou_list =
+ actor::org_unit
+ ->db_Main
+ ->selectcol_arrayref(
+ 'SELECT id FROM actor.org_unit_descendants(?,?)',
+ {},
+ $ou,
+ $depth
+ );
+
+ return undef unless ($ou_list and @$ou_list);
+
+ $iss = serial::issuance->retrieve( $iss );
+ return undef unless ($iss);
+
+ my $issuance = $iss->to_fieldmapper;
+ $issuance->items([]);
+
+ # Now, gather issuances on the same bib, with the same label and date_published ...
+ my @subs = map { $_->id } serial::subscription->search( record_entry => $iss->subscription->record_entry->id );
+
+ my @similar_iss = serial::issuance->search_where(
+ subscription => \@subs,
+ label => $iss->label,
+ date_published => $iss->date_published
+ );
+
+ # ... and add all /their/ items to the target issuance
+ for my $i ( @similar_iss ) {
+ for my $it ( $i->items() ) {
+ next unless $it->unit and not $it->unit->deleted;
+ next unless (grep { $it->unit->circ_lib eq $_ } @$ou_list);
+
+ my $unit = $it->unit->to_fieldmapper;
+ $unit->status( $it->unit->status->to_fieldmapper );
+ $unit->location( $it->unit->location->to_fieldmapper );
+
+ my $item = $it->to_fieldmapper;
+ $item->unit( $unit );
+
+ push @{ $issuance->items }, $item;
+ }
+ }
+
+ return $issuance;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.serial.issuance.ranged_tree',
+ method => 'issuance_ranged_tree',
+ argc => 1,
+ api_level => 1,
+);
+
+sub merge_record_assets {
+ my $self = shift;
+ my $client = shift;
+ my $target = shift;
+ my @sources = @_;
+
+ my $count = 0;
+ for my $source ( @sources ) {
+ $count += asset::call_number
+ ->db_Main
+ ->selectcol_arrayref(
+ "SELECT asset.merge_record_assets(?,?);",
+ {},
+ $target,
+ $source
+ )->[0];
+ }
+
+ return $count;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.asset.merge_record_assets',
+ method => 'merge_record_assets',
+ argc => 2,
+ api_level => 1,
+);
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::authority;
+use base qw/OpenILS::Application::Storage::Publisher/;
+use vars qw/$VERSION/;
+use OpenSRF::EX qw/:try/;
+use OpenILS::Application::Storage::FTS;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::Normalize qw( naco_normalize );
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::Utils::Cache;
+use Data::Dumper;
+use Digest::MD5 qw/md5_hex/;
+use XML::LibXML;
+use Time::HiRes qw/time sleep/;
+use Unicode::Normalize;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+$VERSION = 1;
+
+my $parser = XML::LibXML->new;
+
+sub validate_tag {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my @tags = @{$args{tags}};
+ my @searches = @{$args{searches}};
+
+ my $search_table = authority::full_rec->table;
+
+ my @values;
+ my @selects;
+ for my $t ( @tags ) {
+ for my $search ( @searches ) {
+ my $sf = $$search{subfield};
+ my $term = naco_normalize($$search{term}, $sf);
+
+ $tag = [$tag] if (!ref($tag));
+
+ push @values, $t, $sf, $term;
+
+ push @selects,
+ "SELECT record FROM $search_table ".
+ "WHERE tag = ? AND subfield = ? AND value = ?";
+ }
+
+ my $sql;
+ if ($self->api_name =~ /id_list/) {
+ $sql = 'SELECT DISTINCT record FROM (';
+ } else {
+ $sql = 'SELECT COUNT(DISTINCT record) FROM (';
+ }
+ $sql .= 'SELECT record FROM (('.join(') INTERSECT (', @selects).')) AS x ';
+ $sql .= "JOIN $search_table recheck USING (record) WHERE recheck.tag = ? ";
+ $sql .= "GROUP BY 1 HAVING (COUNT(recheck.id) - ?) = 0) AS foo;";
+
+ if ($self->api_name =~ /id_list/) {
+ my $id_list = authority::full_rec->db_Main->selectcol_arrayref( $sql, {}, @values, $t, scalar(@searches) );
+ return $id_list;
+ } else {
+ my $count = authority::full_rec->db_Main->selectcol_arrayref( $sql, {}, @values, $t, scalar(@searches) )->[0];
+ return $count if ($count > 0);
+ }
+ }
+
+ return 0;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.authority.validate.tag",
+ method => 'validate_tag',
+ api_level => 1,
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.authority.validate.tag.id_list",
+ method => 'validate_tag',
+ api_level => 1,
+);
+
+
+sub find_authority_marc {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $term = NFD(lc($args{term}));
+ my $tag = $args{tag};
+ my $subfield = $args{subfield};
+ my $limit = $args{limit} || 100;
+ my $offset = $args{offset} || 0;
+
+ if ($limit) {
+ $limit = "LIMIT $limit";
+ } else {
+ $limit = '';
+ }
+
+ if ($offset) {
+ $offset = "OFFSET $offset";
+ } else {
+ $offset = '';
+ }
+
+ my $tag_where = "AND f.tag LIKE '$tag'";
+ if (ref $tag) {
+ $tag_where = "AND f.tag IN ('".join("','",@$tag)."')";
+ }
+
+ my $sf_where = "AND f.subfield = '$subfield'";
+ if (ref $subfield) {
+ $sf_where = "AND f.subfield IN ('".join("','",@$subfield)."')";
+ }
+
+ my $search_table = authority::full_rec->table;
+ my $marc_table = authority::record_entry->table;
+
+ my ($index_col) = authority::full_rec->columns('FTS');
+ $index_col ||= 'value';
+
+ my $fts = OpenILS::Application::Storage::FTS->compile(default => $term, 'f.value', "f.$index_col");
+
+ $term =~ s/\W+$//gso;
+ $term =~ s/'/''/gso;
+ $term =~ s/\pM//gso;
+
+ my $fts_where = $fts->sql_where_clause;
+ my $fts_words = join '%', $fts->words;
+
+ return undef unless ($fts_words);
+
+ my $fts_words_where = "f.value LIKE '$fts_words\%'";
+ my $fts_start_where = "f.value LIKE '$term\%'";
+ my $fts_eq_where = "f.value = '$term'";
+
+ my $fts_rank = join '+', $fts->fts_rank;
+
+ my $select = <<" SQL";
+ SELECT a.marc, sum($fts_rank), count(f.record), first(f.value)
+ FROM $search_table f,
+ $marc_table a
+ WHERE $fts_start_where
+ $tag_where
+ $sf_where
+ AND a.id = f.record
+ GROUP BY 1
+ ORDER BY 2 desc, 3 desc, 4
+ $limit
+ $offset
+
+ SQL
+
+ $log->debug("Authority Search SQL :: [$select]",DEBUG);
+
+ my $recs = authority::full_rec->db_Main->selectcol_arrayref( $select );
+
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ $client->respond($_) for (@$recs);
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.authority.search.marc",
+ method => 'find_authority_marc',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+sub _empty_check {
+ my $term = shift;
+ my $class = shift || 'metabib::full_rec';
+
+ my $table = $class->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+ my $fts = OpenILS::Application::Storage::FTS->compile(default => $term, 'm.value', "m.$index_col");
+ my $fts_where = $fts->sql_where_clause;
+
+ my $sql = <<" SQL";
+ SELECT TRUE
+ FROM $table m
+ WHERE $fts_where
+ LIMIT 1
+ SQL
+
+ return $class->db_Main->selectcol_arrayref($sql)->[0];
+}
+
+my $prevtime;
+
+sub find_see_from_controlled {
+ my $self = shift;
+ my $client = shift;
+ my $term = shift;
+ my $limit = shift;
+ my $offset = shift;
+
+ $prevtime = time;
+
+ (my $class = $self->api_name) =~ s/^.+authority.([^\.]+)\.see.+$/$1/o;
+ my $sf = 'a';
+ $sf = 't' if ($class eq 'title');
+
+ my @marc = $self->method_lookup('open-ils.storage.authority.search.marc')
+ ->run( term => $term, tag => [400,410,411,430,450,455], subfield => $sf, limit => $limit, offset => $offset );
+
+
+ for my $m ( @marc ) {
+ my $doc = $parser->parse_string($m);
+ my @nodes = $doc->documentElement->findnodes('//*[substring(@tag,1,1)="1"]/*[@code="a" or @code="d" or @code="x"]');
+ my $list = [ map { $_->textContent } @nodes ];
+ $client->respond( $list ) if (_empty_check(join(' ',@$list), "metabib::${class}_field_entry"));
+ }
+ return undef;
+}
+for my $class ( qw/title author subject keyword series identifier/ ) {
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.authority.$class.see_from.controlled",
+ method => 'find_see_from_controlled',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+ );
+}
+
+sub find_see_also_from_controlled {
+ my $self = shift;
+ my $client = shift;
+ my $term = shift;
+ my $limit = shift;
+ my $offset = shift;
+
+ (my $class = $self->api_name) =~ s/^.+authority.([^\.]+)\.see.+$/$1/o;
+ my $sf = 'a';
+ $sf = 't' if ($class eq 'title');
+
+ my @marc = $self->method_lookup('open-ils.storage.authority.search.marc')
+ ->run( term => $term, tag => [500,510,511,530,550,555], subfield => $sf, limit => $limit, offset => $offset );
+ for my $m ( @marc ) {
+ my $doc = $parser->parse_string($m);
+ my @nodes = $doc->documentElement->findnodes('//*[substring(@tag,1,1)="1"]/*[@code="a" or @code="d" or @code="x"]');
+ my $list = [ map { $_->textContent } @nodes ];
+ $client->respond( $list ) if (_empty_check(join(' ',@$list), "metabib::${class}_field_entry"));
+ }
+ return undef;
+}
+for my $class ( qw/title author subject keyword series identifier/ ) {
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.authority.$class.see_also_from.controlled",
+ method => 'find_see_also_from_controlled',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+ );
+}
+
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::biblio;
+use base qw/OpenILS::Application::Storage/;
+use vars qw/$VERSION/;
+use OpenSRF::EX qw/:try/;
+#use OpenILS::Application::Storage::CDBI::biblio;
+#use OpenILS::Application::Storage::CDBI::asset;
+use OpenILS::Utils::Fieldmapper;
+
+$VERSION = 1;
+
+sub record_copy_count {
+ my $self = shift;
+ my $client = shift;
+
+ my %args = @_;
+
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+ my $st_table = config::copy_status->table;
+ my $src_table = config::bib_source->table;
+ my $br_table = biblio::record_entry->table;
+ my $loc_table = asset::copy_location->table;
+ my $out_table = actor::org_unit_type->table;
+
+ my $descendants = "actor.org_unit_descendants(u.id)";
+ my $ancestors = "actor.org_unit_ancestors(?) u JOIN $out_table t ON (u.ou_type = t.id)";
+
+ if ($args{org_unit} < 0) {
+ $args{org_unit} *= -1;
+ $ancestors = "(select org_unit as id from actor.org_lasso_map where lasso = ?) u CROSS JOIN (SELECT -1 AS depth) t";
+ }
+
+ my $visible = 'AND a.opac_visible = TRUE AND st.opac_visible = TRUE AND loc.opac_visible = TRUE AND cp.opac_visible = TRUE';
+ if ($self->api_name =~ /staff/o) {
+ $visible = ''
+ }
+
+ my $sql = <<" SQL";
+ SELECT t.depth,
+ u.id AS org_unit,
+ sum(
+ (SELECT count(cp.id)
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $descendants a ON (cp.circ_lib = a.id)
+ JOIN $st_table st ON (cp.status = st.id)
+ JOIN $loc_table loc ON (cp.location = loc.id)
+ WHERE cn.record = ?
+ $visible
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE)
+ ) AS count,
+ sum(
+ (SELECT count(cp.id)
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $descendants a ON (cp.circ_lib = a.id)
+ JOIN $st_table st ON (cp.status = st.id)
+ JOIN $loc_table loc ON (cp.location = loc.id)
+ WHERE cn.record = ?
+ $visible
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE
+ AND cp.status IN (0,7,12))
+ ) AS available,
+ sum(
+ (SELECT count(cp.id)
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $st_table st ON (cp.status = st.id)
+ JOIN $loc_table loc ON (cp.location = loc.id)
+ WHERE cn.record = ?
+ AND st.opac_visible = TRUE
+ AND loc.opac_visible = TRUE
+ AND cp.opac_visible = TRUE
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE)
+ ) AS unshadow,
+ sum(
+ (SELECT sum(1)
+ FROM $br_table br
+ JOIN $src_table src ON (src.id = br.source)
+ WHERE br.id = ?
+ AND src.transcendant IS TRUE
+ )
+ ) AS transcendant
+ FROM $ancestors
+ GROUP BY 1,2
+ SQL
+
+ my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
+ $sth->execute(''.$args{record}, ''.$args{record}, ''.$args{record}, ''.$args{record}, ''.$args{org_unit});
+ while ( my $row = $sth->fetchrow_hashref ) {
+ $client->respond( $row );
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.copy_count',
+ method => 'record_copy_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.copy_count.staff',
+ method => 'record_copy_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+sub record_ranged_tree {
+ my $self = shift;
+ my $client = shift;
+ my $r = shift;
+ my $ou = shift;
+ my $depth = shift;
+ my $limit = shift || 0;
+ my $offset = shift || 0;
+
+ my $ou_sql = defined($depth) ?
+ "SELECT id FROM actor.org_unit_descendants(?,?)":
+ "SELECT id FROM actor.org_unit_descendants(?)";
+
+ my $ou_list =
+ actor::org_unit
+ ->db_Main
+ ->selectcol_arrayref(
+ $ou_sql,
+ {},
+ $ou,
+ (defined($depth) ? ($depth) : ()),
+ );
+
+ return undef unless ($ou_list and @$ou_list);
+
+ $r = biblio::record_entry->retrieve( $r );
+ return undef unless ($r);
+
+ my $rec = $r->to_fieldmapper;
+ $rec->call_numbers([]);
+
+ $rec->fixed_fields( $r->record_descriptor->next->to_fieldmapper );
+
+ my $offset_count = 0;
+ my $limit_count = 0;
+ for my $cn ( $r->call_numbers ) {
+ next if ($cn->deleted);
+ my $call_number = $cn->to_fieldmapper;
+ $call_number->copies([]);
+
+
+ for my $cp ( $cn->copies(circ_lib => $ou_list) ) {
+ next if ($cp->deleted);
+ if ($offset > 0 && $offset_count < $offset) {
+ $offset_count++;
+ next;
+ }
+
+ last if ($limit > 0 && $limit_count >= $limit);
+
+ my $copy = $cp->to_fieldmapper;
+ $copy->status( $cp->status->to_fieldmapper );
+ $copy->location( $cp->location->to_fieldmapper );
+ push @{ $call_number->copies }, $copy;
+
+ $limit_count++;
+ }
+
+ last if ($limit > 0 && $limit_count >= $limit);
+
+ push @{ $rec->call_numbers }, $call_number if (@{ $call_number->copies });
+ }
+
+ return $rec;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.ranged_tree',
+ method => 'record_ranged_tree',
+ argc => 1,
+ api_level => 1,
+);
+
+sub record_by_barcode {
+ my $self = shift;
+ my $client = shift;
+
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+
+ my $id = ''.shift;
+ my ($r) = biblio::record_entry->db_Main->selectrow_array( <<" SQL", {}, $id );
+ SELECT cn.record
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cp.call_number = cn.id)
+ WHERE cp.barcode = ?
+ SQL
+
+ my $rec = biblio::record_entry->retrieve( $r );
+
+ return $rec->to_fieldmapper if ($rec);
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.retrieve_by_barcode',
+ method => 'record_by_barcode',
+ api_level => 1,
+ cachable => 1,
+);
+
+sub record_by_copy {
+ my $self = shift;
+ my $client = shift;
+
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+
+ my $id = ''.shift;
+ my ($r) = biblio::record_entry->db_Main->selectrow_array( <<" SQL", {}, $id );
+ SELECT cn.record
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cp.call_number = cn.id)
+ WHERE cp.id = ?
+ SQL
+
+ my $rec = biblio::record_entry->retrieve( $r );
+ return undef unless ($rec);
+
+ my $r_fm = $rec->to_fieldmapper;
+ my $ff = $rec->record_descriptor->next;
+ $r_fm->fixed_fields( $ff->to_fieldmapper ) if ($ff);
+
+ return $r_fm;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.fleshed.biblio.record_entry.retrieve_by_copy',
+ method => 'record_by_copy',
+ api_level => 1,
+ cachable => 1,
+);
+
+
+=comment Old version
+
+my $org_unit_lookup;
+sub record_copy_count {
+ my $self = shift;
+ my $client = shift;
+ my $oid = shift;
+ my @recs = @_;
+
+ if ($self->api_name !~ /batch/o) {
+ @recs = ($recs[0]);
+ }
+
+ throw OpenSRF::EX::InvalidArg ( "No org_unit id passed!" )
+ unless ($oid);
+
+ throw OpenSRF::EX::InvalidArg ( "No record id passed!" )
+ unless (@recs);
+
+ $org_unit_lookup ||= $self->method_lookup('open-ils.storage.direct.actor.org_unit.retrieve');
+ my ($org_unit) = $org_unit_lookup->run($oid);
+
+ # XXX Use descendancy tree here!!!
+ my $short_name_hack = $org_unit->shortname;
+ $short_name_hack = '' if (!$org_unit->parent_ou);
+ $short_name_hack .= '%';
+ # XXX Use descendancy tree here!!!
+
+ my $rec_list = join(',',@recs);
+
+ my $cp_table = asset::copy->table;
+ my $cn_table = asset::call_number->table;
+
+ my $select =<<" SQL";
+ SELECT count(cp.*) as copies
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cp.call_number = cn.id)
+ WHERE cn.owning_lib LIKE ? AND
+ cn.record IN ($rec_list)
+ SQL
+
+ my $sth = asset::copy->db_Main->prepare_cached($select);
+ $sth->execute($short_name_hack);
+
+ my $results = $sth->fetchall_hashref('record');
+
+ $client->respond($$results{$_}{copies} || 0) for (@recs);
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'record_copy_count',
+ api_name => 'open-ils.storage.direct.biblio.record_copy_count',
+ api_level => 1,
+ argc => 1,
+);
+__PACKAGE__->register_method(
+ method => 'record_copy_count',
+ api_name => 'open-ils.storage.direct.biblio.record_copy_count.batch',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+);
+
+=cut
+
+sub global_record_copy_count {
+ my $self = shift;
+ my $client = shift;
+
+ my $rec = shift;
+
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+ my $cl_table = asset::copy_location->table;
+ my $cs_table = config::copy_status->table;
+
+ my $copies_visible = 'AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
+ $copies_visible = '' if ($self->api_name =~ /staff/o);
+
+ my $sql = <<" SQL";
+
+ SELECT owning_lib, sum(avail), sum(tot)
+ FROM (
+ SELECT cn.owning_lib, count(cp.id) as avail, 0 as tot
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $cs_table cs ON (cs.id = cp.status)
+ JOIN $cl_table cl ON (cl.id = cp.location)
+ WHERE cn.record = ?
+ AND cp.status IN (0,7,12)
+ $copies_visible
+ GROUP BY 1
+ UNION
+ SELECT cn.owning_lib, 0 as avail, count(cp.id) as tot
+ FROM $cn_table cn
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $cs_table cs ON (cs.id = cp.status)
+ JOIN $cl_table cl ON (cl.id = cp.location)
+ WHERE cn.record = ?
+ $copies_visible
+ GROUP BY 1
+ ) x
+ GROUP BY 1
+ SQL
+
+ my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
+ $sth->execute("$rec", "$rec");
+
+ $client->respond( $_ ) for (@{$sth->fetchall_arrayref});
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.global_copy_count',
+ method => 'global_record_copy_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.global_copy_count.staff',
+ method => 'global_record_copy_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+sub record_copy_status_count {
+ my $self = shift;
+ my $client = shift;
+
+ my $rec = shift;
+ my $ou = shift || 1;
+ my $depth = shift || 0;
+
+
+ my $descendants = "actor.org_unit_descendants(?,?)";
+
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+ my $cl_table = asset::copy_location->table;
+ my $cs_table = config::copy_status->table;
+
+ my $sql = <<" SQL";
+
+ SELECT cp.circ_lib, cn.label, cp.status, count(cp.id)
+ FROM $cp_table cp,
+ $cn_table cn,
+ $cl_table cl,
+ $cs_table cs,
+ $descendants d
+ WHERE cn.record = ?
+ AND cp.call_number = cn.id
+ AND cp.location = cl.id
+ AND cp.circ_lib = d.id
+ AND cp.status = cs.id
+ AND cl.opac_visible IS TRUE
+ AND cp.opac_visible IS TRUE
+ AND cp.deleted IS FALSE
+ AND cs.opac_visible IS TRUE
+ GROUP BY 1,2,3;
+ SQL
+
+ my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
+ $sth->execute($ou, $depth, "$rec" );
+
+ my %data = ();
+ for my $row (@{$sth->fetchall_arrayref}) {
+ $data{$$row[0]}{$$row[1]}{$$row[2]} += $$row[3];
+ }
+
+ for my $ou (keys %data) {
+ for my $cn (keys %{$data{$ou}}) {
+ $client->respond( [$ou, $cn, $data{$ou}{$cn}] );
+ }
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.status_copy_count',
+ method => 'record_copy_status_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+
+sub record_copy_status_location_count {
+ my $self = shift;
+ my $client = shift;
+
+ my $rec = shift;
+ my $ou = shift || 1;
+ my $depth = shift || 0;
+
+
+ my $descendants = "actor.org_unit_descendants(?,?)";
+
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+ my $cl_table = asset::copy_location->table;
+ my $cs_table = config::copy_status->table;
+
+ # FIXME using oils_i18n_xlate here is exposing a hitherto unexposed
+ # implementation detail of json_query; doing it this way because
+ # json_query currently doesn't grok joining a function to tables
+ my $sql = <<" SQL";
+
+ SELECT cp.circ_lib,
+ cn.label,
+ oils_i18n_xlate('asset.copy_location', 'acpl', 'name', 'id', cl.id::TEXT, ?),
+ cp.status,
+ count(cp.id)
+ FROM $cp_table cp,
+ $cn_table cn,
+ $cl_table cl,
+ $cs_table cs,
+ $descendants d
+ WHERE cn.record = ?
+ AND cp.call_number = cn.id
+ AND cp.location = cl.id
+ AND cp.circ_lib = d.id
+ AND cp.status = cs.id
+ AND cl.opac_visible IS TRUE
+ AND cp.opac_visible IS TRUE
+ AND cp.deleted IS FALSE
+ AND cs.opac_visible IS TRUE
+ GROUP BY 1,2,3,4;
+ SQL
+
+ my $sth = biblio::record_entry->db_Main->prepare_cached($sql);
+ my $ses_locale = $client->session ? $client->session->session_locale : 'en-US';
+ $sth->execute($ses_locale, $ou, $depth, "$rec" );
+
+ my %data = ();
+ for my $row (@{$sth->fetchall_arrayref}) {
+ $data{$$row[0]}{$$row[1]}{$$row[2]}{$$row[3]} += $$row[4];
+ }
+
+ for my $ou (keys %data) {
+ for my $cn (keys %{$data{$ou}}) {
+ for my $cl (keys %{$data{$ou}{$cn}}) {
+ $client->respond( [$ou, $cn, $cl, $data{$ou}{$cn}{$cl}] );
+ }
+ }
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.record_entry.status_copy_location_count',
+ method => 'record_copy_status_location_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::config;
+use base qw/OpenILS::Application::Storage/;
+use OpenILS::Application::Storage::CDBI::config;
+
+
+sub retrieve_all {
+ my $self = shift;
+ my $client = shift;
+
+ $self->api_name =~ /direct\.config\.(.+)\.retrieve/o;
+
+ my $class = 'config::'.$1;
+ for my $rec ( $class->retrieve_all ) {
+ $client->respond( $rec->to_fieldmapper );
+ }
+
+ return undef;
+}
+
+for my $class (
+ qw/metabib_field standing identification_type copy_status
+ non_cataloged_type audience_map item_form_map item_type_map
+ language_map lit_form_map bib_source net_access_level/ ) {
+
+ __PACKAGE__->register_method(
+ method => 'retrieve_all',
+ api_name => "open-ils.storage.direct.config.$class.retrieve.all",
+ argc => 0,
+ stream => 1,
+ );
+}
+
+
+# XXX arg, with the descendancy SPs...
+sub ranged_config_non_cat {
+ my $self = shift;
+ my $client = shift;
+ my @binds = @_;
+
+ my $ctable = config::non_cataloged_type->table;
+
+ my $descendants = defined($binds[1]) ?
+ "actor.org_unit_full_path(?, ?)" :
+ "actor.org_unit_full_path(?)" ;
+
+
+ my $sql = <<" SQL";
+ SELECT DISTINCT c.*
+ FROM $ctable c
+ JOIN $descendants d
+ ON (d.id = c.owning_lib)
+ SQL
+
+ my $sth = config::non_cataloged_type->db_Main->prepare($sql);
+ $sth->execute(@binds);
+
+ while ( my $rec = $sth->fetchrow_hashref ) {
+
+ my $cnct = new Fieldmapper::config::non_cataloged_type;
+ $cnct->name($rec->{name});
+ $cnct->owning_lib($rec->{owning_lib});
+ $cnct->id($rec->{id});
+ $cnct->circ_duration($rec->{circ_duration});
+ $cnct->in_house($rec->{in_house});
+
+ $client->respond( $cnct );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'ranged_config_non_cat',
+ api_name => 'open-ils.storage.ranged.config.non_cataloged_type.retrieve',
+ argc => 1,
+ stream => 1,
+ notes => <<" NOTES",
+ Returns
+ NOTES
+);
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::container;
+use base qw/OpenILS::Application::Storage/;
+#use OpenILS::Application::Storage::CDBI::config;
+
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::metabib;
+use base qw/OpenILS::Application::Storage::Publisher/;
+use vars qw/$VERSION/;
+use OpenSRF::EX qw/:try/;
+use OpenILS::Application::Storage::FTS;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/:level/;
+use OpenSRF::Utils::Cache;
+use OpenSRF::Utils::JSON;
+use Data::Dumper;
+use Digest::MD5 qw/md5_hex/;
+
+
+my $log = 'OpenSRF::Utils::Logger';
+
+$VERSION = 1;
+
+sub ordered_records_from_metarecord {
+ my $self = shift;
+ my $client = shift;
+ my $mr = shift;
+ my $formats = shift;
+ my $org = shift || 1;
+ my $depth = shift;
+
+ my (@types,@forms,@blvl);
+
+ if ($formats) {
+ my ($t, $f, $b) = split '-', $formats;
+ @types = split '', $t;
+ @forms = split '', $f;
+ @blvl = split '', $b;
+ }
+
+ my $descendants =
+ defined($depth) ?
+ "actor.org_unit_descendants($org, $depth)" :
+ "actor.org_unit_descendants($org)" ;
+
+
+ my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
+ $copies_visible = '' if ($self->api_name =~ /staff/o);
+
+ my $sm_table = metabib::metarecord_source_map->table;
+ my $rd_table = metabib::record_descriptor->table;
+ my $fr_table = metabib::full_rec->table;
+ my $cn_table = asset::call_number->table;
+ my $cl_table = asset::copy_location->table;
+ my $cp_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $src_table = config::bib_source->table;
+ my $out_table = actor::org_unit_type->table;
+ my $br_table = biblio::record_entry->table;
+
+ my $sql = <<" SQL";
+ SELECT record,
+ item_type,
+ item_form,
+ quality,
+ FIRST(COALESCE(LTRIM(SUBSTR( value, COALESCE(SUBSTRING(ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'zzzzzzzz')) AS title
+ FROM (
+ SELECT rd.record,
+ rd.item_type,
+ rd.item_form,
+ br.quality,
+ fr.tag,
+ fr.subfield,
+ fr.value,
+ fr.ind2
+ SQL
+
+ if ($copies_visible) {
+ $sql .= <<" SQL";
+ FROM $sm_table sm,
+ $br_table br,
+ $fr_table fr,
+ $rd_table rd
+ WHERE rd.record = sm.source
+ AND fr.record = sm.source
+ AND br.id = sm.source
+ AND sm.metarecord = ?
+ AND (EXISTS ((SELECT 1
+ FROM $cp_table cp
+ JOIN $cn_table cn ON (cp.call_number = cn.id)
+ JOIN $cs_table cs ON (cp.status = cs.id)
+ JOIN $cl_table cl ON (cp.location = cl.id)
+ JOIN $descendants d ON (cp.circ_lib = d.id)
+ WHERE cn.record = sm.source
+ $copies_visible
+ LIMIT 1))
+ OR EXISTS ((
+ SELECT 1
+ FROM $src_table src
+ WHERE src.id = br.source
+ AND src.transcendant IS TRUE))
+ )
+
+ SQL
+ } else {
+ $sql .= <<" SQL";
+ FROM $sm_table sm
+ JOIN $br_table br ON (sm.source = br.id)
+ JOIN $fr_table fr ON (fr.record = br.id)
+ JOIN $rd_table rd ON (rd.record = br.id)
+ WHERE sm.metarecord = ?
+ AND (( EXISTS (
+ SELECT 1
+ FROM $cp_table cp,
+ $cn_table cn,
+ $descendants d
+ WHERE cn.record = br.id
+ AND cn.deleted = FALSE
+ AND cp.deleted = FALSE
+ AND cp.circ_lib = d.id
+ AND cn.id = cp.call_number
+ LIMIT 1
+ ) OR NOT EXISTS (
+ SELECT 1
+ FROM $cp_table cp,
+ $cn_table cn
+ WHERE cn.record = br.id
+ AND cn.deleted = FALSE
+ AND cp.deleted = FALSE
+ AND cn.id = cp.call_number
+ LIMIT 1
+ ))
+ OR EXISTS ((
+ SELECT 1
+ FROM $src_table src
+ WHERE src.id = br.source
+ AND src.transcendant IS TRUE))
+ )
+ SQL
+ }
+
+ if (@types) {
+ $sql .= ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $sql .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+
+ if (@blvl) {
+ $sql .= ' AND rd.bib_level IN ('.join(',',map{'?'}@blvl).')';
+ }
+
+
+
+ $sql .= <<" SQL";
+ OFFSET 0
+ ) AS x
+ WHERE tag = '245'
+ AND subfield = 'a'
+ GROUP BY record, item_type, item_form, quality
+ ORDER BY
+ CASE
+ WHEN item_type IS NULL -- default
+ THEN 0
+ WHEN item_type = '' -- default
+ THEN 0
+ WHEN item_type IN ('a','t') -- books
+ THEN 1
+ WHEN item_type = 'g' -- movies
+ THEN 2
+ WHEN item_type IN ('i','j') -- sound recordings
+ THEN 3
+ WHEN item_type = 'm' -- software
+ THEN 4
+ WHEN item_type = 'k' -- images
+ THEN 5
+ WHEN item_type IN ('e','f') -- maps
+ THEN 6
+ WHEN item_type IN ('o','p') -- mixed
+ THEN 7
+ WHEN item_type IN ('c','d') -- music
+ THEN 8
+ WHEN item_type = 'r' -- 3d
+ THEN 9
+ END,
+ title ASC,
+ quality DESC
+ SQL
+
+ my $ids = metabib::metarecord_source_map->db_Main->selectcol_arrayref($sql, {}, "$mr", @types, @forms, @blvl);
+ return $ids if ($self->api_name =~ /atomic$/o);
+
+ $client->respond( $_ ) for ( @$ids );
+ return undef;
+
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ordered.metabib.metarecord.records',
+ method => 'ordered_records_from_metarecord',
+ api_level => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ordered.metabib.metarecord.records.staff',
+ method => 'ordered_records_from_metarecord',
+ api_level => 1,
+ cachable => 1,
+);
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ordered.metabib.metarecord.records.atomic',
+ method => 'ordered_records_from_metarecord',
+ api_level => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.ordered.metabib.metarecord.records.staff.atomic',
+ method => 'ordered_records_from_metarecord',
+ api_level => 1,
+ cachable => 1,
+);
+
+sub isxn_search {
+ my $self = shift;
+ my $client = shift;
+ my $isxn = lc(shift());
+
+ $isxn =~ s/^\s*//o;
+ $isxn =~ s/\s*$//o;
+ $isxn =~ s/-//o if ($self->api_name =~ /isbn/o);
+
+ my $tag = ($self->api_name =~ /isbn/o) ? "'020' OR f.tag = '024'" : "'022'";
+
+ my $fr_table = metabib::full_rec->table;
+ my $bib_table = biblio::record_entry->table;
+
+ my $sql = <<" SQL";
+ SELECT DISTINCT f.record
+ FROM $fr_table f
+ JOIN $bib_table b ON (b.id = f.record)
+ WHERE (f.tag = $tag)
+ AND f.value LIKE ?
+ AND b.deleted IS FALSE
+ SQL
+
+ my $list = metabib::full_rec->db_Main->selectcol_arrayref($sql, {}, "$isxn%");
+ $client->respond($_) for (@$list);
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.id_list.biblio.record_entry.search.isbn',
+ method => 'isxn_search',
+ api_level => 1,
+ stream => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.id_list.biblio.record_entry.search.issn',
+ method => 'isxn_search',
+ api_level => 1,
+ stream => 1,
+);
+
+sub metarecord_copy_count {
+ my $self = shift;
+ my $client = shift;
+
+ my %args = @_;
+
+ my $sm_table = metabib::metarecord_source_map->table;
+ my $rd_table = metabib::record_descriptor->table;
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+ my $br_table = biblio::record_entry->table;
+ my $src_table = config::bib_source->table;
+ my $cl_table = asset::copy_location->table;
+ my $cs_table = config::copy_status->table;
+ my $out_table = actor::org_unit_type->table;
+
+ my $descendants = "actor.org_unit_descendants(u.id)";
+ my $ancestors = "actor.org_unit_ancestors(?) u JOIN $out_table t ON (u.ou_type = t.id)";
+
+ if ($args{org_unit} < 0) {
+ $args{org_unit} *= -1;
+ $ancestors = "(select org_unit as id from actor.org_lasso_map where lasso = ?) u CROSS JOIN (SELECT -1 AS depth) t";
+ }
+
+ my $copies_visible = 'AND a.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
+ $copies_visible = '' if ($self->api_name =~ /staff/o);
+
+ my (@types,@forms,@blvl);
+ my ($t_filter, $f_filter, $b_filter) = ('','','');
+
+ if ($args{format}) {
+ my ($t, $f, $b) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ @blvl = split '', $b;
+
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+
+ if (@blvl) {
+ $b_filter .= ' AND rd.bib_level IN ('.join(',',map{'?'}@blvl).')';
+ }
+ }
+
+ my $sql = <<" SQL";
+ SELECT t.depth,
+ u.id AS org_unit,
+ sum(
+ (SELECT count(cp.id)
+ FROM $sm_table r
+ JOIN $cn_table cn ON (cn.record = r.source)
+ JOIN $rd_table rd ON (cn.record = rd.record)
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $cs_table cs ON (cp.status = cs.id)
+ JOIN $cl_table cl ON (cp.location = cl.id)
+ JOIN $descendants a ON (cp.circ_lib = a.id)
+ WHERE r.metarecord = ?
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE
+ $copies_visible
+ $t_filter
+ $f_filter
+ $b_filter
+ )
+ ) AS count,
+ sum(
+ (SELECT count(cp.id)
+ FROM $sm_table r
+ JOIN $cn_table cn ON (cn.record = r.source)
+ JOIN $rd_table rd ON (cn.record = rd.record)
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $cs_table cs ON (cp.status = cs.id)
+ JOIN $cl_table cl ON (cp.location = cl.id)
+ JOIN $descendants a ON (cp.circ_lib = a.id)
+ WHERE r.metarecord = ?
+ AND cp.status IN (0,7,12)
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE
+ $copies_visible
+ $t_filter
+ $f_filter
+ $b_filter
+ )
+ ) AS available,
+ sum(
+ (SELECT count(cp.id)
+ FROM $sm_table r
+ JOIN $cn_table cn ON (cn.record = r.source)
+ JOIN $rd_table rd ON (cn.record = rd.record)
+ JOIN $cp_table cp ON (cn.id = cp.call_number)
+ JOIN $cs_table cs ON (cp.status = cs.id)
+ JOIN $cl_table cl ON (cp.location = cl.id)
+ WHERE r.metarecord = ?
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE
+ AND cp.opac_visible IS TRUE
+ AND cs.opac_visible IS TRUE
+ AND cl.opac_visible IS TRUE
+ $t_filter
+ $f_filter
+ $b_filter
+ )
+ ) AS unshadow,
+ sum(
+ (SELECT sum(1)
+ FROM $sm_table r
+ JOIN $br_table br ON (br.id = r.source)
+ JOIN $src_table src ON (src.id = br.source)
+ WHERE r.metarecord = ?
+ AND src.transcendant IS TRUE
+ )
+ ) AS transcendant
+
+ FROM $ancestors
+ GROUP BY 1,2
+ SQL
+
+ my $sth = metabib::metarecord_source_map->db_Main->prepare_cached($sql);
+ $sth->execute( ''.$args{metarecord},
+ @types,
+ @forms,
+ @blvl,
+ ''.$args{metarecord},
+ @types,
+ @forms,
+ @blvl,
+ ''.$args{metarecord},
+ @types,
+ @forms,
+ @blvl,
+ ''.$args{metarecord},
+ ''.$args{org_unit},
+ );
+
+ while ( my $row = $sth->fetchrow_hashref ) {
+ $client->respond( $row );
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.metabib.metarecord.copy_count',
+ method => 'metarecord_copy_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.metabib.metarecord.copy_count.staff',
+ method => 'metarecord_copy_count',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+sub biblio_multi_search_full_rec {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $class_join = $args{class_join} || 'AND';
+ my $limit = $args{limit} || 100;
+ my $offset = $args{offset} || 0;
+ my $sort = $args{'sort'};
+ my $sort_dir = $args{sort_dir} || 'DESC';
+
+ my @binds;
+ my @selects;
+
+ for my $arg (@{ $args{searches} }) {
+ my $term = $$arg{term};
+ my $limiters = $$arg{restrict};
+
+ my ($index_col) = metabib::full_rec->columns('FTS');
+ $index_col ||= 'value';
+ my $search_table = metabib::full_rec->table;
+
+ my $fts = OpenILS::Application::Storage::FTS->compile('default' => $term, 'value',"$index_col");
+
+ my $fts_where = $fts->sql_where_clause();
+ my @fts_ranks = $fts->fts_rank;
+
+ my $rank = join(' + ', @fts_ranks);
+
+ my @wheres;
+ for my $limit (@$limiters) {
+ if ($$limit{tag} =~ /^\d+$/ and $$limit{tag} < 10) {
+ # MARC control field; mfr.subfield is NULL
+ push @wheres, "( tag = ? AND $fts_where )";
+ push @binds, $$limit{tag};
+ $log->debug("Limiting query using { tag => $$limit{tag} }", DEBUG);
+ } else {
+ push @wheres, "( tag = ? AND subfield LIKE ? AND $fts_where )";
+ push @binds, $$limit{tag}, $$limit{subfield};
+ $log->debug("Limiting query using { tag => $$limit{tag}, subfield => $$limit{subfield} }", DEBUG);
+ }
+ }
+ my $where = join(' OR ', @wheres);
+
+ push @selects, "SELECT id, record, $rank as sum FROM $search_table WHERE $where";
+
+ }
+
+ my $descendants = defined($args{depth}) ?
+ "actor.org_unit_descendants($args{org_unit}, $args{depth})" :
+ "actor.org_unit_descendants($args{org_unit})" ;
+
+
+ my $metabib_record_descriptor = metabib::record_descriptor->table;
+ my $metabib_full_rec = metabib::full_rec->table;
+ my $asset_call_number_table = asset::call_number->table;
+ my $asset_copy_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $cl_table = asset::copy_location->table;
+ my $br_table = biblio::record_entry->table;
+
+ my $cj = 'HAVING COUNT(x.id) = ' . scalar(@selects) if ($class_join eq 'AND');
+ my $search_table =
+ '(SELECT x.record, sum(x.sum) FROM (('.
+ join(') UNION ALL (', @selects).
+ ")) x GROUP BY 1 $cj ORDER BY 2 DESC )";
+
+ my $has_vols = 'AND cn.owning_lib = d.id';
+ my $has_copies = 'AND cp.call_number = cn.id';
+ my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
+
+ if ($self->api_name =~ /staff/o) {
+ $copies_visible = '';
+ $has_copies = '' if ($ou_type == 0);
+ $has_vols = '' if ($ou_type == 0);
+ }
+
+ my ($t_filter, $f_filter) = ('','');
+ my ($a_filter, $l_filter, $lf_filter) = ('','','');
+
+ if (my $a = $args{audience}) {
+ $a = [$a] if (!ref($a));
+ my @aud = @$a;
+
+ $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
+ push @binds, @aud;
+ }
+
+ if (my $l = $args{language}) {
+ $l = [$l] if (!ref($l));
+ my @lang = @$l;
+
+ $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
+ push @binds, @lang;
+ }
+
+ if (my $f = $args{lit_form}) {
+ $f = [$f] if (!ref($f));
+ my @lit_form = @$f;
+
+ $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ push @binds, @lit_form;
+ }
+
+ if (my $f = $args{item_form}) {
+ $f = [$f] if (!ref($f));
+ my @forms = @$f;
+
+ $f_filter = ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ push @binds, @forms;
+ }
+
+ if (my $t = $args{item_type}) {
+ $t = [$t] if (!ref($t));
+ my @types = @$t;
+
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ push @binds, @types;
+ }
+
+
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ my @types = split '', $t;
+ my @forms = split '', $f;
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+ push @binds, @types, @forms;
+ }
+
+ my $relevance = 'sum(f.sum)';
+ $relevance = 1 if (!$copies_visible);
+
+ my $rank = $relevance;
+ if (lc($sort) eq 'pubdate') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d+'),'9999')::INT
+ FROM $metabib_full_rec frp
+ WHERE frp.record = f.record
+ AND frp.tag = '260'
+ AND frp.subfield = 'c'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'create_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = f.record)) )
+ RANK
+ } elsif (lc($sort) eq 'edit_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = f.record)) )
+ RANK
+ } elsif (lc($sort) eq 'title') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'zzzzzzzz')
+ FROM $metabib_full_rec frt
+ WHERE frt.record = f.record
+ AND frt.tag = '245'
+ AND frt.subfield = 'a'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'author') {
+ $rank = <<" RANK";
+ ( FIRST((
+ SELECT COALESCE(LTRIM(fra.value),'zzzzzzzz')
+ FROM $metabib_full_rec fra
+ WHERE fra.record = f.record
+ AND fra.tag LIKE '1%'
+ AND fra.subfield = 'a'
+ ORDER BY fra.tag::text::int
+ LIMIT 1
+ )) )
+ RANK
+ } else {
+ $sort = undef;
+ }
+
+
+ if ($copies_visible) {
+ $select = <<" SQL";
+ SELECT f.record, $relevance, count(DISTINCT cp.id), $rank
+ FROM $search_table f,
+ $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $br_table br,
+ $metabib_record_descriptor rd,
+ $descendants d
+ WHERE br.id = f.record
+ AND cn.record = f.record
+ AND rd.record = f.record
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ AND br.deleted IS FALSE
+ AND cn.deleted IS FALSE
+ AND cp.deleted IS FALSE
+ $has_vols
+ $has_copies
+ $copies_visible
+ $t_filter
+ $f_filter
+ $a_filter
+ $l_filter
+ $lf_filter
+ GROUP BY f.record HAVING count(DISTINCT cp.id) > 0
+ ORDER BY 4 $sort_dir,3 DESC
+ SQL
+ } else {
+ $select = <<" SQL";
+ SELECT f.record, 1, 1, $rank
+ FROM $search_table f,
+ $br_table br,
+ $metabib_record_descriptor rd
+ WHERE br.id = f.record
+ AND rd.record = f.record
+ AND br.deleted IS FALSE
+ $t_filter
+ $f_filter
+ $a_filter
+ $l_filter
+ $lf_filter
+ GROUP BY 1,2,3
+ ORDER BY 4 $sort_dir
+ SQL
+ }
+
+
+ $log->debug("Search SQL :: [$select]",DEBUG);
+
+ my $recs = metabib::full_rec->db_Main->selectall_arrayref("$select;", {}, @binds);
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ my $max = 0;
+ $max = 1 if (!@$recs);
+ for (@$recs) {
+ $max = $$_[1] if ($$_[1] > $max);
+ }
+
+ my $count = @$recs;
+ for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
+ next unless ($$rec[0]);
+ my ($rid,$rank,$junk,$skip) = @$rec;
+ $client->respond( [$rid, sprintf('%0.3f',$rank/$max), $count] );
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.full_rec.multi_search',
+ method => 'biblio_multi_search_full_rec',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.biblio.full_rec.multi_search.staff',
+ method => 'biblio_multi_search_full_rec',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+sub search_full_rec {
+ my $self = shift;
+ my $client = shift;
+
+ my %args = @_;
+
+ my $term = $args{term};
+ my $limiters = $args{restrict};
+
+ my ($index_col) = metabib::full_rec->columns('FTS');
+ $index_col ||= 'value';
+ my $search_table = metabib::full_rec->table;
+
+ my $fts = OpenILS::Application::Storage::FTS->compile('default' => $term, 'value',"$index_col");
+
+ my $fts_where = $fts->sql_where_clause();
+ my @fts_ranks = $fts->fts_rank;
+
+ my $rank = join(' + ', @fts_ranks);
+
+ my @binds;
+ my @wheres;
+ for my $limit (@$limiters) {
+ if ($$limit{tag} =~ /^\d+$/ and $$limit{tag} < 10) {
+ # MARC control field; mfr.subfield is NULL
+ push @wheres, "( tag = ? AND $fts_where )";
+ push @binds, $$limit{tag};
+ $log->debug("Limiting query using { tag => $$limit{tag} }", DEBUG);
+ } else {
+ push @wheres, "( tag = ? AND subfield LIKE ? AND $fts_where )";
+ push @binds, $$limit{tag}, $$limit{subfield};
+ $log->debug("Limiting query using { tag => $$limit{tag}, subfield => $$limit{subfield} }", DEBUG);
+ }
+ }
+ my $where = join(' OR ', @wheres);
+
+ my $select = "SELECT record, sum($rank) FROM $search_table WHERE $where GROUP BY 1 ORDER BY 2 DESC;";
+
+ $log->debug("Search SQL :: [$select]",DEBUG);
+
+ my $recs = metabib::full_rec->db_Main->selectall_arrayref($select, {}, @binds);
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ $client->respond($_) for (@$recs);
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.metabib.full_rec.search_fts.value',
+ method => 'search_full_rec',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.storage.direct.metabib.full_rec.search_fts.index_vector',
+ method => 'search_full_rec',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+
+# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
+sub search_class_fts {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $term = $args{term};
+ my $ou = $args{org_unit};
+ my $ou_type = $args{depth};
+ my $limit = $args{limit};
+ my $offset = $args{offset};
+
+ my $limit_clause = '';
+ my $offset_clause = '';
+
+ $limit_clause = "LIMIT $limit" if (defined $limit and int($limit) > 0);
+ $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
+
+ my (@types,@forms);
+ my ($t_filter, $f_filter) = ('','');
+
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+ }
+
+
+
+ my $descendants = defined($ou_type) ?
+ "actor.org_unit_descendants($ou, $ou_type)" :
+ "actor.org_unit_descendants($ou)";
+
+ my $class = $self->{cdbi};
+ my $search_table = $class->table;
+
+ my $metabib_record_descriptor = metabib::record_descriptor->table;
+ my $metabib_metarecord = metabib::metarecord->table;
+ my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
+ my $asset_call_number_table = asset::call_number->table;
+ my $asset_copy_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $cl_table = asset::copy_location->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+ (my $search_class = $self->api_name) =~ s/.*metabib.(\w+).search_fts.*/$1/o;
+ my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $term, 'f.value', "f.$index_col");
+
+ my $fts_where = $fts->sql_where_clause;
+ my @fts_ranks = $fts->fts_rank;
+
+ my $rank = join(' + ', @fts_ranks);
+
+ my $has_vols = 'AND cn.owning_lib = d.id';
+ my $has_copies = 'AND cp.call_number = cn.id';
+ my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
+
+ my $visible_count = ', count(DISTINCT cp.id)';
+ my $visible_count_test = 'HAVING count(DISTINCT cp.id) > 0';
+
+ if ($self->api_name =~ /staff/o) {
+ $copies_visible = '';
+ $visible_count_test = '';
+ $has_copies = '' if ($ou_type == 0);
+ $has_vols = '' if ($ou_type == 0);
+ }
+
+ my $rank_calc = <<" RANK";
+ , (SUM( $rank
+ * CASE WHEN f.value ILIKE ? THEN 1.2 ELSE 1 END -- phrase order
+ * CASE WHEN f.value ILIKE ? THEN 1.5 ELSE 1 END -- first word match
+ * CASE WHEN f.value ~* ? THEN 2 ELSE 1 END -- only word match
+ )/COUNT(m.source)), MIN(COALESCE(CHAR_LENGTH(f.value),1))
+ RANK
+
+ $rank_calc = ',1 , 1' if ($self->api_name =~ /unordered/o);
+
+ if ($copies_visible) {
+ $select = <<" SQL";
+ SELECT m.metarecord $rank_calc $visible_count, CASE WHEN COUNT(DISTINCT m.source) = 1 THEN MAX(m.source) ELSE MAX(0) END
+ FROM $search_table f,
+ $metabib_metarecord_source_map_table m,
+ $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $metabib_record_descriptor rd,
+ $descendants d
+ WHERE $fts_where
+ AND m.source = f.source
+ AND cn.record = m.source
+ AND rd.record = m.source
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ $has_vols
+ $has_copies
+ $copies_visible
+ $t_filter
+ $f_filter
+ GROUP BY 1 $visible_count_test
+ ORDER BY 2 DESC,3
+ $limit_clause $offset_clause
+ SQL
+ } else {
+ $select = <<" SQL";
+ SELECT m.metarecord $rank_calc, 0, CASE WHEN COUNT(DISTINCT m.source) = 1 THEN MAX(m.source) ELSE MAX(0) END
+ FROM $search_table f,
+ $metabib_metarecord_source_map_table m,
+ $metabib_record_descriptor rd
+ WHERE $fts_where
+ AND m.source = f.source
+ AND rd.record = m.source
+ $t_filter
+ $f_filter
+ GROUP BY 1, 4
+ ORDER BY 2 DESC,3
+ $limit_clause $offset_clause
+ SQL
+ }
+
+ $log->debug("Field Search SQL :: [$select]",DEBUG);
+
+ my $SQLstring = join('%',$fts->words);
+ my $REstring = join('\\s+',$fts->words);
+ my $first_word = ($fts->words)[0].'%';
+ my $recs = ($self->api_name =~ /unordered/o) ?
+ $class->db_Main->selectall_arrayref($select, {}, @types, @forms) :
+ $class->db_Main->selectall_arrayref($select, {},
+ '%'.lc($SQLstring).'%', # phrase order match
+ lc($first_word), # first word match
+ '^\\s*'.lc($REstring).'\\s*/?\s*$', # full exact match
+ @types, @forms
+ );
+
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ $client->respond($_) for (map { [@$_[0,1,3,4]] } @$recs);
+ return undef;
+}
+
+for my $class ( qw/title author subject keyword series identifier/ ) {
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.search_fts.metarecord",
+ method => 'search_class_fts',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.search_fts.metarecord.unordered",
+ method => 'search_class_fts',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.search_fts.metarecord.staff",
+ method => 'search_class_fts',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.search_fts.metarecord.staff.unordered",
+ method => 'search_class_fts',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+}
+
+# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
+sub search_class_fts_count {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $term = $args{term};
+ my $ou = $args{org_unit};
+ my $ou_type = $args{depth};
+ my $limit = $args{limit} || 100;
+ my $offset = $args{offset} || 0;
+
+ my $descendants = defined($ou_type) ?
+ "actor.org_unit_descendants($ou, $ou_type)" :
+ "actor.org_unit_descendants($ou)";
+
+ my (@types,@forms);
+ my ($t_filter, $f_filter) = ('','');
+
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+ }
+
+
+ (my $search_class = $self->api_name) =~ s/.*metabib.(\w+).search_fts.*/$1/o;
+
+ my $class = $self->{cdbi};
+ my $search_table = $class->table;
+
+ my $metabib_record_descriptor = metabib::record_descriptor->table;
+ my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
+ my $asset_call_number_table = asset::call_number->table;
+ my $asset_copy_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $cl_table = asset::copy_location->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+ my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $term, 'value',"$index_col");
+
+ my $fts_where = $fts->sql_where_clause;
+
+ my $has_vols = 'AND cn.owning_lib = d.id';
+ my $has_copies = 'AND cp.call_number = cn.id';
+ my $copies_visible = 'AND d.opac_visible IS TRUE AND cp.opac_visible IS TRUE AND cs.opac_visible IS TRUE AND cl.opac_visible IS TRUE';
+ if ($self->api_name =~ /staff/o) {
+ $copies_visible = '';
+ $has_vols = '' if ($ou_type == 0);
+ $has_copies = '' if ($ou_type == 0);
+ }
+
+ # XXX test an "EXISTS version of descendant checking...
+ my $select;
+ if ($copies_visible) {
+ $select = <<" SQL";
+ SELECT count(distinct m.metarecord)
+ FROM $search_table f,
+ $metabib_metarecord_source_map_table m,
+ $metabib_metarecord_source_map_table mr,
+ $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $metabib_record_descriptor rd,
+ $descendants d
+ WHERE $fts_where
+ AND mr.source = f.source
+ AND mr.metarecord = m.metarecord
+ AND cn.record = m.source
+ AND rd.record = m.source
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ $has_vols
+ $has_copies
+ $copies_visible
+ $t_filter
+ $f_filter
+ SQL
+ } else {
+ $select = <<" SQL";
+ SELECT count(distinct m.metarecord)
+ FROM $search_table f,
+ $metabib_metarecord_source_map_table m,
+ $metabib_metarecord_source_map_table mr,
+ $metabib_record_descriptor rd
+ WHERE $fts_where
+ AND mr.source = f.source
+ AND mr.metarecord = m.metarecord
+ AND rd.record = m.source
+ $t_filter
+ $f_filter
+ SQL
+ }
+
+ $log->debug("Field Search Count SQL :: [$select]",DEBUG);
+
+ my $recs = $class->db_Main->selectrow_arrayref($select, {}, @types, @forms)->[0];
+
+ $log->debug("Count Search yielded $recs results.",DEBUG);
+
+ return $recs;
+
+}
+for my $class ( qw/title author subject keyword series identifier/ ) {
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.search_fts.metarecord_count",
+ method => 'search_class_fts_count',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.search_fts.metarecord_count.staff",
+ method => 'search_class_fts_count',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+}
+
+
+# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
+sub postfilter_search_class_fts {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $term = $args{term};
+ my $sort = $args{'sort'};
+ my $sort_dir = $args{sort_dir} || 'DESC';
+ my $ou = $args{org_unit};
+ my $ou_type = $args{depth};
+ my $limit = $args{limit} || 10;
+ my $visibility_limit = $args{visibility_limit} || 5000;
+ my $offset = $args{offset} || 0;
+
+ my $outer_limit = 1000;
+
+ my $limit_clause = '';
+ my $offset_clause = '';
+
+ $limit_clause = "LIMIT $outer_limit";
+ $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
+
+ my (@types,@forms,@lang,@aud,@lit_form);
+ my ($t_filter, $f_filter) = ('','');
+ my ($a_filter, $l_filter, $lf_filter) = ('','','');
+ my ($ot_filter, $of_filter) = ('','');
+ my ($oa_filter, $ol_filter, $olf_filter) = ('','','');
+
+ if (my $a = $args{audience}) {
+ $a = [$a] if (!ref($a));
+ @aud = @$a;
+
+ $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
+ $oa_filter = ' AND ord.audience IN ('.join(',',map{'?'}@aud).')';
+ }
+
+ if (my $l = $args{language}) {
+ $l = [$l] if (!ref($l));
+ @lang = @$l;
+
+ $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
+ $ol_filter = ' AND ord.item_lang IN ('.join(',',map{'?'}@lang).')';
+ }
+
+ if (my $f = $args{lit_form}) {
+ $f = [$f] if (!ref($f));
+ @lit_form = @$f;
+
+ $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ $olf_filter = ' AND ord.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ }
+
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ $of_filter .= ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+ }
+
+
+ my $descendants = defined($ou_type) ?
+ "actor.org_unit_descendants($ou, $ou_type)" :
+ "actor.org_unit_descendants($ou)";
+
+ my $class = $self->{cdbi};
+ my $search_table = $class->table;
+
+ my $metabib_full_rec = metabib::full_rec->table;
+ my $metabib_record_descriptor = metabib::record_descriptor->table;
+ my $metabib_metarecord = metabib::metarecord->table;
+ my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
+ my $asset_call_number_table = asset::call_number->table;
+ my $asset_copy_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $cl_table = asset::copy_location->table;
+ my $br_table = biblio::record_entry->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+ (my $search_class = $self->api_name) =~ s/.*metabib.(\w+).post_filter.*/$1/o;
+
+ my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $term, 'f.value', "f.$index_col");
+
+ my $SQLstring = join('%',map { lc($_) } $fts->words);
+ my $REstring = '^' . join('\s+',map { lc($_) } $fts->words) . '\W*$';
+ my $first_word = lc(($fts->words)[0]).'%';
+
+ my $fts_where = $fts->sql_where_clause;
+ my @fts_ranks = $fts->fts_rank;
+
+ my %bonus = ();
+ $bonus{'metabib::identifier_field_entry'} =
+ $bonus{'metabib::keyword_field_entry'} = [
+ { 'CASE WHEN f.value ILIKE ? THEN 1.2 ELSE 1 END' => $SQLstring }
+ ];
+
+ $bonus{'metabib::title_field_entry'} =
+ $bonus{'metabib::series_field_entry'} = [
+ { 'CASE WHEN f.value ILIKE ? THEN 1.5 ELSE 1 END' => $first_word },
+ { 'CASE WHEN f.value ~* ? THEN 2 ELSE 1 END' => $REstring },
+ @{ $bonus{'metabib::keyword_field_entry'} }
+ ];
+
+ my $bonus_list = join ' * ', map { keys %$_ } @{ $bonus{$class} };
+ $bonus_list ||= '1';
+
+ my @bonus_values = map { values %$_ } @{ $bonus{$class} };
+
+ my $relevance = join(' + ', @fts_ranks);
+ $relevance = <<" RANK";
+ (SUM( ( $relevance ) * ( $bonus_list ) )/COUNT(m.source))
+ RANK
+
+ my $string_default_sort = 'zzzz';
+ $string_default_sort = 'AAAA' if ($sort_dir eq 'DESC');
+
+ my $number_default_sort = '9999';
+ $number_default_sort = '0000' if ($sort_dir eq 'DESC');
+
+ my $rank = $relevance;
+ if (lc($sort) eq 'pubdate') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d+'),'$number_default_sort')::INT
+ FROM $metabib_full_rec frp
+ WHERE frp.record = mr.master_record
+ AND frp.tag = '260'
+ AND frp.subfield = 'c'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'create_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
+ RANK
+ } elsif (lc($sort) eq 'edit_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
+ RANK
+ } elsif (lc($sort) eq 'title') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
+ FROM $metabib_full_rec frt
+ WHERE frt.record = mr.master_record
+ AND frt.tag = '245'
+ AND frt.subfield = 'a'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'author') {
+ $rank = <<" RANK";
+ ( FIRST((
+ SELECT COALESCE(LTRIM(fra.value),'$string_default_sort')
+ FROM $metabib_full_rec fra
+ WHERE fra.record = mr.master_record
+ AND fra.tag LIKE '1%'
+ AND fra.subfield = 'a'
+ ORDER BY fra.tag::text::int
+ LIMIT 1
+ )) )
+ RANK
+ } else {
+ $sort = undef;
+ }
+
+ my $select = <<" SQL";
+ SELECT m.metarecord,
+ $relevance,
+ CASE WHEN COUNT(DISTINCT smrs.source) = 1 THEN MIN(m.source) ELSE 0 END,
+ $rank
+ FROM $search_table f,
+ $metabib_metarecord_source_map_table m,
+ $metabib_metarecord_source_map_table smrs,
+ $metabib_metarecord mr,
+ $metabib_record_descriptor rd
+ WHERE $fts_where
+ AND smrs.metarecord = mr.id
+ AND m.source = f.source
+ AND m.metarecord = mr.id
+ AND rd.record = smrs.source
+ $t_filter
+ $f_filter
+ $a_filter
+ $l_filter
+ $lf_filter
+ GROUP BY m.metarecord
+ ORDER BY 4 $sort_dir, MIN(COALESCE(CHAR_LENGTH(f.value),1))
+ LIMIT $visibility_limit
+ SQL
+
+ if (0) {
+ $select = <<" SQL";
+
+ SELECT DISTINCT s.*
+ FROM $asset_call_number_table cn,
+ $metabib_metarecord_source_map_table mrs,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $br_table br,
+ $descendants d,
+ $metabib_record_descriptor ord,
+ ($select) s
+ WHERE mrs.metarecord = s.metarecord
+ AND br.id = mrs.source
+ AND cn.record = mrs.source
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ AND cn.owning_lib = d.id
+ AND cp.call_number = cn.id
+ AND cp.opac_visible IS TRUE
+ AND cs.opac_visible IS TRUE
+ AND cl.opac_visible IS TRUE
+ AND d.opac_visible IS TRUE
+ AND br.active IS TRUE
+ AND br.deleted IS FALSE
+ AND ord.record = mrs.source
+ $ot_filter
+ $of_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ ORDER BY 4 $sort_dir
+ SQL
+ } elsif ($self->api_name !~ /staff/o) {
+ $select = <<" SQL";
+
+ SELECT DISTINCT s.*
+ FROM ($select) s
+ WHERE EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $metabib_metarecord_source_map_table mrs,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $br_table br,
+ $descendants d,
+ $metabib_record_descriptor ord
+
+ WHERE mrs.metarecord = s.metarecord
+ AND br.id = mrs.source
+ AND cn.record = mrs.source
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ AND cp.circ_lib = d.id
+ AND cp.call_number = cn.id
+ AND cp.opac_visible IS TRUE
+ AND cs.opac_visible IS TRUE
+ AND cl.opac_visible IS TRUE
+ AND d.opac_visible IS TRUE
+ AND br.active IS TRUE
+ AND br.deleted IS FALSE
+ AND ord.record = mrs.source
+ $ot_filter
+ $of_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ LIMIT 1
+ )
+ ORDER BY 4 $sort_dir
+ SQL
+ } else {
+ $select = <<" SQL";
+
+ SELECT DISTINCT s.*
+ FROM ($select) s
+ WHERE EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $metabib_metarecord_source_map_table mrs,
+ $br_table br,
+ $descendants d,
+ $metabib_record_descriptor ord
+
+ WHERE mrs.metarecord = s.metarecord
+ AND br.id = mrs.source
+ AND cn.record = mrs.source
+ AND cn.id = cp.call_number
+ AND br.deleted IS FALSE
+ AND cn.deleted IS FALSE
+ AND ord.record = mrs.source
+ AND ( cn.owning_lib = d.id
+ OR ( cp.circ_lib = d.id
+ AND cp.deleted IS FALSE
+ )
+ )
+ $ot_filter
+ $of_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ LIMIT 1
+ )
+ OR NOT EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $metabib_metarecord_source_map_table mrs,
+ $metabib_record_descriptor ord
+ WHERE mrs.metarecord = s.metarecord
+ AND cn.record = mrs.source
+ AND ord.record = mrs.source
+ $ot_filter
+ $of_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ LIMIT 1
+ )
+ ORDER BY 4 $sort_dir
+ SQL
+ }
+
+
+ $log->debug("Field Search SQL :: [$select]",DEBUG);
+
+ my $recs = $class->db_Main->selectall_arrayref(
+ $select, {},
+ (@bonus_values > 0 ? @bonus_values : () ),
+ ( (!$sort && @bonus_values > 0) ? @bonus_values : () ),
+ @types, @forms, @aud, @lang, @lit_form,
+ @types, @forms, @aud, @lang, @lit_form,
+ ($self->api_name =~ /staff/o ? (@types, @forms, @aud, @lang, @lit_form) : () ) );
+
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ my $max = 0;
+ $max = 1 if (!@$recs);
+ for (@$recs) {
+ $max = $$_[1] if ($$_[1] > $max);
+ }
+
+ my $count = scalar(@$recs);
+ for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
+ my ($mrid,$rank,$skip) = @$rec;
+ $client->respond( [$mrid, sprintf('%0.3f',$rank/$max), $skip, $count] );
+ }
+ return undef;
+}
+
+for my $class ( qw/title author subject keyword series identifier/ ) {
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.post_filter.search_fts.metarecord",
+ method => 'postfilter_search_class_fts',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+ __PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.$class.post_filter.search_fts.metarecord.staff",
+ method => 'postfilter_search_class_fts',
+ api_level => 1,
+ stream => 1,
+ cdbi => "metabib::${class}_field_entry",
+ cachable => 1,
+ );
+}
+
+
+
+my $_cdbi = { title => "metabib::title_field_entry",
+ author => "metabib::author_field_entry",
+ subject => "metabib::subject_field_entry",
+ keyword => "metabib::keyword_field_entry",
+ series => "metabib::series_field_entry",
+ identifier => "metabib::identifier_field_entry",
+};
+
+# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
+sub postfilter_search_multi_class_fts {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $sort = $args{'sort'};
+ my $sort_dir = $args{sort_dir} || 'DESC';
+ my $ou = $args{org_unit};
+ my $ou_type = $args{depth};
+ my $limit = $args{limit} || 10;
+ my $offset = $args{offset} || 0;
+ my $visibility_limit = $args{visibility_limit} || 5000;
+
+ if (!$ou) {
+ $ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
+ }
+
+ if (!defined($args{org_unit})) {
+ die "No target organizational unit passed to ".$self->api_name;
+ }
+
+ if (! scalar( keys %{$args{searches}} )) {
+ die "No search arguments were passed to ".$self->api_name;
+ }
+
+ my $outer_limit = 1000;
+
+ my $limit_clause = '';
+ my $offset_clause = '';
+
+ $limit_clause = "LIMIT $outer_limit";
+ $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
+
+ my ($avail_filter,@types,@forms,@lang,@aud,@lit_form,@vformats) = ('');
+ my ($t_filter, $f_filter, $v_filter) = ('','','');
+ my ($a_filter, $l_filter, $lf_filter) = ('','','');
+ my ($ot_filter, $of_filter, $ov_filter) = ('','','');
+ my ($oa_filter, $ol_filter, $olf_filter) = ('','','');
+
+ if ($args{available}) {
+ $avail_filter = ' AND cp.status IN (0,7,12)';
+ }
+
+ if (my $a = $args{audience}) {
+ $a = [$a] if (!ref($a));
+ @aud = @$a;
+
+ $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
+ $oa_filter = ' AND ord.audience IN ('.join(',',map{'?'}@aud).')';
+ }
+
+ if (my $l = $args{language}) {
+ $l = [$l] if (!ref($l));
+ @lang = @$l;
+
+ $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
+ $ol_filter = ' AND ord.item_lang IN ('.join(',',map{'?'}@lang).')';
+ }
+
+ if (my $f = $args{lit_form}) {
+ $f = [$f] if (!ref($f));
+ @lit_form = @$f;
+
+ $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ $olf_filter = ' AND ord.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ }
+
+ if (my $f = $args{item_form}) {
+ $f = [$f] if (!ref($f));
+ @forms = @$f;
+
+ $f_filter = ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ $of_filter = ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+
+ if (my $t = $args{item_type}) {
+ $t = [$t] if (!ref($t));
+ @types = @$t;
+
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (my $v = $args{vr_format}) {
+ $v = [$v] if (!ref($v));
+ @vformats = @$v;
+
+ $v_filter = ' AND rd.vr_format IN ('.join(',',map{'?'}@vformats).')';
+ $ov_filter = ' AND ord.vr_format IN ('.join(',',map{'?'}@vformats).')';
+ }
+
+
+ # XXX legacy format and item type support
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ $of_filter .= ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+ }
+
+
+
+ my $descendants = defined($ou_type) ?
+ "actor.org_unit_descendants($ou, $ou_type)" :
+ "actor.org_unit_descendants($ou)";
+
+ my $search_table_list = '';
+ my $fts_list = '';
+ my $join_table_list = '';
+ my @rank_list;
+
+ my $field_table = config::metabib_field->table;
+
+ my @bonus_lists;
+ my @bonus_values;
+ my $prev_search_group;
+ my $curr_search_group;
+ my $search_class;
+ my $search_field;
+ my $metabib_field;
+ for my $search_group (sort keys %{$args{searches}}) {
+ (my $search_group_name = $search_group) =~ s/\|/_/gso;
+ ($search_class,$search_field) = split /\|/, $search_group;
+ $log->debug("Searching class [$search_class] and field [$search_field]",DEBUG);
+
+ if ($search_field) {
+ unless ( $metabib_field = config::metabib_field->search( field_class => $search_class, name => $search_field )->next ) {
+ $log->warn("Requested class [$search_class] or field [$search_field] does not exist!");
+ return undef;
+ }
+ }
+
+ $prev_search_group = $curr_search_group if ($curr_search_group);
+
+ $curr_search_group = $search_group_name;
+
+ my $class = $_cdbi->{$search_class};
+ my $search_table = $class->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+
+ my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $args{searches}{$search_group}{term}, $search_group_name.'.value', "$search_group_name.$index_col");
+
+ my $fts_where = $fts->sql_where_clause;
+ my @fts_ranks = $fts->fts_rank;
+
+ my $SQLstring = join('%',map { lc($_) } $fts->words);
+ my $REstring = '^' . join('\s+',map { lc($_) } $fts->words) . '\W*$';
+ my $first_word = lc(($fts->words)[0]).'%';
+
+ $_.=" * (SELECT weight FROM $field_table WHERE $search_group_name.field = id)" for (@fts_ranks);
+ my $rank = join(' + ', @fts_ranks);
+
+ my %bonus = ();
+ $bonus{'keyword'} = [ { "CASE WHEN $search_group_name.value LIKE ? THEN 10 ELSE 1 END" => $SQLstring } ];
+ $bonus{'author'} = [ { "CASE WHEN $search_group_name.value ILIKE ? THEN 10 ELSE 1 END" => $first_word } ];
+
+ $bonus{'series'} = [
+ { "CASE WHEN $search_group_name.value LIKE ? THEN 1.5 ELSE 1 END" => $first_word },
+ { "CASE WHEN $search_group_name.value ~ ? THEN 20 ELSE 1 END" => $REstring },
+ ];
+
+ $bonus{'title'} = [ @{ $bonus{'series'} }, @{ $bonus{'keyword'} } ];
+
+ my $bonus_list = join ' * ', map { keys %$_ } @{ $bonus{$search_class} };
+ $bonus_list ||= '1';
+
+ push @bonus_lists, $bonus_list;
+ push @bonus_values, map { values %$_ } @{ $bonus{$search_class} };
+
+
+ #---------------------
+
+ $search_table_list .= "$search_table $search_group_name, ";
+ push @rank_list,$rank;
+ $fts_list .= " AND $fts_where AND m.source = $search_group_name.source";
+
+ if ($metabib_field) {
+ $join_table_list .= " AND $search_group_name.field = " . $metabib_field->id;
+ $metabib_field = undef;
+ }
+
+ if ($prev_search_group) {
+ $join_table_list .= " AND $prev_search_group.source = $curr_search_group.source";
+ }
+ }
+
+ my $metabib_record_descriptor = metabib::record_descriptor->table;
+ my $metabib_full_rec = metabib::full_rec->table;
+ my $metabib_metarecord = metabib::metarecord->table;
+ my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
+ my $asset_call_number_table = asset::call_number->table;
+ my $asset_copy_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $cl_table = asset::copy_location->table;
+ my $br_table = biblio::record_entry->table;
+ my $source_table = config::bib_source->table;
+
+ my $bonuses = join (' * ', @bonus_lists);
+ my $relevance = join (' + ', @rank_list);
+ $relevance = "SUM( ($relevance) * ($bonuses) )/COUNT(DISTINCT smrs.source)";
+
+ my $string_default_sort = 'zzzz';
+ $string_default_sort = 'AAAA' if ($sort_dir eq 'DESC');
+
+ my $number_default_sort = '9999';
+ $number_default_sort = '0000' if ($sort_dir eq 'DESC');
+
+
+
+ my $secondary_sort = <<" SORT";
+ ( FIRST ((
+ SELECT COALESCE(LTRIM(SUBSTR( sfrt.value, COALESCE(SUBSTRING(sfrt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
+ FROM $metabib_full_rec sfrt,
+ $metabib_metarecord mr
+ WHERE sfrt.record = mr.master_record
+ AND sfrt.tag = '245'
+ AND sfrt.subfield = 'a'
+ LIMIT 1
+ )) )
+ SORT
+
+ my $rank = $relevance;
+ if (lc($sort) eq 'pubdate') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d+'),'$number_default_sort')::INT
+ FROM $metabib_full_rec frp
+ WHERE frp.record = mr.master_record
+ AND frp.tag = '260'
+ AND frp.subfield = 'c'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'create_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
+ RANK
+ } elsif (lc($sort) eq 'edit_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = mr.master_record)) )
+ RANK
+ } elsif (lc($sort) eq 'title') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
+ FROM $metabib_full_rec frt
+ WHERE frt.record = mr.master_record
+ AND frt.tag = '245'
+ AND frt.subfield = 'a'
+ LIMIT 1
+ )) )
+ RANK
+ $secondary_sort = <<" SORT";
+ ( FIRST ((
+ SELECT COALESCE(SUBSTRING(sfrp.value FROM E'\\\\d+'),'$number_default_sort')::INT
+ FROM $metabib_full_rec sfrp
+ WHERE sfrp.record = mr.master_record
+ AND sfrp.tag = '260'
+ AND sfrp.subfield = 'c'
+ LIMIT 1
+ )) )
+ SORT
+ } elsif (lc($sort) eq 'author') {
+ $rank = <<" RANK";
+ ( FIRST((
+ SELECT COALESCE(LTRIM(fra.value),'$string_default_sort')
+ FROM $metabib_full_rec fra
+ WHERE fra.record = mr.master_record
+ AND fra.tag LIKE '1%'
+ AND fra.subfield = 'a'
+ ORDER BY fra.tag::text::int
+ LIMIT 1
+ )) )
+ RANK
+ } else {
+ push @bonus_values, @bonus_values;
+ $sort = undef;
+ }
+
+
+ my $select = <<" SQL";
+ SELECT m.metarecord,
+ $relevance,
+ CASE WHEN COUNT(DISTINCT smrs.source) = 1 THEN FIRST(m.source) ELSE 0 END,
+ $rank,
+ $secondary_sort
+ FROM $search_table_list
+ $metabib_metarecord mr,
+ $metabib_metarecord_source_map_table m,
+ $metabib_metarecord_source_map_table smrs
+ WHERE m.metarecord = smrs.metarecord
+ AND mr.id = m.metarecord
+ $fts_list
+ $join_table_list
+ GROUP BY m.metarecord
+ -- ORDER BY 4 $sort_dir
+ LIMIT $visibility_limit
+ SQL
+
+ if ($self->api_name !~ /staff/o) {
+ $select = <<" SQL";
+
+ SELECT s.*
+ FROM ($select) s
+ WHERE EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $metabib_metarecord_source_map_table mrs,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $br_table br,
+ $descendants d,
+ $metabib_record_descriptor ord
+ WHERE mrs.metarecord = s.metarecord
+ AND br.id = mrs.source
+ AND cn.record = mrs.source
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ AND cp.circ_lib = d.id
+ AND cp.call_number = cn.id
+ AND cp.opac_visible IS TRUE
+ AND cs.opac_visible IS TRUE
+ AND cl.opac_visible IS TRUE
+ AND d.opac_visible IS TRUE
+ AND br.active IS TRUE
+ AND br.deleted IS FALSE
+ AND cp.deleted IS FALSE
+ AND cn.deleted IS FALSE
+ AND ord.record = mrs.source
+ $ot_filter
+ $of_filter
+ $ov_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ $avail_filter
+ LIMIT 1
+ )
+ OR EXISTS (
+ SELECT 1
+ FROM $br_table br,
+ $metabib_metarecord_source_map_table mrs,
+ $metabib_record_descriptor ord,
+ $source_table src
+ WHERE mrs.metarecord = s.metarecord
+ AND ord.record = mrs.source
+ AND br.id = mrs.source
+ AND br.source = src.id
+ AND src.transcendant IS TRUE
+ $ot_filter
+ $of_filter
+ $ov_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ )
+ ORDER BY 4 $sort_dir, 5
+ SQL
+ } else {
+ $select = <<" SQL";
+
+ SELECT DISTINCT s.*
+ FROM ($select) s,
+ $metabib_metarecord_source_map_table omrs,
+ $metabib_record_descriptor ord
+ WHERE omrs.metarecord = s.metarecord
+ AND ord.record = omrs.source
+ AND ( EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $descendants d,
+ $br_table br
+ WHERE br.id = omrs.source
+ AND cn.record = omrs.source
+ AND br.deleted IS FALSE
+ AND cn.deleted IS FALSE
+ AND cp.call_number = cn.id
+ AND ( cn.owning_lib = d.id
+ OR ( cp.circ_lib = d.id
+ AND cp.deleted IS FALSE
+ )
+ )
+ $avail_filter
+ LIMIT 1
+ )
+ OR NOT EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn
+ WHERE cn.record = omrs.source
+ AND cn.deleted IS FALSE
+ LIMIT 1
+ )
+ OR EXISTS (
+ SELECT 1
+ FROM $br_table br,
+ $metabib_metarecord_source_map_table mrs,
+ $metabib_record_descriptor ord,
+ $source_table src
+ WHERE mrs.metarecord = s.metarecord
+ AND br.id = mrs.source
+ AND br.source = src.id
+ AND src.transcendant IS TRUE
+ $ot_filter
+ $of_filter
+ $ov_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+ )
+ )
+ $ot_filter
+ $of_filter
+ $ov_filter
+ $oa_filter
+ $ol_filter
+ $olf_filter
+
+ ORDER BY 4 $sort_dir, 5
+ SQL
+ }
+
+
+ $log->debug("Field Search SQL :: [$select]",DEBUG);
+
+ my $recs = $_cdbi->{title}->db_Main->selectall_arrayref(
+ $select, {},
+ @bonus_values,
+ @types, @forms, @vformats, @aud, @lang, @lit_form,
+ @types, @forms, @vformats, @aud, @lang, @lit_form,
+ # ($self->api_name =~ /staff/o ? (@types, @forms, @aud, @lang, @lit_form) : () )
+ );
+
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ my $max = 0;
+ $max = 1 if (!@$recs);
+ for (@$recs) {
+ $max = $$_[1] if ($$_[1] > $max);
+ }
+
+ my $count = scalar(@$recs);
+ for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
+ next unless ($$rec[0]);
+ my ($mrid,$rank,$skip) = @$rec;
+ $client->respond( [$mrid, sprintf('%0.3f',$rank/$max), $skip, $count] );
+ }
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.post_filter.multiclass.search_fts.metarecord",
+ method => 'postfilter_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.post_filter.multiclass.search_fts.metarecord.staff",
+ method => 'postfilter_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.multiclass.search_fts",
+ method => 'postfilter_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.multiclass.search_fts.staff",
+ method => 'postfilter_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
+sub biblio_search_multi_class_fts {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ my $sort = $args{'sort'};
+ my $sort_dir = $args{sort_dir} || 'DESC';
+ my $ou = $args{org_unit};
+ my $ou_type = $args{depth};
+ my $limit = $args{limit} || 10;
+ my $offset = $args{offset} || 0;
+ my $pref_lang = $args{prefered_language} || 'eng';
+ my $visibility_limit = $args{visibility_limit} || 5000;
+
+ if (!$ou) {
+ $ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
+ }
+
+ if (! scalar( keys %{$args{searches}} )) {
+ die "No search arguments were passed to ".$self->api_name;
+ }
+
+ my $outer_limit = 1000;
+
+ my $limit_clause = '';
+ my $offset_clause = '';
+
+ $limit_clause = "LIMIT $outer_limit";
+ $offset_clause = "OFFSET $offset" if (defined $offset and int($offset) > 0);
+
+ my ($avail_filter,@types,@forms,@lang,@aud,@lit_form,@vformats) = ('');
+ my ($t_filter, $f_filter, $v_filter) = ('','','');
+ my ($a_filter, $l_filter, $lf_filter) = ('','','');
+ my ($ot_filter, $of_filter, $ov_filter) = ('','','');
+ my ($oa_filter, $ol_filter, $olf_filter) = ('','','');
+
+ if ($args{available}) {
+ $avail_filter = ' AND cp.status IN (0,7,12)';
+ }
+
+ if (my $a = $args{audience}) {
+ $a = [$a] if (!ref($a));
+ @aud = @$a;
+
+ $a_filter = ' AND rd.audience IN ('.join(',',map{'?'}@aud).')';
+ $oa_filter = ' AND ord.audience IN ('.join(',',map{'?'}@aud).')';
+ }
+
+ if (my $l = $args{language}) {
+ $l = [$l] if (!ref($l));
+ @lang = @$l;
+
+ $l_filter = ' AND rd.item_lang IN ('.join(',',map{'?'}@lang).')';
+ $ol_filter = ' AND ord.item_lang IN ('.join(',',map{'?'}@lang).')';
+ }
+
+ if (my $f = $args{lit_form}) {
+ $f = [$f] if (!ref($f));
+ @lit_form = @$f;
+
+ $lf_filter = ' AND rd.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ $olf_filter = ' AND ord.lit_form IN ('.join(',',map{'?'}@lit_form).')';
+ }
+
+ if (my $f = $args{item_form}) {
+ $f = [$f] if (!ref($f));
+ @forms = @$f;
+
+ $f_filter = ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ $of_filter = ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+
+ if (my $t = $args{item_type}) {
+ $t = [$t] if (!ref($t));
+ @types = @$t;
+
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (my $v = $args{vr_format}) {
+ $v = [$v] if (!ref($v));
+ @vformats = @$v;
+
+ $v_filter = ' AND rd.vr_format IN ('.join(',',map{'?'}@vformats).')';
+ $ov_filter = ' AND ord.vr_format IN ('.join(',',map{'?'}@vformats).')';
+ }
+
+ # XXX legacy format and item type support
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ if (@types) {
+ $t_filter = ' AND rd.item_type IN ('.join(',',map{'?'}@types).')';
+ $ot_filter = ' AND ord.item_type IN ('.join(',',map{'?'}@types).')';
+ }
+
+ if (@forms) {
+ $f_filter .= ' AND rd.item_form IN ('.join(',',map{'?'}@forms).')';
+ $of_filter .= ' AND ord.item_form IN ('.join(',',map{'?'}@forms).')';
+ }
+ }
+
+
+ my $descendants = defined($ou_type) ?
+ "actor.org_unit_descendants($ou, $ou_type)" :
+ "actor.org_unit_descendants($ou)";
+
+ my $search_table_list = '';
+ my $fts_list = '';
+ my $join_table_list = '';
+ my @rank_list;
+
+ my $field_table = config::metabib_field->table;
+
+ my @bonus_lists;
+ my @bonus_values;
+ my $prev_search_group;
+ my $curr_search_group;
+ my $search_class;
+ my $search_field;
+ my $metabib_field;
+ for my $search_group (sort keys %{$args{searches}}) {
+ (my $search_group_name = $search_group) =~ s/\|/_/gso;
+ ($search_class,$search_field) = split /\|/, $search_group;
+ $log->debug("Searching class [$search_class] and field [$search_field]",DEBUG);
+
+ if ($search_field) {
+ unless ( $metabib_field = config::metabib_field->search( field_class => $search_class, name => $search_field )->next ) {
+ $log->warn("Requested class [$search_class] or field [$search_field] does not exist!");
+ return undef;
+ }
+ }
+
+ $prev_search_group = $curr_search_group if ($curr_search_group);
+
+ $curr_search_group = $search_group_name;
+
+ my $class = $_cdbi->{$search_class};
+ my $search_table = $class->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+
+ my $fts = OpenILS::Application::Storage::FTS->compile($search_class => $args{searches}{$search_group}{term}, $search_group_name.'.value', "$search_group_name.$index_col");
+
+ my $fts_where = $fts->sql_where_clause;
+ my @fts_ranks = $fts->fts_rank;
+
+ my $SQLstring = join('%',map { lc($_) } $fts->words) .'%';
+ my $REstring = '^' . join('\s+',map { lc($_) } $fts->words) . '\W*$';
+ my $first_word = lc(($fts->words)[0]).'%';
+
+ $_.=" * (SELECT weight FROM $field_table WHERE $search_group_name.field = id)" for (@fts_ranks);
+ my $rank = join(' + ', @fts_ranks);
+
+ my %bonus = ();
+ $bonus{'subject'} = [];
+ $bonus{'author'} = [ { "CASE WHEN $search_group_name.value ILIKE ? THEN 1.5 ELSE 1 END" => $first_word } ];
+
+ $bonus{'keyword'} = [ { "CASE WHEN $search_group_name.value ILIKE ? THEN 10 ELSE 1 END" => $SQLstring } ];
+
+ $bonus{'series'} = [
+ { "CASE WHEN $search_group_name.value ILIKE ? THEN 1.5 ELSE 1 END" => $first_word },
+ { "CASE WHEN $search_group_name.value ~ ? THEN 20 ELSE 1 END" => $REstring },
+ ];
+
+ $bonus{'title'} = [ @{ $bonus{'series'} }, @{ $bonus{'keyword'} } ];
+
+ if ($pref_lang) {
+ push @{ $bonus{'title'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
+ push @{ $bonus{'author'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
+ push @{ $bonus{'subject'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
+ push @{ $bonus{'keyword'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
+ push @{ $bonus{'series'} }, { "CASE WHEN rd.item_lang = ? THEN 10 ELSE 1 END" => $pref_lang };
+ }
+
+ my $bonus_list = join ' * ', map { keys %$_ } @{ $bonus{$search_class} };
+ $bonus_list ||= '1';
+
+ push @bonus_lists, $bonus_list;
+ push @bonus_values, map { values %$_ } @{ $bonus{$search_class} };
+
+ #---------------------
+
+ $search_table_list .= "$search_table $search_group_name, ";
+ push @rank_list,$rank;
+ $fts_list .= " AND $fts_where AND b.id = $search_group_name.source";
+
+ if ($metabib_field) {
+ $fts_list .= " AND $curr_search_group.field = " . $metabib_field->id;
+ $metabib_field = undef;
+ }
+
+ if ($prev_search_group) {
+ $join_table_list .= " AND $prev_search_group.source = $curr_search_group.source";
+ }
+ }
+
+ my $metabib_record_descriptor = metabib::record_descriptor->table;
+ my $metabib_full_rec = metabib::full_rec->table;
+ my $metabib_metarecord = metabib::metarecord->table;
+ my $metabib_metarecord_source_map_table = metabib::metarecord_source_map->table;
+ my $asset_call_number_table = asset::call_number->table;
+ my $asset_copy_table = asset::copy->table;
+ my $cs_table = config::copy_status->table;
+ my $cl_table = asset::copy_location->table;
+ my $br_table = biblio::record_entry->table;
+ my $source_table = config::bib_source->table;
+
+
+ my $bonuses = join (' * ', @bonus_lists);
+ my $relevance = join (' + ', @rank_list);
+ $relevance = "AVG( ($relevance) * ($bonuses) )";
+
+ my $string_default_sort = 'zzzz';
+ $string_default_sort = 'AAAA' if ($sort_dir eq 'DESC');
+
+ my $number_default_sort = '9999';
+ $number_default_sort = '0000' if ($sort_dir eq 'DESC');
+
+ my $rank = $relevance;
+ if (lc($sort) eq 'pubdate') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(SUBSTRING(frp.value FROM E'\\\\d{4}'),'$number_default_sort')::INT
+ FROM $metabib_full_rec frp
+ WHERE frp.record = b.id
+ AND frp.tag = '260'
+ AND frp.subfield = 'c'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'create_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT create_date FROM $br_table rbr WHERE rbr.id = b.id)) )
+ RANK
+ } elsif (lc($sort) eq 'edit_date') {
+ $rank = <<" RANK";
+ ( FIRST (( SELECT edit_date FROM $br_table rbr WHERE rbr.id = b.id)) )
+ RANK
+ } elsif (lc($sort) eq 'title') {
+ $rank = <<" RANK";
+ ( FIRST ((
+ SELECT COALESCE(LTRIM(SUBSTR( frt.value, COALESCE(SUBSTRING(frt.ind2 FROM E'\\\\d+'),'0')::INT + 1 )),'$string_default_sort')
+ FROM $metabib_full_rec frt
+ WHERE frt.record = b.id
+ AND frt.tag = '245'
+ AND frt.subfield = 'a'
+ LIMIT 1
+ )) )
+ RANK
+ } elsif (lc($sort) eq 'author') {
+ $rank = <<" RANK";
+ ( FIRST((
+ SELECT COALESCE(LTRIM(fra.value),'$string_default_sort')
+ FROM $metabib_full_rec fra
+ WHERE fra.record = b.id
+ AND fra.tag LIKE '1%'
+ AND fra.subfield = 'a'
+ ORDER BY fra.tag::text::int
+ LIMIT 1
+ )) )
+ RANK
+ } else {
+ push @bonus_values, @bonus_values;
+ $sort = undef;
+ }
+
+
+ my $select = <<" SQL";
+ SELECT b.id,
+ $relevance AS rel,
+ $rank AS rank,
+ b.source
+ FROM $search_table_list
+ $metabib_record_descriptor rd,
+ $source_table src,
+ $br_table b
+ WHERE rd.record = b.id
+ AND b.active IS TRUE
+ AND b.deleted IS FALSE
+ $fts_list
+ $join_table_list
+ $t_filter
+ $f_filter
+ $v_filter
+ $a_filter
+ $l_filter
+ $lf_filter
+ GROUP BY b.id, b.source
+ ORDER BY 3 $sort_dir
+ LIMIT $visibility_limit
+ SQL
+
+ if ($self->api_name !~ /staff/o) {
+ $select = <<" SQL";
+
+ SELECT s.*
+ FROM ($select) s
+ LEFT OUTER JOIN $source_table src ON (s.source = src.id)
+ WHERE EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $cs_table cs,
+ $cl_table cl,
+ $descendants d
+ WHERE cn.record = s.id
+ AND cp.status = cs.id
+ AND cp.location = cl.id
+ AND cp.call_number = cn.id
+ AND cp.opac_visible IS TRUE
+ AND cs.opac_visible IS TRUE
+ AND cl.opac_visible IS TRUE
+ AND d.opac_visible IS TRUE
+ AND cp.deleted IS FALSE
+ AND cn.deleted IS FALSE
+ AND cp.circ_lib = d.id
+ $avail_filter
+ LIMIT 1
+ )
+ OR src.transcendant IS TRUE
+ ORDER BY 3 $sort_dir
+ SQL
+ } else {
+ $select = <<" SQL";
+
+ SELECT s.*
+ FROM ($select) s
+ LEFT OUTER JOIN $source_table src ON (s.source = src.id)
+ WHERE EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn,
+ $asset_copy_table cp,
+ $descendants d
+ WHERE cn.record = s.id
+ AND cp.call_number = cn.id
+ AND cn.deleted IS FALSE
+ AND cp.circ_lib = d.id
+ AND cp.deleted IS FALSE
+ $avail_filter
+ LIMIT 1
+ )
+ OR NOT EXISTS (
+ SELECT 1
+ FROM $asset_call_number_table cn
+ WHERE cn.record = s.id
+ LIMIT 1
+ )
+ OR src.transcendant IS TRUE
+ ORDER BY 3 $sort_dir
+ SQL
+ }
+
+
+ $log->debug("Field Search SQL :: [$select]",DEBUG);
+
+ my $recs = $_cdbi->{title}->db_Main->selectall_arrayref(
+ $select, {},
+ @bonus_values, @types, @forms, @vformats, @aud, @lang, @lit_form
+ );
+
+ $log->debug("Search yielded ".scalar(@$recs)." results.",DEBUG);
+
+ my $count = scalar(@$recs);
+ for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
+ next unless ($$rec[0]);
+ my ($mrid,$rank) = @$rec;
+ $client->respond( [$mrid, sprintf('%0.3f',$rank), $count] );
+ }
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.search_fts.record",
+ method => 'biblio_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.search_fts.record.staff",
+ method => 'biblio_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.search_fts",
+ method => 'biblio_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.search_fts.staff",
+ method => 'biblio_search_multi_class_fts',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+
+my %locale_map;
+my $default_preferred_language;
+my $default_preferred_language_weight;
+
+# XXX factored most of the PG dependant stuff out of here... need to find a way to do "dependants".
+sub staged_fts {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ if (!$locale_map{COMPLETE}) {
+
+ my @locales = config::i18n_locale->search_where({ code => { '<>' => '' } });
+ for my $locale ( @locales ) {
+ $locale_map{lc($locale->code)} = $locale->marc_code;
+ }
+ $locale_map{COMPLETE} = 1;
+
+ }
+
+ if (!$default_preferred_language) {
+
+ $default_preferred_language = OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value(
+ apps => 'open-ils.storage' => app_settings => 'default_preferred_language'
+ );
+
+ }
+
+ if (!$default_preferred_language_weight) {
+
+ $default_preferred_language_weight = OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value(
+ apps => 'open-ils.storage' => app_settings => 'default_preferred_language_weight'
+ );
+
+ }
+
+ # inclusion, exclusion, delete_adjusted_inclusion, delete_adjusted_exclusion
+ my $estimation_strategy = $args{estimation_strategy} || 'inclusion';
+
+ my $ou = $args{org_unit};
+ my $limit = $args{limit} || 10;
+ my $offset = $args{offset} || 0;
+
+ if (!$ou) {
+ $ou = actor::org_unit->search( { parent_ou => undef } )->next->id;
+ }
+
+ if (! scalar( keys %{$args{searches}} )) {
+ die "No search arguments were passed to ".$self->api_name;
+ }
+
+ my (@between,@statuses,@locations,@types,@forms,@lang,@aud,@lit_form,@vformats,@bib_level);
+
+ if (!defined($args{preferred_language})) {
+ my $ses_locale = $client->session ? $client->session->session_locale : $default_preferred_language;
+ $args{preferred_language} =
+ $locale_map{ lc($ses_locale) } || 'eng';
+ }
+
+ if (!defined($args{preferred_language_weight})) {
+ $args{preferred_language_weight} = $default_preferred_language_weight || 2;
+ }
+
+ if ($args{available}) {
+ @statuses = (0,7,12);
+ }
+
+ if (my $s = $args{locations}) {
+ $s = [$s] if (!ref($s));
+ @locations = @$s;
+ }
+
+ if (my $b = $args{between}) {
+ if (ref($b) && @$b == 2) {
+ @between = @$b;
+ }
+ }
+
+ if (my $s = $args{statuses}) {
+ $s = [$s] if (!ref($s));
+ @statuses = @$s;
+ }
+
+ if (my $a = $args{audience}) {
+ $a = [$a] if (!ref($a));
+ @aud = @$a;
+ }
+
+ if (my $l = $args{language}) {
+ $l = [$l] if (!ref($l));
+ @lang = @$l;
+ }
+
+ if (my $f = $args{lit_form}) {
+ $f = [$f] if (!ref($f));
+ @lit_form = @$f;
+ }
+
+ if (my $f = $args{item_form}) {
+ $f = [$f] if (!ref($f));
+ @forms = @$f;
+ }
+
+ if (my $t = $args{item_type}) {
+ $t = [$t] if (!ref($t));
+ @types = @$t;
+ }
+
+ if (my $b = $args{bib_level}) {
+ $b = [$b] if (!ref($b));
+ @bib_level = @$b;
+ }
+
+ if (my $v = $args{vr_format}) {
+ $v = [$v] if (!ref($v));
+ @vformats = @$v;
+ }
+
+ # XXX legacy format and item type support
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ @types = split '', $t;
+ @forms = split '', $f;
+ }
+
+ my %stored_proc_search_args;
+ for my $search_group (sort keys %{$args{searches}}) {
+ (my $search_group_name = $search_group) =~ s/\|/_/gso;
+ my ($search_class,$search_field) = split /\|/, $search_group;
+ $log->debug("Searching class [$search_class] and field [$search_field]",DEBUG);
+
+ if ($search_field) {
+ unless ( config::metabib_field->search( field_class => $search_class, name => $search_field )->next ) {
+ $log->warn("Requested class [$search_class] or field [$search_field] does not exist!");
+ return undef;
+ }
+ }
+
+ my $class = $_cdbi->{$search_class};
+ my $search_table = $class->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+
+ my $fts = OpenILS::Application::Storage::FTS->compile(
+ $search_class => $args{searches}{$search_group}{term},
+ $search_group_name.'.value',
+ "$search_group_name.$index_col"
+ );
+ $fts->sql_where_clause; # this builds the ranks for us
+
+ my @fts_ranks = $fts->fts_rank;
+ my @fts_queries = $fts->fts_query;
+ my @phrases = map { lc($_) } $fts->phrases;
+ my @words = map { lc($_) } $fts->words;
+
+ $stored_proc_search_args{$search_group} = {
+ fts_rank => \@fts_ranks,
+ fts_query => \@fts_queries,
+ phrase => \@phrases,
+ word => \@words,
+ };
+
+ }
+
+ my $param_search_ou = $ou;
+ my $param_depth = $args{depth}; $param_depth = 'NULL' unless (defined($param_depth) and length($param_depth) > 0 );
+ my $param_searches = OpenSRF::Utils::JSON->perl2JSON( \%stored_proc_search_args ); $param_searches =~ s/\$//go; $param_searches = '$$'.$param_searches.'$$';
+ my $param_statuses = '$${' . join(',', map { s/\$//go; "\"$_\"" } @statuses ) . '}$$';
+ my $param_locations = '$${' . join(',', map { s/\$//go; "\"$_\"" } @locations) . '}$$';
+ my $param_audience = '$${' . join(',', map { s/\$//go; "\"$_\"" } @aud ) . '}$$';
+ my $param_language = '$${' . join(',', map { s/\$//go; "\"$_\"" } @lang ) . '}$$';
+ my $param_lit_form = '$${' . join(',', map { s/\$//go; "\"$_\"" } @lit_form ) . '}$$';
+ my $param_types = '$${' . join(',', map { s/\$//go; "\"$_\"" } @types ) . '}$$';
+ my $param_forms = '$${' . join(',', map { s/\$//go; "\"$_\"" } @forms ) . '}$$';
+ my $param_vformats = '$${' . join(',', map { s/\$//go; "\"$_\"" } @vformats ) . '}$$';
+ my $param_bib_level = '$${' . join(',', map { s/\$//go; "\"$_\"" } @bib_level) . '}$$';
+ my $param_before = $args{before}; $param_before = 'NULL' unless (defined($param_before) and length($param_before) > 0 );
+ my $param_after = $args{after} ; $param_after = 'NULL' unless (defined($param_after ) and length($param_after ) > 0 );
+ my $param_during = $args{during}; $param_during = 'NULL' unless (defined($param_during) and length($param_during) > 0 );
+ my $param_between = '$${"' . join('","', map { int($_) } @between) . '"}$$';
+ my $param_pref_lang = $args{preferred_language}; $param_pref_lang =~ s/\$//go; $param_pref_lang = '$$'.$param_pref_lang.'$$';
+ my $param_pref_lang_multiplier = $args{preferred_language_weight}; $param_pref_lang_multiplier ||= 'NULL';
+ my $param_sort = $args{'sort'}; $param_sort =~ s/\$//go; $param_sort = '$$'.$param_sort.'$$';
+ my $param_sort_desc = defined($args{sort_dir}) && $args{sort_dir} =~ /^d/io ? "'t'" : "'f'";
+ my $metarecord = $self->api_name =~ /metabib/o ? "'t'" : "'f'";
+ my $staff = $self->api_name =~ /staff/o ? "'t'" : "'f'";
+ my $param_rel_limit = $args{core_limit}; $param_rel_limit ||= 'NULL';
+ my $param_chk_limit = $args{check_limit}; $param_chk_limit ||= 'NULL';
+ my $param_skip_chk = $args{skip_check}; $param_skip_chk ||= 'NULL';
+
+ my $sth = metabib::metarecord_source_map->db_Main->prepare(<<" SQL");
+ SELECT *
+ FROM search.staged_fts(
+ $param_search_ou\:\:INT,
+ $param_depth\:\:INT,
+ $param_searches\:\:TEXT,
+ $param_statuses\:\:INT[],
+ $param_locations\:\:INT[],
+ $param_audience\:\:TEXT[],
+ $param_language\:\:TEXT[],
+ $param_lit_form\:\:TEXT[],
+ $param_types\:\:TEXT[],
+ $param_forms\:\:TEXT[],
+ $param_vformats\:\:TEXT[],
+ $param_bib_level\:\:TEXT[],
+ $param_before\:\:TEXT,
+ $param_after\:\:TEXT,
+ $param_during\:\:TEXT,
+ $param_between\:\:TEXT[],
+ $param_pref_lang\:\:TEXT,
+ $param_pref_lang_multiplier\:\:REAL,
+ $param_sort\:\:TEXT,
+ $param_sort_desc\:\:BOOL,
+ $metarecord\:\:BOOL,
+ $staff\:\:BOOL,
+ $param_rel_limit\:\:INT,
+ $param_chk_limit\:\:INT,
+ $param_skip_chk\:\:INT
+ );
+ SQL
+
+ $sth->execute;
+
+ my $recs = $sth->fetchall_arrayref({});
+ my $summary_row = pop @$recs;
+
+ my $total = $$summary_row{total};
+ my $checked = $$summary_row{checked};
+ my $visible = $$summary_row{visible};
+ my $deleted = $$summary_row{deleted};
+ my $excluded = $$summary_row{excluded};
+
+ my $estimate = $visible;
+ if ( $total > $checked && $checked ) {
+
+ $$summary_row{hit_estimate} = FTS_paging_estimate($self, $client, $checked, $visible, $excluded, $deleted, $total);
+ $estimate = $$summary_row{estimated_hit_count} = $$summary_row{hit_estimate}{$estimation_strategy};
+
+ }
+
+ delete $$summary_row{id};
+ delete $$summary_row{rel};
+ delete $$summary_row{record};
+
+ $client->respond( $summary_row );
+
+ $log->debug("Search yielded ".scalar(@$recs)." checked, visible results with an approximate visible total of $estimate.",DEBUG);
+
+ for my $rec (@$recs[$offset .. $offset + $limit - 1]) {
+ delete $$rec{checked};
+ delete $$rec{visible};
+ delete $$rec{excluded};
+ delete $$rec{deleted};
+ delete $$rec{total};
+ $$rec{rel} = sprintf('%0.3f',$$rec{rel});
+
+ $client->respond( $rec );
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.staged.search_fts",
+ method => 'staged_fts',
+ api_level => 0,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.staged.search_fts.staff",
+ method => 'staged_fts',
+ api_level => 0,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.multiclass.staged.search_fts",
+ method => 'staged_fts',
+ api_level => 0,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.multiclass.staged.search_fts.staff",
+ method => 'staged_fts',
+ api_level => 0,
+ stream => 1,
+ cachable => 1,
+);
+
+sub FTS_paging_estimate {
+ my $self = shift;
+ my $client = shift;
+
+ my $checked = shift;
+ my $visible = shift;
+ my $excluded = shift;
+ my $deleted = shift;
+ my $total = shift;
+
+ my $deleted_ratio = $deleted / $checked;
+ my $delete_adjusted_total = $total - ( $total * $deleted_ratio );
+
+ my $exclusion_ratio = $excluded / $checked;
+ my $delete_adjusted_exclusion_ratio = $excluded / ($checked - $deleted);
+
+ my $inclusion_ratio = $visible / $checked;
+ my $delete_adjusted_inclusion_ratio = $visible / ($checked - $deleted);
+
+ return {
+ exclusion => int($delete_adjusted_total - ( $delete_adjusted_total * $exclusion_ratio )),
+ inclusion => int($delete_adjusted_total * $inclusion_ratio),
+ delete_adjusted_exclusion => int($delete_adjusted_total - ( $delete_adjusted_total * $delete_adjusted_exclusion_ratio )),
+ delete_adjusted_inclusion => int($delete_adjusted_total * $delete_adjusted_inclusion_ratio)
+ };
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.fts_paging_estimate",
+ method => 'FTS_paging_estimate',
+ argc => 5,
+ strict => 1,
+ api_level => 1,
+ signature => {
+ 'return'=> q#
+ Hash of estimation values based on four variant estimation strategies:
+ exclusion -- Estimate based on the ratio of excluded records on the current superpage;
+ inclusion -- Estimate based on the ratio of visible records on the current superpage;
+ delete_adjusted_exclusion -- Same as exclusion strategy, but the ratio is adjusted by deleted count;
+ delete_adjusted_inclusion -- Same as inclusion strategy, but the ratio is adjusted by deleted count;
+ #,
+ desc => q#
+ Helper method used to determin the approximate number of
+ hits for a search that spans multiple superpages. For
+ sparse superpages, the inclusion estimate will likely be the
+ best estimate. The exclusion strategy is the original, but
+ inclusion is the default.
+ #,
+ params => [
+ { name => 'checked',
+ desc => 'Number of records check -- nominally the size of a superpage, or a remaining amount from the last superpage.',
+ type => 'number'
+ },
+ { name => 'visible',
+ desc => 'Number of records visible to the search location on the current superpage.',
+ type => 'number'
+ },
+ { name => 'excluded',
+ desc => 'Number of records excluded from the search location on the current superpage.',
+ type => 'number'
+ },
+ { name => 'deleted',
+ desc => 'Number of deleted records on the current superpage.',
+ type => 'number'
+ },
+ { name => 'total',
+ desc => 'Total number of records up to check_limit (superpage_size * max_superpages).',
+ type => 'number'
+ }
+ ]
+ }
+);
+
+
+sub xref_count {
+ my $self = shift;
+ my $client = shift;
+ my $args = shift;
+
+ my $term = $$args{term};
+ my $limit = $$args{max} || 1;
+ my $min = $$args{min} || 1;
+ my @classes = @{$$args{class}};
+
+ $limit = $min if ($min > $limit);
+
+ if (!@classes) {
+ @classes = ( qw/ title author subject series keyword / );
+ }
+
+ my %matches;
+ my $bre_table = biblio::record_entry->table;
+ my $cn_table = asset::call_number->table;
+ my $cp_table = asset::copy->table;
+
+ for my $search_class ( @classes ) {
+
+ my $class = $_cdbi->{$search_class};
+ my $search_table = $class->table;
+
+ my ($index_col) = $class->columns('FTS');
+ $index_col ||= 'value';
+
+
+ my $where = OpenILS::Application::Storage::FTS
+ ->compile($search_class => $term, $search_class.'.value', "$search_class.$index_col")
+ ->sql_where_clause;
+
+ my $SQL = <<" SQL";
+ SELECT COUNT(DISTINCT X.source)
+ FROM (SELECT $search_class.source
+ FROM $search_table $search_class
+ JOIN $bre_table b ON (b.id = $search_class.source)
+ WHERE $where
+ AND NOT b.deleted
+ AND b.active
+ LIMIT $limit) X
+ HAVING COUNT(DISTINCT X.source) >= $min;
+ SQL
+
+ my $res = $class->db_Main->selectrow_arrayref( $SQL );
+ $matches{$search_class} = $res ? $res->[0] : 0;
+ }
+
+ return \%matches;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.search.xref",
+ method => 'xref_count',
+ api_level => 1,
+);
+
+sub query_parser_fts {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+
+ # grab the query parser and initialize it
+ my $parser = $OpenILS::Application::Storage::QParser;
+ $parser->use;
+
+ if (!$parser->initialization_complete) {
+ my $cstore = OpenSRF::AppSession->create( 'open-ils.cstore' );
+ $parser->initialize(
+ config_metabib_field_index_norm_map =>
+ $cstore->request(
+ 'open-ils.cstore.direct.config.metabib_field_index_norm_map.search.atomic',
+ { id => { "!=" => undef } },
+ { flesh => 1, flesh_fields => { cmfinm => [qw/norm/] }, order_by => [{ class => "cmfinm", field => "pos" }] }
+ )->gather(1),
+ search_relevance_adjustment =>
+ $cstore->request(
+ 'open-ils.cstore.direct.search.relevance_adjustment.search.atomic',
+ { id => { "!=" => undef } }
+ )->gather(1),
+ config_metabib_field =>
+ $cstore->request(
+ 'open-ils.cstore.direct.config.metabib_field.search.atomic',
+ { id => { "!=" => undef } }
+ )->gather(1),
+ config_metabib_search_alias =>
+ $cstore->request(
+ 'open-ils.cstore.direct.config.metabib_search_alias.search.atomic',
+ { alias => { "!=" => undef } }
+ )->gather(1),
+ );
+
+ $cstore->disconnect;
+ die("Cannot initialize $parser!") unless ($parser->initialization_complete);
+ }
+
+
+ # populate the locale/language map
+ if (!$locale_map{COMPLETE}) {
+
+ my @locales = config::i18n_locale->search_where({ code => { '<>' => '' } });
+ for my $locale ( @locales ) {
+ $locale_map{lc($locale->code)} = $locale->marc_code;
+ }
+ $locale_map{COMPLETE} = 1;
+
+ }
+
+ # I hope we have a query!
+ if (! $args{query} ) {
+ die "No query was passed to ".$self->api_name;
+ }
+
+
+ my $simple_plan = $args{_simple_plan};
+ # remove bad chunks of the %args hash
+ for my $bad ( grep { /^_/ } keys(%args)) {
+ delete($args{$bad});
+ }
+
+
+ # parse the query and supply any query-level %arg-based defaults
+ # we expect, and make use of, query, superpage, superpage_size, debug and core_limit args
+ my $query = $parser->new( %args )->parse;
+
+
+ # set the locale-based default prefered location
+ if (!$query->parse_tree->find_filter('preferred_language')) {
+ $parser->default_preferred_language( $args{preferred_language} );
+ if (!$parser->default_preferred_language) {
+ my $ses_locale = $client->session ? $client->session->session_locale : '';
+ $parser->default_preferred_language( $locale_map{ lc($ses_locale) } );
+ }
+ $parser->default_preferred_language(
+ OpenSRF::Utils::SettingsClient->new->config_value(
+ apps => 'open-ils.storage' => app_settings => 'default_preferred_language'
+ )
+ ) if (!$parser->default_preferred_language);
+ }
+
+
+ # set the global default language multiplier
+ if (!$query->parse_tree->find_filter('preferred_language_weight') and !$query->parse_tree->find_filter('preferred_language_multiplier')) {
+ $parser->default_preferred_language_multiplier($args{preferred_language_weight});
+ $parser->default_preferred_language_multiplier($args{preferred_language_multiplier});
+ $parser->default_preferred_language_multiplier(
+ OpenSRF::Utils::SettingsClient->new->config_value(
+ apps => 'open-ils.storage' => app_settings => 'default_preferred_language_weight'
+ )
+ ) if (!$parser->default_preferred_language_multiplier);
+ }
+
+ # gather the site, if one is specified, defaulting to the in-query version
+ my $ou = $args{org_unit};
+ if (my ($filter) = $query->parse_tree->find_filter('site')) {
+ $ou = $filter->args->[0] if (@{$filter->args});
+ }
+ $ou = actor::org_unit->search( { shortname => $ou } )->next->id if ($ou and $ou !~ /^\d+$/);
+
+
+ # gather lasso, as with $ou
+ my $lasso = $args{lasso};
+ if (my ($filter) = $query->parse_tree->find_filter('lasso')) {
+ $lasso = $filter->args->[0] if (@{$filter->args});
+ }
+ $lasso = actor::org_lasso->search( { name => $lasso } )->next->id if ($lasso and $lasso !~ /^\d+$/);
+ $lasso = -$lasso if ($lasso);
+
+
+# # XXX once we have org_unit containers, we can make user-defined lassos .. WHEEE
+# # gather user lasso, as with $ou and lasso
+# my $mylasso = $args{my_lasso};
+# if (my ($filter) = $query->parse_tree->find_filter('my_lasso')) {
+# $mylasso = $filter->args->[0] if (@{$filter->args});
+# }
+# $mylasso = actor::org_unit->search( { name => $mylasso } )->next->id if ($mylasso and $mylasso !~ /^\d+$/);
+
+
+ # if we have a lasso, go with that, otherwise ... ou
+ $ou = $lasso if ($lasso);
+
+
+ # get the default $ou if we have nothing
+ $ou = actor::org_unit->search( { parent_ou => undef } )->next->id if (!$ou and !$lasso and !$mylasso);
+
+
+ # XXX when user lassos are here, check to make sure we don't have one -- it'll be passed in the depth, with an ou of 0
+ # gather the depth, if one is specified, defaulting to the in-query version
+ my $depth = $args{depth};
+ if (my ($filter) = $query->parse_tree->find_filter('depth')) {
+ $depth = $filter->args->[0] if (@{$filter->args});
+ }
+ $depth = actor::org_unit->search_where( [{ name => $depth },{ opac_label => $depth }], {limit => 1} )->next->id if ($depth and $depth !~ /^\d+$/);
+
+
+ # gather the limit or default to 10
+ my $limit = $args{check_limit} || 'NULL';
+ if (my ($filter) = $query->parse_tree->find_filter('limit')) {
+ $limit = $filter->args->[0] if (@{$filter->args});
+ }
+ if (my ($filter) = $query->parse_tree->find_filter('check_limit')) {
+ $limit = $filter->args->[0] if (@{$filter->args});
+ }
+
+
+ # gather the offset or default to 0
+ my $offset = $args{skip_check} || $args{offset} || 0;
+ if (my ($filter) = $query->parse_tree->find_filter('offset')) {
+ $offset = $filter->args->[0] if (@{$filter->args});
+ }
+ if (my ($filter) = $query->parse_tree->find_filter('skip_check')) {
+ $offset = $filter->args->[0] if (@{$filter->args});
+ }
+
+
+ # gather the estimation strategy or default to inclusion
+ my $estimation_strategy = $args{estimation_strategy} || 'inclusion';
+ if (my ($filter) = $query->parse_tree->find_filter('estimation_strategy')) {
+ $estimation_strategy = $filter->args->[0] if (@{$filter->args});
+ }
+
+
+ # gather the estimation strategy or default to inclusion
+ my $core_limit = $args{core_limit};
+ if (my ($filter) = $query->parse_tree->find_filter('core_limit')) {
+ $core_limit = $filter->args->[0] if (@{$filter->args});
+ }
+
+
+ # gather statuses, and then forget those if we have an #available modifier
+ my @statuses;
+ if (my ($filter) = $query->parse_tree->find_filter('statuses')) {
+ @statuses = @{$filter->args} if (@{$filter->args});
+ }
+ @statuses = (0,7,12) if ($query->parse_tree->find_modifier('available'));
+
+
+ # gather locations
+ my @location;
+ if (my ($filter) = $query->parse_tree->find_filter('locations')) {
+ @location = @{$filter->args} if (@{$filter->args});
+ }
+
+
+ my $param_check = $limit || $query->superpage_size || 'NULL';
+ my $param_offset = $offset || 'NULL';
+ my $param_limit = $core_limit || 'NULL';
+
+ my $sp = $query->superpage || 1;
+ if ($sp > 1) {
+ $param_offset = ($sp - 1) * $sp_size;
+ }
+
+ my $param_search_ou = $ou;
+ my $param_depth = $depth; $param_depth = 'NULL' unless (defined($depth) and length($depth) > 0 );
+ my $param_core_query = "\$core_query_$$\$" . $query->parse_tree->toSQL . "\$core_query_$$\$";
+ my $param_statuses = '$${' . join(',', map { s/\$//go; "\"$_\""} @statuses) . '}$$';
+ my $param_locations = '$${' . join(',', map { s/\$//go; "\"$_\""} @location) . '}$$';
+ my $staff = ($self->api_name =~ /staff/ or $query->parse_tree->find_modifier('staff')) ? "'t'" : "'f'";
+ my $metarecord = ($self->api_name =~ /metabib/ or $query->parse_tree->find_modifier('metabib') or $query->parse_tree->find_modifier('metarecord')) ? "'t'" : "'f'";
+
+ my $sth = metabib::metarecord_source_map->db_Main->prepare(<<" SQL");
+ SELECT * /* bib search */
+ FROM search.query_parser_fts(
+ $param_search_ou\:\:INT,
+ $param_depth\:\:INT,
+ $param_core_query\:\:TEXT,
+ $param_statuses\:\:INT[],
+ $param_locations\:\:INT[],
+ $param_offset\:\:INT,
+ $param_check\:\:INT,
+ $param_limit\:\:INT,
+ $metarecord\:\:BOOL,
+ $staff\:\:BOOL
+ );
+ SQL
+
+ $sth->execute;
+
+ my $recs = $sth->fetchall_arrayref({});
+ my $summary_row = pop @$recs;
+
+ my $total = $$summary_row{total};
+ my $checked = $$summary_row{checked};
+ my $visible = $$summary_row{visible};
+ my $deleted = $$summary_row{deleted};
+ my $excluded = $$summary_row{excluded};
+
+ my $estimate = $visible;
+ if ( $total > $checked && $checked ) {
+
+ $$summary_row{hit_estimate} = FTS_paging_estimate($self, $client, $checked, $visible, $excluded, $deleted, $total);
+ $estimate = $$summary_row{estimated_hit_count} = $$summary_row{hit_estimate}{$estimation_strategy};
+
+ }
+
+ delete $$summary_row{id};
+ delete $$summary_row{rel};
+ delete $$summary_row{record};
+
+ if (defined($simple_plan)) {
+ $$summary_row{complex_query} = $simple_plan ? 0 : 1;
+ } else {
+ $$summary_row{complex_query} = $query->simple_plan ? 0 : 1;
+ }
+
+ $client->respond( $summary_row );
+
+ $log->debug("Search yielded ".scalar(@$recs)." checked, visible results with an approximate visible total of $estimate.",DEBUG);
+
+ for my $rec (@$recs) {
+ delete $$rec{checked};
+ delete $$rec{visible};
+ delete $$rec{excluded};
+ delete $$rec{deleted};
+ delete $$rec{total};
+ $$rec{rel} = sprintf('%0.3f',$$rec{rel});
+
+ $client->respond( $rec );
+ }
+ return undef;
+}
+
+sub query_parser_fts_wrapper {
+ my $self = shift;
+ my $client = shift;
+ my %args = @_;
+
+ $log->debug("Entering compatability wrapper function for old-style staged search", DEBUG);
+ # grab the query parser and initialize it
+ my $parser = $OpenILS::Application::Storage::QParser;
+ $parser->use;
+
+ if (!$parser->initialization_complete) {
+ my $cstore = OpenSRF::AppSession->create( 'open-ils.cstore' );
+ $parser->initialize(
+ config_metabib_field_index_norm_map =>
+ $cstore->request(
+ 'open-ils.cstore.direct.config.metabib_field_index_norm_map.search.atomic',
+ { id => { "!=" => undef } },
+ { flesh => 1, flesh_fields => { cmfinm => [qw/norm/] }, order_by => [{ class => "cmfinm", field => "pos" }] }
+ )->gather(1),
+ search_relevance_adjustment =>
+ $cstore->request(
+ 'open-ils.cstore.direct.search.relevance_adjustment.search.atomic',
+ { id => { "!=" => undef } }
+ )->gather(1),
+ config_metabib_field =>
+ $cstore->request(
+ 'open-ils.cstore.direct.config.metabib_field.search.atomic',
+ { id => { "!=" => undef } }
+ )->gather(1),
+ config_metabib_search_alias =>
+ $cstore->request(
+ 'open-ils.cstore.direct.config.metabib_search_alias.search.atomic',
+ { alias => { "!=" => undef } }
+ )->gather(1),
+ );
+
+ $cstore->disconnect;
+ die("Cannot initialize $parser!") unless ($parser->initialization_complete);
+ }
+
+ if (! scalar( keys %{$args{searches}} )) {
+ die "No search arguments were passed to ".$self->api_name;
+ }
+
+ $log->debug("Constructing QueryParser query from staged search hash ...", DEBUG);
+ my $base_query = '';
+ for my $sclass ( keys %{$args{searches}} ) {
+ $log->debug(" --> staged search key: $sclass --> term: $args{searches}{$sclass}{term}", DEBUG);
+ $base_query .= " $sclass: $args{searches}{$sclass}{term}";
+ }
+
+ my $query = $base_query;
+ $log->debug("Full base query: $base_query", DEBUG);
+
+ $query = "$args{facets} $query" if ($args{facets});
+
+ if (!$locale_map{COMPLETE}) {
+
+ my @locales = config::i18n_locale->search_where({ code => { '<>' => '' } });
+ for my $locale ( @locales ) {
+ $locale_map{lc($locale->code)} = $locale->marc_code;
+ }
+ $locale_map{COMPLETE} = 1;
+
+ }
+
+ my $base_plan = $parser->new( query => $base_query )->parse;
+
+ $query = "preferred_language($args{preferred_language}) $query"
+ if ($args{preferred_language} and !$base_plan->parse_tree->find_filter('preferred_language'));
+ $query = "preferred_language_weight($args{preferred_language_weight}) $query"
+ if ($args{preferred_language_weight} and !$base_plan->parse_tree->find_filter('preferred_language_weight') and !$base_plan->parse_tree->find_filter('preferred_language_multiplier'));
+
+ $query = "estimation_strategy($args{estimation_strategy}) $query" if ($args{estimation_strategy});
+ $query = "site($args{org_unit}) $query" if ($args{org_unit});
+ $query = "depth($args{depth}) $query" if (defined($args{depth}));
+ $query = "sort($args{sort}) $query" if ($args{sort});
+ $query = "limit($args{limit}) $query" if ($args{limit});
+ $query = "core_limit($args{core_limit}) $query" if ($args{core_limit});
+ $query = "skip_check($args{skip_check}) $query" if ($args{skip_check});
+ $query = "superpage($args{superpage}) $query" if ($args{superpage});
+ $query = "offset($args{offset}) $query" if ($args{offset});
+ $query = "#metarecord $query" if ($self->api_name =~ /metabib/);
+ $query = "#available $query" if ($args{available});
+ $query = "#descending $query" if ($args{sort_dir} && $args{sort_dir} =~ /^d/i);
+ $query = "#staff $query" if ($self->api_name =~ /staff/);
+ $query = "before($args{before}) $query" if (defined($args{before}) and $args{before} =~ /^\d+$/);
+ $query = "after($args{after}) $query" if (defined($args{after}) and $args{after} =~ /^\d+$/);
+ $query = "during($args{during}) $query" if (defined($args{during}) and $args{during} =~ /^\d+$/);
+ $query = "between($args{between}[0],$args{between}[1]) $query"
+ if ( ref($args{between}) and @{$args{between}} == 2 and $args{between}[0] =~ /^\d+$/ and $args{between}[1] =~ /^\d+$/ );
+
+
+ my (@between,@statuses,@locations,@types,@forms,@lang,@aud,@lit_form,@vformats,@bib_level);
+
+ # XXX legacy format and item type support
+ if ($args{format}) {
+ my ($t, $f) = split '-', $args{format};
+ $args{item_type} = [ split '', $t ];
+ $args{item_form} = [ split '', $f ];
+ }
+
+ for my $filter ( qw/locations statuses between audience language lit_form item_form item_type bib_level vr_format/ ) {
+ if (my $s = $args{$filter}) {
+ $s = [$s] if (!ref($s));
+
+ my @filter_list = @$s;
+
+ next if ($filter eq 'between' and scalar(@filter_list) != 2);
+ next if (@filter_list == 0);
+
+ my $filter_string = join ',', @filter_list;
+ $query = "$filter($filter_string) $query";
+ }
+ }
+
+ $log->debug("Full QueryParser query: $query", DEBUG);
+
+ return query_parser_fts($self, $client, query => $query, _simple_plan => $base_plan->simple_plan );
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.staged.search_fts",
+ method => 'query_parser_fts_wrapper',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.biblio.multiclass.staged.search_fts.staff",
+ method => 'query_parser_fts_wrapper',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.multiclass.staged.search_fts",
+ method => 'query_parser_fts_wrapper',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.storage.metabib.multiclass.staged.search_fts.staff",
+ method => 'query_parser_fts_wrapper',
+ api_level => 1,
+ stream => 1,
+ cachable => 1,
+);
+
+
+1;
+
--- /dev/null
+package OpenILS::Application::Storage::Publisher::money;
+use base qw/OpenILS::Application::Storage/;
+use OpenSRF::Utils::Logger qw/:level/;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub _make_mbts {
+ my @xacts = @_;
+
+ my @mbts;
+ for my $x (@xacts) {
+ my $s = new Fieldmapper::money::billable_transaction_summary;
+ $s->id( $x->id );
+ $s->usr( $x->usr );
+ $s->xact_start( $x->xact_start );
+ $s->xact_finish( $x->xact_finish );
+
+ my $to = 0;
+ my $lb = undef;
+ for my $b ($x->billings) {
+ next if ($b->voided);
+ #$log->debug( "billing is ".$b->amount, DEBUG );
+ $to += ($b->amount * 100);
+ $lb ||= $b->billing_ts;
+ if ($b->billing_ts ge $lb) {
+ $lb = $b->billing_ts;
+ $s->last_billing_note($b->note);
+ $s->last_billing_ts($b->billing_ts);
+ $s->last_billing_type($b->billing_type);
+ }
+ }
+
+ $s->total_owed( sprintf('%0.2f', ($to) / 100 ) );
+
+ my $tp = 0;
+ my $lp = undef;
+ for my $p ($x->payments) {
+ #$log->debug( "payment is ".$p->amount." voided = ".$p->voided, DEBUG );
+ next if ($p->voided eq 't');
+ $tp += ($p->amount * 100);
+ $lp ||= $p->payment_ts;
+ if ($p->payment_ts ge $lp) {
+ $lp = $p->payment_ts;
+ $s->last_payment_note($p->note);
+ $s->last_payment_ts($p->payment_ts);
+ $s->last_payment_type($p->payment_type);
+ }
+ }
+ $s->total_paid( sprintf('%0.2f', ($tp) / 100 ) );
+
+ $s->balance_owed( sprintf('%0.2f', (($to) - ($tp)) / 100) );
+ #$log->debug( "balance of ".$x->id." == ".$s->balance_owed, DEBUG );
+
+ if (action::circulation->retrieve($x->id)) {
+ $s->xact_type( 'circulation' );
+ } elsif (money::grocery->retrieve($x->id)) {
+ $s->xact_type( 'grocery' );
+ } elsif (booking::reservation->retrieve($x->id)) {
+ $s->xact_type( 'reservation' );
+ }
+
+ push @mbts, $s;
+ }
+
+ return @mbts;
+}
+
+sub search_mbts {
+ my $self = shift;
+ my $client = shift;
+ my $search = shift;
+
+ my @xacts = money::billable_transaction->search_where( $search );
+ $client->respond( $_ ) for (_make_mbts(@xacts));
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'search_mbts',
+ api_name => 'open-ils.storage.money.billable_transaction.summary.search',
+ stream => 1,
+ argc => 1,
+);
+
+sub search_ous {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+
+ my @xacts = $self->method_lookup( 'open-ils.storage.money.billable_transaction.summary.search' )->run( { usr => $usr, xact_finish => undef } );
+
+ my ($total,$owed,$paid) = (0.0,0.0,0.0);
+ for my $x (@xacts) {
+ $total += $x->total_owed;
+ $owed += $x->balance_owed;
+ $paid += $x->total_paid;
+ }
+
+ my $ous = Fieldmapper::money::open_user_summary->new;
+ $ous->usr( $usr );
+ $ous->total_paid( sprintf('%0.2f', $paid) );
+ $ous->total_owed( sprintf('%0.2f', $total) );
+ $ous->balance_owed( sprintf('%0.2f', $owed) );
+
+ return $ous;
+}
+__PACKAGE__->register_method(
+ method => 'search_ous',
+ api_name => 'open-ils.storage.money.open_user_summary.search',
+ argc => 1,
+);
+
+
+sub new_collections {
+ my $self = shift;
+ my $client = shift;
+ my $age = shift;
+ my $amount = shift;
+ my @loc = @_;
+
+ my $mct = money::collections_tracker->table;
+ my $mb = money::billing->table;
+ my $circ = action::circulation->table;
+ my $mg = money::grocery->table;
+ my $res = booking::reservation->table;
+ my $descendants = "actor.org_unit_descendants((select id from actor.org_unit where shortname = ?))";
+
+ my $SQL = <<" SQL";
+
+select
+ usr,
+ MAX(last_billing) as last_pertinent_billing,
+ SUM(total_billing) - SUM(COALESCE(p.amount,0)) as threshold_amount
+ from (select
+ x.id,
+ x.usr,
+ MAX(b.billing_ts) as last_billing,
+ SUM(b.amount) AS total_billing
+ from action.circulation x
+ left join money.collections_tracker c ON (c.usr = x.usr AND c.location = ?)
+ join money.billing b on (b.xact = x.id)
+ where x.xact_finish is null
+ and c.id is null
+ and x.circ_lib in (XX)
+ and b.billing_ts < current_timestamp - ? * '1 day'::interval
+ and not b.voided
+ group by 1,2
+
+ union all
+
+ select
+ x.id,
+ x.usr,
+ MAX(b.billing_ts) as last_billing,
+ SUM(b.amount) AS total_billing
+ from money.grocery x
+ left join money.collections_tracker c ON (c.usr = x.usr AND c.location = ?)
+ join money.billing b on (b.xact = x.id)
+ where x.xact_finish is null
+ and c.id is null
+ and x.billing_location in (XX)
+ and b.billing_ts < current_timestamp - ? * '1 day'::interval
+ and not b.voided
+ group by 1,2
+
+ union all
+
+ select
+ x.id,
+ x.usr,
+ MAX(b.billing_ts) as last_billing,
+ SUM(b.amount) AS total_billing
+ from booking.reservation x
+ left join money.collections_tracker c ON (c.usr = x.usr AND c.location = ?)
+ join money.billing b on (b.xact = x.id)
+ where x.xact_finish is null
+ and c.id is null
+ and x.pickup_lib in (XX)
+ and b.billing_ts < current_timestamp - ? * '1 day'::interval
+ and not b.voided
+ group by 1,2
+ ) full_list
+ left join money.payment p on (full_list.id = p.xact)
+ group by 1
+ having SUM(total_billing) - SUM(COALESCE(p.amount,0)) > ?
+;
+ SQL
+
+ my @l_ids;
+ for my $l (@loc) {
+ my ($org) = actor::org_unit->search( shortname => uc($l) );
+ next unless $org;
+
+ my $o_list = actor::org_unit->db_Main->selectcol_arrayref( "SELECT id FROM actor.org_unit_descendants(?);", {}, $org->id );
+ next unless (@$o_list);
+
+ my $o_txt = join ',' => @$o_list;
+
+ (my $real_sql = $SQL) =~ s/XX/$o_txt/gsm;
+
+ my $sth = money::collections_tracker->db_Main->prepare($real_sql);
+ $sth->execute( $org->id, $age, $org->id, $age, $org->id, $age, $amount );
+
+ while (my $row = $sth->fetchrow_hashref) {
+ #$row->{usr} = actor::user->retrieve($row->{usr})->to_fieldmapper;
+ $client->respond( $row );
+ }
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'new_collections',
+ api_name => 'open-ils.storage.money.collections.users_of_interest',
+ stream => 1,
+ argc => 3,
+);
+
+sub users_owing_money {
+ my $self = shift;
+ my $client = shift;
+ my $start = shift;
+ my $end = shift;
+ my $amount = shift;
+ my @loc = @_;
+
+ my $mct = money::collections_tracker->table;
+ my $mb = money::billing->table;
+ my $circ = action::circulation->table;
+ my $mg = money::grocery->table;
+ my $descendants = "actor.org_unit_descendants((select id from actor.org_unit where shortname = ?))";
+
+ my $SQL = <<" SQL";
+
+select
+ usr,
+ SUM(total_billing) - SUM(COALESCE(p.amount,0)) as threshold_amount
+ from (select
+ x.id,
+ x.usr,
+ SUM(b.amount) AS total_billing
+ from action.circulation x
+ join money.billing b on (b.xact = x.id)
+ where x.xact_finish is null
+ and x.circ_lib in (XX)
+ and b.billing_ts between ? and ?
+ and not b.voided
+ group by 1,2
+
+ union all
+
+ select
+ x.id,
+ x.usr,
+ SUM(b.amount) AS total_billing
+ from money.grocery x
+ join money.billing b on (b.xact = x.id)
+ where x.xact_finish is null
+ and x.billing_location in (XX)
+ and b.billing_ts between ? and ?
+ and not b.voided
+ group by 1,2
+
+ union all
+
+ select
+ x.id,
+ x.usr,
+ SUM(b.amount) AS total_billing
+ from booking.reservation x
+ join money.billing b on (b.xact = x.id)
+ where x.xact_finish is null
+ and x.pickup_lib in (XX)
+ and b.billing_ts between ? and ?
+ and not b.voided
+ group by 1,2
+ ) full_list
+ left join money.payment p on (full_list.id = p.xact)
+ group by 1
+ having SUM(total_billing) - SUM(COALESCE(p.amount,0)) > ?
+;
+ SQL
+
+ my @l_ids;
+ for my $l (@loc) {
+ my ($org) = actor::org_unit->search( shortname => uc($l) );
+ next unless $org;
+
+ my $o_list = actor::org_unit->db_Main->selectcol_arrayref( "SELECT id FROM actor.org_unit_descendants(?);", {}, $org->id );
+ next unless (@$o_list);
+
+ my $o_txt = join ',' => @$o_list;
+
+ (my $real_sql = $SQL) =~ s/XX/$o_txt/gsm;
+
+ my $sth = money::collections_tracker->db_Main->prepare($real_sql);
+ $sth->execute( $start, $end, $start, $end, $amount );
+
+ while (my $row = $sth->fetchrow_hashref) {
+ #$row->{usr} = actor::user->retrieve($row->{usr})->to_fieldmapper;
+ $client->respond( $row );
+ }
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'users_owing_money',
+ api_name => 'open-ils.storage.money.collections.users_owing_money',
+ stream => 1,
+ argc => 4,
+);
+
+sub active_in_collections {
+ my $self = shift;
+ my $client = shift;
+ my $startdate = shift;
+ my $enddate = shift;
+ my @loc = @_;
+
+ my $mct = money::collections_tracker->table;
+ my $mb = money::billing->table;
+ my $circ = action::circulation->table;
+ my $mg = money::grocery->table;
+
+ my $SQL = <<" SQL";
+SELECT usr,
+ MAX(last_pertinent_billing) AS last_pertinent_billing,
+ MAX(last_pertinent_payment) AS last_pertinent_payment
+ FROM (
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM booking.reservation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.billing bl ON (lt.id = bl.xact)
+ WHERE cl.location = ?
+ AND lt.pickup_lib IN (XX)
+ AND bl.void_time BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ MAX(bl.billing_ts) AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM booking.reservation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.billing bl ON (lt.id = bl.xact)
+ WHERE cl.location = ?
+ AND lt.pickup_lib IN (XX)
+ AND bl.billing_ts BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ MAX(pm.payment_ts) AS last_pertinent_payment
+ FROM booking.reservation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.payment pm ON (lt.id = pm.xact)
+ WHERE cl.location = ?
+ AND lt.pickup_lib IN (XX)
+ AND pm.payment_ts BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM money.grocery lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.billing bl ON (lt.id = bl.xact)
+ WHERE cl.location = ?
+ AND lt.billing_location IN (XX)
+ AND bl.void_time BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ MAX(bl.billing_ts) AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM money.grocery lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.billing bl ON (lt.id = bl.xact)
+ WHERE cl.location = ?
+ AND lt.billing_location IN (XX)
+ AND bl.billing_ts BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ MAX(pm.payment_ts) AS last_pertinent_payment
+ FROM money.grocery lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.payment pm ON (lt.id = pm.xact)
+ WHERE cl.location = ?
+ AND lt.billing_location IN (XX)
+ AND pm.payment_ts BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM action.circulation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ WHERE cl.location = ?
+ AND lt.circ_lib IN (XX)
+ AND lt.checkin_time BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ MAX(pm.payment_ts) AS last_pertinent_payment
+ FROM action.circulation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.payment pm ON (lt.id = pm.xact)
+ WHERE cl.location = ?
+ AND lt.circ_lib IN (XX)
+ AND pm.payment_ts BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ NULL::TIMESTAMPTZ AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM action.circulation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.billing bl ON (lt.id = bl.xact)
+ WHERE cl.location = ?
+ AND lt.circ_lib IN (XX)
+ AND bl.void_time BETWEEN ? AND ?
+ GROUP BY 1
+
+ UNION ALL
+ SELECT lt.usr,
+ MAX(bl.billing_ts) AS last_pertinent_billing,
+ NULL::TIMESTAMPTZ AS last_pertinent_payment
+ FROM action.circulation lt
+ JOIN money.collections_tracker cl ON (lt.usr = cl.usr)
+ JOIN money.billing bl ON (lt.id = bl.xact)
+ WHERE cl.location = ?
+ AND lt.circ_lib IN (XX)
+ AND bl.billing_ts BETWEEN ? AND ?
+ GROUP BY 1
+ ) foo
+ GROUP BY 1
+;
+ SQL
+
+ my @l_ids;
+ for my $l (@loc) {
+ my ($org) = actor::org_unit->search( shortname => uc($l) );
+ next unless $org;
+
+ my $o_list = actor::org_unit->db_Main->selectcol_arrayref( "SELECT id FROM actor.org_unit_descendants(?);", {}, $org->id );
+ next unless (@$o_list);
+
+ my $o_txt = join ',' => @$o_list;
+
+ (my $real_sql = $SQL) =~ s/XX/$o_txt/gsm;
+
+ my $sth = money::collections_tracker->db_Main->prepare($real_sql);
+ $sth->execute(
+ # reservation queries
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate,
+
+ # grocery queries
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate,
+
+ # circ queries
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate,
+ $org->id, $startdate, $enddate
+ );
+
+ while (my $row = $sth->fetchrow_hashref) {
+ $row->{usr} = actor::user->retrieve($row->{usr})->to_fieldmapper;
+ $client->respond( $row );
+ }
+ }
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'active_in_collections',
+ api_name => 'open-ils.storage.money.collections.users_with_activity',
+ stream => 1,
+ argc => 3,
+);
+
+sub ou_desk_payments {
+ my $self = shift;
+ my $client = shift;
+ my $lib = shift;
+ my $startdate = shift;
+ my $enddate = shift;
+
+ return undef unless ($startdate =~ /^\d{4}-\d{2}-\d{2}$/o);
+ return undef unless ($enddate =~ /^\d{4}-\d{2}-\d{2}$/o);
+ return undef unless ($lib =~ /^\d+$/o);
+
+ my $sql = <<" SQL";
+
+ SELECT ws.id as workstation,
+ SUM( CASE WHEN p.payment_type = 'cash_payment' THEN p.amount ELSE 0.0 END ) as cash_payment,
+ SUM( CASE WHEN p.payment_type = 'check_payment' THEN p.amount ELSE 0.0 END ) as check_payment,
+ SUM( CASE WHEN p.payment_type = 'credit_card_payment' THEN p.amount ELSE 0.0 END ) as credit_card_payment
+ FROM money.desk_payment_view p
+ JOIN actor.workstation ws ON (ws.id = p.cash_drawer)
+ WHERE p.payment_ts >= '$startdate'
+ AND p.payment_ts < '$enddate'::TIMESTAMPTZ + INTERVAL '1 day'
+ AND p.voided IS FALSE
+ AND ws.owning_lib = $lib
+ GROUP BY 1
+ ORDER BY 1;
+
+ SQL
+
+ my $rows = money::payment->db_Main->selectall_arrayref( $sql );
+
+ for my $r (@$rows) {
+ my $x = new Fieldmapper::money::workstation_payment_summary;
+ $x->workstation( actor::workstation->retrieve($$r[0])->to_fieldmapper );
+ $x->cash_payment($$r[1]);
+ $x->check_payment($$r[2]);
+ $x->credit_card_payment($$r[3]);
+
+ $client->respond($x);
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'ou_desk_payments',
+ api_name => 'open-ils.storage.money.org_unit.desk_payments',
+ stream => 1,
+ argc => 3,
+);
+
+sub ou_user_payments {
+ my $self = shift;
+ my $client = shift;
+ my $lib = shift;
+ my $startdate = shift;
+ my $enddate = shift;
+
+ return undef unless ($startdate =~ /^\d{4}-\d{2}-\d{2}$/o);
+ return undef unless ($enddate =~ /^\d{4}-\d{2}-\d{2}$/o);
+ return undef unless ($lib =~ /^\d+$/o);
+
+ my $sql = <<" SQL";
+
+ SELECT au.id as usr,
+ SUM( CASE WHEN p.payment_type = 'forgive_payment' THEN p.amount ELSE 0.0 END ) as forgive_payment,
+ SUM( CASE WHEN p.payment_type = 'work_payment' THEN p.amount ELSE 0.0 END ) as work_payment,
+ SUM( CASE WHEN p.payment_type = 'credit_payment' THEN p.amount ELSE 0.0 END ) as credit_payment,
+ SUM( CASE WHEN p.payment_type = 'goods_payment' THEN p.amount ELSE 0.0 END ) as goods_payment
+ FROM money.bnm_payment_view p
+ JOIN actor.usr au ON (au.id = p.accepting_usr)
+ WHERE p.payment_ts >= '$startdate'
+ AND p.payment_ts < '$enddate'::TIMESTAMPTZ + INTERVAL '1 day'
+ AND p.voided IS FALSE
+ AND au.home_ou = $lib
+ AND p.payment_type IN ('credit_payment','forgive_payment','work_payment','goods_payment')
+ GROUP BY 1
+ ORDER BY 1;
+
+ SQL
+
+ my $rows = money::payment->db_Main->selectall_arrayref( $sql );
+
+ for my $r (@$rows) {
+ my $x = new Fieldmapper::money::user_payment_summary;
+ $x->usr( actor::user->retrieve($$r[0])->to_fieldmapper );
+ $x->forgive_payment($$r[1]);
+ $x->work_payment($$r[2]);
+ $x->credit_payment($$r[3]);
+ $x->goods_payment($$r[4]);
+
+ $client->respond($x);
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'ou_user_payments',
+ api_name => 'open-ils.storage.money.org_unit.user_payments',
+ stream => 1,
+ argc => 3,
+);
+
+sub mark_unrecovered {
+ my $self = shift;
+ my $xact = shift;
+
+ my $x = money::billable_xact->retrieve($xact);
+ $x->unrecovered( 't' );
+ return $x->update;
+}
+__PACKAGE__->register_method(
+ method => 'mark_unrecovered',
+ api_name => 'open-ils.storage.money.billable_xact.mark_unrecovered',
+ argc => 1,
+);
+
+
+1;
--- /dev/null
+package OpenILS::Application::Storage::Publisher::permission;
+use base qw/OpenILS::Application::Storage/;
+#use OpenILS::Application::Storage::CDBI::config;
+
+
+sub retrieve_all {
+ my $self = shift;
+ my $client = shift;
+
+ for my $rec ( permission::grp_tree->retrieve_all ) {
+ $client->respond( $rec->to_fieldmapper );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'retrieve_all',
+ api_name => 'open-ils.storage.direct.permission.grp_tree.retrieve.all',
+ argc => 0,
+ stream => 1,
+);
+
+sub retrieve_perms {
+ my $self = shift;
+ my $client = shift;
+
+ for my $rec ( sort { $a->code cmp $b->code } permission::perm_list->retrieve_all ) {
+ $client->respond( $rec->to_fieldmapper );
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'retrieve_perms',
+ api_name => 'open-ils.storage.direct.permission.perm_list.retrieve.all',
+ argc => 0,
+ stream => 1,
+);
+
+sub usr_has_perm {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+ my $perm = shift;
+ my $target = shift;
+
+ return permission::usr_grp_map->db_Main->selectrow_arrayref(<<" SQL",{}, "$usr", "$perm", "$target")->[0];
+ SELECT permission.usr_has_perm(?,?,?)
+ SQL
+}
+__PACKAGE__->register_method(
+ method => 'usr_has_perm',
+ api_name => 'open-ils.storage.permission.user_has_perm',
+ argc => 3,
+);
+
+sub usr_has_home_perm {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+ my $perm = shift;
+ my $target = shift;
+
+ return permission::usr_grp_map->db_Main->selectrow_arrayref(<<" SQL",{}, "$usr", "$perm", "$target")->[0];
+ SELECT permission.usr_has_home_perm(?,?,?)
+ SQL
+}
+__PACKAGE__->register_method(
+ method => 'usr_has_home_perm',
+ api_name => 'open-ils.storage.permission.user_has_home_perm',
+ argc => 3,
+);
+
+sub usr_has_work_perm {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+ my $perm = shift;
+ my $target = shift;
+
+ return permission::usr_grp_map->db_Main->selectrow_arrayref(<<" SQL",{}, "$usr", "$perm", "$target")->[0];
+ SELECT permission.usr_has_work_perm(?,?,?)
+ SQL
+}
+__PACKAGE__->register_method(
+ method => 'usr_has_work_perm',
+ api_name => 'open-ils.storage.permission.user_has_work_perm',
+ argc => 3,
+);
+
+sub usr_perms {
+ my $self = shift;
+ my $client = shift;
+ my $usr = shift;
+
+ my $sth = permission::usr_perm_map->db_Main->prepare('SELECT DISTINCT * FROM permission.usr_perms(?)');
+ $sth->execute("$usr");
+
+ $client->respond( $_->to_fieldmapper ) for ( map { permission::usr_perm_map->construct($_) } $sth->fetchall_hash );
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ method => 'usr_perms',
+ api_name => 'open-ils.storage.permission.user_perms',
+ argc => 1,
+ stream => 1,
+);
+
+1;
--- /dev/null
+package QueryParser;
+our %parser_config = (
+ QueryParser => {
+ filters => [],
+ modifiers => [],
+ operators => {
+ 'and' => '&&',
+ 'or' => '||',
+ group_start => '(',
+ group_end => ')',
+ required => '+',
+ modifier => '#'
+ }
+ }
+);
+
+sub facet_class_count {
+ my $self = shift;
+ return @{$self->facet_classes};
+}
+
+sub search_class_count {
+ my $self = shift;
+ return @{$self->search_classes};
+}
+
+sub filter_count {
+ my $self = shift;
+ return @{$self->filters};
+}
+
+sub modifier_count {
+ my $self = shift;
+ return @{$self->modifiers};
+}
+
+sub custom_data {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{custom_data} ||= {};
+ return $parser_config{$class}{custom_data};
+}
+
+sub operators {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{operators} ||= {};
+ return $parser_config{$class}{operators};
+}
+
+sub filters {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{filters} ||= [];
+ return $parser_config{$class}{filters};
+}
+
+sub modifiers {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{modifiers} ||= [];
+ return $parser_config{$class}{modifiers};
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %opts = @_;
+
+ my $self = bless {} => $class;
+
+ for my $o (keys %{QueryParser->operators}) {
+ $class->operator($o => QueryParser->operator($o)) unless ($class->operator($o));
+ }
+
+ for my $opt ( keys %opts) {
+ $self->$opt( $opts{$opt} ) if ($self->can($opt));
+ }
+
+ return $self;
+}
+
+sub new_plan {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ return do{$pkg.'::query_plan'}->new( QueryParser => $self, @_ );
+}
+
+sub add_search_filter {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $filter = shift;
+
+ return $filter if (grep { $_ eq $filter } @{$pkg->filters});
+ push @{$pkg->filters}, $filter;
+ return $filter;
+}
+
+sub add_search_modifier {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $modifier = shift;
+
+ return $modifier if (grep { $_ eq $modifier } @{$pkg->modifiers});
+ push @{$pkg->modifiers}, $modifier;
+ return $modifier;
+}
+
+sub add_facet_class {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+
+ return $class if (grep { $_ eq $class } @{$pkg->facet_classes});
+
+ push @{$pkg->facet_classes}, $class;
+ $pkg->facet_fields->{$class} = [];
+
+ return $class;
+}
+
+sub add_search_class {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+
+ return $class if (grep { $_ eq $class } @{$pkg->search_classes});
+
+ push @{$pkg->search_classes}, $class;
+ $pkg->search_fields->{$class} = [];
+ $pkg->default_search_class( $pkg->search_classes->[0] ) if (@{$pkg->search_classes} == 1);
+
+ return $class;
+}
+
+sub operator {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $opname = shift;
+ my $op = shift;
+
+ return undef unless ($opname);
+
+ $parser_config{$class}{operators} ||= {};
+ $parser_config{$class}{operators}{$opname} = $op if ($op);
+
+ return $parser_config{$class}{operators}{$opname};
+}
+
+sub facet_classes {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $classes = shift;
+
+ $parser_config{$class}{facet_classes} ||= [];
+ $parser_config{$class}{facet_classes} = $classes if (ref($classes) && @$classes);
+ return $parser_config{$class}{facet_classes};
+}
+
+sub search_classes {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $classes = shift;
+
+ $parser_config{$class}{classes} ||= [];
+ $parser_config{$class}{classes} = $classes if (ref($classes) && @$classes);
+ return $parser_config{$class}{classes};
+}
+
+sub add_query_normalizer {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+ my $func = shift;
+ my $params = shift || [];
+
+ return $func if (grep { $_ eq $func } @{$pkg->query_normalizers->{$class}->{$field}});
+
+ push(@{$pkg->query_normalizers->{$class}->{$field}}, { function => $func, params => $params });
+
+ return $func;
+}
+
+sub query_normalizers {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+
+ my $class = shift;
+ my $field = shift;
+
+ $parser_config{$pkg}{normalizers} ||= {};
+ if ($class) {
+ if ($field) {
+ $parser_config{$pkg}{normalizers}{$class}{$field} ||= [];
+ return $parser_config{$pkg}{normalizers}{$class}{$field};
+ } else {
+ return $parser_config{$pkg}{normalizers}{$class};
+ }
+ }
+
+ return $parser_config{$pkg}{normalizers};
+}
+
+sub default_search_class {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ $QueryParser::parser_config{$pkg}{default_class} = $pkg->add_search_class( $class ) if $class;
+
+ return $QueryParser::parser_config{$pkg}{default_class};
+}
+
+sub remove_facet_class {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+
+ return $class if (!grep { $_ eq $class } @{$pkg->facet_classes});
+
+ $pkg->facet_classes( [ grep { $_ ne $class } @{$pkg->facet_classes} ] );
+ delete $QueryParser::parser_config{$pkg}{facet_fields}{$class};
+
+ return $class;
+}
+
+sub remove_search_class {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+
+ return $class if (!grep { $_ eq $class } @{$pkg->search_classes});
+
+ $pkg->search_classes( [ grep { $_ ne $class } @{$pkg->search_classes} ] );
+ delete $QueryParser::parser_config{$pkg}{fields}{$class};
+
+ return $class;
+}
+
+sub add_facet_field {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+
+ $pkg->add_facet_class( $class );
+
+ return { $class => $field } if (grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
+
+ push @{$pkg->facet_fields->{$class}}, $field;
+
+ return { $class => $field };
+}
+
+sub facet_fields {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{facet_fields} ||= {};
+ return $parser_config{$class}{facet_fields};
+}
+
+sub add_search_field {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+
+ $pkg->add_search_class( $class );
+
+ return { $class => $field } if (grep { $_ eq $field } @{$pkg->search_fields->{$class}});
+
+ push @{$pkg->search_fields->{$class}}, $field;
+
+ return { $class => $field };
+}
+
+sub search_fields {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{fields} ||= {};
+ return $parser_config{$class}{fields};
+}
+
+sub add_search_class_alias {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $alias = shift;
+
+ $pkg->add_search_class( $class );
+
+ return { $class => $alias } if (grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
+
+ push @{$pkg->search_class_aliases->{$class}}, $alias;
+
+ return { $class => $alias };
+}
+
+sub search_class_aliases {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{class_map} ||= {};
+ return $parser_config{$class}{class_map};
+}
+
+sub add_search_field_alias {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+ my $alias = shift;
+
+ return { $class => { $field => $alias } } if (grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
+
+ push @{$pkg->search_field_aliases->{$class}{$field}}, $alias;
+
+ return { $class => { $field => $alias } };
+}
+
+sub search_field_aliases {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ $parser_config{$class}{field_alias_map} ||= {};
+ return $parser_config{$class}{field_alias_map};
+}
+
+sub remove_facet_field {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+
+ return { $class => $field } if (!$pkg->facet_fields->{$class} || !grep { $_ eq $field } @{$pkg->facet_fields->{$class}});
+
+ $pkg->facet_fields->{$class} = [ grep { $_ ne $field } @{$pkg->facet_fields->{$class}} ];
+
+ return { $class => $field };
+}
+
+sub remove_search_field {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+
+ return { $class => $field } if (!$pkg->search_fields->{$class} || !grep { $_ eq $field } @{$pkg->search_fields->{$class}});
+
+ $pkg->search_fields->{$class} = [ grep { $_ ne $field } @{$pkg->search_fields->{$class}} ];
+
+ return { $class => $field };
+}
+
+sub remove_search_field_alias {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $field = shift;
+ my $alias = shift;
+
+ return { $class => { $field => $alias } } if (!$pkg->search_field_aliases->{$class}{$field} || !grep { $_ eq $alias } @{$pkg->search_field_aliases->{$class}{$field}});
+
+ $pkg->search_field_aliases->{$class}{$field} = [ grep { $_ ne $alias } @{$pkg->search_field_aliases->{$class}{$field}} ];
+
+ return { $class => { $field => $alias } };
+}
+
+sub remove_search_class_alias {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $class = shift;
+ my $alias = shift;
+
+ return { $class => $alias } if (!$pkg->search_class_aliases->{$class} || !grep { $_ eq $alias } @{$pkg->search_class_aliases->{$class}});
+
+ $pkg->search_class_aliases->{$class} = [ grep { $_ ne $alias } @{$pkg->search_class_aliases->{$class}} ];
+
+ return { $class => $alias };
+}
+
+sub debug {
+ my $self = shift;
+ my $q = shift;
+ $self->{_debug} = $q if (defined $q);
+ return $self->{_debug};
+}
+
+sub query {
+ my $self = shift;
+ my $q = shift;
+ $self->{_query} = $q if (defined $q);
+ return $self->{_query};
+}
+
+sub parse_tree {
+ my $self = shift;
+ my $q = shift;
+ $self->{_parse_tree} = $q if (defined $q);
+ return $self->{_parse_tree};
+}
+
+sub parse {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ warn " ** parse package is $pkg\n" if $self->debug;
+ $self->parse_tree(
+ $self->decompose(
+ $self->query( shift() )
+ )
+ );
+
+ return $self;
+}
+
+sub decompose {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+
+ warn " ** decompose package is $pkg\n" if $self->debug;
+
+ $_ = shift;
+ my $current_class = shift || $self->default_search_class;
+
+ my $recursing = shift || 0;
+
+ # Build the search class+field uber-regexp
+ my $search_class_re = '^\s*(';
+ my $first_class = 1;
+
+ my %seen_classes;
+ for my $class ( keys %{$pkg->search_fields} ) {
+
+ for my $field ( @{$pkg->search_fields->{$class}} ) {
+
+ for my $alias ( @{$pkg->search_field_aliases->{$class}{$field}} ) {
+ $alias = qr/$alias/;
+ s/(^|\s+)$alias[:=]/$1$class\|$field:/g;
+ }
+ }
+
+ $search_class_re .= '|' unless ($first_class);
+ $first_class = 0;
+ $search_class_re .= $class . '(?:\|\w+)*';
+ $seen_classes{$class} = 1;
+ }
+
+ for my $class ( keys %{$pkg->search_class_aliases} ) {
+
+ for my $alias ( @{$pkg->search_class_aliases->{$class}} ) {
+ $alias = qr/$alias/;
+ s/(^|[^|])\b$alias\|/$1$class\|/g;
+ s/(^|[^|])\b$alias[:=]/$1$class:/g;
+ }
+
+ $search_class_re .= '|' unless ($first_class);
+ $first_class = 0;
+
+ $search_class_re .= $class . '(?:\|\w+)*' if (!$seen_classes{$class});
+ $seen_classes{$class} = 1;
+ }
+ $search_class_re .= '):';
+
+ warn " ** Search class RE: $search_class_re\n" if $self->debug;
+
+ my $required_re = $pkg->operator('required');
+ $required_re = qr/^\s*\Q$required_re\E/;
+ my $and_re = $pkg->operator('and');
+ $and_re = qr/^\s*\Q$and_re\E/;
+
+ my $or_re = $pkg->operator('or');
+ $or_re = qr/^\s*\Q$or_re\E/;
+
+ my $group_start_re = $pkg->operator('group_start');
+ $group_start_re = qr/^\s*\Q$group_start_re\E/;
+
+ my $group_end = $pkg->operator('group_end');
+ my $group_end_re = qr/^\s*\Q$group_end\E/;
+
+ my $modifier_tag_re = $pkg->operator('modifier');
+ $modifier_tag_re = qr/^\s*\Q$modifier_tag_re\E/;
+
+
+ # Build the filter and modifier uber-regexps
+ my $facet_re = '^\s*((?:' . join( '|', @{$pkg->facet_classes}) . ')(?:\|\w+)*)\[(.+?)\]';
+ warn " Facet RE: $facet_re\n" if $self->debug;
+
+ my $filter_re = '^\s*(' . join( '|', @{$pkg->filters}) . ')\(([^()]+)\)';
+ my $filter_as_class_re = '^\s*(' . join( '|', @{$pkg->filters}) . '):\s*(\S+)';
+
+ my $modifier_re = '^\s*'.$modifier_tag_re.'(' . join( '|', @{$pkg->modifiers}) . ')\b';
+ my $modifier_as_class_re = '^\s*(' . join( '|', @{$pkg->modifiers}) . '):\s*(\S+)';
+
+ my $struct = $self->new_plan( level => $recursing );
+ my $remainder = '';
+
+ my $last_type = '';
+ while (!$remainder) {
+ if (/^\s*$/) { # end of an explicit group
+ last;
+ } elsif (/$group_end_re/) { # end of an explicit group
+ warn "Encountered explicit group end\n" if $self->debug;
+
+ $_ = $';
+ $remainder = $';
+
+ $last_type = '';
+ } elsif ($self->filter_count && /$filter_re/) { # found a filter
+ warn "Encountered search filter: $1 set to $2\n" if $self->debug;
+
+ $_ = $';
+ $struct->new_filter( $1 => [ split '[, ]+', $2 ] );
+
+ $last_type = '';
+ } elsif ($self->filter_count && /$filter_as_class_re/) { # found a filter
+ warn "Encountered search filter: $1 set to $2\n" if $self->debug;
+
+ $_ = $';
+ $struct->new_filter( $1 => [ split '[, ]+', $2 ] );
+
+ $last_type = '';
+ } elsif ($self->modifier_count && /$modifier_re/) { # found a modifier
+ warn "Encountered search modifier: $1\n" if $self->debug;
+
+ $_ = $';
+ if (!$struct->top_plan) {
+ warn " Search modifiers only allowed at the top level of the query\n" if $self->debug;
+ } else {
+ $struct->new_modifier($1);
+ }
+
+ $last_type = '';
+ } elsif ($self->modifier_count && /$modifier_as_class_re/) { # found a modifier
+ warn "Encountered search modifier: $1\n" if $self->debug;
+
+ my $mod = $1;
+
+ $_ = $';
+ if (!$struct->top_plan) {
+ warn " Search modifiers only allowed at the top level of the query\n" if $self->debug;
+ } elsif ($2 =~ /^[ty1]/i) {
+ $struct->new_modifier($mod);
+ }
+
+ $last_type = '';
+ } elsif (/$group_start_re/) { # start of an explicit group
+ warn "Encountered explicit group start\n" if $self->debug;
+
+ my ($substruct, $subremainder) = $self->decompose( $', $current_class, $recursing + 1 );
+ $struct->add_node( $substruct );
+ $_ = $subremainder;
+
+ $last_type = '';
+ } elsif (/$and_re/) { # ANDed expression
+ $_ = $';
+ next if ($last_type eq 'AND');
+ next if ($last_type eq 'OR');
+ warn "Encountered AND\n" if $self->debug;
+
+ $struct->joiner( '&' );
+
+ $last_type = 'AND';
+ } elsif (/$or_re/) { # ORed expression
+ $_ = $';
+ next if ($last_type eq 'AND');
+ next if ($last_type eq 'OR');
+ warn "Encountered OR\n" if $self->debug;
+
+ $struct->joiner( '|' );
+
+ $last_type = 'OR';
+ } elsif ($self->facet_class_count && /$facet_re/) { # changing current class
+ warn "Encountered facet: $1 => $2\n" if $self->debug;
+
+ my $facet = $1;
+ my $facet_value = [ split '\s*#\s*', $2 ];
+ $struct->new_facet( $facet => $facet_value );
+ $_ = $';
+
+ $last_type = '';
+ } elsif ($self->search_class_count && /$search_class_re/) { # changing current class
+
+ if ($last_type eq 'CLASS') {
+ $struct->remove_last_node( $current_class );
+ warn "Encountered class change with no searches!\n" if $self->debug;
+ }
+
+ warn "Encountered class change: $1\n" if $self->debug;
+
+ $current_class = $1;
+ $struct->classed_node( $current_class );
+ $_ = $';
+
+ $last_type = 'CLASS';
+ } elsif (/^\s*"([^"]+)"/) { # phrase, always anded
+ warn "Encountered phrase: $1\n" if $self->debug;
+
+ $struct->joiner( '&' );
+ my $phrase = $1;
+
+ my $class_node = $struct->classed_node($current_class);
+ $class_node->add_phrase( $phrase );
+ $_ = $phrase . $';
+
+ $last_type = '';
+ } elsif (/$required_re([^\s)]+)/) { # phrase, always anded
+ warn "Encountered required atom (mini phrase): $1\n" if $self->debug;
+
+ my $phrase = $1;
+
+ my $class_node = $struct->classed_node($current_class);
+ $class_node->add_phrase( $phrase );
+ $_ = $phrase . $';
+ $struct->joiner( '&' );
+
+ $last_type = '';
+ } elsif (/^\s*([^$group_end\s]+)/o) { # atom
+ warn "Encountered atom: $1\n" if $self->debug;
+ warn "Remainder: $'\n" if $self->debug;
+
+ my $atom = $1;
+ my $after = $';
+
+ $_ = $after;
+ $last_type = '';
+
+ my $negator = ($atom =~ s/^-//o) ? '!' : '';
+ my $truncate = ($atom =~ s/\*$//o) ? '*' : '';
+
+ if (!grep { $atom eq $_ } ('&','|')) { # throw away & and |, not allowed in tsquery, and not really useful anyway
+ my $class_node = $struct->classed_node($current_class);
+ $class_node->add_fts_atom( $atom, suffix => $truncate, prefix => $negator, node => $class_node );
+ $struct->joiner( '&' );
+ }
+ }
+
+ last unless ($_);
+
+ }
+
+ return $struct if !wantarray;
+ return ($struct, $remainder);
+}
+
+sub find_class_index {
+ my $class = shift;
+ my $query = shift;
+
+ my ($class_part, @field_parts) = split '\|', $class;
+ $class_part ||= $class;
+
+ for my $idx ( 0 .. scalar(@$query) - 1 ) {
+ next unless ref($$query[$idx]);
+ return $idx if ( $$query[$idx]{requested_class} && $class eq $$query[$idx]{requested_class} );
+ }
+
+ push(@$query, { classname => $class_part, (@field_parts ? (fields => \@field_parts) : ()), requested_class => $class, ftsquery => [], phrases => [] });
+ return -1;
+}
+
+sub core_limit {
+ my $self = shift;
+ my $l = shift;
+ $self->{core_limit} = $l if ($l);
+ return $self->{core_limit};
+}
+
+sub superpage {
+ my $self = shift;
+ my $l = shift;
+ $self->{superpage} = $l if ($l);
+ return $self->{superpage};
+}
+
+sub superpage_size {
+ my $self = shift;
+ my $l = shift;
+ $self->{superpage_size} = $l if ($l);
+ return $self->{superpage_size};
+}
+
+
+#-------------------------------
+package QueryParser::query_plan;
+
+sub QueryParser {
+ my $self = shift;
+ return undef unless ref($self);
+ return $self->{QueryParser};
+}
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my %args = (query => [], joiner => '&', @_);
+
+ return bless \%args => $pkg;
+}
+
+sub new_node {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ my $node = do{$pkg.'::node'}->new( plan => $self, @_ );
+ $self->add_node( $node );
+ return $node;
+}
+
+sub new_facet {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ my $name = shift;
+ my $args = shift;
+
+ my $node = do{$pkg.'::facet'}->new( plan => $self, name => $name, 'values' => $args );
+ $self->add_node( $node );
+
+ return $node;
+}
+
+sub new_filter {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ my $name = shift;
+ my $args = shift;
+
+ my $node = do{$pkg.'::filter'}->new( plan => $self, name => $name, args => $args );
+ $self->add_filter( $node );
+
+ return $node;
+}
+
+sub find_filter {
+ my $self = shift;
+ my $needle = shift;;
+ return undef unless ($needle);
+ return grep { $_->name eq $needle } @{ $self->filters };
+}
+
+sub find_modifier {
+ my $self = shift;
+ my $needle = shift;;
+ return undef unless ($needle);
+ return grep { $_->name eq $needle } @{ $self->modifiers };
+}
+
+sub new_modifier {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ my $name = shift;
+
+ my $node = do{$pkg.'::modifier'}->new( $name );
+ $self->add_modifier( $node );
+
+ return $node;
+}
+
+sub classed_node {
+ my $self = shift;
+ my $requested_class = shift;
+
+ my $node;
+ for my $n (@{$self->{query}}) {
+ next unless (ref($n) && $n->isa( 'QueryParser::query_plan::node' ));
+ if ($n->requested_class eq $requested_class) {
+ $node = $n;
+ last;
+ }
+ }
+
+ if (!$node) {
+ $node = $self->new_node;
+ $node->requested_class( $requested_class );
+ }
+
+ return $node;
+}
+
+sub remove_last_node {
+ my $self = shift;
+ my $requested_class = shift;
+
+ my $old = pop(@{$self->query_nodes});
+ pop(@{$self->query_nodes}) if (@{$self->query_nodes});
+
+ return $old;
+}
+
+sub query_nodes {
+ my $self = shift;
+ return $self->{query};
+}
+
+sub add_node {
+ my $self = shift;
+ my $node = shift;
+
+ $self->{query} ||= [];
+ push(@{$self->{query}}, $self->joiner) if (@{$self->{query}});
+ push(@{$self->{query}}, $node);
+
+ return $self;
+}
+
+sub top_plan {
+ my $self = shift;
+
+ return $self->{level} ? 0 : 1;
+}
+
+sub plan_level {
+ my $self = shift;
+ return $self->{level};
+}
+
+sub joiner {
+ my $self = shift;
+ my $joiner = shift;
+
+ $self->{joiner} = $joiner if ($joiner);
+ return $self->{joiner};
+}
+
+sub modifiers {
+ my $self = shift;
+ $self->{modifiers} ||= [];
+ return $self->{modifiers};
+}
+
+sub add_modifier {
+ my $self = shift;
+ my $modifier = shift;
+
+ $self->{modifiers} ||= [];
+ return $self if (grep {$$_ eq $$modifier} @{$self->{modifiers}});
+
+ push(@{$self->{modifiers}}, $modifier);
+
+ return $self;
+}
+
+sub facets {
+ my $self = shift;
+ $self->{facets} ||= [];
+ return $self->{facets};
+}
+
+sub add_facet {
+ my $self = shift;
+ my $facet = shift;
+
+ $self->{facets} ||= [];
+ return $self if (grep {$_->name eq $facet->name} @{$self->{facets}});
+
+ push(@{$self->{facets}}, $facet);
+
+ return $self;
+}
+
+sub filters {
+ my $self = shift;
+ $self->{filters} ||= [];
+ return $self->{filters};
+}
+
+sub add_filter {
+ my $self = shift;
+ my $filter = shift;
+
+ $self->{filters} ||= [];
+ return $self if (grep {$_->name eq $filter->name} @{$self->{filters}});
+
+ push(@{$self->{filters}}, $filter);
+
+ return $self;
+}
+
+
+#-------------------------------
+package QueryParser::query_plan::node;
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my %args = @_;
+
+ return bless \%args => $pkg;
+}
+
+sub new_atom {
+ my $self = shift;
+ my $pkg = ref($self) || $self;
+ return do{$pkg.'::atom'}->new( @_ );
+}
+
+sub requested_class { # also split into classname and fields
+ my $self = shift;
+ my $class = shift;
+
+ if ($class) {
+ my ($class_part, @field_parts) = split '\|', $class;
+ $class_part ||= $class;
+
+ $self->{requested_class} = $class;
+ $self->{classname} = $class_part;
+ $self->{fields} = \@field_parts;
+ }
+
+ return $self->{requested_class};
+}
+
+sub plan {
+ my $self = shift;
+ my $plan = shift;
+
+ $self->{plan} = $plan if ($plan);
+ return $self->{plan};
+}
+
+sub classname {
+ my $self = shift;
+ my $class = shift;
+
+ $self->{classname} = $class if ($class);
+ return $self->{classname};
+}
+
+sub fields {
+ my $self = shift;
+ my @fields = @_;
+
+ $self->{fields} ||= [];
+ $self->{fields} = \@fields if (@fields);
+ return $self->{fields};
+}
+
+sub phrases {
+ my $self = shift;
+ my @phrases = @_;
+
+ $self->{phrases} ||= [];
+ $self->{phrases} = \@phrases if (@phrases);
+ return $self->{phrases};
+}
+
+sub add_phrase {
+ my $self = shift;
+ my $phrase = shift;
+
+ push(@{$self->phrases}, $phrase);
+
+ return $self;
+}
+
+sub query_atoms {
+ my $self = shift;
+ my @query_atoms = @_;
+
+ $self->{query_atoms} ||= [];
+ $self->{query_atoms} = \@query_atoms if (@query_atoms);
+ return $self->{query_atoms};
+}
+
+sub add_fts_atom {
+ my $self = shift;
+ my $atom = shift;
+
+ if (!ref($atom)) {
+ my $content = $atom;
+ my @parts = @_;
+
+ $atom = $self->new_atom( content => $content, @parts );
+ }
+
+ push(@{$self->query_atoms}, $self->plan->joiner) if (@{$self->query_atoms});
+ push(@{$self->query_atoms}, $atom);
+
+ return $self;
+}
+
+#-------------------------------
+package QueryParser::query_plan::node::atom;
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my %args = @_;
+
+ return bless \%args => $pkg;
+}
+
+sub node {
+ my $self = shift;
+ return undef unless (ref $self);
+ return $self->{node};
+}
+
+sub content {
+ my $self = shift;
+ return undef unless (ref $self);
+ return $self->{content};
+}
+
+sub prefix {
+ my $self = shift;
+ return undef unless (ref $self);
+ return $self->{prefix};
+}
+
+sub suffix {
+ my $self = shift;
+ return undef unless (ref $self);
+ return $self->{suffix};
+}
+
+#-------------------------------
+package QueryParser::query_plan::filter;
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my %args = @_;
+
+ return bless \%args => $pkg;
+}
+
+sub plan {
+ my $self = shift;
+ return $self->{plan};
+}
+
+sub name {
+ my $self = shift;
+ return $self->{name};
+}
+
+sub args {
+ my $self = shift;
+ return $self->{args};
+}
+
+#-------------------------------
+package QueryParser::query_plan::facet;
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my %args = @_;
+
+ return bless \%args => $pkg;
+}
+
+sub plan {
+ my $self = shift;
+ return $self->{plan};
+}
+
+sub name {
+ my $self = shift;
+ return $self->{name};
+}
+
+sub values {
+ my $self = shift;
+ return $self->{'values'};
+}
+
+#-------------------------------
+package QueryParser::query_plan::modifier;
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref($pkg) || $pkg;
+ my $modifier = shift;
+
+ return bless \$modifier => $pkg;
+}
+
+sub name {
+ my $self = shift;
+ return $$self;
+}
+
+1;
+
--- /dev/null
+# We'll be working with XML, so...
+use XML::LibXML;
+use XML::LibXSLT;
+use Unicode::Normalize;
+
+# ... and this has some handy common methods
+use OpenILS::Application::AppUtils;
+
+my $parser = new XML::LibXML;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+package OpenILS::Application::SuperCat;
+
+use strict;
+use warnings;
+use OpenILS::Utils::Normalize qw( naco_normalize );
+
+# All OpenSRF applications must be based on OpenSRF::Application or
+# a subclass thereof. Makes sense, eh?
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+# This is the client class, used for connecting to open-ils.storage
+use OpenSRF::AppSession;
+
+# This is an extension of Error.pm that supplies some error types to throw
+use OpenSRF::EX qw(:try);
+
+# This is a helper class for querying the OpenSRF Settings application ...
+use OpenSRF::Utils::SettingsClient;
+
+# ... and here we have the built in logging helper ...
+use OpenSRF::Utils::Logger qw($logger);
+
+# ... and this is our OpenILS object (en|de)coder and psuedo-ORM package.
+use OpenILS::Utils::Fieldmapper;
+
+our (
+ $_parser,
+ $_xslt,
+ %record_xslt,
+ %metarecord_xslt,
+ %holdings_data_cache,
+);
+
+sub child_init {
+ # we need an XML parser
+ $_parser = new XML::LibXML;
+
+ # and an xslt parser
+ $_xslt = new XML::LibXSLT;
+
+ # parse the MODS xslt ...
+ my $mods33_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2MODS33.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{mods33}{xslt} = $_xslt->parse_stylesheet( $mods33_xslt );
+ $record_xslt{mods33}{namespace_uri} = 'http://www.loc.gov/mods/v3';
+ $record_xslt{mods33}{docs} = 'http://www.loc.gov/mods/';
+ $record_xslt{mods33}{schema_location} = 'http://www.loc.gov/standards/mods/v3/mods-3-3.xsd';
+
+ # parse the MODS xslt ...
+ my $mods32_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2MODS32.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{mods32}{xslt} = $_xslt->parse_stylesheet( $mods32_xslt );
+ $record_xslt{mods32}{namespace_uri} = 'http://www.loc.gov/mods/v3';
+ $record_xslt{mods32}{docs} = 'http://www.loc.gov/mods/';
+ $record_xslt{mods32}{schema_location} = 'http://www.loc.gov/standards/mods/v3/mods-3-2.xsd';
+
+ # parse the MODS xslt ...
+ my $mods3_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2MODS3.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{mods3}{xslt} = $_xslt->parse_stylesheet( $mods3_xslt );
+ $record_xslt{mods3}{namespace_uri} = 'http://www.loc.gov/mods/v3';
+ $record_xslt{mods3}{docs} = 'http://www.loc.gov/mods/';
+ $record_xslt{mods3}{schema_location} = 'http://www.loc.gov/standards/mods/v3/mods-3-1.xsd';
+
+ # parse the MODS xslt ...
+ my $mods_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2MODS.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{mods}{xslt} = $_xslt->parse_stylesheet( $mods_xslt );
+ $record_xslt{mods}{namespace_uri} = 'http://www.loc.gov/mods/';
+ $record_xslt{mods}{docs} = 'http://www.loc.gov/mods/';
+ $record_xslt{mods}{schema_location} = 'http://www.loc.gov/standards/mods/mods.xsd';
+
+ # parse the ATOM entry xslt ...
+ my $atom_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2ATOM.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{atom}{xslt} = $_xslt->parse_stylesheet( $atom_xslt );
+ $record_xslt{atom}{namespace_uri} = 'http://www.w3.org/2005/Atom';
+ $record_xslt{atom}{docs} = 'http://www.ietf.org/rfc/rfc4287.txt';
+
+ # parse the RDFDC xslt ...
+ my $rdf_dc_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2RDFDC.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{rdf_dc}{xslt} = $_xslt->parse_stylesheet( $rdf_dc_xslt );
+ $record_xslt{rdf_dc}{namespace_uri} = 'http://purl.org/dc/elements/1.1/';
+ $record_xslt{rdf_dc}{schema_location} = 'http://purl.org/dc/elements/1.1/';
+
+ # parse the SRWDC xslt ...
+ my $srw_dc_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2SRWDC.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{srw_dc}{xslt} = $_xslt->parse_stylesheet( $srw_dc_xslt );
+ $record_xslt{srw_dc}{namespace_uri} = 'info:srw/schema/1/dc-schema';
+ $record_xslt{srw_dc}{schema_location} = 'http://www.loc.gov/z3950/agency/zing/srw/dc-schema.xsd';
+
+ # parse the OAIDC xslt ...
+ my $oai_dc_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2OAIDC.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{oai_dc}{xslt} = $_xslt->parse_stylesheet( $oai_dc_xslt );
+ $record_xslt{oai_dc}{namespace_uri} = 'http://www.openarchives.org/OAI/2.0/oai_dc/';
+ $record_xslt{oai_dc}{schema_location} = 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd';
+
+ # parse the RSS xslt ...
+ my $rss_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2RSS2.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{rss2}{xslt} = $_xslt->parse_stylesheet( $rss_xslt );
+
+ # parse the FGDC xslt ...
+ my $fgdc_xslt = $_parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/MARC21slim2FGDC.xsl"
+ );
+ # and stash a transformer
+ $record_xslt{fgdc}{xslt} = $_xslt->parse_stylesheet( $fgdc_xslt );
+ $record_xslt{fgdc}{docs} = 'http://www.fgdc.gov/metadata/csdgm/index_html';
+ $record_xslt{fgdc}{schema_location} = 'http://www.fgdc.gov/metadata/fgdc-std-001-1998.xsd';
+
+ register_record_transforms();
+
+ return 1;
+}
+
+sub register_record_transforms {
+ for my $type ( keys %record_xslt ) {
+ __PACKAGE__->register_method(
+ method => 'retrieve_record_transform',
+ api_name => "open-ils.supercat.record.$type.retrieve",
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns the \U$type\E representation ".
+ "of the requested bibliographic record",
+ params =>
+ [
+ { name => 'bibId',
+ desc => 'An OpenILS biblio::record_entry id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => "The bib record in \U$type\E",
+ type => 'string' }
+ }
+ );
+
+ __PACKAGE__->register_method(
+ method => 'retrieve_isbn_transform',
+ api_name => "open-ils.supercat.isbn.$type.retrieve",
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns the \U$type\E representation ".
+ "of the requested bibliographic record",
+ params =>
+ [
+ { name => 'isbn',
+ desc => 'An ISBN',
+ type => 'string' },
+ ],
+ 'return' =>
+ { desc => "The bib record in \U$type\E",
+ type => 'string' }
+ }
+ );
+ }
+}
+
+sub tree_walker {
+ my $tree = shift;
+ my $field = shift;
+ my $filter = shift;
+
+ return unless ($tree && ref($tree->$field));
+
+ my @things = $filter->($tree);
+ for my $v ( @{$tree->$field} ){
+ push @things, $filter->($v);
+ push @things, tree_walker($v, $field, $filter);
+ }
+ return @things
+}
+
+sub cn_browse {
+ my $self = shift;
+ my $client = shift;
+
+ my $label = shift;
+ my $ou = shift;
+ my $page_size = shift || 9;
+ my $page = shift || 0;
+ my $statuses = shift || [];
+ my $copy_locations = shift || [];
+
+ my ($before_limit,$after_limit) = (0,0);
+ my ($before_offset,$after_offset) = (0,0);
+
+ if (!$page) {
+ $before_limit = $after_limit = int($page_size / 2);
+ $after_limit += 1 if ($page_size % 2);
+ } else {
+ $before_offset = $after_offset = int($page_size / 2);
+ $before_offset += 1 if ($page_size % 2);
+ $before_limit = $after_limit = $page_size;
+ }
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $o_search = { shortname => $ou };
+ if (!$ou || $ou eq '-') {
+ $o_search = { parent_ou => undef };
+ }
+
+ my $orgs = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ $o_search,
+ { flesh => 100,
+ flesh_fields => { aou => [qw/children/] }
+ }
+ )->gather(1);
+
+ my @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
+
+ $logger->debug("Searching for CNs at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ my @list = ();
+
+ my @cp_filter = ();
+ if (@$statuses || @$copy_locations) {
+ @cp_filter = (
+ '-exists' => {
+ from => 'acp',
+ where => {
+ call_number => { '=' => { '+acn' => 'id' } },
+ deleted => 'f',
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ }
+ }
+ );
+ }
+
+ if ($page <= 0) {
+ my $before = $_storage->request(
+ "open-ils.cstore.direct.asset.call_number.search.atomic",
+ { label => { "<" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
+ owning_lib => \@ou_ids,
+ deleted => 'f',
+ @cp_filter
+ },
+ { flesh => 1,
+ flesh_fields => { acn => [qw/record owning_lib/] },
+ order_by => { acn => "oils_text_as_bytea(label_sortkey) desc, oils_text_as_bytea(label) desc, id desc, owning_lib desc" },
+ limit => $before_limit,
+ offset => abs($page) * $page_size - $before_offset,
+ }
+ )->gather(1);
+ push @list, reverse(@$before);
+ }
+
+ if ($page >= 0) {
+ my $after = $_storage->request(
+ "open-ils.cstore.direct.asset.call_number.search.atomic",
+ { label => { ">=" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
+ owning_lib => \@ou_ids,
+ deleted => 'f',
+ @cp_filter
+ },
+ { flesh => 1,
+ flesh_fields => { acn => [qw/record owning_lib/] },
+ order_by => { acn => "oils_text_as_bytea(label_sortkey), oils_text_as_bytea(label), id, owning_lib" },
+ limit => $after_limit,
+ offset => abs($page) * $page_size - $after_offset,
+ }
+ )->gather(1);
+ push @list, @$after;
+ }
+
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'cn_browse',
+ api_name => 'open-ils.supercat.call_number.browse',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the XML representation of the requested bibliographic record's holdings
+ DESC
+ params =>
+ [
+ { name => 'label',
+ desc => 'The target call number lable',
+ type => 'string' },
+ { name => 'org_unit',
+ desc => 'The org unit shortname (or "-" or undef for global) to browse',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ { name => 'statuses',
+ desc => 'Array of statuses to filter copies by, optional and can be undef.',
+ type => 'array' },
+ { name => 'locations',
+ desc => 'Array of copy locations to filter copies by, optional and can be undef.',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'Call numbers with owning_lib and record fleshed',
+ type => 'array' }
+ }
+);
+
+sub cn_startwith {
+ my $self = shift;
+ my $client = shift;
+
+ my $label = shift;
+ my $ou = shift;
+ my $limit = shift || 10;
+ my $page = shift || 0;
+ my $statuses = shift || [];
+ my $copy_locations = shift || [];
+
+
+ my $offset = abs($page) * $limit;
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $o_search = { shortname => $ou };
+ if (!$ou || $ou eq '-') {
+ $o_search = { parent_ou => undef };
+ }
+
+ my $orgs = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ $o_search,
+ { flesh => 100,
+ flesh_fields => { aou => [qw/children/] }
+ }
+ )->gather(1);
+
+ my @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
+
+ $logger->debug("Searching for CNs at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ my @list = ();
+
+ my @cp_filter = ();
+ if (@$statuses || @$copy_locations) {
+ @cp_filter = (
+ '-exists' => {
+ from => 'acp',
+ where => {
+ call_number => { '=' => { '+acn' => 'id' } },
+ deleted => 'f',
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ }
+ }
+ );
+ }
+
+ if ($page < 0) {
+ my $before = $_storage->request(
+ "open-ils.cstore.direct.asset.call_number.search.atomic",
+ { label => { "<" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
+ owning_lib => \@ou_ids,
+ deleted => 'f',
+ @cp_filter
+ },
+ { flesh => 1,
+ flesh_fields => { acn => [qw/record owning_lib/] },
+ order_by => { acn => "oils_text_as_bytea(label_sortkey) desc, oils_text_as_bytea(label) desc, id desc, owning_lib desc" },
+ limit => $limit,
+ offset => $offset,
+ }
+ )->gather(1);
+ push @list, reverse(@$before);
+ }
+
+ if ($page >= 0) {
+ my $after = $_storage->request(
+ "open-ils.cstore.direct.asset.call_number.search.atomic",
+ { label => { ">=" => { transform => "oils_text_as_bytea", value => ["oils_text_as_bytea", $label] } },
+ owning_lib => \@ou_ids,
+ deleted => 'f',
+ @cp_filter
+ },
+ { flesh => 1,
+ flesh_fields => { acn => [qw/record owning_lib/] },
+ order_by => { acn => "oils_text_as_bytea(label_sortkey), oils_text_as_bytea(label), id, owning_lib" },
+ limit => $limit,
+ offset => $offset,
+ }
+ )->gather(1);
+ push @list, @$after;
+ }
+
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'cn_startwith',
+ api_name => 'open-ils.supercat.call_number.startwith',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the XML representation of the requested bibliographic record's holdings
+ DESC
+ params =>
+ [
+ { name => 'label',
+ desc => 'The target call number lable',
+ type => 'string' },
+ { name => 'org_unit',
+ desc => 'The org unit shortname (or "-" or undef for global) to browse',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ { name => 'statuses',
+ desc => 'Array of statuses to filter copies by, optional and can be undef.',
+ type => 'array' },
+ { name => 'locations',
+ desc => 'Array of copy locations to filter copies by, optional and can be undef.',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'Call numbers with owning_lib and record fleshed',
+ type => 'array' }
+ }
+);
+
+
+sub new_books_by_item {
+ my $self = shift;
+ my $client = shift;
+
+ my $ou = shift;
+ my $page_size = shift || 10;
+ my $page = shift || 1;
+ my $statuses = shift || [];
+ my $copy_locations = shift || [];
+
+ my $offset = $page_size * ($page - 1);
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my @ou_ids;
+ if ($ou && $ou ne '-') {
+ my $orgs = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ { shortname => $ou },
+ { flesh => 100,
+ flesh_fields => { aou => [qw/children/] }
+ }
+ )->gather(1);
+ @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
+ }
+
+ $logger->debug("Searching for records with new copies at orgs [".join(',',@ou_ids)."], based on $ou");
+ my $cns = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { acn => ['record'],
+ acp => [{ aggregate => 1 => transform => max => column => create_date => alias => 'create_date'}]
+ },
+ from => { 'acn' => { 'acp' => { field => call_number => fkey => 'id' } } },
+ where =>
+ { '+acp' =>
+ { deleted => 'f',
+ ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ },
+ '+acn' => { record => { '>' => 0 } },
+ },
+ order_by => { acp => { create_date => { transform => 'max', direction => 'desc' } } },
+ limit => $page_size,
+ offset => $offset
+ }
+ )->gather(1);
+
+ return [ map { $_->{record} } @$cns ];
+}
+__PACKAGE__->register_method(
+ method => 'new_books_by_item',
+ api_name => 'open-ils.supercat.new_book_list',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the XML representation of the requested bibliographic record's holdings
+ DESC
+ params =>
+ [
+ { name => 'org_unit',
+ desc => 'The org unit shortname (or "-" or undef for global) to list',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of records to retrieve, default is 10',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of records to retrieve, calculated based on page_size. Starts at 1.',
+ type => 'number' },
+ { name => 'statuses',
+ desc => 'Array of statuses to filter copies by, optional and can be undef.',
+ type => 'array' },
+ { name => 'locations',
+ desc => 'Array of copy locations to filter copies by, optional and can be undef.',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'Record IDs',
+ type => 'array' }
+ }
+);
+
+
+sub general_browse {
+ my $self = shift;
+ my $client = shift;
+ return tag_sf_browse($self, $client, $self->{tag}, $self->{subfield}, @_);
+}
+__PACKAGE__->register_method(
+ method => 'general_browse',
+ api_name => 'open-ils.supercat.title.browse',
+ tag => 'tnf', subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target title', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_browse',
+ api_name => 'open-ils.supercat.author.browse',
+ tag => [qw/100 110 111/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target author', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_browse',
+ api_name => 'open-ils.supercat.subject.browse',
+ tag => [qw/600 610 611 630 648 650 651 653 655 656 662 690 691 696 697 698 699/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target subject', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_browse',
+ api_name => 'open-ils.supercat.topic.browse',
+ tag => [qw/650 690/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target topical subject', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_browse',
+ api_name => 'open-ils.supercat.series.browse',
+ tag => [qw/440 490 800 810 811 830/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target series', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+
+
+sub tag_sf_browse {
+ my $self = shift;
+ my $client = shift;
+
+ my $tag = shift;
+ my $subfield = shift;
+ my $value = shift;
+ my $ou = shift;
+ my $page_size = shift || 9;
+ my $page = shift || 0;
+ my $statuses = shift || [];
+ my $copy_locations = shift || [];
+
+ my ($before_limit,$after_limit) = (0,0);
+ my ($before_offset,$after_offset) = (0,0);
+
+ if (!$page) {
+ $before_limit = $after_limit = int($page_size / 2);
+ $after_limit += 1 if ($page_size % 2);
+ } else {
+ $before_offset = $after_offset = int($page_size / 2);
+ $before_offset += 1 if ($page_size % 2);
+ $before_limit = $after_limit = $page_size;
+ }
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my @ou_ids;
+ if ($ou && $ou ne '-') {
+ my $orgs = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ { shortname => $ou },
+ { flesh => 100,
+ flesh_fields => { aou => [qw/children/] }
+ }
+ )->gather(1);
+ @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
+ }
+
+ $logger->debug("Searching for records at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ my @list = ();
+
+ if ($page <= 0) {
+ my $before = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { mfr => [qw/record value/] },
+ from => 'mfr',
+ where =>
+ { '+mfr' =>
+ { tag => $tag,
+ subfield => $subfield,
+ value => { '<' => lc($value) }
+ },
+ '-or' => [
+ { '-exists' =>
+ { select=> { acp => [ 'id' ] },
+ from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
+ '+acp' =>
+ { deleted => 'f',
+ ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ }
+ },
+ limit => 1
+ }
+ },
+ { '-exists' =>
+ { select=> { auri => [ 'id' ] },
+ from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
+ '+auri' => { active => 't' }
+ },
+ limit => 1
+ }
+ }
+ ]
+ },
+ order_by => { mfr => { value => 'desc' } },
+ limit => $before_limit,
+ offset => abs($page) * $page_size - $before_offset,
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } reverse(@$before);
+ }
+
+ if ($page >= 0) {
+ my $after = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { mfr => [qw/record value/] },
+ from => 'mfr',
+ where =>
+ { '+mfr' =>
+ { tag => $tag,
+ subfield => $subfield,
+ value => { '>=' => lc($value) }
+ },
+ '-or' => [
+ { '-exists' =>
+ { select=> { acp => [ 'id' ] },
+ from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
+ '+acp' =>
+ { deleted => 'f',
+ ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ }
+ },
+ limit => 1
+ }
+ },
+ { '-exists' =>
+ { select=> { auri => [ 'id' ] },
+ from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
+ '+auri' => { active => 't' }
+ },
+ limit => 1
+ },
+ }
+ ]
+ },
+ order_by => { mfr => { value => 'asc' } },
+ limit => $after_limit,
+ offset => abs($page) * $page_size - $after_offset,
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } @$after;
+ }
+
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'tag_sf_browse',
+ api_name => 'open-ils.supercat.tag.browse',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a list of the requested org-scoped record IDs held
+ DESC
+ params =>
+ [
+ { name => 'tag',
+ desc => 'The target MARC tag',
+ type => 'string' },
+ { name => 'subfield',
+ desc => 'The target MARC subfield',
+ type => 'string' },
+ { name => 'value',
+ desc => 'The target string',
+ type => 'string' },
+ { name => 'org_unit',
+ desc => 'The org unit shortname (or "-" or undef for global) to browse',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ { name => 'statuses',
+ desc => 'Array of statuses to filter copies by, optional and can be undef.',
+ type => 'array' },
+ { name => 'locations',
+ desc => 'Array of copy locations to filter copies by, optional and can be undef.',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'Record IDs that have copies at the relevant org units',
+ type => 'array' }
+ }
+);
+
+sub general_authority_browse {
+ my $self = shift;
+ my $client = shift;
+ return authority_tag_sf_browse($self, $client, $self->{tag}, $self->{subfield}, @_);
+}
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.title.browse',
+ tag => ['130'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target title', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.author.browse',
+ tag => [qw/100 110 111/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target author', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.subject.browse',
+ tag => [qw/148 150 151 155/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.topic.browse',
+ tag => ['150'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target topical subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.title.refs.browse',
+ tag => ['130'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target title', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.author.refs.browse',
+ tag => [qw/100 110 111/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target author', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.subject.refs.browse',
+ tag => [qw/148 150 151 155/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_browse',
+ api_name => 'open-ils.supercat.authority.topic.refs.browse',
+ tag => ['150'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target topical subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+
+sub authority_tag_sf_browse {
+ my $self = shift;
+ my $client = shift;
+
+ my $tag = shift;
+ my $subfield = shift;
+ my $value = shift;
+ my $page_size = shift || 9;
+ my $page = shift || 0;
+
+ # Match authority.full_rec normalization
+ $value = naco_normalize($value, $subfield);
+
+ my ($before_limit,$after_limit) = (0,0);
+ my ($before_offset,$after_offset) = (0,0);
+
+ if (!$page) {
+ $before_limit = $after_limit = int($page_size / 2);
+ $after_limit += 1 if ($page_size % 2);
+ } else {
+ $before_offset = $after_offset = int($page_size / 2);
+ $before_offset += 1 if ($page_size % 2);
+ $before_limit = $after_limit = $page_size;
+ }
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ # .refs variant includes 4xx and 5xx variants for see / see also
+ my @ref_tags = ();
+ foreach my $tagname (@$tag) {
+ push(@ref_tags, $tagname);
+ if ($self->api_name =~ /\.refs\./) {
+ push(@ref_tags, '4' . substr($tagname, 1, 2));
+ push(@ref_tags, '5' . substr($tagname, 1, 2));
+ }
+ }
+ my @list = ();
+
+ if ($page <= 0) {
+ my $before = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { afr => [qw/record value/] },
+ from => { 'are', 'afr' },
+ where => {
+ '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '<' => $value } },
+ '+are' => { 'deleted' => 'f' }
+ },
+ order_by => { afr => { value => 'desc' } },
+ limit => $before_limit,
+ offset => abs($page) * $page_size - $before_offset,
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } reverse(@$before);
+ }
+
+ if ($page >= 0) {
+ my $after = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { afr => [qw/record value/] },
+ from => { 'are', 'afr' },
+ where => {
+ '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '>=' => $value } },
+ '+are' => { 'deleted' => 'f' }
+ },
+ order_by => { afr => { value => 'asc' } },
+ limit => $after_limit,
+ offset => abs($page) * $page_size - $after_offset,
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } @$after;
+ }
+
+ # If we're not pulling in see/see also references, just return the raw list
+ if ($self->api_name !~ /\.refs\./) {
+ return \@list;
+ }
+
+ # Remove dupe record IDs that turn up due to 4xx and 5xx matches
+ my @retlist = ();
+ my %seen;
+ foreach my $record (@list) {
+ next if exists $seen{$record};
+ push @retlist, int($record);
+ $seen{$record} = 1;
+ }
+
+ return \@retlist;
+}
+__PACKAGE__->register_method(
+ method => 'authority_tag_sf_browse',
+ api_name => 'open-ils.supercat.authority.tag.browse',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a list of the requested authority record IDs held
+ DESC
+ params =>
+ [
+ { name => 'tag',
+ desc => 'The target Authority MARC tag',
+ type => 'string' },
+ { name => 'subfield',
+ desc => 'The target Authority MARC subfield',
+ type => 'string' },
+ { name => 'value',
+ desc => 'The target string',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'Authority Record IDs that are near the target string',
+ type => 'array' }
+ }
+);
+
+sub general_startwith {
+ my $self = shift;
+ my $client = shift;
+ return tag_sf_startwith($self, $client, $self->{tag}, $self->{subfield}, @_);
+}
+__PACKAGE__->register_method(
+ method => 'general_startwith',
+ api_name => 'open-ils.supercat.title.startwith',
+ tag => 'tnf', subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target title', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_startwith',
+ api_name => 'open-ils.supercat.author.startwith',
+ tag => [qw/100 110 111/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target author', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_startwith',
+ api_name => 'open-ils.supercat.subject.startwith',
+ tag => [qw/600 610 611 630 648 650 651 653 655 656 662 690 691 696 697 698 699/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target subject', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_startwith',
+ api_name => 'open-ils.supercat.topic.startwith',
+ tag => [qw/650 690/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target topical subject', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_startwith',
+ api_name => 'open-ils.supercat.series.startwith',
+ tag => [qw/440 490 800 810 811 830/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested org-scoped record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target series', type => 'string' },
+ { name => 'org_unit', desc => 'The org unit shortname (or "-" or undef for global) to browse', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' },
+ { name => 'statuses', desc => 'Array of statuses to filter copies by, optional and can be undef.', type => 'array' },
+ { name => 'locations', desc => 'Array of copy locations to filter copies by, optional and can be undef.', type => 'array' }, ],
+ 'return' => { desc => 'Record IDs that have copies at the relevant org units', type => 'array' }
+ }
+);
+
+
+sub tag_sf_startwith {
+ my $self = shift;
+ my $client = shift;
+
+ my $tag = shift;
+ my $subfield = shift;
+ my $value = shift;
+ my $ou = shift;
+ my $limit = shift || 10;
+ my $page = shift || 0;
+ my $statuses = shift || [];
+ my $copy_locations = shift || [];
+
+ my $offset = $limit * abs($page);
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my @ou_ids;
+ if ($ou && $ou ne '-') {
+ my $orgs = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ { shortname => $ou },
+ { flesh => 100,
+ flesh_fields => { aou => [qw/children/] }
+ }
+ )->gather(1);
+ @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
+ }
+
+ $logger->debug("Searching for records at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ my @list = ();
+
+ if ($page < 0) {
+ my $before = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { mfr => [qw/record value/] },
+ from => 'mfr',
+ where =>
+ { '+mfr' =>
+ { tag => $tag,
+ subfield => $subfield,
+ value => { '<' => lc($value) }
+ },
+ '-or' => [
+ { '-exists' =>
+ { select=> { acp => [ 'id' ] },
+ from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
+ '+acp' =>
+ { deleted => 'f',
+ ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ }
+ },
+ limit => 1
+ }
+ },
+ { '-exists' =>
+ { select=> { auri => [ 'id' ] },
+ from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
+ '+auri' => { active => 't' }
+ },
+ limit => 1
+ }
+ }
+ ]
+ },
+ order_by => { mfr => { value => 'desc' } },
+ limit => $limit,
+ offset => $offset
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } reverse(@$before);
+ }
+
+ if ($page >= 0) {
+ my $after = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { mfr => [qw/record value/] },
+ from => 'mfr',
+ where =>
+ { '+mfr' =>
+ { tag => $tag,
+ subfield => $subfield,
+ value => { '>=' => lc($value) }
+ },
+ '-or' => [
+ { '-exists' =>
+ { select=> { acp => [ 'id' ] },
+ from => { acn => { acp => { field => 'call_number', fkey => 'id' } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } } },
+ '+acp' =>
+ { deleted => 'f',
+ ((@ou_ids) ? ( circ_lib => \@ou_ids) : ()),
+ ((@$statuses) ? ( status => $statuses) : ()),
+ ((@$copy_locations) ? ( location => $copy_locations) : ())
+ }
+ },
+ limit => 1
+ }
+ },
+ { '-exists' =>
+ { select=> { auri => [ 'id' ] },
+ from => { acn => { auricnm => { field => 'call_number', fkey => 'id', join => { auri => { field => 'id', fkey => 'uri' } } } } },
+ where =>
+ { '+acn' => { record => { '=' => { '+mfr' => 'record' } }, (@ou_ids) ? ( owning_lib => \@ou_ids) : () },
+ '+auri' => { active => 't' }
+ },
+ limit => 1
+ },
+ }
+ ]
+ },
+ order_by => { mfr => { value => 'asc' } },
+ limit => $limit,
+ offset => $offset
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } @$after;
+ }
+
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'tag_sf_startwith',
+ api_name => 'open-ils.supercat.tag.startwith',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a list of the requested org-scoped record IDs held
+ DESC
+ params =>
+ [
+ { name => 'tag',
+ desc => 'The target MARC tag',
+ type => 'string' },
+ { name => 'subfield',
+ desc => 'The target MARC subfield',
+ type => 'string' },
+ { name => 'value',
+ desc => 'The target string',
+ type => 'string' },
+ { name => 'org_unit',
+ desc => 'The org unit shortname (or "-" or undef for global) to browse',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ { name => 'statuses',
+ desc => 'Array of statuses to filter copies by, optional and can be undef.',
+ type => 'array' },
+ { name => 'locations',
+ desc => 'Array of copy locations to filter copies by, optional and can be undef.',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'Record IDs that have copies at the relevant org units',
+ type => 'array' }
+ }
+);
+
+sub general_authority_startwith {
+ my $self = shift;
+ my $client = shift;
+ return authority_tag_sf_startwith($self, $client, $self->{tag}, $self->{subfield}, @_);
+}
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.title.startwith',
+ tag => ['130'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target title', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.author.startwith',
+ tag => [qw/100 110 111/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target author', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.subject.startwith',
+ tag => [qw/148 150 151 155/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.topic.startwith',
+ tag => ['150'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held",
+ params =>
+ [ { name => 'value', desc => 'The target topical subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.title.refs.startwith',
+ tag => ['130'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target title', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.author.refs.startwith',
+ tag => [qw/100 110 111/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target author', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.subject.refs.startwith',
+ tag => [qw/148 150 151 155/], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'general_authority_startwith',
+ api_name => 'open-ils.supercat.authority.topic.refs.startwith',
+ tag => ['150'], subfield => 'a',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => "Returns a list of the requested authority record IDs held, including see (4xx) and see also (5xx) references",
+ params =>
+ [ { name => 'value', desc => 'The target topical subject', type => 'string' },
+ { name => 'page_size', desc => 'Count of records to retrieve, default is 9', type => 'number' },
+ { name => 'page', desc => 'The page of records retrieved, calculated based on page_size. Can be positive, negative or 0.', type => 'number' }, ],
+ 'return' => { desc => 'Authority Record IDs that are near the target string', type => 'array' }
+ }
+);
+
+sub authority_tag_sf_startwith {
+ my $self = shift;
+ my $client = shift;
+
+ my $tag = shift;
+ my $subfield = shift;
+
+ my $value = shift;
+ my $limit = shift || 10;
+ my $page = shift || 0;
+
+ # Match authority.full_rec normalization
+ $value = naco_normalize($value, $subfield);
+
+ my $ref_limit = $limit;
+ my $offset = $limit * abs($page);
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my @ref_tags = ();
+ # .refs variant includes 4xx and 5xx variants for see / see also
+ foreach my $tagname (@$tag) {
+ push(@ref_tags, $tagname);
+ if ($self->api_name =~ /\.refs\./) {
+ push(@ref_tags, '4' . substr($tagname, 1, 2));
+ push(@ref_tags, '5' . substr($tagname, 1, 2));
+ }
+ }
+
+ my @list = ();
+
+ if ($page < 0) {
+ # Don't skip the first actual page of results in descending order
+ $offset = $offset - $limit;
+
+ my $before = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { afr => [qw/record value/] },
+ from => { 'afr', 'are' },
+ where => {
+ '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '<' => $value } },
+ '+are' => { deleted => 'f' }
+ },
+ order_by => { afr => { value => 'desc' } },
+ limit => $ref_limit,
+ offset => $offset,
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } reverse(@$before);
+ }
+
+ if ($page >= 0) {
+ my $after = $_storage->request(
+ "open-ils.cstore.json_query.atomic",
+ { select => { afr => [qw/record value/] },
+ from => { 'afr', 'are' },
+ where => {
+ '+afr' => { tag => \@ref_tags, subfield => $subfield, value => { '>=' => $value } },
+ '+are' => { deleted => 'f' }
+ },
+ order_by => { afr => { value => 'asc' } },
+ limit => $ref_limit,
+ offset => $offset,
+ }
+ )->gather(1);
+ push @list, map { $_->{record} } @$after;
+ }
+
+ # If we're not pulling in see/see also references, just return the raw list
+ if ($self->api_name !~ /\.refs\./) {
+ return \@list;
+ }
+
+ # Remove dupe record IDs that turn up due to 4xx and 5xx matches
+ my @retlist = ();
+ my %seen;
+ foreach my $record (@list) {
+ next if exists $seen{$record};
+ push @retlist, int($record);
+ $seen{$record} = 1;
+ }
+
+ return \@retlist;
+}
+__PACKAGE__->register_method(
+ method => 'authority_tag_sf_startwith',
+ api_name => 'open-ils.supercat.authority.tag.startwith',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a list of the requested authority record IDs held
+ DESC
+ params =>
+ [
+ { name => 'tag',
+ desc => 'The target Authority MARC tag',
+ type => 'string' },
+ { name => 'subfield',
+ desc => 'The target Authority MARC subfield',
+ type => 'string' },
+ { name => 'value',
+ desc => 'The target string',
+ type => 'string' },
+ { name => 'page_size',
+ desc => 'Count of call numbers to retrieve, default is 9',
+ type => 'number' },
+ { name => 'page',
+ desc => 'The page of call numbers to retrieve, calculated based on page_size. Can be positive, negative or 0.',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'Authority Record IDs that are near the target string',
+ type => 'array' }
+ }
+);
+
+
+sub holding_data_formats {
+ return [{
+ marcxml => {
+ namespace_uri => 'http://www.loc.gov/MARC21/slim',
+ docs => 'http://www.loc.gov/marcxml/',
+ schema_location => 'http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd',
+ }
+ }];
+}
+__PACKAGE__->register_method( method => 'holding_data_formats', api_name => 'open-ils.supercat.acn.formats', api_level => 1 );
+__PACKAGE__->register_method( method => 'holding_data_formats', api_name => 'open-ils.supercat.acp.formats', api_level => 1 );
+__PACKAGE__->register_method( method => 'holding_data_formats', api_name => 'open-ils.supercat.auri.formats', api_level => 1 );
+
+
+__PACKAGE__->register_method(
+ method => 'retrieve_uri',
+ api_name => 'open-ils.supercat.auri.marcxml.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a fleshed call number object
+ DESC
+ params =>
+ [
+ { name => 'uri_id',
+ desc => 'An OpenILS asset::uri id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'fleshed uri',
+ type => 'object' }
+ }
+);
+sub retrieve_uri {
+ my $self = shift;
+ my $client = shift;
+ my $cpid = shift;
+ my $args = shift || {};
+
+ return OpenILS::Application::SuperCat::unAPI
+ ->new(OpenSRF::AppSession
+ ->create( 'open-ils.cstore' )
+ ->request(
+ "open-ils.cstore.direct.asset.uri.retrieve",
+ $cpid,
+ { flesh => 10,
+ flesh_fields => {
+ auri => [qw/call_number_maps/],
+ auricnm => [qw/call_number/],
+ acn => [qw/owning_lib record/],
+ }
+ })
+ ->gather(1))
+ ->as_xml($args);
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_copy',
+ api_name => 'open-ils.supercat.acp.marcxml.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a fleshed call number object
+ DESC
+ params =>
+ [
+ { name => 'cn_id',
+ desc => 'An OpenILS asset::copy id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'fleshed copy',
+ type => 'object' }
+ }
+);
+sub retrieve_copy {
+ my $self = shift;
+ my $client = shift;
+ my $cpid = shift;
+ my $args = shift || {};
+
+ return OpenILS::Application::SuperCat::unAPI
+ ->new(OpenSRF::AppSession
+ ->create( 'open-ils.cstore' )
+ ->request(
+ "open-ils.cstore.direct.asset.copy.retrieve",
+ $cpid,
+ { flesh => 2,
+ flesh_fields => {
+ acn => [qw/owning_lib record/],
+ acp => [qw/call_number location status circ_lib stat_cat_entries notes/],
+ }
+ })
+ ->gather(1))
+ ->as_xml($args);
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_callnumber',
+ api_name => 'open-ils.supercat.acn.marcxml.retrieve',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a fleshed call number object
+ DESC
+ params =>
+ [
+ { name => 'cn_id',
+ desc => 'An OpenILS asset::call_number id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'call number with copies',
+ type => 'object' }
+ }
+);
+sub retrieve_callnumber {
+ my $self = shift;
+ my $client = shift;
+ my $cnid = shift;
+ my $args = shift || {};
+
+ return OpenILS::Application::SuperCat::unAPI
+ ->new(OpenSRF::AppSession
+ ->create( 'open-ils.cstore' )
+ ->request(
+ "open-ils.cstore.direct.asset.call_number.retrieve",
+ $cnid,
+ { flesh => 5,
+ flesh_fields => {
+ acn => [qw/owning_lib record copies uri_maps/],
+ auricnm => [qw/uri/],
+ acp => [qw/location status circ_lib stat_cat_entries notes/],
+ }
+ })
+ ->gather(1))
+ ->as_xml($args);
+
+}
+
+__PACKAGE__->register_method(
+ method => 'basic_record_holdings',
+ api_name => 'open-ils.supercat.record.basic_holdings.retrieve',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns a basic hash representation of the requested bibliographic record's holdings
+ DESC
+ params =>
+ [
+ { name => 'bibId',
+ desc => 'An OpenILS biblio::record_entry id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'Hash of bib record holdings hierarchy (call numbers and copies)',
+ type => 'string' }
+ }
+);
+sub basic_record_holdings {
+ my $self = shift;
+ my $client = shift;
+ my $bib = shift;
+ my $ou = shift;
+
+ # holdings hold an array of call numbers, which hold an array of copies
+ # holdings => [ label: { library, [ copies: { barcode, location, status, circ_lib } ] } ]
+ my %holdings;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $tree = $_storage->request(
+ "open-ils.cstore.direct.biblio.record_entry.retrieve",
+ $bib,
+ { flesh => 5,
+ flesh_fields => {
+ bre => [qw/call_numbers/],
+ acn => [qw/copies owning_lib/],
+ acp => [qw/location status circ_lib/],
+ }
+ }
+ )->gather(1);
+
+ my $o_search = { shortname => uc($ou) };
+ if (!$ou || $ou eq '-') {
+ $o_search = { parent_ou => undef };
+ }
+
+ my $orgs = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ $o_search,
+ { flesh => 100,
+ flesh_fields => { aou => [qw/children/] }
+ }
+ )->gather(1);
+
+ my @ou_ids = tree_walker($orgs, 'children', sub {shift->id}) if $orgs;
+
+ $logger->debug("Searching for holdings at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ for my $cn (@{$tree->call_numbers}) {
+ next unless ( $cn->deleted eq 'f' || $cn->deleted == 0 );
+
+ my $found = 0;
+ for my $c (@{$cn->copies}) {
+ next unless grep {$c->circ_lib->id == $_} @ou_ids;
+ next unless ( $c->deleted eq 'f' || $c->deleted == 0 );
+ $found = 1;
+ last;
+ }
+ next unless $found;
+
+ $holdings{$cn->label}{'owning_lib'} = $cn->owning_lib->shortname;
+
+ for my $cp (@{$cn->copies}) {
+
+ next unless grep { $cp->circ_lib->id == $_ } @ou_ids;
+ next unless ( $cp->deleted eq 'f' || $cp->deleted == 0 );
+
+ push @{$holdings{$cn->label}{'copies'}}, {
+ barcode => $cp->barcode,
+ status => $cp->status->name,
+ location => $cp->location->name,
+ circlib => $cp->circ_lib->shortname
+ };
+
+ }
+ }
+
+ return \%holdings;
+}
+
+#__PACKAGE__->register_method(
+# method => 'new_record_holdings',
+# api_name => 'open-ils.supercat.record.holdings_xml.retrieve',
+# api_level => 1,
+# argc => 1,
+# stream => 1,
+# signature =>
+# { desc => <<" DESC",
+#Returns the XML representation of the requested bibliographic record's holdings
+# DESC
+# params =>
+# [
+# { name => 'bibId',
+# desc => 'An OpenILS biblio::record_entry id',
+# type => 'number' },
+# ],
+# 'return' =>
+# { desc => 'Stream of bib record holdings hierarchy in XML',
+# type => 'string' }
+# }
+#);
+#
+
+sub new_record_holdings {
+ my $self = shift;
+ my $client = shift;
+ my $bib = shift;
+ my $ou = shift;
+ my $depth = shift;
+ my $flesh = shift;
+ my $paging = shift;
+
+ $paging = [-1,0] if (!$paging or !ref($paging) or @$paging == 0);
+ my $limit = $$paging[0];
+ my $offset = $$paging[1] || 0;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+ my $_search = OpenSRF::AppSession->create( 'open-ils.search' );
+
+ my $o_search = { shortname => uc($ou) };
+ if (!$ou || $ou eq '-') {
+ $o_search = { parent_ou => undef };
+ }
+
+ my $one_org = $_storage->request(
+ "open-ils.cstore.direct.actor.org_unit.search",
+ $o_search
+ )->gather(1);
+
+ my $count_req = $_search->request('open-ils.search.biblio.record.copy_count' => $one_org->id => $bib);
+ my $staff_count_req = $_search->request('open-ils.search.biblio.record.copy_count.staff' => $one_org->id => $bib);
+
+ my $orgs = $_storage->request(
+ 'open-ils.cstore.json_query.atomic',
+ { from => [ 'actor.org_unit_descendants', defined($depth) ? ( $one_org->id, $depth ) : ( $one_org->id ) ] }
+ )->gather(1);
+
+
+ my @ou_ids = map { $_->{id} } @$orgs;
+
+ $logger->info("Searching for holdings at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ my %subselect = ( '-or' => [
+ { owning_lib => \@ou_ids },
+ { '-exists' =>
+ { from => 'acp',
+ where => {
+ call_number => { '=' => {'+acn'=>'id'} },
+ deleted => 'f',
+ circ_lib => \@ou_ids
+ }
+ }
+ }
+ ]);
+
+ if ($flesh and $flesh eq 'uris') {
+ %subselect = (
+ owning_lib => \@ou_ids,
+ '-exists' => {
+ from => { auricnm => 'auri' },
+ where => {
+ call_number => { '=' => {'+acn'=>'id'} },
+ '+auri' => { active => 't' }
+ }
+ }
+ );
+ }
+
+
+ my $cns = $_storage->request(
+ "open-ils.cstore.direct.asset.call_number.search.atomic",
+ { record => $bib,
+ deleted => 'f',
+ %subselect
+ },
+ { flesh => 5,
+ flesh_fields => {
+ acn => [qw/copies owning_lib uri_maps/],
+ auricnm => [qw/uri/],
+ acp => [qw/circ_lib location status stat_cat_entries notes/],
+ asce => [qw/stat_cat/],
+ },
+ ( $limit > -1 ? ( limit => $limit ) : () ),
+ ( $offset ? ( offset => $offset ) : () ),
+ order_by => { acn => { label_sortkey => {} } }
+ }
+ )->gather(1);
+
+ my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
+ $year += 1900;
+ $month += 1;
+
+ $client->respond("<holdings xmlns='http://open-ils.org/spec/holdings/v1'><counts>\n");
+
+ my $copy_counts = $count_req->gather(1);
+ my $staff_copy_counts = $staff_count_req->gather(1);
+
+ for my $c (@$copy_counts) {
+ $$c{transcendant} ||= 0;
+ my $out = "<count type='public'";
+ $out .= " $_='$$c{$_}'" for (qw/count available unshadow transcendant org_unit depth/);
+ $client->respond("$out/>\n")
+ }
+
+ for my $c (@$staff_copy_counts) {
+ $$c{transcendant} ||= 0;
+ my $out = "<count type='staff'";
+ $out .= " $_='$$c{$_}'" for (qw/count available unshadow transcendant org_unit depth/);
+ $client->respond("$out/>\n")
+ }
+
+ $client->respond("</counts><volumes>\n");
+
+ for my $cn (@$cns) {
+ next unless (@{$cn->copies} > 0 or (ref($cn->uri_maps) and @{$cn->uri_maps}));
+
+ # We don't want O:A:S:unAPI::acn to return the record, we've got that already
+ # In the context of BibTemplate, copies aren't necessary because we pull those
+ # in a separate call
+ $client->respond(
+ OpenILS::Application::SuperCat::unAPI::acn
+ ->new( $cn )
+ ->as_xml( {no_record => 1, no_copies => ($flesh ? 0 : 1)} )
+ );
+ }
+
+ $client->respond("</volumes><subscriptions>\n");
+
+ $logger->info("Searching for serial holdings at orgs [".join(',',@ou_ids)."], based on $ou");
+
+ %subselect = ( '-or' => [
+ { owning_lib => \@ou_ids },
+ { '-exists' =>
+ { from => 'sdist',
+ where => { holding_lib => \@ou_ids }
+ }
+ }
+ ]);
+
+ my $ssubs = $_storage->request(
+ "open-ils.cstore.direct.serial.subscription.search.atomic",
+ { record_entry => $bib,
+ %subselect
+ },
+ { flesh => 7,
+ flesh_fields => {
+ ssub => [qw/distributions issuances scaps owning_lib/],
+ sdist => [qw/basic_summary supplement_summary index_summary streams holding_lib/],
+ sstr => [qw/items/],
+ sitem => [qw/notes unit/],
+ sunit => [qw/notes location status circ_lib stat_cat_entries call_number/],
+ acn => [qw/owning_lib/],
+ },
+ ( $limit > -1 ? ( limit => $limit ) : () ),
+ ( $offset ? ( offset => $offset ) : () ),
+ order_by => {
+ ssub => {
+ start_date => {},
+ owning_lib => {},
+ id => {}
+ },
+ sdist => {
+ label => {},
+ owning_lib => {},
+ },
+ sunit => {
+ date_expected => {},
+ }
+ }
+ }
+ )->gather(1);
+
+
+ for my $ssub (@$ssubs) {
+ next unless (@{$ssub->distributions} or @{$ssub->issuances} or @{$ssub->scaps});
+
+ # We don't want O:A:S:unAPI::ssub to return the record, we've got that already
+ # In the context of BibTemplate, copies aren't necessary because we pull those
+ # in a separate call
+ $client->respond(
+ OpenILS::Application::SuperCat::unAPI::ssub
+ ->new( $ssub )
+ ->as_xml( {no_record => 1, no_items => ($flesh ? 0 : 1)} )
+ );
+ }
+
+
+ return "</subscriptions></holdings>\n";
+}
+__PACKAGE__->register_method(
+ method => 'new_record_holdings',
+ api_name => 'open-ils.supercat.record.holdings_xml.retrieve',
+ api_level => 1,
+ argc => 1,
+ stream => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the XML representation of the requested bibliographic record's holdings
+ DESC
+ params =>
+ [
+ { name => 'bibId',
+ desc => 'An OpenILS biblio::record_entry ID',
+ type => 'number' },
+ { name => 'orgUnit',
+ desc => 'An OpenILS actor::org_unit short name that limits the scope of returned holdings',
+ type => 'text' },
+ { name => 'depth',
+ desc => 'An OpenILS actor::org_unit_type depththat limits the scope of returned holdings',
+ type => 'number' },
+ { name => 'hideCopies',
+ desc => 'Flag that prevents the inclusion of copies in the returned holdings',
+ type => 'boolean' },
+ { name => 'paging',
+ desc => 'Arry of limit and offset for holdings paging',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'Stream of bib record holdings hierarchy in XML',
+ type => 'string' }
+ }
+);
+
+sub isbn_holdings {
+ my $self = shift;
+ my $client = shift;
+ my $isbn = shift;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $recs = $_storage->request(
+ 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
+ { tag => { like => '02%'}, value => {like => "$isbn\%"}}
+ )->gather(1);
+
+ return undef unless (@$recs);
+
+ return ($self->method_lookup( 'open-ils.supercat.record.holdings_xml.retrieve')->run( $recs->[0]->record ))[0];
+}
+__PACKAGE__->register_method(
+ method => 'isbn_holdings',
+ api_name => 'open-ils.supercat.isbn.holdings_xml.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the XML representation of the requested bibliographic record's holdings
+ DESC
+ params =>
+ [
+ { name => 'isbn',
+ desc => 'An isbn',
+ type => 'string' },
+ ],
+ 'return' =>
+ { desc => 'The bib record holdings hierarchy in XML',
+ type => 'string' }
+ }
+);
+
+sub escape {
+ my $self = shift;
+ my $text = shift;
+ return '' unless $text;
+ $text =~ s/&/&/gsom;
+ $text =~ s/</</gsom;
+ $text =~ s/>/>/gsom;
+ $text =~ s/"/"/gsom;
+ $text =~ s/'/'/gsom;
+ return $text;
+}
+
+sub recent_changes {
+ my $self = shift;
+ my $client = shift;
+ my $when = shift || '1-01-01';
+ my $limit = shift;
+
+ my $type = 'biblio';
+ my $hint = 'bre';
+
+ if ($self->api_name =~ /authority/o) {
+ $type = 'authority';
+ $hint = 'are';
+ }
+
+ my $axis = 'create_date';
+ $axis = 'edit_date' if ($self->api_name =~ /edit/o);
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ return $_storage->request(
+ "open-ils.cstore.direct.$type.record_entry.id_list.atomic",
+ { $axis => { ">" => $when }, id => { '>' => 0 }, deleted => 'f', active => 't' },
+ { order_by => { $hint => "$axis desc" }, limit => $limit }
+ )->gather(1);
+}
+
+for my $t ( qw/biblio authority/ ) {
+ for my $a ( qw/import edit/ ) {
+
+ __PACKAGE__->register_method(
+ method => 'recent_changes',
+ api_name => "open-ils.supercat.$t.record.$a.recent",
+ api_level => 1,
+ argc => 0,
+ signature =>
+ { desc => "Returns a list of recently ${a}ed $t records",
+ params =>
+ [
+ { name => 'when',
+ desc => "Date to start looking for ${a}ed records",
+ default => '1-01-01',
+ type => 'string' },
+
+ { name => 'limit',
+ desc => "Maximum count to retrieve",
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => "An id list of $t records",
+ type => 'array' }
+ },
+ );
+ }
+}
+
+
+sub retrieve_authority_marcxml {
+ my $self = shift;
+ my $client = shift;
+ my $rid = shift;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $record = $_storage->request( 'open-ils.cstore.direct.authority.record_entry.retrieve' => $rid )->gather(1);
+ return $U->entityize( $record->marc ) if ($record);
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_authority_marcxml',
+ api_name => 'open-ils.supercat.authority.marcxml.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the MARCXML representation of the requested authority record
+ DESC
+ params =>
+ [
+ { name => 'authorityId',
+ desc => 'An OpenILS authority::record_entry id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'The authority record in MARCXML',
+ type => 'string' }
+ }
+);
+
+sub retrieve_record_marcxml {
+ my $self = shift;
+ my $client = shift;
+ my $rid = shift;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $record = $_storage->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $rid )->gather(1);
+ return $U->entityize( $record->marc ) if ($record);
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_record_marcxml',
+ api_name => 'open-ils.supercat.record.marcxml.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the MARCXML representation of the requested bibliographic record
+ DESC
+ params =>
+ [
+ { name => 'bibId',
+ desc => 'An OpenILS biblio::record_entry id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'The bib record in MARCXML',
+ type => 'string' }
+ }
+);
+
+sub retrieve_isbn_marcxml {
+ my $self = shift;
+ my $client = shift;
+ my $isbn = shift;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $recs = $_storage->request(
+ 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
+ { tag => { like => '02%'}, value => {like => "$isbn\%"}}
+ )->gather(1);
+
+ return undef unless (@$recs);
+
+ my $record = $_storage->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $recs->[0]->record )->gather(1);
+ return $U->entityize( $record->marc ) if ($record);
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ method => 'retrieve_isbn_marcxml',
+ api_name => 'open-ils.supercat.isbn.marcxml.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the MARCXML representation of the requested ISBN
+ DESC
+ params =>
+ [
+ { name => 'ISBN',
+ desc => 'An ... um ... ISBN',
+ type => 'string' },
+ ],
+ 'return' =>
+ { desc => 'The bib record in MARCXML',
+ type => 'string' }
+ }
+);
+
+sub retrieve_record_transform {
+ my $self = shift;
+ my $client = shift;
+ my $rid = shift;
+
+ (my $transform = $self->api_name) =~ s/^.+record\.([^\.]+)\.retrieve$/$1/o;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+ #$_storage->connect;
+
+ my $record = $_storage->request(
+ 'open-ils.cstore.direct.biblio.record_entry.retrieve',
+ $rid
+ )->gather(1);
+
+ return undef unless ($record);
+
+ return $U->entityize($record_xslt{$transform}{xslt}->transform( $_parser->parse_string( $record->marc ) )->toString);
+}
+
+sub retrieve_isbn_transform {
+ my $self = shift;
+ my $client = shift;
+ my $isbn = shift;
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ my $recs = $_storage->request(
+ 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
+ { tag => { like => '02%'}, value => {like => "$isbn\%"}}
+ )->gather(1);
+
+ return undef unless (@$recs);
+
+ (my $transform = $self->api_name) =~ s/^.+isbn\.([^\.]+)\.retrieve$/$1/o;
+
+ my $record = $_storage->request( 'open-ils.cstore.direct.biblio.record_entry.retrieve' => $recs->[0]->record )->gather(1);
+
+ return undef unless ($record);
+
+ return $U->entityize($record_xslt{$transform}{xslt}->transform( $_parser->parse_string( $record->marc ) )->toString);
+}
+
+sub retrieve_record_objects {
+ my $self = shift;
+ my $client = shift;
+ my $ids = shift;
+
+ $ids = [$ids] unless (ref $ids);
+ $ids = [grep {$_} @$ids];
+
+ return [] unless (@$ids);
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+ return $_storage->request('open-ils.cstore.direct.biblio.record_entry.search.atomic' => { id => [grep {$_} @$ids] })->gather(1);
+}
+__PACKAGE__->register_method(
+ method => 'retrieve_record_objects',
+ api_name => 'open-ils.supercat.record.object.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the Fieldmapper object representation of the requested bibliographic records
+ DESC
+ params =>
+ [
+ { name => 'bibIds',
+ desc => 'OpenILS biblio::record_entry ids',
+ type => 'array' },
+ ],
+ 'return' =>
+ { desc => 'The bib records',
+ type => 'array' }
+ }
+);
+
+
+sub retrieve_isbn_object {
+ my $self = shift;
+ my $client = shift;
+ my $isbn = shift;
+
+ return undef unless ($isbn);
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+ my $recs = $_storage->request(
+ 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
+ { tag => { like => '02%'}, value => {like => "$isbn\%"}}
+ )->gather(1);
+
+ return undef unless (@$recs);
+
+ return $_storage->request(
+ 'open-ils.cstore.direct.biblio.record_entry.search.atomic',
+ { id => $recs->[0]->record }
+ )->gather(1);
+}
+__PACKAGE__->register_method(
+ method => 'retrieve_isbn_object',
+ api_name => 'open-ils.supercat.isbn.object.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the Fieldmapper object representation of the requested bibliographic record
+ DESC
+ params =>
+ [
+ { name => 'isbn',
+ desc => 'an ISBN',
+ type => 'string' },
+ ],
+ 'return' =>
+ { desc => 'The bib record',
+ type => 'object' }
+ }
+);
+
+
+
+sub retrieve_metarecord_mods {
+ my $self = shift;
+ my $client = shift;
+ my $rid = shift;
+
+ my $_storage = OpenSRF::AppSession->connect( 'open-ils.cstore' );
+
+ # Get the metarecord in question
+ my $mr =
+ $_storage->request(
+ 'open-ils.cstore.direct.metabib.metarecord.retrieve' => $rid
+ )->gather(1);
+
+ # Now get the map of all bib records for the metarecord
+ my $recs =
+ $_storage->request(
+ 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
+ {metarecord => $rid}
+ )->gather(1);
+
+ $logger->debug("Adding ".scalar(@$recs)." bib record to the MODS of the metarecord");
+
+ # and retrieve the lead (master) record as MODS
+ my ($master) =
+ $self ->method_lookup('open-ils.supercat.record.mods.retrieve')
+ ->run($mr->master_record);
+ my $master_mods = $_parser->parse_string($master)->documentElement;
+ $master_mods->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $master_mods->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+
+ # ... and a MODS clone to populate, with guts removed.
+ my $mods = $_parser->parse_string($master)->documentElement;
+ $mods->setNamespace( "http://www.loc.gov/mods/", "mods" ); # modsCollection element
+ $mods->setNamespace('http://www.loc.gov/mods/', undef, 1);
+ ($mods) = $mods->findnodes('//mods:mods');
+ #$mods->setNamespace( "http://www.loc.gov/mods/", "mods" ); # mods element
+ $mods->removeChildNodes;
+ $mods->setNamespace('http://www.loc.gov/mods/', undef, 1);
+
+ # Add the metarecord ID as a (locally defined) info URI
+ my $recordInfo = $mods
+ ->ownerDocument
+ ->createElement("recordInfo");
+
+ my $recordIdentifier = $mods
+ ->ownerDocument
+ ->createElement("recordIdentifier");
+
+ my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
+ $year += 1900;
+ $month += 1;
+
+ my $id = $mr->id;
+ $recordIdentifier->appendTextNode(
+ sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d:metabib-metarecord/$id", $month, $day)
+ );
+
+ $recordInfo->appendChild($recordIdentifier);
+ $mods->appendChild($recordInfo);
+
+ # Grab the title, author and ISBN for the master record and populate the metarecord
+ my ($title) = $master_mods->findnodes( './mods:titleInfo[not(@type)]' );
+
+ if ($title) {
+ $title->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $title->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+ $title = $mods->ownerDocument->importNode($title);
+ $mods->appendChild($title);
+ }
+
+ my ($author) = $master_mods->findnodes( './mods:name[mods:role/mods:text[text()="creator"]]' );
+ if ($author) {
+ $author->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $author->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+ $author = $mods->ownerDocument->importNode($author);
+ $mods->appendChild($author);
+ }
+
+ my ($isbn) = $master_mods->findnodes( './mods:identifier[@type="isbn"]' );
+ if ($isbn) {
+ $isbn->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $isbn->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+ $isbn = $mods->ownerDocument->importNode($isbn);
+ $mods->appendChild($isbn);
+ }
+
+ # ... and loop over the constituent records
+ for my $map ( @$recs ) {
+
+ # get the MODS
+ my ($rec) =
+ $self ->method_lookup('open-ils.supercat.record.mods.retrieve')
+ ->run($map->source);
+
+ my $part_mods = $_parser->parse_string($rec);
+ $part_mods->documentElement->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $part_mods->documentElement->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+ ($part_mods) = $part_mods->findnodes('//mods:mods');
+
+ for my $node ( ($part_mods->findnodes( './mods:subject' )) ) {
+ $node->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $node->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+ $node = $mods->ownerDocument->importNode($node);
+ $mods->appendChild( $node );
+ }
+
+ my $relatedItem = $mods
+ ->ownerDocument
+ ->createElement("relatedItem");
+
+ $relatedItem->setAttribute( type => 'constituent' );
+
+ my $identifier = $mods
+ ->ownerDocument
+ ->createElement("identifier");
+
+ $identifier->setAttribute( type => 'uri' );
+
+ my $subRecordInfo = $mods
+ ->ownerDocument
+ ->createElement("recordInfo");
+
+ my $subRecordIdentifier = $mods
+ ->ownerDocument
+ ->createElement("recordIdentifier");
+
+ my $subid = $map->source;
+ $subRecordIdentifier->appendTextNode(
+ sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d:biblio-record_entry/$subid",
+ $month,
+ $day
+ )
+ );
+ $subRecordInfo->appendChild($subRecordIdentifier);
+
+ $relatedItem->appendChild( $subRecordInfo );
+
+ my ($tor) = $part_mods->findnodes( './mods:typeOfResource' );
+ $tor->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $tor->setNamespace( "http://www.loc.gov/mods/", undef, 1 ) if ($tor);
+ $tor = $mods->ownerDocument->importNode($tor) if ($tor);
+ $relatedItem->appendChild($tor) if ($tor);
+
+ if ( my ($part_isbn) = $part_mods->findnodes( './mods:identifier[@type="isbn"]' ) ) {
+ $part_isbn->setNamespace( "http://www.loc.gov/mods/", "mods" );
+ $part_isbn->setNamespace( "http://www.loc.gov/mods/", undef, 1 );
+ $part_isbn = $mods->ownerDocument->importNode($part_isbn);
+ $relatedItem->appendChild( $part_isbn );
+
+ if (!$isbn) {
+ $isbn = $mods->appendChild( $part_isbn->cloneNode(1) );
+ }
+ }
+
+ $mods->appendChild( $relatedItem );
+
+ }
+
+ $_storage->disconnect;
+
+ return $U->entityize($mods->toString);
+
+}
+__PACKAGE__->register_method(
+ method => 'retrieve_metarecord_mods',
+ api_name => 'open-ils.supercat.metarecord.mods.retrieve',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the MODS representation of the requested metarecord
+ DESC
+ params =>
+ [
+ { name => 'metarecordId',
+ desc => 'An OpenILS metabib::metarecord id',
+ type => 'number' },
+ ],
+ 'return' =>
+ { desc => 'The metarecord in MODS',
+ type => 'string' }
+ }
+);
+
+sub list_metarecord_formats {
+ my @list = (
+ { mods =>
+ { namespace_uri => 'http://www.loc.gov/mods/',
+ docs => 'http://www.loc.gov/mods/',
+ schema_location => 'http://www.loc.gov/standards/mods/mods.xsd',
+ }
+ }
+ );
+
+ for my $type ( keys %metarecord_xslt ) {
+ push @list,
+ { $type =>
+ { namespace_uri => $metarecord_xslt{$type}{namespace_uri},
+ docs => $metarecord_xslt{$type}{docs},
+ schema_location => $metarecord_xslt{$type}{schema_location},
+ }
+ };
+ }
+
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'list_metarecord_formats',
+ api_name => 'open-ils.supercat.metarecord.formats',
+ api_level => 1,
+ argc => 0,
+ signature =>
+ { desc => <<" DESC",
+Returns the list of valid metarecord formats that supercat understands.
+ DESC
+ 'return' =>
+ { desc => 'The format list',
+ type => 'array' }
+ }
+);
+
+
+sub list_authority_formats {
+ my @list = (
+ { marcxml =>
+ { namespace_uri => 'http://www.loc.gov/MARC21/slim',
+ docs => 'http://www.loc.gov/marcxml/',
+ schema_location => 'http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd',
+ }
+ }
+ );
+
+# for my $type ( keys %record_xslt ) {
+# push @list,
+# { $type =>
+# { namespace_uri => $record_xslt{$type}{namespace_uri},
+# docs => $record_xslt{$type}{docs},
+# schema_location => $record_xslt{$type}{schema_location},
+# }
+# };
+# }
+#
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'list_authority_formats',
+ api_name => 'open-ils.supercat.authority.formats',
+ api_level => 1,
+ argc => 0,
+ signature =>
+ { desc => <<" DESC",
+Returns the list of valid authority formats that supercat understands.
+ DESC
+ 'return' =>
+ { desc => 'The format list',
+ type => 'array' }
+ }
+);
+
+sub list_record_formats {
+ my @list = (
+ { marcxml =>
+ { namespace_uri => 'http://www.loc.gov/MARC21/slim',
+ docs => 'http://www.loc.gov/marcxml/',
+ schema_location => 'http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd',
+ }
+ }
+ );
+
+ for my $type ( keys %record_xslt ) {
+ push @list,
+ { $type =>
+ { namespace_uri => $record_xslt{$type}{namespace_uri},
+ docs => $record_xslt{$type}{docs},
+ schema_location => $record_xslt{$type}{schema_location},
+ }
+ };
+ }
+
+ return \@list;
+}
+__PACKAGE__->register_method(
+ method => 'list_record_formats',
+ api_name => 'open-ils.supercat.record.formats',
+ api_level => 1,
+ argc => 0,
+ signature =>
+ { desc => <<" DESC",
+Returns the list of valid record formats that supercat understands.
+ DESC
+ 'return' =>
+ { desc => 'The format list',
+ type => 'array' }
+ }
+);
+__PACKAGE__->register_method(
+ method => 'list_record_formats',
+ api_name => 'open-ils.supercat.isbn.formats',
+ api_level => 1,
+ argc => 0,
+ signature =>
+ { desc => <<" DESC",
+Returns the list of valid record formats that supercat understands.
+ DESC
+ 'return' =>
+ { desc => 'The format list',
+ type => 'array' }
+ }
+);
+
+
+sub oISBN {
+ my $self = shift;
+ my $client = shift;
+ my $isbn = shift;
+
+ $isbn =~ s/-//gso;
+
+ throw OpenSRF::EX::InvalidArg ('I need an ISBN please')
+ unless (length($isbn) >= 10);
+
+ my $_storage = OpenSRF::AppSession->create( 'open-ils.cstore' );
+
+ # Create a storage session, since we'll be making muliple requests.
+ $_storage->connect;
+
+ # Find the record that has that ISBN.
+ my $bibrec = $_storage->request(
+ 'open-ils.cstore.direct.metabib.full_rec.search.atomic',
+ { tag => '020', subfield => 'a', value => { like => lc($isbn).'%'} }
+ )->gather(1);
+
+ # Go away if we don't have one.
+ return {} unless (@$bibrec);
+
+ # Find the metarecord for that bib record.
+ my $mr = $_storage->request(
+ 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
+ {source => $bibrec->[0]->record}
+ )->gather(1);
+
+ # Find the other records for that metarecord.
+ my $records = $_storage->request(
+ 'open-ils.cstore.direct.metabib.metarecord_source_map.search.atomic',
+ {metarecord => $mr->[0]->metarecord}
+ )->gather(1);
+
+ # Just to be safe. There's currently no unique constraint on sources...
+ my %unique_recs = map { ($_->source, 1) } @$records;
+ my @rec_list = sort keys %unique_recs;
+
+ # And now fetch the ISBNs for thos records.
+ my $recs = [];
+ push @$recs,
+ $_storage->request(
+ 'open-ils.cstore.direct.metabib.full_rec.search',
+ { tag => '020', subfield => 'a', record => $_ }
+ )->gather(1) for (@rec_list);
+
+ # We're done with the storage server session.
+ $_storage->disconnect;
+
+ # Return the oISBN data structure. This will be XMLized at a higher layer.
+ return
+ { metarecord => $mr->[0]->metarecord,
+ record_list => { map { $_ ? ($_->record, $_->value) : () } @$recs } };
+
+}
+__PACKAGE__->register_method(
+ method => 'oISBN',
+ api_name => 'open-ils.supercat.oisbn',
+ api_level => 1,
+ argc => 1,
+ signature =>
+ { desc => <<" DESC",
+Returns the ISBN list for the metarecord of the requested isbn
+ DESC
+ params =>
+ [
+ { name => 'isbn',
+ desc => 'An ISBN. Duh.',
+ type => 'string' },
+ ],
+ 'return' =>
+ { desc => 'record to isbn map',
+ type => 'object' }
+ }
+);
+
+package OpenILS::Application::SuperCat::unAPI;
+use base qw/OpenILS::Application::SuperCat/;
+
+sub as_xml {
+ die "dummy superclass, use a real class";
+}
+
+sub new {
+ my $class = shift;
+ my $obj = shift;
+ return unless ($obj);
+
+ $class = ref($class) || $class;
+
+ if ($class eq __PACKAGE__) {
+ return unless (ref($obj));
+ $class .= '::' . $obj->json_hint;
+ }
+
+ return bless { obj => $obj } => $class;
+}
+
+sub obj {
+ my $self = shift;
+ return $self->{obj};
+}
+
+package OpenILS::Application::SuperCat::unAPI::auri;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <uri xmlns="http://open-ils.org/spec/holdings/v1" ';
+ $xml .= 'id="tag:open-ils.org:asset-uri/' . $self->obj->id . '" ';
+ $xml .= 'use_restriction="' . $self->escape( $self->obj->use_restriction ) . '" ';
+ $xml .= 'label="' . $self->escape( $self->obj->label ) . '" ';
+ $xml .= 'href="' . $self->escape( $self->obj->href ) . '">';
+
+ if (!$args->{no_volumes}) {
+ if (ref($self->obj->call_number_maps) && @{ $self->obj->call_number_maps }) {
+ $xml .= " <volumes>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_->call_number )
+ ->as_xml({ %$args, no_uris=>1, no_copies=>1 })
+ } @{ $self->obj->call_number_maps }
+ ) . " </volumes>\n";
+
+ } else {
+ $xml .= " <volumes/>\n";
+ }
+ }
+
+ $xml .= " </uri>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::acn;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <volume xmlns="http://open-ils.org/spec/holdings/v1" ';
+
+ $xml .= 'id="tag:open-ils.org:asset-call_number/' . $self->obj->id . '" ';
+ $xml .= 'lib="' . $self->escape( $self->obj->owning_lib->shortname ) . '" ';
+ $xml .= 'opac_visible="' . $self->obj->owning_lib->opac_visible . '" ';
+ $xml .= 'deleted="' . $self->obj->deleted . '" ';
+ $xml .= 'label="' . $self->escape( $self->obj->label ) . '">';
+ $xml .= "\n";
+
+ if (!$args->{no_copies}) {
+ if (ref($self->obj->copies) && @{ $self->obj->copies }) {
+ $xml .= " <copies>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_volume=>1 })
+ } @{ $self->obj->copies }
+ ) . " </copies>\n";
+
+ } else {
+ $xml .= " <copies/>\n";
+ }
+ }
+
+ if (!$args->{no_uris}) {
+ if (ref($self->obj->uri_maps) && @{ $self->obj->uri_maps }) {
+ $xml .= " <uris>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_->uri )
+ ->as_xml({ %$args, no_volumes=>1 })
+ } @{ $self->obj->uri_maps }
+ ) . " </uris>\n";
+
+ } else {
+ $xml .= " <uris/>\n";
+ }
+ }
+
+
+ $xml .= ' <owning_lib xmlns="http://open-ils.org/spec/actors/v1" ';
+ $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->owning_lib->id . '" ';
+ $xml .= 'shortname="'.$self->escape( $self->obj->owning_lib->shortname ) .'" ';
+ $xml .= 'name="'.$self->escape( $self->obj->owning_lib->name ) .'"/>';
+ $xml .= "\n";
+
+ unless ($args->{no_record}) {
+ my $rec_tag = "tag:open-ils.org:biblio-record_entry/".$self->obj->record->id.'/'.$self->escape( $self->obj->owning_lib->shortname ) ;
+
+ my $r_doc = $parser->parse_string($self->obj->record->marc);
+ $r_doc->documentElement->setAttribute( id => $rec_tag );
+ $xml .= $U->entityize($r_doc->documentElement->toString);
+ }
+
+ $xml .= " </volume>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::ssub;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <subscription xmlns="http://open-ils.org/spec/holdings/v1" ';
+
+ $xml .= 'id="tag:open-ils.org:serial-subscription/' . $self->obj->id . '" ';
+ $xml .= 'start="' . $self->escape( $self->obj->start_date ) . '" ';
+ $xml .= 'end="' . $self->escape( $self->obj->end_date ) . '" ';
+ $xml .= 'expected_date_offset="' . $self->escape( $self->obj->expected_date_offset ) . '">';
+ $xml .= "\n";
+
+ if (!$args->{no_distributions}) {
+ if (ref($self->obj->distributions) && @{ $self->obj->distributions }) {
+ $xml .= " <distributions>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_subscription=>1, no_issuance=>1 })
+ } @{ $self->obj->distributions }
+ ) . " </distributions>\n";
+
+ } else {
+ $xml .= " <distributions/>\n";
+ }
+ }
+
+ if (!$args->{no_captions_and_patterns}) {
+ if (ref($self->obj->scaps) && @{ $self->obj->scaps }) {
+ $xml .= " <captions_and_patterns>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_subscription=>1 })
+ } @{ $self->obj->scaps }
+ ) . " </captions_and_patterns>\n";
+
+ } else {
+ $xml .= " <captions_and_patterns/>\n";
+ }
+ }
+
+ if (!$args->{no_issuances}) {
+ if (ref($self->obj->issuances) && @{ $self->obj->issuances }) {
+ $xml .= " <issuances>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_subscription=>1, no_items=>1 })
+ } @{ $self->obj->issuances }
+ ) . " </issuances>\n";
+
+ } else {
+ $xml .= " <issuances/>\n";
+ }
+ }
+
+
+ $xml .= ' <owning_lib xmlns="http://open-ils.org/spec/actors/v1" ';
+ $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->owning_lib->id . '" ';
+ $xml .= 'shortname="'.$self->escape( $self->obj->owning_lib->shortname ) .'" ';
+ $xml .= 'name="'.$self->escape( $self->obj->owning_lib->name ) .'"/>';
+ $xml .= "\n";
+
+ unless ($args->{no_record}) {
+ my $rec_tag = "tag:open-ils.org:biblio-record_entry/".$self->obj->record->id.'/'.$self->escape( $self->obj->owning_lib->shortname ) ;
+
+ my $r_doc = $parser->parse_string($self->obj->record_entry->marc);
+ $r_doc->documentElement->setAttribute( id => $rec_tag );
+ $xml .= $U->entityize($r_doc->documentElement->toString);
+ }
+
+ $xml .= " </subscription>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::ssum_base;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ (my $type = ref($self)) =~ s/^.+([^:]+)$/$1/;
+
+ my $xml = " <serial_summary xmlns=\"http://open-ils.org/spec/holdings/v1\" type=\"$type\" ";
+
+ $xml .= "id=\"tag:open-ils.org:serial-summary-$type/" . $self->obj->id . '" ';
+ $xml .= 'generated_coverage="' . $self->escape( $self->obj->generated_coverage ) . '" ';
+ $xml .= 'show_generated="' . $self->escape( $self->obj->show_generated ) . '" ';
+ $xml .= 'textual_holdings="' . $self->escape( $self->obj->textual_holdings ) . '">';
+ $xml .= "\n";
+
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->distribution )->as_xml({ %$args, no_summaries=>1 }) if (!$args->{no_distribution});
+
+ $xml .= " </serial_summary>\n";
+
+ return $xml;
+}
+
+
+package OpenILS::Application::SuperCat::unAPI::sssum;
+use base qw/OpenILS::Application::SuperCat::unAPI::ssum_base/;
+
+package OpenILS::Application::SuperCat::unAPI::sbsum;
+use base qw/OpenILS::Application::SuperCat::unAPI::ssum_base/;
+
+package OpenILS::Application::SuperCat::unAPI::sisum;
+use base qw/OpenILS::Application::SuperCat::unAPI::ssum_base/;
+
+package OpenILS::Application::SuperCat::unAPI::sdist;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <distribution xmlns="http://open-ils.org/spec/holdings/v1" ';
+
+ $xml .= 'id="tag:open-ils.org:serial-distribution/' . $self->obj->id . '" ';
+ $xml .= 'label="' . $self->escape( $self->obj->label ) . '" ';
+ $xml .= 'unit_label_prefix="' . $self->escape( $self->obj->unit_label_prefix ) . '" ';
+ $xml .= 'unit_label_suffix="' . $self->escape( $self->obj->unit_label_suffix ) . '">';
+ $xml .= "\n";
+
+ if (!$args->{no_distributions}) {
+ if (ref($self->obj->streams) && @{ $self->obj->streams }) {
+ $xml .= " <streams>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_distribution=>1 })
+ } @{ $self->obj->streams }
+ ) . " </streams>\n";
+
+ } else {
+ $xml .= " <streams/>\n";
+ }
+ }
+
+ if (!$args->{no_summaries}) {
+ $xml .= " <summaries>\n";
+ $xml .= join ('',
+ map {
+ defined $_ ?
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_distribution=>1 }) : ""
+ } ($self->obj->basic_summary, $self->obj->supplement_summary, $self->obj->index_summary)
+ );
+
+ $xml .= " </summaries>\n";
+ }
+
+
+ $xml .= ' <holding_lib xmlns="http://open-ils.org/spec/actors/v1" ';
+ $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->holding_lib->id . '" ';
+ $xml .= 'shortname="'.$self->escape( $self->obj->holding_lib->shortname ) .'" ';
+ $xml .= 'name="'.$self->escape( $self->obj->holding_lib->name ) .'"/>';
+ $xml .= "\n";
+
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->subscription )->as_xml({ %$args, no_distributions=>1 }) if (!$args->{no_subscription});
+
+ if (!$args->{no_record} && $self->obj->record_entry) {
+ my $rec_tag = "tag:open-ils.org:serial-record_entry/".$self->obj->record_entry->id ;
+
+ my $r_doc = $parser->parse_string($self->obj->record_entry->marc);
+ $r_doc->documentElement->setAttribute( id => $rec_tag );
+ $xml .= $U->entityize($r_doc->documentElement->toString);
+ }
+
+ $xml .= " </distribution>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::sstr;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <stream xmlns="http://open-ils.org/spec/holdings/v1" ';
+
+ $xml .= 'id="tag:open-ils.org:serial-stream/' . $self->obj->id . '" ';
+ $xml .= 'routing_label="' . $self->escape( $self->obj->routing_label ) . '">';
+ $xml .= "\n";
+
+ if (!$args->{no_items}) {
+ if (ref($self->obj->items) && @{ $self->obj->items }) {
+ $xml .= " <items>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_stream=>1 })
+ } @{ $self->obj->items }
+ ) . " </items>\n";
+
+ } else {
+ $xml .= " <items/>\n";
+ }
+ }
+
+ #XXX routing_list_user's?
+
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->distribution )->as_xml({ %$args, no_streams=>1 }) if (!$args->{no_distribution});
+
+ $xml .= " </stream>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::sitem;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <serial_item xmlns="http://open-ils.org/spec/holdings/v1" ';
+
+ $xml .= 'id="tag:open-ils.org:serial-item/' . $self->obj->id . '" ';
+ $xml .= 'date_expected="' . $self->escape( $self->obj->date_expected ) . '"';
+ $xml .= ' date_received="' . $self->escape( $self->obj->date_received ) .'"'if ($self->obj->date_received);
+
+ if ($args->{no_issuance}) {
+ my $siss = ref($self->obj->issuance) ? $self->obj->issuance->id : $self->obj->issuance;
+ $xml .= ' issuance="tag:open-ils.org:serial-issuance/' . $siss . '"';
+ }
+
+ $xml .= ">\n";
+
+ if (ref($self->obj->notes) && $self->obj->notes) {
+ $xml .= " <notes>\n";
+ for my $note ( @{$self->obj->notes} ) {
+ next unless ( $note->pub eq 't' );
+ $xml .= sprintf(' <note date="%s" title="%s">%s</note>',$note->create_date, $self->escape($note->title), $self->escape($note->value));
+ $xml .= "\n";
+ }
+ $xml .= " </notes>\n";
+ } else {
+ $xml .= " <notes/>\n";
+ }
+
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->issuance )->as_xml({ %$args, no_items=>1 }) if (!$args->{no_issuance});
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->stream )->as_xml({ %$args, no_items=>1 }) if (!$args->{no_stream});
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->unit )->as_xml({ %$args, no_items=>1, no_volumes=>1 }) if ($self->obj->unit && !$args->{no_unit});
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->uri )->as_xml({ %$args, no_items=>1, no_volumes=>1 }) if ($self->obj->uri && !$args->{no_uri});
+
+ $xml .= " </serial_item>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::sunit;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <serial_unit xmlns="http://open-ils.org/spec/holdings/v1" '.
+ 'id="tag:open-ils.org:serial-unit/' . $self->obj->id . '" ';
+
+ $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" ' for (qw/
+ create_date edit_date copy_number circulate deposit ref holdable deleted
+ deposit_amount price barcode circ_modifier circ_as_type opac_visible cost
+ status_changed_time floating mint_condition detailed_contents sort_key summary_contents
+ /);
+
+ $xml .= ">\n";
+
+ $xml .= ' <status ident="' . $self->obj->status->id . '">' . $self->escape( $self->obj->status->name ) . "</status>\n";
+ $xml .= ' <location ident="' . $self->obj->location->id . '">' . $self->escape( $self->obj->location->name ) . "</location>\n";
+ $xml .= ' <circlib ident="' . $self->obj->circ_lib->id . '">' . $self->escape( $self->obj->circ_lib->name ) . "</circlib>\n";
+
+ $xml .= ' <circ_lib xmlns="http://open-ils.org/spec/actors/v1" ';
+ $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->circ_lib->id . '" ';
+ $xml .= 'shortname="'.$self->escape( $self->obj->circ_lib->shortname ) .'" ';
+ $xml .= 'name="'.$self->escape( $self->obj->circ_lib->name ) .'"/>';
+ $xml .= "\n";
+
+ $xml .= " <copy_notes>\n";
+ if (ref($self->obj->notes) && $self->obj->notes) {
+ for my $note ( @{$self->obj->notes} ) {
+ next unless ( $note->pub eq 't' );
+ $xml .= sprintf(' <copy_note date="%s" title="%s">%s</copy_note>',$note->create_date, $self->escape($note->title), $self->escape($note->value));
+ $xml .= "\n";
+ }
+ }
+
+ $xml .= " </copy_notes>\n";
+ $xml .= " <statcats>\n";
+
+ if (ref($self->obj->stat_cat_entries) && $self->obj->stat_cat_entries) {
+ for my $sce ( @{$self->obj->stat_cat_entries} ) {
+ next unless ( $sce->stat_cat->opac_visible eq 't' );
+ $xml .= sprintf(' <statcat name="%s">%s</statcat>',$self->escape($sce->stat_cat->name) ,$self->escape($sce->value));
+ $xml .= "\n";
+ }
+ }
+ $xml .= " </statcats>\n";
+
+ unless ($args->{no_volume}) {
+ if (ref($self->obj->call_number)) {
+ $xml .= OpenILS::Application::SuperCat::unAPI
+ ->new( $self->obj->call_number )
+ ->as_xml({ %$args, no_copies=>1 });
+ } else {
+ $xml .= " <volume/>\n";
+ }
+ }
+
+ $xml .= " </serial_unit>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::scap;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <caption_and_pattern xmlns="http://open-ils.org/spec/holdings/v1" '.
+ 'id="tag:open-ils.org:serial-caption_and_pattern/' . $self->obj->id . '" ';
+
+ $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" ' for (qw/
+ create_date type active pattern_code enum_1 enum_2 enum_3 enum_4
+ enum_5 enum_6 chron_1 chron_2 chron_3 chron_4 chron_5 start_date end_date
+ /);
+ $xml .= ">\n";
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->subscription )->as_xml({ %$args, no_captions_and_patterns=>1 }) if (!$args->{no_subscription});
+ $xml .= " </caption_and_pattern>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::siss;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <issuance xmlns="http://open-ils.org/spec/holdings/v1" '.
+ 'id="tag:open-ils.org:serial-issuance/' . $self->obj->id . '" ';
+
+ $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" '
+ for (qw/create_date edit_date label date_published holding_code holding_type holding_link_id/);
+
+ $xml .= ">\n";
+
+ if (!$args->{no_items}) {
+ if (ref($self->obj->items) && @{ $self->obj->items }) {
+ $xml .= " <items>\n" . join(
+ '',
+ map {
+ OpenILS::Application::SuperCat::unAPI
+ ->new( $_ )
+ ->as_xml({ %$args, no_stream=>1 })
+ } @{ $self->obj->items }
+ ) . " </items>\n";
+
+ } else {
+ $xml .= " <items/>\n";
+ }
+ }
+
+ $xml .= OpenILS::Application::SuperCat::unAPI->new( $self->obj->subscription )->as_xml({ %$args, no_issuances=>1 }) if (!$args->{no_subscription});
+ $xml .= " </issuance>\n";
+
+ return $xml;
+}
+
+package OpenILS::Application::SuperCat::unAPI::acp;
+use base qw/OpenILS::Application::SuperCat::unAPI/;
+
+sub as_xml {
+ my $self = shift;
+ my $args = shift;
+
+ my $xml = ' <copy xmlns="http://open-ils.org/spec/holdings/v1" '.
+ 'id="tag:open-ils.org:asset-copy/' . $self->obj->id . '" ';
+
+ $xml .= $_ . '="' . $self->escape( $self->obj->$_ ) . '" ' for (qw/
+ create_date edit_date copy_number circulate deposit ref holdable deleted
+ deposit_amount price barcode circ_modifier circ_as_type opac_visible
+ /);
+
+ $xml .= ">\n";
+
+ $xml .= ' <status ident="' . $self->obj->status->id . '">' . $self->escape( $self->obj->status->name ) . "</status>\n";
+ $xml .= ' <location ident="' . $self->obj->location->id . '" opac_visible="'.$self->obj->location->opac_visible.'">' . $self->escape( $self->obj->location->name ) . "</location>\n";
+ $xml .= ' <circlib ident="' . $self->obj->circ_lib->id . '" opac_visible="'.$self->obj->circ_lib->opac_visible.'">' . $self->escape( $self->obj->circ_lib->name ) . "</circlib>\n";
+
+ $xml .= ' <circ_lib xmlns="http://open-ils.org/spec/actors/v1" ';
+ $xml .= 'id="tag:open-ils.org:actor-org_unit/' . $self->obj->circ_lib->id . '" ';
+ $xml .= 'shortname="'.$self->escape( $self->obj->circ_lib->shortname ) .'" ';
+ $xml .= 'name="'.$self->escape( $self->obj->circ_lib->name ) .'" opac_visible="'.$self->obj->circ_lib->opac_visible.'"/>';
+ $xml .= "\n";
+
+ $xml .= " <copy_notes>\n";
+ if (ref($self->obj->notes) && $self->obj->notes) {
+ for my $note ( @{$self->obj->notes} ) {
+ next unless ( $note->pub eq 't' );
+ $xml .= sprintf(' <copy_note date="%s" title="%s">%s</copy_note>',$note->create_date, $self->escape($note->title), $self->escape($note->value));
+ $xml .= "\n";
+ }
+ }
+
+ $xml .= " </copy_notes>\n";
+ $xml .= " <statcats>\n";
+
+ if (ref($self->obj->stat_cat_entries) && $self->obj->stat_cat_entries) {
+ for my $sce ( @{$self->obj->stat_cat_entries} ) {
+ next unless ( $sce->stat_cat->opac_visible eq 't' );
+ $xml .= sprintf(' <statcat name="%s">%s</statcat>',$self->escape($sce->stat_cat->name) ,$self->escape($sce->value));
+ $xml .= "\n";
+ }
+ }
+ $xml .= " </statcats>\n";
+
+ unless ($args->{no_volume}) {
+ if (ref($self->obj->call_number)) {
+ $xml .= OpenILS::Application::SuperCat::unAPI
+ ->new( $self->obj->call_number )
+ ->as_xml({ %$args, no_copies=>1 });
+ } else {
+ $xml .= " <volume/>\n";
+ }
+ }
+
+ $xml .= " </copy>\n";
+
+ return $xml;
+}
+
+
+1;
+# vim: et:ts=4:sw=4
--- /dev/null
+package OpenILS::Application::Trigger;
+use strict; use warnings;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils::JSON;
+
+use OpenSRF::AppSession;
+use OpenSRF::MultiSession;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils qw/:datetime/;
+
+use DateTime;
+use DateTime::Format::ISO8601;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::Trigger::Event;
+use OpenILS::Application::Trigger::EventGroup;
+
+
+my $log = 'OpenSRF::Utils::Logger';
+my $parallel_collect;
+my $parallel_react;
+
+sub initialize {
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ $parallel_collect = $conf->config_value( apps => 'open-ils.trigger' => app_settings => parallel => 'collect') || 1;
+ $parallel_react = $conf->config_value( apps => 'open-ils.trigger' => app_settings => parallel => 'react') || 1;
+
+}
+sub child_init {}
+
+sub create_active_events_for_object {
+ my $self = shift;
+ my $client = shift;
+ my $key = shift;
+ my $target = shift;
+ my $location = shift;
+ my $granularity = shift;
+ my $user_data = shift;
+
+ my $ident = $target->Identity;
+ my $ident_value = $target->$ident();
+
+ my $editor = new_editor(xact=>1);
+
+ my $hooks = $editor->search_action_trigger_hook(
+ { key => $key,
+ core_type => $target->json_hint
+ }
+ );
+
+ unless(@$hooks) {
+ $editor->rollback;
+ return undef;
+ }
+
+ my %hook_hash = map { ($_->key, $_) } @$hooks;
+
+ my $orgs = $editor->json_query({ from => [ 'actor.org_unit_ancestors' => $location ] });
+ my $defs = $editor->search_action_trigger_event_definition(
+ { hook => [ keys %hook_hash ],
+ owner => [ map { $_->{id} } @$orgs ],
+ active => 't'
+ }
+ );
+
+ for my $def ( @$defs ) {
+ next if ($granularity && $def->granularity ne $granularity );
+
+ if ($def->usr_field && $def->opt_in_setting) {
+ my $ufield = $def->usr_field;
+ my $uid = $target->$ufield;
+ $uid = $uid->id if (ref $uid); # fleshed user object, unflesh it
+
+ my $opt_in_setting = $editor->search_actor_user_setting(
+ { usr => $uid,
+ name => $def->opt_in_setting,
+ value => 'true'
+ }
+ );
+
+ next unless (@$opt_in_setting);
+ }
+
+ my $date = DateTime->now;
+
+ if ($hook_hash{$def->hook}->passive eq 'f') {
+
+ if (my $dfield = $def->delay_field) {
+ if ($target->$dfield()) {
+ $date = DateTime::Format::ISO8601->new->parse_datetime( cleanse_ISO8601($target->$dfield) );
+ } else {
+ next;
+ }
+ }
+
+ $date->add( seconds => interval_to_seconds($def->delay) );
+ }
+
+ my $event = Fieldmapper::action_trigger::event->new();
+ $event->target( $ident_value );
+ $event->event_def( $def->id );
+ $event->run_time( $date->strftime( '%F %T%z' ) );
+ $event->user_data( OpenSRF::Utils::JSON->perl2JSON($user_data) ) if (defined($user_data));
+
+ $editor->create_action_trigger_event( $event );
+
+ $client->respond( $event->id );
+ }
+
+ $editor->commit;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.autocreate',
+ method => 'create_active_events_for_object',
+ api_level=> 1,
+ stream => 1,
+ argc => 3
+);
+
+sub create_event_for_object_and_def {
+ my $self = shift;
+ my $client = shift;
+ my $definitions = shift;
+ my $target = shift;
+ my $location = shift;
+ my $user_data = shift;
+
+ my $ident = $target->Identity;
+ my $ident_value = $target->$ident();
+
+ my @active = ($self->api_name =~ /inactive/o) ? () : ( active => 't' );
+
+ my $editor = new_editor(xact=>1);
+
+ my $orgs = $editor->json_query({ from => [ 'actor.org_unit_ancestors' => $location ] });
+ my $defs = $editor->search_action_trigger_event_definition(
+ { id => $definitions,
+ owner => [ map { $_->{id} } @$orgs ],
+ @active
+ }
+ );
+
+ my $hooks = $editor->search_action_trigger_hook(
+ { key => [ map { $_->hook } @$defs ],
+ core_type => $target->json_hint
+ }
+ );
+
+ my %hook_hash = map { ($_->key, $_) } @$hooks;
+
+ for my $def ( @$defs ) {
+
+ if ($def->usr_field && $def->opt_in_setting) {
+ my $ufield = $def->usr_field;
+ my $uid = $target->$ufield;
+ $uid = $uid->id if (ref $uid); # fleshed user object, unflesh it
+
+ my $opt_in_setting = $editor->search_actor_user_setting(
+ { usr => $uid,
+ name => $def->opt_in_setting,
+ value => 'true'
+ }
+ );
+
+ next unless (@$opt_in_setting);
+ }
+
+ my $date = DateTime->now;
+
+ if ($hook_hash{$def->hook}->passive eq 'f') {
+
+ if (my $dfield = $def->delay_field) {
+ if ($target->$dfield()) {
+ $date = DateTime::Format::ISO8601->new->parse_datetime( cleanse_ISO8601($target->$dfield) );
+ } else {
+ next;
+ }
+ }
+
+ $date->add( seconds => interval_to_seconds($def->delay) );
+ }
+
+ my $event = Fieldmapper::action_trigger::event->new();
+ $event->target( $ident_value );
+ $event->event_def( $def->id );
+ $event->run_time( $date->strftime( '%F %T%z' ) );
+ $event->user_data( OpenSRF::Utils::JSON->perl2JSON($user_data) ) if (defined($user_data));
+
+ $editor->create_action_trigger_event( $event );
+
+ $client->respond( $event->id );
+ }
+
+ $editor->commit;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.autocreate.by_definition',
+ method => 'create_event_for_object_and_def',
+ api_level=> 1,
+ stream => 1,
+ argc => 3
+);
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.autocreate.by_definition.include_inactive',
+ method => 'create_event_for_object_and_def',
+ api_level=> 1,
+ stream => 1,
+ argc => 3
+);
+
+
+# Retrieves events by object, or object type + filter
+# $object : a target object or object type (class hint)
+#
+# $filter : an optional hash of filters ... top level keys:
+# event
+# filters on the atev objects, such as states or null-ness of timing
+# fields. contains the effective default of:
+# { state => 'pending' }
+# an example, which overrides the default, and will find
+# stale 'found' events:
+# { state => 'found', update_time => { '<' => 'yesterday' } }
+#
+# event_def
+# filters on the atevdef object. contains the effective default of:
+# { active => 't' }
+#
+# hook
+# filters on the hook object. no defaults, but there is a pinned,
+# unchangeable filter based on the passed hint or object type (see
+# $object above). an example for finding passive events:
+# { passive => 't' }
+#
+# target
+# filters against the target field on the event. this can contain
+# either an array of target ids (if you passed an object type, and
+# not an object) or can contain a json_query that will return exactly
+# a list of target-type ids. If you pass an object, the pkey value of
+# that object will be used as a filter in addition to the filter passed
+# in here. example filter for circs of user 1234 that are open:
+# { select => { circ => ['id'] },
+# from => 'circ',
+# where => {
+# usr => 1234,
+# checkin_time => undef,
+# '-or' => [
+# { stop_fines => undef },
+# { stop_fines => { 'not in' => ['LOST','LONGOVERDUE','CLAIMSRETURNED'] } }
+# ]
+# }
+
+sub events_by_target {
+ my $self = shift;
+ my $client = shift;
+ my $object = shift;
+ my $filter = shift || {};
+ my $flesh_fields = shift || {};
+ my $flesh_depth = shift || 1;
+
+ my $obj_class = ref($object) || _fm_class_by_hint($object);
+ my $obj_hint = ref($object) ? _fm_hint_by_class(ref($object)) : $object;
+
+ my $object_ident_field = $obj_class->Identity;
+
+ my $query = {
+ select => { atev => ["id"] },
+ from => {
+ atev => {
+ atevdef => {
+ field => "id",
+ fkey => "event_def",
+ join => {
+ ath => { field => "key", fkey => "hook" }
+ }
+ }
+ }
+ },
+ where => {
+ "+ath" => { core_type => $obj_hint },
+ "+atevdef" => { active => 't' },
+ "+atev" => { state => 'pending' }
+ },
+ order_by => { "atev" => [ 'run_time', 'add_time' ] }
+ };
+
+ $query->{limit} = $filter->{limit} if defined $filter->{limit};
+ $query->{offset} = $filter->{offset} if defined $filter->{offset};
+ $query->{order_by} = $filter->{order_by} if defined $filter->{order_by};
+
+
+ # allow multiple 'target' filters
+ $query->{where}->{'+atev'}->{'-and'} = [];
+
+ # if we got a real object, filter on its pkey value
+ if (ref($object)) { # pass an object, require that target
+ push @{ $query->{where}->{'+atev'}->{'-and'} },
+ { target => $object->$object_ident_field }
+ }
+
+ # we have a fancy complex target filter or a list of target ids
+ if ($$filter{target}) {
+ push @{ $query->{where}->{'+atev'}->{'-and'} },
+ { target => {in => $$filter{target} } };
+ }
+
+ # pass no target filter or object, you get no events
+ if (!@{ $query->{where}->{'+atev'}->{'-and'} }) {
+ return undef;
+ }
+
+ # any hook filters, other than the required core_type filter
+ if ($$filter{hook}) {
+ $query->{where}->{'+ath'}->{$_} = $$filter{hook}{$_}
+ for (grep { $_ ne 'core_type' } keys %{$$filter{hook}});
+ }
+
+ # any event_def filters. defaults to { active => 't' }
+ if ($$filter{event_def}) {
+ $query->{where}->{'+atevdef'}->{$_} = $$filter{event_def}{$_}
+ for (keys %{$$filter{event_def}});
+ }
+
+ # any event filters. defaults to { state => 'pending' }.
+ # don't overwrite '-and' used for multiple target filters above
+ if ($$filter{event}) {
+ $query->{where}->{'+atev'}->{$_} = $$filter{event}{$_}
+ for (grep { $_ ne '-and' } keys %{$$filter{event}});
+ }
+
+ my $e = new_editor(xact=>1);
+
+ my $events = $e->json_query($query);
+
+ $flesh_fields->{atev} = ['event_def'] unless $flesh_fields->{atev};
+
+ for my $id (@$events) {
+ my $event = $e->retrieve_action_trigger_event([
+ $id->{id},
+ {flesh => $flesh_depth, flesh_fields => $flesh_fields}
+ ]);
+
+ (my $meth = $obj_class) =~ s/^Fieldmapper:://o;
+ $meth =~ s/::/_/go;
+ $meth = 'retrieve_'.$meth;
+
+ $event->target($e->$meth($event->target));
+ $client->respond($event);
+ }
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.events_by_target',
+ method => 'events_by_target',
+ api_level=> 1,
+ stream => 1,
+ argc => 2
+);
+
+sub _fm_hint_by_class {
+ my $class = shift;
+ return Fieldmapper->publish_fieldmapper->{$class}->{hint};
+}
+
+sub _fm_class_by_hint {
+ my $hint = shift;
+
+ my ($class) = grep {
+ Fieldmapper->publish_fieldmapper->{$_}->{hint} eq $hint
+ } keys %{ Fieldmapper->publish_fieldmapper };
+
+ return $class;
+}
+
+sub create_batch_events {
+ my $self = shift;
+ my $client = shift;
+ my $key = shift;
+ my $location_field = shift; # where to look for event_def.owner filtering ... circ_lib, for instance, where hook.core_type = circ
+ my $filter = shift || {};
+ my $granularity = shift;
+ my $user_data = shift;
+
+ my $active = ($self->api_name =~ /active/o) ? 1 : 0;
+ if ($active && !keys(%$filter)) {
+ $log->info("Active batch event creation requires a target filter but none was supplied to create_batch_events");
+ return undef;
+ }
+
+ return undef unless ($key && $location_field);
+
+ my $editor = new_editor(xact=>1);
+ my $hooks = $editor->search_action_trigger_hook(
+ { passive => $active ? 'f' : 't', key => $key }
+ );
+
+ my %hook_hash = map { ($_->key, $_) } @$hooks;
+
+ my $defs = $editor->search_action_trigger_event_definition(
+ { hook => [ keys %hook_hash ], active => 't' },
+ );
+
+ my $orig_filter_and = [];
+ if ($$filter{'-and'}) {
+ for my $f ( @{ $$filter{'-and'} } ) {
+ push @$orig_filter_and, $f;
+ }
+ }
+
+ for my $def ( @$defs ) {
+ next if ($granularity && $def->granularity ne $granularity );
+
+ my $date = DateTime->now->subtract( seconds => interval_to_seconds($def->delay) );
+
+ # we may need to do some work to backport this to 1.2
+ $filter->{ $location_field } = { 'in' =>
+ {
+ select => { aou => [{ column => 'id', transform => 'actor.org_unit_descendants', result_field => 'id' }] },
+ from => 'aou',
+ where => { id => $def->owner }
+ }
+ };
+
+ my $run_time = 'now';
+ if ($active) {
+ $run_time =
+ DateTime
+ ->now
+ ->add( seconds => interval_to_seconds($def->delay) )
+ ->strftime( '%F %T%z' );
+ } else {
+ if ($def->max_delay) {
+ my @times = sort {$a <=> $b} interval_to_seconds($def->delay), interval_to_seconds($def->max_delay);
+ $filter->{ $def->delay_field } = {
+ 'between' => [
+ DateTime->now->subtract( seconds => $times[1] )->strftime( '%F %T%z' ),
+ DateTime->now->subtract( seconds => $times[0] )->strftime( '%F %T%z' )
+ ]
+ };
+ } else {
+ $filter->{ $def->delay_field } = {
+ '<=' => DateTime->now->subtract( seconds => interval_to_seconds($def->delay) )->strftime( '%F %T%z' )
+ };
+ }
+ }
+
+ my $class = _fm_class_by_hint($hook_hash{$def->hook}->core_type);
+
+ # filter where this target has an event (and it's pending, for active hooks)
+ $$filter{'-and'} = [];
+ for my $f ( @$orig_filter_and ) {
+ push @{ $$filter{'-and'} }, $f;
+ }
+
+ my $join = { 'join' => {
+ atev => {
+ field => 'target',
+ fkey => $class->Identity,
+ type => 'left',
+ filter => { event_def => $def->id }
+ }
+ }};
+
+ push @{ $filter->{'-and'} }, { '+atev' => { id => undef } };
+
+ if ($def->usr_field && $def->opt_in_setting) {
+ push @{ $filter->{'-and'} }, {
+ '-exists' => {
+ from => 'aus',
+ where => {
+ name => $def->opt_in_setting,
+ usr => { '=' => { '+' . $hook_hash{$def->hook}->core_type => $def->usr_field } },
+ value=> 'true'
+ }
+ }
+ };
+ }
+
+ $class =~ s/^Fieldmapper:://o;
+ $class =~ s/::/_/go;
+ my $method = 'search_'. $class;
+
+ # for cleaner logging
+ my $def_id = $def->id;
+ my $hook = $def->hook;
+
+ $logger->info("trigger: create_batch_events() collecting object IDs for def=$def_id / hook=$hook");
+
+ my $object_ids = $editor->$method( [$filter, $join], {idlist => 1, timeout => 10800} );
+
+ if($object_ids) {
+ $logger->info("trigger: create_batch_events() fetched ".scalar(@$object_ids)." object IDs for def=$def_id / hook=$hook");
+ } else {
+ $logger->warn("trigger: create_batch_events() timeout occurred collecting object IDs for def=$def_id / hook=$hook");
+ }
+
+ for my $o_id (@$object_ids) {
+
+ my $event = Fieldmapper::action_trigger::event->new();
+ $event->target( $o_id );
+ $event->event_def( $def->id );
+ $event->run_time( $run_time );
+ $event->user_data( OpenSRF::Utils::JSON->perl2JSON($user_data) ) if (defined($user_data));
+
+ $editor->create_action_trigger_event( $event );
+
+ $client->respond( $event->id );
+ }
+
+ $logger->info("trigger: create_batch_events() successfully created events for def=$def_id / hook=$hook");
+ }
+
+ $logger->info("trigger: create_batch_events() done creating events");
+
+ $editor->commit;
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.passive.event.autocreate.batch',
+ method => 'create_batch_events',
+ api_level=> 1,
+ stream => 1,
+ argc => 2
+);
+
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.active.event.autocreate.batch',
+ method => 'create_batch_events',
+ api_level=> 1,
+ stream => 1,
+ argc => 2
+);
+
+sub fire_single_event {
+ my $self = shift;
+ my $client = shift;
+ my $event_id = shift;
+
+ my $e = OpenILS::Application::Trigger::Event->new($event_id);
+
+ if ($e->validate->valid) {
+ $logger->info("trigger: Event is valid, reacting...");
+ $e->react->cleanup;
+ }
+
+ $e->editor->disconnect;
+ OpenILS::Application::Trigger::Event->ClearObjectCache();
+
+ return {
+ valid => $e->valid,
+ reacted => $e->reacted,
+ cleanedup => $e->cleanedup,
+ event => $e->event
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.fire',
+ method => 'fire_single_event',
+ api_level=> 1,
+ argc => 1
+);
+
+sub fire_event_group {
+ my $self = shift;
+ my $client = shift;
+ my $events = shift;
+
+ my $e = OpenILS::Application::Trigger::EventGroup->new(@$events);
+
+ if ($e->validate->valid) {
+ $logger->info("trigger: Event group is valid, reacting...");
+ $e->react->cleanup;
+ }
+
+ $e->editor->disconnect;
+ OpenILS::Application::Trigger::Event->ClearObjectCache();
+
+ return {
+ valid => $e->valid,
+ reacted => $e->reacted,
+ cleanedup => $e->cleanedup,
+ events => [map { $_->event } @{$e->events}]
+ };
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event_group.fire',
+ method => 'fire_event_group',
+ api_level=> 1,
+ argc => 1
+);
+
+sub pending_events {
+ my $self = shift;
+ my $client = shift;
+ my $granularity = shift;
+ my $granflag = shift;
+
+ my $query = [{ state => 'pending', run_time => {'<' => 'now'} }, { order_by => { atev => [ qw/run_time add_time/] }, 'join' => 'atevdef' }];
+
+ if (defined $granularity) {
+ if ($granflag) {
+ $query->[0]->{'+atevdef'} = {granularity => $granularity};
+ } else {
+ $query->[0]->{'+atevdef'} = {'-or' => [ {granularity => $granularity}, {granularity => undef} ] };
+ }
+ } else {
+ $query->[0]->{'+atevdef'} = {granularity => undef};
+ }
+
+ return new_editor(xact=>1)->search_action_trigger_event(
+ $query, { idlist=> 1, timeout => 7200, substream => 1 }
+ );
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.find_pending',
+ method => 'pending_events',
+ api_level=> 1
+);
+
+sub gather_events {
+ my $self = shift;
+ my $client = shift;
+ my $e_ids = shift;
+
+ $e_ids = [$e_ids] if (!ref($e_ids));
+
+ my @events;
+ for my $e_id (@$e_ids) {
+ my $e;
+ try {
+ $e = OpenILS::Application::Trigger::Event->new($e_id);
+ } catch Error with {
+ $logger->error("trigger: Event creation failed with ".shift());
+ };
+
+ next if !$e or $e->event->state eq 'invalid';
+
+ try {
+ $e->build_environment;
+ } catch Error with {
+ $logger->error("trigger: Event environment building failed with ".shift());
+ };
+
+ $e->editor->disconnect;
+ $e->environment->{EventProcessor} = undef; # remove circular ref for json encoding
+ $client->respond($e);
+ }
+
+ OpenILS::Application::Trigger::Event->ClearObjectCache();
+
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.gather',
+ method => 'gather_events',
+ api_level=> 1
+);
+
+sub grouped_events {
+ my $self = shift;
+ my $client = shift;
+ my $granularity = shift;
+ my $granflag = shift;
+
+ my ($events) = $self->method_lookup('open-ils.trigger.event.find_pending')->run($granularity, $granflag);
+
+ my %groups = ( '*' => [] );
+
+ if($events) {
+ $logger->info("trigger: grouped_events found ".scalar(@$events)." pending events to process");
+ } else {
+ $logger->warn("trigger: grouped_events timed out loading pending events");
+ return \%groups;
+ }
+
+ my @fleshed_events;
+
+ if ($parallel_collect == 1 or @$events == 1) { # use method lookup
+ @fleshed_events = $self->method_lookup('open-ils.trigger.event.gather')->run($events);
+ } else {
+ my $self_multi = OpenSRF::MultiSession->new(
+ app => 'open-ils.trigger',
+ cap => $parallel_collect,
+ success_handler => sub {
+ my $self = shift;
+ my $req = shift;
+
+ push @fleshed_events,
+ map { OpenILS::Application::Trigger::Event->new($_) }
+ map { $_->content }
+ @{ $req->{response} };
+ },
+ );
+
+ $self_multi->request( 'open-ils.trigger.event.gather' => $_ ) for ( @$events );
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ $self_multi->session_wait(1);
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+ }
+
+ for my $e (@fleshed_events) {
+ if (my $group = $e->event->event_def->group_field) {
+
+ # split the grouping link steps
+ my @steps = split /\./, $group;
+ my $group_field = pop(@steps); # we didn't flesh to this, it's a field not an object
+
+ my $node;
+ eval {
+ $node = $e->target;
+ $node = $node->$_() for ( @steps );
+ };
+
+ unless($node) { # should not get here, but to be safe..
+ $e->update_state('invalid');
+ next;
+ }
+
+ # get the grouping value for the grouping object on this event
+ my $ident_value = $node->$group_field();
+ if(ref $ident_value) {
+ my $ident_field = $ident_value->Identity;
+ $ident_value = $ident_value->$ident_field()
+ }
+
+ # push this event onto the event+grouping_value stack
+ $groups{$e->event->event_def->id}{$ident_value} ||= [];
+ push @{ $groups{$e->event->event_def->id}{$ident_value} }, $e;
+ } else {
+ # it's a non-grouped event
+ push @{ $groups{'*'} }, $e;
+ }
+ }
+
+
+ return \%groups;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.find_pending_by_group',
+ method => 'grouped_events',
+ api_level=> 1
+);
+
+sub run_all_events {
+ my $self = shift;
+ my $client = shift;
+ my $granularity = shift;
+ my $granflag = shift;
+
+ my ($groups) = $self->method_lookup('open-ils.trigger.event.find_pending_by_group')->run($granularity, $granflag);
+ $client->respond({"status" => "found"}) if (keys(%$groups) > 1 || @{$$groups{'*'}});
+
+ my $self_multi;
+ if ($parallel_react > 1 and (keys(%$groups) > 1 || @{$$groups{'*'}} > 1)) {
+ $self_multi = OpenSRF::MultiSession->new(
+ app => 'open-ils.trigger',
+ cap => $parallel_react,
+ session_hash_function => sub {
+ my $args = shift;
+ return $args->{target_id};
+ },
+ success_handler => sub {
+ my $me = shift;
+ my $req = shift;
+ $client->respond( $req->{response}->[0]->content );
+ }
+ );
+ }
+
+ for my $def ( keys %$groups ) {
+ if ($def eq '*') {
+ $logger->info("trigger: run_all_events firing un-grouped events");
+ for my $event ( @{ $$groups{'*'} } ) {
+ try {
+ if ($self_multi) {
+ $event->environment->{EventProcessor} = undef; # remove circular ref for json encoding
+ $self_multi->request({target_id => $event->id}, 'open-ils.trigger.event.fire', $event);
+ } else {
+ $client->respond(
+ $self
+ ->method_lookup('open-ils.trigger.event.fire')
+ ->run($event)
+ );
+ }
+ } catch Error with {
+ $logger->error("trigger: event firing failed with ".shift());
+ };
+ }
+ $logger->info("trigger: run_all_events completed queuing un-grouped events");
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+
+ } else {
+ my $defgroup = $$groups{$def};
+ $logger->info("trigger: run_all_events firing events for grouped event def=$def");
+ for my $ident ( keys %$defgroup ) {
+ $logger->info("trigger: run_all_events firing group for grouped event def=$def and grp ident $ident");
+ try {
+ if ($self_multi) {
+ $_->environment->{EventProcessor} = undef for @{$$defgroup{$ident}}; # remove circular ref for json encoding
+ $self_multi->request({target_id => $ident}, 'open-ils.trigger.event_group.fire', $$defgroup{$ident});
+ } else {
+ $client->respond(
+ $self
+ ->method_lookup('open-ils.trigger.event_group.fire')
+ ->run($$defgroup{$ident})
+ );
+ }
+ $client->status( new OpenSRF::DomainObject::oilsContinueStatus );
+ } catch Error with {
+ $logger->error("trigger: event firing failed with ".shift());
+ };
+ }
+ $logger->info("trigger: run_all_events completed queuing events for grouped event def=$def");
+ }
+ }
+
+ $self_multi->session_wait(1) if ($self_multi);
+ $logger->info("trigger: run_all_events completed firing events");
+
+ $client->respond_complete();
+ return undef;
+}
+__PACKAGE__->register_method(
+ api_name => 'open-ils.trigger.event.run_all_pending',
+ method => 'run_all_events',
+ api_level=> 1
+);
+
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Cleanup;
+use strict; use warnings;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+sub fourty_two { return 42 }
+sub NOOP_True { return 1 }
+sub NOOP_False { return 0 }
+
+sub DeleteTempBiblioBucket {
+ my($self, $env) = @_;
+ my $e = new_editor(xact => 1);
+ my $buckets = $env->{target};
+
+ for my $bucket (@$buckets) {
+
+ foreach my $item (@{ $bucket->items }) {
+ $e->delete_container_biblio_record_entry_bucket_item($item);
+ }
+
+ $e->delete_container_biblio_record_entry_bucket($bucket);
+ }
+
+ $e->commit or $e->die_event;
+
+ return 1;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Collector;
+use strict; use warnings;
+sub fourty_two { return 42 }
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Event;
+use strict; use warnings;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::Trigger::ModRunner;
+use Safe;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub new {
+ my $class = shift;
+ my $id = shift;
+ my $editor = shift;
+ $class = ref($class) || $class;
+
+ my $standalone = $editor ? 0 : 1;
+ $editor ||= new_editor();
+
+ if (ref($id) && ref($id) eq $class) {
+ $id->environment->{EventProcessor} = $id
+ if ($id->environment->{complete}); # in case it came over an opensrf tube
+ $id->editor( $editor );
+ $id->standalone( $standalone );
+ return $id;
+ }
+
+ my $self = bless { id => $id, editor => $editor, standalone => $standalone } => $class;
+
+ return $self->init()
+}
+
+sub init {
+ my $self = shift;
+ my $id = shift;
+
+ return $self if ($self->event);
+
+ $self->id( $id );
+ $self->environment( {} );
+
+ if (!$self->id) {
+ $log->error("No Event ID provided");
+ die "No Event ID provided";
+ }
+
+ return $self if (!$self->id);
+
+ if ($self->standalone) {
+ $self->editor->xact_begin || return undef;
+ }
+
+ $self->event(
+ $self->editor->retrieve_action_trigger_event([
+ $self->id, {
+ flesh => 2,
+ flesh_fields => {
+ atev => [ qw/event_def/ ],
+ atevdef => [ qw/hook env params/ ]
+ }
+ }
+ ])
+ );
+
+ if ($self->standalone) {
+ $self->editor->xact_rollback || return undef;
+ }
+
+ $self->user_data(OpenSRF::Utils::JSON->JSON2perl( $self->event->user_data ))
+ if (defined( $self->event->user_data ));
+
+ if ($self->event->state eq 'valid') {
+ $self->valid(1);
+ } elsif ($self->event->state eq 'invalid') {
+ $self->valid(0);
+ } elsif ($self->event->state eq 'reacting') {
+ $self->valid(1);
+ } elsif ($self->event->state eq 'reacted') {
+ $self->valid(1);
+ $self->reacted(1);
+ } elsif ($self->event->state eq 'cleaning') {
+ $self->valid(1);
+ $self->reacted(1);
+ } elsif ($self->event->state eq 'complete') {
+ $self->valid(1);
+ $self->reacted(1);
+ $self->cleanedup(1);
+ } elsif ($self->event->state eq 'error') {
+ $self->valid(0);
+ $self->reacted(0);
+ $self->cleanedup(0);
+ }
+
+
+ $self->update_state('found') || die 'Unable to update event state';
+
+ my $class = $self->_fm_class_by_hint( $self->event->event_def->hook->core_type );
+
+ my $meth = "retrieve_" . $class;
+ $meth =~ s/Fieldmapper:://;
+ $meth =~ s/::/_/;
+
+ if ($self->standalone) {
+ $self->editor->xact_begin || return undef;
+ }
+
+ $self->target( $self->editor->$meth( $self->event->target ) );
+
+ if ($self->standalone) {
+ $self->editor->xact_rollback || return undef;
+ }
+
+ unless($self->target) {
+ $self->update_state('invalid');
+ $self->valid(0);
+ }
+
+ return $self;
+}
+
+sub cleanup {
+ my $self = shift;
+ my $env = shift || $self->environment;
+
+ return $self if (defined $self->cleanedup);
+
+ if (defined $self->reacted) {
+ $self->update_state( 'cleaning') || die 'Unable to update event state';
+ try {
+ my $cleanup = $self->reacted ? $self->event->event_def->cleanup_success : $self->event->event_def->cleanup_failure;
+ if($cleanup) {
+ $self->cleanedup(
+ OpenILS::Application::Trigger::ModRunner::Cleanup
+ ->new( $cleanup, $env)
+ ->run
+ ->final_result
+ );
+ } else {
+ $self->cleanedup(1);
+ }
+ } otherwise {
+ $log->error("Event cleanup failed with ". shift() );
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ };
+
+ if ($self->cleanedup) {
+ $self->update_state( 'complete' ) || die 'Unable to update event state';
+ } else {
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ }
+
+ } else {
+ $self->{cleanedup} = undef;
+ }
+ return $self;
+}
+
+sub react {
+ my $self = shift;
+ my $env = shift || $self->environment;
+
+ return $self if (defined $self->reacted);
+
+ if ($self->valid) {
+ if ($self->event->event_def->group_field) { # can't react individually to a grouped definition
+ $self->{reacted} = undef;
+ } else {
+ $self->update_state( 'reacting') || die 'Unable to update event state';
+ try {
+ $self->reacted(
+ OpenILS::Application::Trigger::ModRunner::Reactor
+ ->new( $self->event->event_def->reactor, $env )
+ ->run
+ ->final_result
+ );
+ } otherwise {
+ $log->error("Event reacting failed with ". shift() );
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ };
+
+ if (defined $self->reacted) {
+ $self->update_state( 'reacted' ) || die 'Unable to update event state';
+ } else {
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ }
+ }
+ } else {
+ $self->{reacted} = undef;
+ }
+ return $self;
+}
+
+sub validate {
+ my $self = shift;
+
+ return $self if (defined $self->valid);
+
+ if ($self->build_environment->environment->{complete}) {
+ $self->update_state( 'validating') || die 'Unable to update event state';
+ try {
+ $self->valid(
+ OpenILS::Application::Trigger::ModRunner::Validator
+ ->new( $self->event->event_def->validator, $self->environment )
+ ->run
+ ->final_result
+ );
+ } otherwise {
+ $log->error("Event validation failed with ". shift() );
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ };
+
+ if (defined $self->valid) {
+ if ($self->valid) {
+ $self->update_state( 'valid' ) || die 'Unable to update event state';
+ } else {
+ $self->update_state( 'invalid' ) || die 'Unable to update event state';
+ }
+ } else {
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ }
+ } else {
+ $self->{valid} = undef
+ }
+
+ return $self;
+}
+
+sub cleanedup {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $c = shift;
+ $self->{cleanedup} = $c if (defined $c);
+ return $self->{cleanedup};
+}
+
+sub user_data {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $r = shift;
+ $self->{user_data} = $r if (defined $r);
+ return $self->{user_data};
+}
+
+sub reacted {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $r = shift;
+ $self->{reacted} = $r if (defined $r);
+ return $self->{reacted};
+}
+
+sub valid {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $v = shift;
+ $self->{valid} = $v if (defined $v);
+ return $self->{valid};
+}
+
+sub event {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $e = shift;
+ $self->{event} = $e if (defined $e);
+ return $self->{event};
+}
+
+sub id {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $i = shift;
+ $self->{id} = $i if (defined $i);
+ return $self->{id};
+}
+
+sub environment {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $e = shift;
+ $self->{environment} = $e if (defined $e);
+ return $self->{environment};
+}
+
+sub editor {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $e = shift;
+ $self->{editor} = $e if (defined $e);
+ return $self->{editor};
+}
+
+sub unfind {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ die 'Cannot unfind a reacted event' if (defined $self->reacted);
+
+ $self->update_state( 'pending' ) || die 'Unable to update event state';
+ $self->{id} = undef;
+ $self->{event} = undef;
+ $self->{environment} = undef;
+ return $self;
+}
+
+sub target {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $t = shift;
+ $self->{target} = $t if (defined $t);
+ return $self->{target};
+}
+
+sub standalone {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $t = shift;
+ $self->{standalone} = $t if (defined $t);
+ return $self->{standalone};
+}
+
+sub update_state {
+ my $self = shift;
+ return undef unless ($self && ref $self);
+
+ my $state = shift;
+ return undef unless ($state);
+
+ my $fields = shift;
+
+ if ($self->standalone) {
+ $self->editor->xact_begin || return undef;
+ }
+
+ my $e = $self->editor->retrieve_action_trigger_event( $self->id );
+ if (!$e) {
+ $log->error( "Could not retrieve object ".$self->id." for update" ) if (!$e);
+ return undef;
+ }
+
+ if ($fields && ref($fields)) {
+ $e->$_($$fields{$_}) for (keys %$fields);
+ }
+
+ $log->info( "Retrieved object ".$self->id." for update" );
+ $e->start_time( 'now' ) unless $e->start_time;
+ $e->update_time( 'now' );
+ $e->update_process( $$ );
+ $e->state( $state );
+
+ $e->clear_start_time() if ($e->state eq 'pending');
+ $e->complete_time( 'now' ) if ($e->state eq 'complete');
+
+ my $ok = $self->editor->update_action_trigger_event( $e );
+ if (!$ok) {
+ $self->editor->xact_rollback if ($self->standalone);
+ $log->error( "Update of event ".$self->id." failed" );
+ return undef;
+ } else {
+ $e = $self->editor->data;
+ $e = $self->editor->retrieve_action_trigger_event( $e ) if (!ref($e));
+ if (!$e) {
+ $log->error( "Update of event ".$self->id." did not return an object" );
+ return undef;
+ }
+ $log->info( "Update of event ".$e->id." suceeded" );
+ $ok = $self->editor->xact_commit if ($self->standalone);
+ }
+
+ if ($ok) {
+ $self->event->start_time( $e->start_time );
+ $self->event->update_time( $e->update_time );
+ $self->event->update_process( $e->update_process );
+ $self->event->state( $e->state );
+ }
+
+ return $ok || undef;
+}
+
+my $current_environment;
+
+sub build_environment {
+ my $self = shift;
+ return $self if ($self->environment->{complete});
+
+ $self->update_state( 'collecting') || die 'Unable to update event state';
+
+ try {
+
+ my $compartment = new Safe;
+ $compartment->permit(':default','require','dofile','caller');
+ $compartment->share('$current_environment');
+
+ $self->environment->{EventProcessor} = $self;
+ $self->environment->{target} = $self->target;
+ $self->environment->{event} = $self->event;
+ $self->environment->{template} = $self->event->event_def->template;
+ $self->environment->{user_data} = $self->user_data;
+
+ $current_environment = $self->environment;
+
+ $self->environment->{params}{ $_->param } = $compartment->reval($_->value) for ( @{$self->event->event_def->params} );
+
+ for my $e ( @{$self->event->event_def->env} ) {
+ my (@label, @path);
+ @path = split(/\./, $e->path) if ($e->path);
+ @label = split(/\./, $e->label) if ($e->label);
+
+ $self->_object_by_path( $self->target, $e->collector, \@label, \@path );
+ }
+
+ if ($self->event->event_def->group_field) {
+ my @group_path = split(/\./, $self->event->event_def->group_field);
+ pop(@group_path); # the last part is a field, should not get fleshed
+ my $group_object = $self->_object_by_path( $self->target, undef, [], \@group_path ) if (@group_path);
+ }
+
+ $self->environment->{complete} = 1;
+ } otherwise {
+ $log->error( shift() );
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ };
+
+ if ($self->environment->{complete}) {
+ $self->update_state( 'collected' ) || die 'Unable to update event state';
+ } else {
+ $self->update_state( 'error' ) || die 'Unable to update event state';
+ }
+
+ return $self;
+}
+
+sub _fm_class_by_hint {
+ my $self = shift;
+ my $hint = shift;
+
+ my ($class) = grep {
+ Fieldmapper->publish_fieldmapper->{$_}->{hint} eq $hint
+ } keys %{ Fieldmapper->publish_fieldmapper };
+
+ return $class;
+}
+
+my %_object_by_path_cache = ();
+sub ClearObjectCache {
+ for my $did ( keys %_object_by_path_cache ) {
+ my $phash = $_object_by_path_cache{$did};
+ for my $path ( keys %$phash ) {
+ my $shash = $$phash{$path};
+ for my $step ( keys %$shash ) {
+ my $fhash = $$shash{$step};
+ for my $ffield ( keys %$fhash ) {
+ my $lhash = $$fhash{$ffield};
+ for my $lfield ( keys %$lhash ) {
+ delete $$lhash{$lfield};
+ }
+ delete $$fhash{$ffield};
+ }
+ delete $$shash{$step};
+ }
+ delete $$phash{$path};
+ }
+ delete $_object_by_path_cache{$did};
+ }
+}
+
+sub _object_by_path {
+ my $self = shift;
+ my $context = shift;
+ my $collector = shift;
+ my $label = shift;
+ my $path = shift;
+ my $ed = shift;
+ my $red = shift;
+
+ my $outer = 0;
+ if (!$ed) {
+ $ed = new_editor(xact=>1);
+ $outer = 1;
+ }
+
+ my $step = shift(@$path);
+
+ my $fhint = Fieldmapper->publish_fieldmapper->{$context->class_name}{links}{$step}{class};
+ my $fclass = $self->_fm_class_by_hint( $fhint );
+
+ OpenSRF::EX::ERROR->throw(
+ "$step is not a field on ".$context->class_name." Please repair the environment.")
+ unless $fhint;
+
+ my $ffield = Fieldmapper->publish_fieldmapper->{$context->class_name}{links}{$step}{key};
+ my $rtype = Fieldmapper->publish_fieldmapper->{$context->class_name}{links}{$step}{reltype};
+
+ my $meth = 'retrieve_';
+ my $multi = 0;
+ my $lfield = $step;
+ if ($rtype ne 'has_a') {
+ $meth = 'search_';
+ $multi = 1;
+ $lfield = $context->Identity;
+ }
+
+ $meth .= $fclass;
+ $meth =~ s/Fieldmapper:://;
+ $meth =~ s/::/_/g;
+
+ my $obj = $context->$step();
+
+ $logger->debug(
+ sprintf "_object_by_path(): meth=%s, obj=%s, multi=%s, step=%s, lfield=%s",
+ map {defined($_)? $_ : ''} ($meth, $obj, $multi, $step, $lfield)
+ );
+
+ if (!ref $obj) {
+
+ my $lval = $context->$lfield();
+
+ if(defined $lval) {
+
+ my $def_id = $self->event->event_def->id;
+ my $str_path = join('.', @$path);
+
+ $obj = $_object_by_path_cache{$def_id}{$str_path}{$step}{$ffield}{$lval} ||
+ (
+ (grep /cstore/, @{
+ Fieldmapper->publish_fieldmapper->{$fclass}{controller}
+ }) ? $ed : ($red ||= new_rstore_editor(xact=>1))
+ )->$meth( ($multi) ? { $ffield => $lval } : $lval);
+
+ $_object_by_path_cache{$def_id}{$str_path}{$step}{$ffield}{$lval} ||= $obj;
+ }
+ }
+
+ if (@$path) {
+
+ my $obj_list = [];
+ if (!$multi) {
+ $obj_list = [$obj] if ($obj);
+ } else {
+ $obj_list = $obj;
+ }
+
+ for (@$obj_list) {
+ my @path_clone = @$path;
+ $self->_object_by_path( $_, $collector, $label, \@path_clone, $ed, $red );
+ }
+
+ $obj = $$obj_list[0] if (!$multi || $rtype eq 'might_have');
+ $context->$step( $obj ) if ($obj && (!$label || !@$label));
+
+ } else {
+
+ if ($collector) {
+ my $obj_list = [$obj] if ($obj && !$multi);
+ $obj_list = $obj if ($multi);
+
+ my @new_obj_list;
+ for my $o ( @$obj_list ) {
+ push @new_obj_list,
+ OpenILS::Application::Trigger::ModRunner::Collector
+ ->new( $collector, $o )
+ ->run
+ ->final_result
+ }
+
+ if (!$multi) {
+ $obj = $new_obj_list[0];
+ } else {
+ $obj = \@new_obj_list;
+ }
+ }
+
+ if ($label && @$label) {
+ my $node = $self->environment;
+ my $i = 0; my $max = scalar(@$label);
+ for (; $i < $max; $i++) {
+ my $part = $$label[$i];
+ $$node{$part} ||= {};
+ $node = $$node{$part};
+ }
+ $$node{$$label[-1]} = $obj;
+ } else {
+ $obj = $$obj[0] if $rtype eq 'might_have';
+ $context->$step( $obj ) if ($obj);
+ }
+ }
+
+ if ($outer) {
+ $ed->rollback;
+ $red->rollback if $red;
+ }
+ return $obj;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::EventGroup;
+use strict; use warnings;
+use OpenILS::Application::Trigger::Event;
+use base 'OpenILS::Application::Trigger::Event';
+use OpenSRF::EX qw/:try/;
+
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::Trigger::ModRunner;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub new {
+ my $class = shift;
+ my @ids = @_;
+ $class = ref($class) || $class;
+
+ my $editor = new_editor(xact=>1);
+
+ my $self = bless {
+ environment => {},
+ events => [
+ map {
+ ref($_) ?
+ do { $_->standalone(0); $_->editor($editor); $_ } :
+ OpenILS::Application::Trigger::Event->new($_, $editor)
+ } @ids
+ ],
+ ids => [ map { ref($_) ? $_->id : $_ } @ids ],
+ editor => $editor
+ } => $class;
+
+
+ $self->editor->xact_commit; # flush out those updates
+ $self->editor->xact_begin;
+
+ return $self;
+}
+
+sub react {
+ my $self = shift;
+
+ return $self if (defined $self->reacted);
+
+ if ($self->valid) {
+ $self->update_state( 'reacting') || die 'Unable to update event group state';
+ $self->build_environment;
+
+ try {
+ $self->reacted(
+ OpenILS::Application::Trigger::ModRunner::Reactor
+ ->new( $self->event->event_def->reactor, $self->environment )
+ ->run
+ ->final_result
+ );
+ } otherwise {
+ $log->error("Event reacting failed with ". shift() );
+ $self->update_state( 'error' ) || die 'Unable to update event group state';
+ };
+
+ if (defined $self->reacted) {
+ $self->update_state( 'reacted' ) || die 'Unable to update event group state';
+ } else {
+ $self->update_state( 'error' ) || die 'Unable to update event group state';
+ }
+ } else {
+ $self->{reacted} = undef;
+ }
+ return $self;
+}
+
+sub validate {
+ my $self = shift;
+
+ return $self if (defined $self->valid);
+
+ $self->update_state( 'validating') || die 'Unable to update event group state';
+ $self->editor->xact_begin;
+
+ my @valid_events;
+ try {
+ for my $event ( @{ $self->events } ) {
+ $event->validate;
+ push @valid_events, $event if ($event->valid);
+ }
+ $self->valid(1) if (@valid_events);
+ $self->{events} = \@valid_events;
+ $self->{ids} = [ map { $_->id } @valid_events ];
+ $self->editor->xact_commit;
+ } otherwise {
+ $log->error("Event group validation failed with ". shift() );
+ $self->editor->xact_rollback;
+ $self->update_state( 'error' ) || die 'Unable to update event group state';
+ };
+
+ return $self;
+}
+
+sub cleanedup {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $c = shift;
+ $self->{cleanedup} = $c if (defined $c);
+ return $self->{cleanedup};
+}
+
+sub reacted {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $r = shift;
+ $self->{reacted} = $r if (defined $r);
+ return $self->{reacted};
+}
+
+sub valid {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $v = shift;
+ $self->{valid} = $v if (defined $v);
+ return $self->{valid};
+}
+
+sub event {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ return $self->{events}[0]->event;
+}
+
+sub events {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ return $self->{events};
+}
+
+sub ids {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ return $self->{ids};
+}
+
+sub environment {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $e = shift;
+ $self->{environment} = $e if (defined $e);
+ return $self->{environment};
+}
+
+sub editor {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $e = shift;
+ $self->{editor} = $e if (defined $e);
+ return $self->{editor};
+}
+
+sub unfind {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ die 'Cannot unfind a reacted event group' if (defined $self->reacted);
+
+ $self->update_state( 'pending' ) || die 'Unable to update event group state';
+ $self->{events} = undef;
+ return $self;
+}
+
+sub update_state {
+ my $self = shift;
+ return undef unless ($self && ref $self);
+
+ my $state = shift;
+ return undef unless ($state);
+
+ my $fields = shift;
+
+ $self->editor->xact_begin || return undef;
+
+ my @oks;
+ my $ok;
+ my $last_updated;
+ for my $event ( @{ $self->events } ) {
+ my $e = $self->editor->retrieve_action_trigger_event( $event->id );
+ $e->start_time( 'now' ) unless $e->start_time;
+ $e->update_time( 'now' );
+ $e->update_process( $$ );
+ $e->state( $state );
+
+ $e->clear_start_time() if ($e->state eq 'pending');
+
+ if ($fields && ref($fields)) {
+ $e->$_($$fields{$_}) for (keys %$fields);
+ }
+
+ my $ok = $self->editor->update_action_trigger_event( $e );
+ if ($ok) {
+ push @oks, $ok;
+ $last_updated = $e->id;
+ }
+ }
+
+ if (scalar(@oks) < scalar(@{ $self->ids })) {
+ $self->editor->xact_rollback;
+ return undef;
+ }
+
+ my $updated = $self->editor->retrieve_action_trigger_event($last_updated);
+ $ok = $self->editor->xact_commit;
+
+ if ($ok) {
+ for my $event ( @{ $self->events } ) {
+ my $e = $event->event;
+ $e->start_time( $updated->start_time );
+ $e->update_time( $updated->update_time );
+ $e->update_process( $updated->update_process );
+ $e->state( $updated->state );
+ }
+ }
+
+ return $ok || undef;
+}
+
+sub findEvent {
+ my $self = shift;
+ my $member = shift;
+
+ $member = $member->id if (ref($member));
+
+ my @list = grep { $member == $_->id } @{ $self->events };
+
+ return shift(@list);
+}
+
+sub build_environment {
+ my $self = shift;
+ my $env = $self->environment;
+
+ $$env{EventProcessor} = $self;
+ $$env{target} = [];
+ $$env{event} = [];
+ $$env{user_data} = [];
+ for my $e ( @{ $self->events } ) {
+ for my $env_part ( keys %{ $e->environment } ) {
+ next if ($env_part eq 'EventProcessor');
+ if ($env_part eq 'target') {
+ push @{ $$env{target} }, $e->environment->{target};
+ } elsif ($env_part eq 'event') {
+ push @{ $$env{event} }, $e->environment->{event};
+ } elsif ($env_part eq 'user_data') {
+ push @{ $$env{user_data} }, $e->environment->{user_data};
+ } else {
+ $$env{$env_part} = $e->environment->{$env_part};
+ }
+ }
+ }
+
+ return $self;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::ModLoader;
+use strict; use warnings;
+use UNIVERSAL::require;
+
+sub prefix { return 'OpenILS::Application::Trigger' }
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $mod = shift;
+ return undef unless ($mod);
+
+ my $self = bless {
+ module => ref $mod ? $mod->module() : $mod,
+ handler => 'handler'
+ } => $class;
+
+ return $self->load;
+}
+
+sub loaded {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $l = shift;
+ $self->{loaded} = $l if (defined $l);
+ return $self->{loaded};
+}
+
+sub handler {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $h = shift;
+ $self->{handler} = $h if $h;
+ return $self->{handler};
+}
+
+sub module {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $m = shift;
+ $self->{module} = $m if $m;
+ return $self->{module};
+}
+
+sub load {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $m = shift || $self->module;
+ my $h = shift || $self->handler;
+ return 1 unless $m;
+
+ my $loaded = $m->use;
+
+ if (!$loaded) {
+ my $builtin_m = $self->prefix . "::$m";
+ $loaded = $builtin_m->use;
+
+ if (!$loaded) {
+ if ($m =~ /::/o) {
+ ($h = $m) =~ s/^.+::([^:]+)$/$1/o;
+ $m =~ s/^(.+)::[^:]+$/$1/o;
+
+ $loaded = $m->use;
+
+ if (!$loaded) {
+ $h = $self->handler;
+ $builtin_m = $self->prefix . "::$m";
+ $loaded = $m->use;
+
+ $m = $builtin_m if ($loaded);
+ }
+ } else {
+ $loaded = $m->use;
+
+ # The following is an escape hatch for builtin dummy handlers
+ if (!$loaded) {
+ $loaded = $self->prefix->use;
+ if ($loaded && $self->prefix->can( $self->module ) ) {
+ $m = $self->prefix;
+ $h = $self->module;
+ }
+ }
+ }
+ } else {
+ $m = $builtin_m;
+ }
+ }
+
+ if ($loaded) {
+ $self->module( $m );
+ $self->handler( $h );
+ }
+
+ $self->loaded($loaded);
+ return $self;
+}
+
+package OpenILS::Application::Trigger::ModRunner;
+use base 'OpenILS::Application::Trigger::ModLoader';
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $m = shift;
+ my $e = shift || {};
+
+ my $self = $class->SUPER::new( $m );
+ return undef unless ($self && $self->loaded);
+
+ $self->environment( $e );
+ return $self;
+}
+
+sub pass {
+ my $old = shift;
+ return undef unless (ref $old);
+
+ my $class = ref($old);
+ my $m = shift;
+
+ my $self = $class->SUPER::new( $m );
+ return undef unless ($self && $self->loaded);
+
+ $self->environment( $old->environment );
+ return $self;
+}
+
+sub environment {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $e = shift;
+ $self->{environment} = $e if (defined $e);
+ return $self->{environment};
+}
+
+sub final_result {
+ my $self = shift;
+ return undef unless (ref $self);
+
+ my $r = shift;
+ $self->{final_result} = $r if (defined $r);
+ return $self->{final_result};
+}
+
+sub run {
+ my $self = shift;
+ return undef unless (ref $self && $self->loaded);
+
+ $self->environment( shift );
+
+ my $m = $self->module;
+ my $h = $self->handler;
+ my $e = $self->environment;
+ $self->final_result( $m->$h( $e ) );
+
+ return $self;
+};
+
+package OpenILS::Application::Trigger::ModRunner::Collector;
+use base 'OpenILS::Application::Trigger::ModRunner';
+sub prefix { return 'OpenILS::Application::Trigger::Collector' }
+
+package OpenILS::Application::Trigger::ModRunner::Validator;
+use base 'OpenILS::Application::Trigger::ModRunner';
+sub prefix { return 'OpenILS::Application::Trigger::Validator' }
+
+package OpenILS::Application::Trigger::ModRunner::Reactor;
+use base 'OpenILS::Application::Trigger::ModRunner';
+sub prefix { return 'OpenILS::Application::Trigger::Reactor' }
+
+package OpenILS::Application::Trigger::ModRunner::Cleanup;
+use base 'OpenILS::Application::Trigger::ModRunner';
+sub prefix { return 'OpenILS::Application::Trigger::Cleanup' }
+
+package OpenILS::Application::Trigger::ModStackRunner;
+use base 'OpenILS::Application::Trigger::ModRunner';
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my $m = shift;
+ $m = [$m] unless (ref($m) =~ /ARRAY/o);
+
+ my $e = shift || {};
+
+ my $self = bless {
+ runners => []
+ } => $class;
+
+ for my $mod ( @$m ) {
+ my $r = $self->SUPER::new( $m );
+ return undef unless ($r && $r->loaded);
+ push @{$self->{runners}}, $r;
+ }
+
+ $self->loaded(1);
+
+ return $self;
+}
+
+sub pass {
+ my $old = shift;
+ return undef unless (ref $old);
+
+ my $class = ref($old);
+ my $m = shift;
+
+ my $self = $class->new( $m );
+ return undef unless ($self && $self->loaded);
+
+ $self->environment( $old->environment );
+ return $self;
+}
+
+sub run {
+ my $self = shift;
+ return undef unless (ref $self && $self->loaded);
+
+ $self->environment( shift );
+ my $e = $self->environment;
+
+ for my $r (@{$self->{runners}}) {
+ my $m = $r->module;
+ my $h = $r->handler;
+ $r->final_result( $m->$h( $e ) );
+ }
+
+ return $self;
+};
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Reactor;
+use strict; use warnings;
+use Template;
+use DateTime;
+use DateTime::Format::ISO8601;
+use Unicode::Normalize;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+my $U = 'OpenILS::Application::AppUtils';
+
+sub fourty_two { return 42 }
+sub NOOP_True { return 1 }
+sub NOOP_False { return 0 }
+
+
+
+# helper functions inserted into the TT environment
+my $_TT_helpers = {
+
+ # turns a date into something TT can understand
+ format_date => sub {
+ my $date = shift;
+ $date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($date));
+ return sprintf(
+ "%0.2d:%0.2d:%0.2d %0.2d-%0.2d-%0.4d",
+ $date->hour,
+ $date->minute,
+ $date->second,
+ $date->day,
+ $date->month,
+ $date->year
+ );
+ },
+
+ # escapes a string for inclusion in an XML document. escapes &, <, and > characters
+ escape_xml => sub {
+ my $str = shift;
+ $str =~ s/&/&/sog;
+ $str =~ s/</</sog;
+ $str =~ s/>/>/sog;
+ return $str;
+ },
+
+ escape_json => sub {
+ my $str = shift;
+ $str =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
+ return $str;
+ },
+
+ # strip non-ASCII characters after splitting base characters and diacritics
+ # least common denominator for EDIFACT messages using the UNOB character set
+ force_jedi_unob => sub {
+ my $str = shift;
+ $str = NFD($str);
+ $str =~ s/[\x{0080}-\x{fffd}]//g;
+ return $str;
+ },
+
+ # returns the calculated user locale
+ get_user_locale => sub {
+ my $user_id = shift;
+ return $U->get_user_locale($user_id);
+ },
+
+ # returns the calculated copy price
+ get_copy_price => sub {
+ my $copy_id = shift;
+ return $U->get_copy_price(new_editor(xact=>1), $copy_id);
+ },
+
+ # given a copy, returns the title and author in a hash
+ get_copy_bib_basics => sub {
+ my $copy_id = shift;
+ my $copy = new_editor(xact=>1)->retrieve_asset_copy([
+ $copy_id,
+ {
+ flesh => 2,
+ flesh_fields => {
+ acp => ['call_number'],
+ acn => ['record']
+ }
+ }
+ ]);
+ if($copy->call_number->id == -1) {
+ return {
+ title => $copy->dummy_title,
+ author => $copy->dummy_author,
+ };
+ } else {
+ my $mvr = $U->record_to_mvr($copy->call_number->record);
+ return {
+ title => $mvr->title,
+ author => $mvr->author
+ };
+ }
+ },
+
+ # returns the org unit setting value
+ get_org_setting => sub {
+ my($org_id, $setting) = @_;
+ return $U->ou_ancestor_setting_value($org_id, $setting);
+ },
+
+ # This basically greps/maps out ths isbn string values, but also promotes the first isbn-13 to the
+ # front of the line (so that the EDI translator takes it as primary) if there is one.
+ get_li_isbns => sub {
+ my $attrs = shift;
+ my @isbns;
+ my $primary;
+ foreach (@$attrs) {
+ $_->attr_name eq 'isbn' or next;
+ my $val = $_->attr_value;
+ if (! $primary and length($val) == 13) {
+ $primary = $val;
+ } else {
+ push @isbns, $val;
+ }
+ }
+ $primary and unshift @isbns, $primary;
+ $logger->debug("get_li_isbns returning isbns: " . join(', ', @isbns));
+ return @isbns;
+ },
+
+ # helpers.get_li_attr('isbn_13', li.attributes)
+ # returns matching line item attribute, or undef
+ get_li_attr => sub {
+ my $name = shift or return; # the first arg is always the name
+ my ($type, $attr) = (scalar(@_) == 1) ? (undef, $_[0]) : @_;
+ # if the next is the last, it's the attributes, otherwise type
+ # use Data::Dumper; $logger->warn("get_li_attr: " . Dumper($attr));
+ ($name and @$attr) or return;
+ my $length;
+ $name =~ s/^(\D+)_(\d+)$/$1/ and $length = $2;
+ foreach (@$attr) {
+ $_->attr_name eq $name or next;
+ next if $length and $length != length($_->attr_value);
+ return $_->attr_value if (! $type) or $type eq $_->attr_type;
+ }
+ return;
+ },
+};
+
+
+# processes templates. Returns template output on success, undef on error
+sub run_TT {
+ my $self = shift;
+ my $env = shift;
+ my $nostore = shift;
+ return undef unless $env->{template};
+
+ my $error;
+ my $output = '';
+ my $tt = Template->new;
+ # my $tt = Template->new(ENCODING => 'utf8'); # ??
+ $env->{helpers} = $_TT_helpers;
+
+ unless( $tt->process(\$env->{template}, $env, \$output) ) {
+ $output = undef;
+ ($error = $tt->error) =~ s/\n/ /og;
+ $logger->error("Error processing Trigger template: $error");
+ }
+
+ if ( $error or (!$nostore && $output) ) {
+ my $t_o = Fieldmapper::action_trigger::event_output->new;
+ $t_o->data( ($error) ? $error : $output );
+ $t_o->is_error( ($error) ? 't' : 'f' );
+ $logger->info("trigger: writing " . length($t_o->data) . " bytes to template output");
+
+ $env->{EventProcessor}->editor->xact_begin;
+ $t_o = $env->{EventProcessor}->editor->create_action_trigger_event_output( $t_o );
+
+ my $state = (ref $$env{event} eq 'ARRAY') ? $$env{event}->[0]->state : $env->{event}->state;
+ my $key = ($error) ? 'error_output' : 'template_output';
+ $env->{EventProcessor}->update_state( $state, { $key => $t_o->id } );
+ }
+
+ return $output;
+}
+
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::ApplyCircFee;
+use base 'OpenILS::Application::Trigger::Reactor';
+use strict; use warnings;
+use Error qw/:try/;
+use OpenILS::Const qw/:const/;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+
+
+sub ABOUT {
+ return <<ABOUT;
+
+ Creates a bill (money.billing) for the configured amount, linked to the circulation.
+ This reactor uses the Notification Fee billing type.
+ If an event definition template is defined, it will be used to generate the bill note.
+
+ Required event parameters:
+ "amount" The amount to bill
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+
+ my $e = new_editor(xact => 1);
+ my $btype = $e->retrieve_config_billing_type(OILS_BILLING_TYPE_NOTIFICATION_FEE);
+
+ my $circ = $$env{target};
+ my $amount = $$env{params}{amount} || $btype->default_price;
+
+ unless($amount) {
+ $logger->error("ApplyCircFee needs a fee amount");
+ $e->rollback;
+ return 0;
+ }
+
+ my $bill = Fieldmapper::money::billing->new;
+ $bill->xact($circ->id);
+ $bill->amount($amount);
+ $bill->btype(OILS_BILLING_TYPE_NOTIFICATION_FEE);
+ $bill->billing_type($btype->name);
+ $bill->note($self->run_TT($env));
+
+ unless( $e->create_money_billing($bill) ) {
+ $e->rollback;
+ return 0;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::ApplyPatronPenalty;
+use base 'OpenILS::Application::Trigger::Reactor';
+use strict; use warnings;
+use Error qw/:try/;
+use OpenILS::Const qw/:const/;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::AppUtils;
+my $U = "OpenILS::Application::AppUtils";
+
+
+sub ABOUT {
+ return <<ABOUT;
+
+ Applies a standing penalty to a patron. If there is a template, the template is
+ used as the value for the note
+
+ Required named (with labels) environment variables:
+ "user" -- User object fleshed into the environment
+ "context_org" -- Org unit object fleshed into the environment
+
+ Note: Using named env variables with a grouped event definition where the
+ env vars may be different depending on the target produces undefined behavior.
+ Don't use this reactor if more than one User or Org Unit object may be
+ referenced accross the set of target objects.
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+
+ my $pname = $$env{params}{standing_penalty};
+ my $user = $$env{environment}{user};
+ my $context_org = $$env{environment}{context_org};
+
+ unless($pname and ref $user and ref $context_org) {
+ $logger->error("ApplyPatronPenalty: missing parameters");
+ return 0;
+ }
+
+ my $e = new_editor(xact => 1);
+
+ my $ptype = $e->search_config_standing_penalty({name => $pname})->[0];
+
+ unless($ptype) {
+ $logger->error("ApplyPatronPenalty: invalid penalty name '$pname'");
+ $e->rollback;
+ return 0;
+ }
+
+ $context_org = (defined $ptype->org_depth) ?
+ $U->org_unit_ancestor_at_depth($context_org->id, $ptype->org_depth) :
+ $context_org->id;
+
+ # apply the penalty
+ my $penalty = Fieldmapper::actor::usr_standing_penalty->new;
+ $penalty->usr($user->id);
+ $penalty->org_unit($context_org);
+ $penalty->standing_penalty($ptype->id);
+ $penalty->note($self->run_TT($env));
+
+ unless($e->create_actor_user_standing_penalty($penalty)) {
+ $e->rollback;
+ return 0;
+ }
+
+ $e->commit;
+ return 1;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::AstCall;
+use base 'OpenILS::Application::Trigger::Reactor';
+use OpenSRF::Utils::Logger qw($logger);
+# use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+
+use strict; use warnings;
+use Error qw/:try/;
+use Data::Dumper;
+
+use OpenSRF::Utils::SettingsClient;
+use RPC::XML::Client;
+$Data::Dumper::Indent = 0;
+
+my $U = 'OpenILS::Application::AppUtils';
+
+my $e = new_editor(xact => 1);
+
+# $last_channel_used is:
+# ~ index (not literal value) of last channel used in a callfile
+# ~ index is of position in @channels (zero-based)
+# ~ cached at package level
+# ~ typically for Zap (PSTN), not VOIP
+
+our @channels;
+our $last_channel_used = 0;
+our $telephony;
+
+sub ABOUT {
+ return <<ABOUT;
+
+ The AstCall reactor module creates a callfile for Asterisk, given a
+ template describing the message and an environment defining
+ necessary information for contacting the Asterisk server and scheduling
+ a call with it.
+
+ABOUT
+}
+
+sub get_conf {
+ # $logger->info(__PACKAGE__ . ": get_conf()");
+ $telephony and return $telephony;
+ my $config = OpenSRF::Utils::SettingsClient->new;
+ # config object cached by package
+ $telephony = $config->config_value('notifications', 'telephony');
+ return $telephony;
+}
+
+sub get_channels {
+ @channels and return @channels;
+ my $config = get_conf(); # populated $telephony object
+ @channels = @{ $config->{channels} };
+ return @channels;
+}
+
+sub next_channel {
+ # Increments $last_channel_used, or resets it to zero, as necessary.
+ # Returns appropriate value from channels array.
+ my @chans = get_channels();
+ unless(@chans) {
+ $logger->error(__PACKAGE__ . ": Cannot build call using " .
+ (shift ||'driver') .
+ ", no notifications.telephony.channels found in config!");
+ return;
+ }
+ if (++$last_channel_used > $#chans) {
+ $last_channel_used = 0;
+ }
+ return $chans[$last_channel_used]; # say, 'Zap/1' or 'Zap/12'
+}
+
+sub channel {
+ my $tech = get_conf()->{driver} || 'SIP';
+ if ($tech !~ /^SIP/) {
+ return next_channel($tech);
+ }
+ return $tech; # say, 'SIP' or 'SIP/ubab33'
+}
+
+sub get_extra_lines {
+ my $lines = get_conf()->{callfile_lines} or return '';
+ my @fixed;
+ foreach (split "\n", $lines) {
+ s/^\s*//g; # strip leading spaces
+ /\S/ or next; # skip empty lines
+ push @fixed, $_;
+ }
+ (scalar @fixed) or return '';
+ return join("\n", @fixed) . "\n";
+}
+
+sub host_string {
+ my $conf = get_conf();
+ my $host = $conf->{host};
+ unless ($host) {
+ $logger->error(__PACKAGE__ . ": No telephony/host in config.");
+ return;
+ }
+
+ # prepend http:// if no protocol specified
+ $host =~ /^\S+:\/\// or $host = 'http://' . $host;
+ # append port number if specified
+ $conf->{port} and $host .= ":" . $conf->{port};
+
+ return $host;
+}
+sub rpc_client {
+ # TODO: caching? (would take testing to ensure memory and
+ # connections are clean/stable)
+ my $host = (@_ ? shift : host_string()) or return;
+ return new RPC::XML::Client($host);
+}
+
+sub handler {
+ my ($self, $env) = @_;
+
+ $logger->info(__PACKAGE__ . ": entered handler");
+
+ # assignment, not comparison
+ unless ($env->{channel_prefix} = channel()) {
+ $logger->error(__PACKAGE__ . ": Cannot find tech/resource in config");
+ return 0;
+ }
+
+ $env->{extra_lines} = get_extra_lines() || '';
+ my $tmpl_output = $self->run_TT($env);
+ if (not $tmpl_output) {
+ $logger->error(__PACKAGE__ . ": no template input");
+ return 0;
+ }
+
+ my @eventids = map {$_->id} @{$env->{event}};
+ @eventids or push @eventids, '';
+
+ my $eo = Fieldmapper::action_trigger::event_output->new;
+
+ # XXX we have to actually create this in the DB now if we expect to use the
+ # ID later
+ $eo->data("");
+ $eo = $e->create_action_trigger_event_output($eo) or return $e->die_event;
+ if ($env->{"extra_lines"}) {
+ $tmpl_output .= ";; added by handler:\n";
+ $tmpl_output .= $env->{"extra_lines"};
+ }
+
+ # or would we prefer distinct lines instead of comma-separated?
+ $tmpl_output .= "; event_ids = " . join(",",@eventids) . "\n";
+ $tmpl_output .= "; event_output = " . $eo->id . "\n";
+
+ #my $filename_fragment = $userid . '_' . $eventids[0] . 'uniq' . time;
+ # not $noticetype,
+ # the event_output.id tells us all we need to know
+ # XXX why is id in here twice?
+ my $filename_fragment = $eo->id . '_' . $eo->id;
+
+ # TODO: add scheduling intelligence and use it here... or not if
+ # relying only on crontab
+ my $client = rpc_client();
+ my $resp = $client->send_request(
+ 'inject', $tmpl_output, $filename_fragment, 0
+ ); # FIXME: 0 could be seconds-from-epoch UTC if deferred call needed
+
+ $logger->debug(
+ ref $resp ? ("Response: " . Dumper($resp->value)) : "Error: $resp"
+ );
+
+ if ($resp->{code} and $resp->{code}->value == 200) {
+ $eo->is_error('f');
+ $eo->data('filename: ' . $resp->{spooled_filename}->value);
+ # could look for the file that replaced it
+ } else {
+ $eo->is_error('t');
+ my $msg = $resp->{faultcode} ? $resp->{faultcode}->value :
+ $resp->{ code} ? $resp->{ code}->value :
+ " -- UNKNOWN response '$resp'";
+ $msg .= " for $filename_fragment";
+ $eo->data("Error " . $msg);
+ $logger->error(__PACKAGE__ . ": Mediator Error " . $msg);
+ }
+
+ # Now point all our events' async_output to the newly made row
+# $eo = $env->{EventProcessor}->editor->
+# create_action_trigger_event_output( $eo );
+ $e->update_action_trigger_event_output($eo) or return $e->die_event;
+ foreach (@eventids) {
+ my $event = $e->retrieve_action_trigger_event($_);
+ $event->async_output($eo->id);
+ $e->update_action_trigger_event($event);
+ }
+ $e->commit; # defer till after loop?
+
+ # TODO: a sub for saving async_output might belong in Trigger.pm
+ 1;
+}
+
+sub _files {
+ my $response = shift or return;
+ return map {$response->{$_}} sort grep {/^file_\d*/} keys %$response;
+}
+
+=head1 EXAMPLE CALFILES
+
+Note: all lines start flush left (no leading whitespace)
+
+=head2 Example callfile (successful)
+
+ Channel: SIP/ubab33/17707775555
+ Context: overdue-test
+ MaxRetries: 1
+ RetryTime: 60
+ WaitTime: 30
+ Extension: 10
+ Archive: 1
+ Set: items=1
+ Set: titlestring=chez nos gens;; added by OpenILS::Application::Trigger::Reactor::AstCall handler:
+ ; event_ids = 123,145
+ ; event_output = 14;; added by inject() in the mediator
+ Set: callfilename=EG_1258060382_6.call
+
+ StartRetry: 2139 1 (1258060442)
+ Status: Completed
+ Channel: SIP/ubab33/17707775555
+
+=head2 Example callfile (FAILED)
+
+ CallerID: "Jack Jackson" <17707775555>
+ Context: overdue-test
+ MaxRetries: 1
+ RetryTime: 60
+ WaitTime: 30
+ Extension: 10
+ Archive: 1
+ Set: items=1
+ Set: titlestring=Land Before Time;; added by OpenILS::Application::Trigger::Reactor::AstCall handler:
+ Set: LOOP=1
+ Set: callfilename=EG_joe_20091109145355.call
+
+ StartRetry: 2139 1 (1257907526)
+ ; FAILED: 0
+
+ EndRetry: 2139 1 (1257907496)
+
+ StartRetry: 2139 2 (1257907617)
+ ; FAILED: 0
+ Status: Expired
+
+=head2 Possible data structure:
+
+ $feedback = {
+ status => val,
+ attempts => [ $attempt1, $attempt2 ... $attemptN ],
+ anything_else => scalar,
+ }
+ ...
+ $attempt = {
+ time => secs from epoch (UTC) for the BEGINNING of the call,
+ duration => secs,
+ failed => code,
+ }
+
+=cut
+
+sub feedback_hash {
+ # parses the done callfile comments from Mediator
+ # return ref to hash
+ my $content = shift or return;
+ my %hash = ();
+ # my @attempts = ();
+ my @lines = split "\n", $content;
+ foreach (shift @lines) {
+ s/^\s*(Set:\s*)?//i; # strip leading whitespace, and possible "Set:"
+ if (/^StartRetry: \d+ (\d+) \((\d+)\)/) {
+ # go parse an attempt;
+ # go record an attempt;
+ }
+ if (/^(Status):\s*(\S+)/i or /^;+\s*(FAILED):\s*(\S*)/i) {
+ $hash{lc $1} = $2;
+ next;
+ }
+
+ /^;+\s*(\S+)\s*[=:]\s*([^;]*)$/ and $hash{lc $1} = $2;
+ }
+ if (exists $hash{failed}) {
+ $hash{failcode} = $hash{failed};
+ # b/c "0" is a common failcode and we want a more binary indicator
+ $hash{failed} = 1;
+ }
+ return \%hash;
+}
+
+sub cleanup {
+ my $self = shift or return;
+ my $files = join(',',@_) or return;
+ my $client = rpc_client();
+ return $client->send_request('cleanup', $files);
+ # TODO: more error checking
+}
+
+sub retrieve {
+ my $self = shift or return;
+ my $client = rpc_client();
+ my $resp = $client->send_request('retrieve');
+ unless ($resp and ref $resp) {
+ $logger->error(
+ __PACKAGE__ . ": Mediator Error: " .
+ ($resp ? 'Bad' : 'No') . " response to retrieve request"
+ );
+ return;
+ }
+
+ # my $count = $resp{match_count}; # how many files we should have
+ # my @rm_list = ();
+ my @files = _files($resp);
+ foreach (@files) {
+ my $content = $resp->{$_}->content;
+ my $filename = $resp->{$_}->filename;
+ unless ($content) {
+ $logger->error(__PACKAGE__ .
+ ": Mediator sent incomplete/unintelligible message for " .
+ "filename " . ($filename || 'UNKNOWN'));
+ next;
+ }
+ my $feedback = feedback_hash($content);
+ my $output = $e->retrieve_action_trigger_event_output(
+ $feedback->{event_output}
+ );
+ if ($content == $output->data) {
+ $logger->error(
+ __PACKAGE__ . ": Mediator sent duplicate file "
+ . $resp->{$_}->filename . " for event_output " .
+ $feedback->{event_output}
+ );
+ } else {
+ $output->data($content);
+ }
+ $e->commit; # defer until after loop? probably not
+ my $clean = $client->send_request('cleanup', $filename);
+ # TODO: deletion by (comma-separated) filenames in chunks
+ # instead of individually?
+ # push @rm_list, $_; $client->send_request('cleanup', join(',',@rm_list));
+ unless ($clean and ref $clean) {
+ $logger->error(
+ __PACKAGE__ . ": Mediator Error: " .
+ ($clean ? 'Bad' : 'No') .
+ " response to cleanup $filename request");
+ next;
+ }
+ unless ($clean->{code}->value == 200 and $clean->{delete_count}) {
+ $logger->error(__PACKAGE__ . ": cleanup $filename returned " . (
+ $resp->{faultcode} ? $resp->{faultcode}->value :
+ $resp->{ code} ? $resp->{ code}->value :
+ " -- UNKNOWN response '$resp'"
+ ) . " with delete_count " .
+ (defined $clean->{delete_count} ? $clean->{delete_count} : 'UNDEF'));
+ }
+ }
+ return @files;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::GeneratePurchaseOrderJEDI;
+use base 'OpenILS::Application::Trigger::Reactor';
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+sub ABOUT {
+ return <<ABOUT;
+
+Generates PO JEDI (JSON EDI) output for subsequent processing and EDI delivery
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ return 1 if $self->run_TT($env);
+ return 0;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::MarkItemLost;
+use base 'OpenILS::Application::Trigger::Reactor';
+use strict; use warnings;
+use Error qw/:try/;
+use Data::Dumper;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+use OpenILS::Application::Cat::AssetCommon;
+$Data::Dumper::Indent = 0;
+
+
+sub ABOUT {
+ return <<ABOUT;
+
+ Marks circulation and corresponding item as lost. This uses
+ the standard mark-lost functionality, creating billings where appropriate.
+
+ Required event parameters:
+ "editor" which points to a user ID. This is the user that effectively
+ performs the action. For example, when the copy status is updated,
+ this user is entered as the last editor of the copy.
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ my $e = new_editor(xact => 1);
+ $e->requestor($e->retrieve_actor_user($$env{params}{editor}));
+
+ my $circ = $$env{target};
+ my $evt = OpenILS::Application::Cat::AssetCommon->set_item_lost($e, $circ->target_copy);
+ if($evt) {
+ $logger->error("trigger: MarkItemLost failed with event ".$evt->{textcode});
+ return 0;
+ }
+
+ $e->commit;
+
+ my $ses = OpenSRF::AppSession->create('open-ils.trigger');
+ $ses->request('open-ils.trigger.event.autocreate', 'lost.auto', $circ, $circ->circ_lib);
+
+ return 1;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::ProcessTemplate;
+use base 'OpenILS::Application::Trigger::Reactor';
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+sub ABOUT {
+ return <<ABOUT;
+
+The ProcessTemplate Reactor Module simply processes the configured template.
+The output, like all processed templates, is stored in the event_output table.
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ return 1 if $self->run_TT($env);
+ return 0;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::SendEmail;
+use strict; use warnings;
+use Error qw/:try/;
+use Data::Dumper;
+use Email::Send;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::Trigger::Reactor;
+use OpenSRF::Utils::Logger qw/:logger/;
+use utf8;
+$Data::Dumper::Indent = 0;
+
+use base 'OpenILS::Application::Trigger::Reactor';
+
+my $log = 'OpenSRF::Utils::Logger';
+
+sub ABOUT {
+ return <<ABOUT;
+
+The SendEmail Reactor Module attempts to email out, via Email::Send,
+whatever is constructed by the template passed in from the Event Definition.
+
+The SMTP server specified by the /opensrf/default/email_notify/smtp_server
+setting is used to send the email, and the value at
+/opensrf/default/email_notify/sender_address is passed into the template as
+the 'default_sender' variable.
+
+No default template is assumed, and all information other than the
+default_sender that the system provides is expected to be gathered by the
+Event Definition through either Environment or Parameter definitions.
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $smtp = $conf->config_value('email_notify', 'smtp_server');
+ $$env{default_sender} = $conf->config_value('email_notify', 'sender_address');
+
+ my $text = $self->run_TT($env);
+ return 0 if (!$text);
+
+ my $sender = Email::Send->new({mailer => 'SMTP'});
+ $sender->mailer_args([Host => $smtp]);
+
+ my $stat;
+ my $err;
+
+ utf8::encode($text); # prevent "Wide character" errors in Email::Send
+
+ try {
+ $stat = $sender->send($text);
+ } catch Error with {
+ $err = $stat = shift;
+ $logger->error("SendEmail Reactor: Email failed with error: $err");
+ };
+
+ if( !$err and $stat and $stat->type eq 'success' ) {
+ $logger->info("SendEmail Reactor: successfully sent email");
+ return 1;
+ } else {
+ $logger->warn("SendEmail Reactor: unable to send email: ".Dumper($stat));
+ $text =~ s/\n//og;
+ $logger->warn("SendEmail Reactor: failed email template: $text");
+ return 0;
+ }
+
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::SendFile;
+use OpenILS::Application::Trigger::Reactor;
+use base 'OpenILS::Application::Trigger::Reactor';
+
+# use OpenSRF::Utils::SettingsClient;
+use OpenILS::Utils::RemoteAccount;
+
+use strict;
+use warnings;
+
+sub ABOUT {
+ return <<ABOUT;
+
+The SendFile Reactor Module attempts to transfer a file to a remote server via
+SCP, FTP or SFTP.
+
+No default template is assumed, and all information is expected to be gathered
+by the Event Definition through event parameters:
+ ~ remote_host (required)
+ ~ remote_user
+ ~ remote_password
+ ~ remote_account
+ ~ remote_filename
+ ~ ssh_privatekey
+ ~ ssh_publickey
+ ~ type (FTP, SFTP or SCP -- default FTP)
+ ~ port
+ ~ debug
+
+The processed template is passed as "content" with the other params to
+OpenILS::Utils::RemoteAccount. See perldoc OpenILS::Utils::RemoteAccount for more.
+
+TODO: allow config.remote_account.id to specify options.
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ my $params = $env->{params};
+
+ $params->{content} = $self->run_TT($env) or return;
+ my $connection = OpenILS::Utils::RemoteAccount->new(%$params) or return;
+ return $connection->put;
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Trigger::Reactor::StaticEmail;
+use strict; use warnings;
+use Error qw/:try/;
+use Data::Dumper;
+use Email::Send;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::Trigger::Reactor;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+use base 'OpenILS::Application::Trigger::Reactor';
+
+my $log = 'OpenSRF::Utils::Logger';
+
+my $default_template = <<TT;
+To: [%- params.recipient %]
+From: [%- params.sender %]
+Subject: [%- params.subject %]
+
+[% params.body %]
+TT
+
+sub ABOUT {
+ return <<ABOUT;
+
+The StagicEmail Reactor Module sends an email to the address specified by the
+"recipient" parameter. This is the only required parameter (in fact the
+template is not even required), though sender, subject and body parameters are
+also accepted and used by the default template.
+
+The default template looks like:
+-------
+$default_template
+-------
+
+ABOUT
+}
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $smtp = $conf->config_value('email_notify', 'smtp_server');
+ $$env{params}{sender} ||= $conf->config_value('email_notify', 'sender_address');
+ $$env{params}{subject} ||= 'Test subject -- StaticEmail Reactor';
+ $$env{params}{body} ||= 'Test body -- StaticEmail Reactor';
+ $$env{template} ||= $default_template;
+
+ $$env{params}{recipient} or return 0;
+
+ my $text = $self->run_TT($env);
+ return 0 if (!$text);
+
+ $logger->info("StaticEmail Reactor: sending email to ".
+ $$env{params}{recipient}." via SMTP server $smtp");
+
+ my $sender = Email::Send->new({mailer => 'SMTP'});
+ $sender->mailer_args([Host => $smtp]);
+
+
+ my $stat;
+ my $err;
+
+ try {
+ $stat = $sender->send($text);
+ } catch Error with {
+ $err = $stat = shift;
+ $logger->error("StaticEmail Reactor: Email failed with error: $err");
+ };
+
+ if( !$err and $stat and $stat->type eq 'success' ) {
+ $logger->info("StaticEmail Reactor: successfully sent email");
+ return 1;
+ } else {
+ $logger->warn("StaticEmail Reactor: unable to send email: ".Dumper($stat));
+ return 0;
+ }
+
+}
+
+1;
+
--- /dev/null
+package OpenILS::Application::Trigger::Validator;
+use strict; use warnings;
+use DateTime;
+use DateTime::Format::ISO8601;
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Const qw/:const/;
+sub fourty_two { return 42 }
+sub NOOP_True { return 1 }
+sub NOOP_False { return 0 }
+
+sub CircIsOpen {
+ my $self = shift;
+ my $env = shift;
+
+ return 0 if (defined($env->{target}->checkin_time));
+
+ if ($env->{params}->{min_target_age}) {
+ $env->{params}->{target_age_field} = 'xact_start';
+ return 0 if (!$self->MinPassiveTargetAge($env));
+ }
+
+ return 1;
+}
+
+sub MinPassiveTargetAge {
+ my $self = shift;
+ my $env = shift;
+ my $target = $env->{target};
+ my $delay_field = $env->{params}->{target_age_field} || $env->{event}->event_def->delay_field;
+
+ unless($env->{params}->{min_target_age}) {
+ $logger->warn("'min_target_age' parameter required for MinPassiveTargetAge validator");
+ return 0; # no-op false
+ }
+
+ unless($delay_field) {
+ $logger->warn("'target_age_field' parameter or delay_field required for MinPassiveTargetAge validator");
+ return 0; # no-op false
+ }
+
+ my $delay_field_ts = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($target->$delay_field()));
+
+ # to get the minimum time that the target must have aged to, add the min age to the delay field
+ $delay_field_ts->add( seconds => interval_to_seconds( $env->{params}->{min_target_age} ) );
+
+ return 1 if $delay_field_ts <= DateTime->now;
+ return 0;
+}
+
+sub CircIsOverdue {
+ my $self = shift;
+ my $env = shift;
+ my $circ = $env->{target};
+
+ return 0 if $circ->checkin_time;
+ return 0 if $circ->stop_fines and not $circ->stop_fines =~ /MAXFINES|LONGOVERDUE/;
+
+ if ($env->{params}->{min_target_age}) {
+ $env->{params}->{target_age_field} = 'xact_start';
+ return 0 if (!$self->MinPassiveTargetAge($env));
+ }
+
+ my $due_date = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($circ->due_date));
+ return 0 if $due_date > DateTime->now;
+
+ return 1;
+}
+
+sub HoldIsAvailable {
+ my $self = shift;
+ my $env = shift;
+
+ my $hold = $env->{target};
+
+ return 1 if
+ !$hold->cancel_time and
+ $hold->capture_time and
+ $hold->current_copy and
+ $hold->current_copy->status == OILS_COPY_STATUS_ON_HOLDS_SHELF;
+
+ return 0;
+}
+
+sub HoldIsCancelled {
+ my $self = shift;
+ my $env = shift;
+
+ my $hold = $env->{target};
+
+ return ($hold->cancel_time) ? 1 : 0;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Validator::Acq;
+use strict; use warnings;
+# use OpenSRF::Utils::Logger qw/:logger/;
+
+sub get_lineitem_from_req {
+ my($self, $env) = @_;
+ my $req = $env->{target};
+ return (ref $env->{target}->lineitem) ?
+ $env->{target}->lineitem :
+ $self->editor->retrieve_acq_lineitem($$env->{target}->lineitem);
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Validator::Acq::PurchaseOrderEDIRequired;
+use strict; use warnings;
+# use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Utils::CStoreEditor qw/ new_editor /;
+use OpenILS::Application::AppUtils;
+my $U = 'OpenILS::Application::AppUtils';
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ my $po = $env->{target};
+
+ my $provider =
+ ref($po->provider) ?
+ $po->provider :
+ new_editor->retrieve_acq_provider($po->provider);
+
+ return 1 if
+ ($po->state eq 'on-order' or
+ $po->state eq 'retry' ) and
+ $provider and
+ $provider->edi_default and
+ $U->is_true($provider->active);
+
+ return 0;
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Validator::Acq::UserRequestCancelled;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Application::Trigger::Validator::Acq;
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ return OpenILS::Application::Trigger::Validator::Acq::get_lineitem_from_req($self, $env)->state eq 'cancelled';
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Validator::Acq::UserRequestOrdered;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Application::Trigger::Validator::Acq;
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ return OpenILS::Application::Trigger::Validator::Acq::get_lineitem_from_req($self, $env)->state eq 'on-order';
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Trigger::Validator::Acq::UserRequestReceived;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/:logger/;
+use OpenILS::Application::Trigger::Validator::Acq;
+
+sub handler {
+ my $self = shift;
+ my $env = shift;
+ return OpenILS::Application::Trigger::Validator::Acq::get_lineitem_from_req($self, $env)->state eq 'received';
+}
+
+1;
--- /dev/null
+package OpenILS::Application::Vandelay;
+use strict; use warnings;
+use OpenILS::Application;
+use base qw/OpenILS::Application/;
+use Unicode::Normalize;
+use OpenSRF::EX qw/:try/;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Cache;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use MARC::Batch;
+use MARC::Record;
+use MARC::File::XML;
+use OpenILS::Utils::Fieldmapper;
+use Time::HiRes qw(time);
+use OpenSRF::Utils::Logger qw/$logger/;
+use MIME::Base64;
+use OpenILS::Const qw/:const/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Cat::BibCommon;
+use OpenILS::Application::Cat::AuthCommon;
+use OpenILS::Application::Cat::AssetCommon;
+my $U = 'OpenILS::Application::AppUtils';
+
+# A list of LDR/06 values from http://loc.gov/marc
+my %record_types = (
+ a => 'bib',
+ c => 'bib',
+ d => 'bib',
+ e => 'bib',
+ f => 'bib',
+ g => 'bib',
+ i => 'bib',
+ j => 'bib',
+ k => 'bib',
+ m => 'bib',
+ o => 'bib',
+ p => 'bib',
+ r => 'bib',
+ t => 'bib',
+ u => 'holdings',
+ v => 'holdings',
+ x => 'holdings',
+ y => 'holdings',
+ z => 'auth',
+ ' ' => 'bib',
+);
+
+sub initialize {}
+sub child_init {}
+
+# --------------------------------------------------------------------------------
+# Biblio ingest
+
+sub create_bib_queue {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $name = shift;
+ my $owner = shift;
+ my $type = shift;
+ my $import_def = shift;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_BIB_IMPORT_QUEUE');
+ $owner ||= $e->requestor->id;
+
+ if ($e->search_vandelay_bib_queue( {name => $name, owner => $owner, queue_type => $type})->[0]) {
+ $e->rollback;
+ return OpenILS::Event->new('BIB_QUEUE_EXISTS')
+ }
+
+ my $queue = new Fieldmapper::vandelay::bib_queue();
+ $queue->name( $name );
+ $queue->owner( $owner );
+ $queue->queue_type( $type ) if ($type);
+ $queue->item_attr_def( $import_def ) if ($import_def);
+
+ my $new_q = $e->create_vandelay_bib_queue( $queue );
+ return $e->die_event unless ($new_q);
+ $e->commit;
+
+ return $new_q;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.create",
+ method => "create_bib_queue",
+ api_level => 1,
+ argc => 4,
+);
+
+
+sub create_auth_queue {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $name = shift;
+ my $owner = shift;
+ my $type = shift;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE');
+ $owner ||= $e->requestor->id;
+
+ if ($e->search_vandelay_bib_queue({name => $name, owner => $owner, queue_type => $type})->[0]) {
+ $e->rollback;
+ return OpenILS::Event->new('AUTH_QUEUE_EXISTS')
+ }
+
+ my $queue = new Fieldmapper::vandelay::authority_queue();
+ $queue->name( $name );
+ $queue->owner( $owner );
+ $queue->queue_type( $type ) if ($type);
+
+ my $new_q = $e->create_vandelay_authority_queue( $queue );
+ $e->die_event unless ($new_q);
+ $e->commit;
+
+ return $new_q;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.authority_queue.create",
+ method => "create_auth_queue",
+ api_level => 1,
+ argc => 3,
+);
+
+sub add_record_to_bib_queue {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $queue = shift;
+ my $marc = shift;
+ my $purpose = shift;
+ my $bib_source = shift;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+
+ $queue = $e->retrieve_vandelay_bib_queue($queue);
+
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless
+ ($e->allowed('CREATE_BIB_IMPORT_QUEUE', undef, $queue) ||
+ $e->allowed('CREATE_BIB_IMPORT_QUEUE'));
+
+ my $new_rec = _add_bib_rec($e, $marc, $queue->id, $purpose, $bib_source);
+
+ return $e->die_event unless ($new_rec);
+ $e->commit;
+ return $new_rec;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.queued_bib_record.create",
+ method => "add_record_to_bib_queue",
+ api_level => 1,
+ argc => 3,
+);
+
+sub _add_bib_rec {
+ my $e = shift;
+ my $marc = shift;
+ my $queue = shift;
+ my $purpose = shift;
+ my $bib_source = shift;
+
+ my $rec = new Fieldmapper::vandelay::queued_bib_record();
+ $rec->marc( $marc );
+ $rec->queue( $queue );
+ $rec->purpose( $purpose ) if ($purpose);
+ $rec->bib_source($bib_source);
+
+ return $e->create_vandelay_queued_bib_record( $rec );
+}
+
+sub add_record_to_authority_queue {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $queue = shift;
+ my $marc = shift;
+ my $purpose = shift;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+
+ $queue = $e->retrieve_vandelay_authority_queue($queue);
+
+ return $e->die_event unless $e->checkauth;
+ return $e->die_event unless
+ ($e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE', undef, $queue) ||
+ $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE'));
+
+ my $new_rec = _add_auth_rec($e, $marc, $queue->id, $purpose);
+
+ return $e->die_event unless ($new_rec);
+ $e->commit;
+ return $new_rec;
+}
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.queued_authority_record.create",
+ method => "add_record_to_authority_queue",
+ api_level => 1,
+ argc => 3,
+);
+
+sub _add_auth_rec {
+ my $e = shift;
+ my $marc = shift;
+ my $queue = shift;
+ my $purpose = shift;
+
+ my $rec = new Fieldmapper::vandelay::queued_authority_record();
+ $rec->marc( $marc );
+ $rec->queue( $queue );
+ $rec->purpose( $purpose ) if ($purpose);
+
+ return $e->create_vandelay_queued_authority_record( $rec );
+}
+
+sub process_spool {
+ my $self = shift;
+ my $client = shift;
+ my $auth = shift;
+ my $fingerprint = shift || '';
+ my $queue_id = shift;
+ my $purpose = shift;
+ my $filename = shift;
+ my $bib_source = shift;
+
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+
+ my $queue;
+ my $type = $self->{record_type};
+
+ if($type eq 'bib') {
+ $queue = $e->retrieve_vandelay_bib_queue($queue_id) or return $e->die_event;
+ } else {
+ $queue = $e->retrieve_vandelay_authority_queue($queue_id) or return $e->die_event;
+ }
+
+ my $evt = check_queue_perms($e, $type, $queue);
+ return $evt if ($evt);
+
+ my $cache = new OpenSRF::Utils::Cache();
+
+ if($fingerprint) {
+ my $data = $cache->get_cache('vandelay_import_spool_' . $fingerprint);
+ $purpose = $data->{purpose};
+ $filename = $data->{path};
+ $bib_source = $data->{bib_source};
+ }
+
+ unless(-r $filename) {
+ $logger->error("unable to read MARC file $filename");
+ return -1; # make this an event XXX
+ }
+
+ $logger->info("vandelay spooling $fingerprint purpose=$purpose file=$filename");
+
+ my $marctype = 'USMARC';
+
+ open F, $filename;
+ $marctype = 'XML' if (getc(F) =~ /^\D/o);
+ close F;
+
+ my $batch = new MARC::Batch ($marctype, $filename);
+ $batch->strict_off;
+
+ my $response_scale = 10;
+ my $count = 0;
+ my $r = -1;
+ while (try { $r = $batch->next } otherwise { $r = -1 }) {
+ if ($r == -1) {
+ $logger->warn("Processing of record $count in set $filename failed. Skipping this record");
+ $count++;
+ }
+
+ $logger->info("processing record $count");
+
+ try {
+ (my $xml = $r->as_xml_record()) =~ s/\n//sog;
+ $xml =~ s/^<\?xml.+\?\s*>//go;
+ $xml =~ s/>\s+</></go;
+ $xml =~ s/\p{Cc}//go;
+ $xml = $U->entityize($xml);
+ $xml =~ s/[\x00-\x1f]//go;
+
+ my $qrec;
+ # Check the leader to ensure we've got something resembling the expected
+ # Allow spaces to give records the benefit of the doubt
+ my $ldr_type = substr($r->leader(), 6, 1);
+ if ($type eq 'bib' && ($record_types{$ldr_type}) eq 'bib' || $ldr_type eq ' ') {
+ $qrec = _add_bib_rec( $e, $xml, $queue_id, $purpose, $bib_source ) or return $e->die_event;
+ } elsif ($type eq 'auth' && ($record_types{$ldr_type}) eq 'auth' || $ldr_type eq ' ') {
+ $qrec = _add_auth_rec( $e, $xml, $queue_id, $purpose ) or return $e->die_event;
+ } else {
+ # I don't know how to handle this type; rock on
+ $logger->error("In process_spool(), type was $type and leader type was $ldr_type ; not currently supported");
+ next;
+ }
+
+ if($self->api_name =~ /stream_results/ and $qrec) {
+ $client->respond($qrec->id)
+ } else {
+ $client->respond($count) if (++$count % $response_scale) == 0;
+ $response_scale *= 10 if ($count == ($response_scale * 10));
+ }
+ } catch Error with {
+ my $error = shift;
+ $logger->warn("Encountered a bad record at Vandelay ingest: ".$error);
+ }
+ }
+
+ $e->commit;
+ unlink($filename);
+ $cache->delete_cache('vandelay_import_spool_' . $fingerprint) if $fingerprint;
+ return $count;
+}
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib.process_spool",
+ method => "process_spool",
+ api_level => 1,
+ argc => 3,
+ max_chunk_size => 0,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth.process_spool",
+ method => "process_spool",
+ api_level => 1,
+ argc => 3,
+ max_chunk_size => 0,
+ record_type => 'auth'
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib.process_spool.stream_results",
+ method => "process_spool",
+ api_level => 1,
+ argc => 3,
+ stream => 1,
+ max_chunk_size => 0,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth.process_spool.stream_results",
+ method => "process_spool",
+ api_level => 1,
+ argc => 3,
+ stream => 1,
+ max_chunk_size => 0,
+ record_type => 'auth'
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.records.retrieve",
+ method => 'retrieve_queued_records',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_queue.records.retrieve",
+ method => 'retrieve_queued_records',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'auth'
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.records.matches.retrieve",
+ method => 'retrieve_queued_records',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'bib',
+ signature => {
+ desc => q/Only retrieve queued bib records that have matches against existing records/
+ }
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_queue.records.matches.retrieve",
+ method => 'retrieve_queued_records',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'auth',
+ signature => {
+ desc => q/Only retrieve queued authority records that have matches against existing records/
+ }
+
+);
+
+sub retrieve_queued_records {
+ my($self, $conn, $auth, $queue_id, $options) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ $options ||= {};
+ my $limit = $$options{limit} || 20;
+ my $offset = $$options{offset} || 0;
+
+ my $type = $self->{record_type};
+ my $queue;
+ if($type eq 'bib') {
+ $queue = $e->retrieve_vandelay_bib_queue($queue_id) or return $e->die_event;
+ } else {
+ $queue = $e->retrieve_vandelay_authority_queue($queue_id) or return $e->die_event;
+ }
+ my $evt = check_queue_perms($e, $type, $queue);
+ return $evt if ($evt);
+
+ my $class = ($type eq 'bib') ? 'vqbr' : 'vqar';
+ my $search = ($type eq 'bib') ?
+ 'search_vandelay_queued_bib_record' : 'search_vandelay_queued_authority_record';
+ my $retrieve = ($type eq 'bib') ?
+ 'retrieve_vandelay_queued_bib_record' : 'retrieve_vandelay_queued_authority_record';
+
+ my $filter = ($$options{non_imported}) ? {import_time => undef} : {};
+
+ my $record_ids;
+ if($self->api_name =~ /matches/) {
+ # fetch only matched records
+ $record_ids = queued_records_with_matches($e, $type, $queue_id, $limit, $offset, $filter);
+ } else {
+ # fetch all queue records
+ $record_ids = $e->$search([
+ {queue => $queue_id, %$filter},
+ {order_by => {$class => 'id'}, limit => $limit, offset => $offset}
+ ],
+ {idlist => 1}
+ );
+ }
+
+
+ for my $rec_id (@$record_ids) {
+ my $params = {
+ flesh => 1,
+ flesh_fields => {$class => ['attributes', 'matches']},
+ };
+ my $rec = $e->$retrieve([$rec_id, $params]);
+ $rec->clear_marc if $$options{clear_marc};
+ $conn->respond($rec);
+ }
+ $e->rollback;
+ return undef;
+}
+
+sub check_queue_perms {
+ my($e, $type, $queue) = @_;
+ if ($type eq 'bib') {
+ return $e->die_event unless
+ ($e->allowed('CREATE_BIB_IMPORT_QUEUE', undef, $queue) ||
+ $e->allowed('CREATE_BIB_IMPORT_QUEUE'));
+ } else {
+ return $e->die_event unless
+ ($e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE', undef, $queue) ||
+ $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE'));
+ }
+
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_record.list.import",
+ method => 'import_record_list',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'bib'
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_record.list.import",
+ method => 'import_record_list',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'auth'
+);
+
+sub import_record_list {
+ my($self, $conn, $auth, $rec_ids, $args) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ $args ||= {};
+ my $err = import_record_list_impl($self, $conn, $rec_ids, $e->requestor, $args);
+ $e->rollback;
+ return $err if $err;
+ return {complete => 1};
+}
+
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.import",
+ method => 'import_queue',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ max_chunk_size => 0,
+ record_type => 'bib'
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_queue.import",
+ method => 'import_queue',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ max_chunk_size => 0,
+ record_type => 'auth'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.nomatch.import",
+ method => 'import_queue',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ signature => {
+ desc => q/Only import records that have no collisions/
+ },
+ max_chunk_size => 0,
+ record_type => 'bib'
+);
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_queue.nomatch.import",
+ method => 'import_queue',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ signature => {
+ desc => q/Only import records that have no collisions/
+ },
+ max_chunk_size => 0,
+ record_type => 'auth'
+);
+sub import_queue {
+ my($self, $conn, $auth, $q_id, $options) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ $options ||= {};
+ my $type = $self->{record_type};
+ my $class = ($type eq 'bib') ? 'vqbr' : 'vqar';
+
+ my $query = {queue => $q_id, import_time => undef};
+
+ if($self->api_name =~ /nomatch/) {
+ my $matched_recs = queued_records_with_matches($e, $type, $q_id, undef, undef, {import_time => undef});
+ $query->{id} = {'not in' => $matched_recs} if @$matched_recs;
+ }
+
+ my $search = ($type eq 'bib') ?
+ 'search_vandelay_queued_bib_record' : 'search_vandelay_queued_authority_record';
+ my $rec_ids = $e->$search($query, {idlist => 1});
+ my $err = import_record_list_impl($self, $conn, $rec_ids, $e->requestor, $options);
+ try {$e->rollback} otherwise {}; # only using this to make the read authoritative -- don't die from it
+ return $err if $err;
+ return {complete => 1};
+}
+
+# returns a list of queued record IDs for a given queue that
+# have at least one entry in the match table
+sub queued_records_with_matches {
+ my($e, $type, $q_id, $limit, $offset, $filter) = @_;
+
+ my $match_class = 'vbm';
+ my $rec_class = 'vqbr';
+ if($type eq 'auth') {
+ $match_class = 'vam';
+ $rec_class = 'vqar';
+ }
+
+ $filter ||= {};
+ $filter->{queue} = $q_id;
+
+ my $query = {
+ distinct => 1,
+ select => {$match_class => ['queued_record']},
+ from => {
+ $match_class => {
+ $rec_class => {
+ field => 'id',
+ fkey => 'queued_record',
+ filter => $filter,
+ }
+ }
+ }
+ };
+
+ if($limit or defined $offset) {
+ $limit ||= 20;
+ $offset ||= 0;
+ $query->{limit} = $limit;
+ $query->{offset} = $offset;
+ }
+
+ my $data = $e->json_query($query);
+ return [ map {$_->{queued_record}} @$data ];
+}
+
+sub import_record_list_impl {
+ my($self, $conn, $rec_ids, $requestor, $args) = @_;
+
+ my $overlay_map = $args->{overlay_map} || {};
+ my $type = $self->{record_type};
+ my $total = @$rec_ids;
+ my $count = 0;
+ my %queues;
+
+ my $step = 1;
+
+ my $auto_overlay_exact = $$args{auto_overlay_exact};
+ my $auto_overlay_1match = $$args{auto_overlay_1match};
+ my $merge_profile = $$args{merge_profile};
+ my $bib_source = $$args{bib_source};
+ my $report_all = $$args{report_all};
+
+ my $overlay_func = 'vandelay.overlay_bib_record';
+ my $auto_overlay_func = 'vandelay.auto_overlay_bib_record';
+ my $retrieve_func = 'retrieve_vandelay_queued_bib_record';
+ my $update_func = 'update_vandelay_queued_bib_record';
+ my $search_func = 'search_vandelay_queued_bib_record';
+ my $retrieve_queue_func = 'retrieve_vandelay_bib_queue';
+ my $update_queue_func = 'update_vandelay_bib_queue';
+ my $rec_class = 'vqbr';
+
+ my %bib_sources;
+ my $editor = new_editor();
+ my $sources = $editor->search_config_bib_source({id => {'!=' => undef}});
+
+ foreach my $src (@$sources) {
+ $bib_sources{$src->id} = $src->source;
+ }
+
+ if($type eq 'auth') {
+ $overlay_func =~ s/bib/auth/o;
+ $auto_overlay_func = s/bib/auth/o;
+ $retrieve_func =~ s/bib/authority/o;
+ $retrieve_queue_func =~ s/bib/authority/o;
+ $update_queue_func =~ s/bib/authority/o;
+ $update_func =~ s/bib/authority/o;
+ $search_func =~ s/bib/authority/o;
+ $rec_class = 'vqar';
+ }
+
+ my @success_rec_ids;
+ for my $rec_id (@$rec_ids) {
+
+ my $overlay_target = $overlay_map->{$rec_id};
+
+ my $error = 0;
+ my $e = new_editor(xact => 1);
+ $e->requestor($requestor);
+
+ my $rec = $e->$retrieve_func([
+ $rec_id,
+ { flesh => 1,
+ flesh_fields => { $rec_class => ['matches']},
+ }
+ ]);
+
+ unless($rec) {
+ $conn->respond({total => $total, progress => ++$count, imported => $rec_id, err_event => $e->event});
+ $e->rollback;
+ next;
+ }
+
+ if($rec->import_time) {
+ $e->rollback;
+ next;
+ }
+
+ $queues{$rec->queue} = 1;
+
+ my $record;
+ my $imported = 0;
+
+ if(defined $overlay_target) {
+ # Caller chose an explicit overlay target
+
+ my $res = $e->json_query(
+ {
+ from => [
+ $overlay_func,
+ $rec->id,
+ $overlay_target,
+ $merge_profile
+ ]
+ }
+ );
+
+ if($res and ($res = $res->[0])) {
+
+ if($res->{$overlay_func} eq 't') {
+ $logger->info("vl: $type direct overlay succeeded for queued rec " .
+ $rec->id . " and overlay target $overlay_target");
+ $imported = 1;
+ }
+
+ } else {
+ $error = 1;
+ $logger->error("vl: Error attempting overlay with func=$overlay_func, profile=$merge_profile, record=$rec_id");
+ }
+
+ } else {
+
+ if($auto_overlay_1match) {
+ # caller says to overlay if there is exactly 1 match
+
+ my %match_recs = map { $_->eg_record => 1 } @{$rec->matches};
+
+ if( scalar(keys %match_recs) == 1) { # all matches point to the same record
+
+ my $res = $e->json_query(
+ {
+ from => [
+ $overlay_func,
+ $rec->id,
+ $rec->matches->[0]->eg_record,
+ $merge_profile
+ ]
+ }
+ );
+
+ if($res and ($res = $res->[0])) {
+
+ if($res->{$overlay_func} eq 't') {
+ $logger->info("vl: $type overlay-1match succeeded for queued rec " . $rec->id);
+ $imported = 1;
+ }
+
+ } else {
+ $error = 1;
+ $logger->error("vl: Error attempting overlay with func=$overlay_func, profile=$merge_profile, record=$rec_id");
+ }
+ }
+ }
+
+ if(!$imported and !$error and $auto_overlay_exact and scalar(@{$rec->matches}) == 1 ) {
+
+ # caller says to overlay if there is an /exact/ match
+
+ my $res = $e->json_query(
+ {
+ from => [
+ $auto_overlay_func,
+ $rec->id,
+ $merge_profile
+ ]
+ }
+ );
+
+ if($res and ($res = $res->[0])) {
+
+ if($res->{$auto_overlay_func} eq 't') {
+ $logger->info("vl: $type auto-overlay succeeded for queued rec " . $rec->id);
+ $imported = 1;
+ }
+
+ } else {
+ $error = 1;
+ $logger->error("vl: Error attempting overlay with func=$auto_overlay_func, profile=$merge_profile, record=$rec_id");
+ }
+ }
+
+ if(!$imported and !$error) {
+
+ # No overlay / merge occurred. Do a traditional record import by creating a new record
+
+ if($type eq 'bib') {
+ $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import($e, $rec->marc, $bib_sources{$rec->bib_source});
+ } else {
+
+ $record = OpenILS::Application::Cat::AuthCommon->import_authority_record($e, $rec->marc); #$source);
+ }
+
+ if($U->event_code($record)) {
+
+ $e->event($record);
+ $e->rollback;
+
+ } else {
+
+ $logger->info("vl: successfully imported new $type record");
+ $rec->imported_as($record->id);
+ $rec->import_time('now');
+
+ $imported = 1 if $e->$update_func($rec);
+ }
+ }
+ }
+
+ if($imported) {
+ push @success_rec_ids, $rec_id;
+ $e->commit;
+ } else {
+ # Send an update whenever there's an error
+ $conn->respond({total => $total, progress => ++$count, imported => $rec_id, err_event => $e->event});
+ }
+
+ if($report_all or (++$count % $step) == 0) {
+ $conn->respond({total => $total, progress => $count, imported => $rec_id});
+ # report often at first, climb quickly, then hold steady
+ $step *= 2 unless $step == 256;
+ }
+ }
+
+ # see if we need to mark any queues as complete
+ for my $q_id (keys %queues) {
+
+ my $e = new_editor(xact => 1);
+ my $remaining = $e->$search_func(
+ [{queue => $q_id, import_time => undef}, {limit =>1}], {idlist => 1});
+
+ unless(@$remaining) {
+ my $queue = $e->$retrieve_queue_func($q_id);
+
+ unless($U->is_true($queue->complete)) {
+ $queue->complete('t');
+ $e->$update_queue_func($queue) or return $e->die_event;
+ $e->commit;
+ next;
+ }
+ }
+ $e->rollback;
+ }
+
+ import_record_asset_list_impl($conn, \@success_rec_ids, $requestor);
+
+ $conn->respond({total => $total, progress => $count});
+ return undef;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.owner.retrieve",
+ method => 'owner_queue_retrieve',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.authority_queue.owner.retrieve",
+ method => 'owner_queue_retrieve',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'auth'
+);
+
+sub owner_queue_retrieve {
+ my($self, $conn, $auth, $owner_id, $filters) = @_;
+ my $e = new_editor(authtoken => $auth, xact => 1);
+ return $e->die_event unless $e->checkauth;
+ $owner_id = $e->requestor->id; # XXX add support for viewing other's queues?
+ my $queues;
+ $filters ||= {};
+ my $search = {owner => $owner_id};
+ $search->{$_} = $filters->{$_} for keys %$filters;
+
+ if($self->{record_type} eq 'bib') {
+ $queues = $e->search_vandelay_bib_queue(
+ [$search, {order_by => {vbq => 'lower(name)'}}]);
+ } else {
+ $queues = $e->search_vandelay_authority_queue(
+ [$search, {order_by => {vaq => 'lower(name)'}}]);
+ }
+ $conn->respond($_) for @$queues;
+ $e->rollback;
+ return undef;
+}
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.delete",
+ method => "delete_queue",
+ api_level => 1,
+ argc => 2,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_queue.delete",
+ method => "delete_queue",
+ api_level => 1,
+ argc => 2,
+ record_type => 'auth'
+);
+
+sub delete_queue {
+ my($self, $conn, $auth, $q_id) = @_;
+ my $e = new_editor(xact => 1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ if($self->{record_type} eq 'bib') {
+ return $e->die_event unless $e->allowed('CREATE_BIB_IMPORT_QUEUE');
+ my $queue = $e->retrieve_vandelay_bib_queue($q_id)
+ or return $e->die_event;
+ $e->delete_vandelay_bib_queue($queue)
+ or return $e->die_event;
+ } else {
+ return $e->die_event unless $e->allowed('CREATE_AUTHORITY_IMPORT_QUEUE');
+ my $queue = $e->retrieve_vandelay_authority_queue($q_id)
+ or return $e->die_event;
+ $e->delete_vandelay_authority_queue($queue)
+ or return $e->die_event;
+ }
+ $e->commit;
+ return 1;
+}
+
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.queued_bib_record.html",
+ method => 'queued_record_html',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.queued_authority_record.html",
+ method => 'queued_record_html',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'auth'
+);
+
+sub queued_record_html {
+ my($self, $conn, $auth, $rec_id) = @_;
+ my $e = new_editor(xact=>1,authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+ my $rec;
+ if($self->{record_type} eq 'bib') {
+ $rec = $e->retrieve_vandelay_queued_bib_record($rec_id)
+ or return $e->die_event;
+ } else {
+ $rec = $e->retrieve_vandelay_queued_authority_record($rec_id)
+ or return $e->die_event;
+ }
+
+ $e->rollback;
+ return $U->simplereq(
+ 'open-ils.search',
+ 'open-ils.search.biblio.record.html', undef, 1, $rec->marc);
+}
+
+
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.bib_queue.summary.retrieve",
+ method => 'retrieve_queue_summary',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'bib'
+);
+__PACKAGE__->register_method(
+ api_name => "open-ils.vandelay.auth_queue.summary.retrieve",
+ method => 'retrieve_queue_summary',
+ api_level => 1,
+ argc => 2,
+ stream => 1,
+ record_type => 'auth'
+);
+
+sub retrieve_queue_summary {
+ my($self, $conn, $auth, $queue_id) = @_;
+ my $e = new_editor(xact=>1, authtoken => $auth);
+ return $e->die_event unless $e->checkauth;
+
+ my $queue;
+ my $type = $self->{record_type};
+ if($type eq 'bib') {
+ $queue = $e->retrieve_vandelay_bib_queue($queue_id)
+ or return $e->die_event;
+ } else {
+ $queue = $e->retrieve_vandelay_authority_queue($queue_id)
+ or return $e->die_event;
+ }
+
+ my $evt = check_queue_perms($e, $type, $queue);
+ return $evt if $evt;
+
+ my $search = 'search_vandelay_queued_bib_record';
+ $search =~ s/bib/authority/ if $type ne 'bib';
+
+ return {
+ queue => $queue,
+ total => scalar(@{$e->$search({queue => $queue_id}, {idlist=>1})}),
+ imported => scalar(@{$e->$search({queue => $queue_id, import_time => {'!=' => undef}}, {idlist=>1})}),
+ };
+}
+
+# --------------------------------------------------------------------------------
+# Given a list of queued record IDs, imports all items attached to those records
+# --------------------------------------------------------------------------------
+sub import_record_asset_list_impl {
+ my($conn, $rec_ids, $requestor) = @_;
+
+ my $total = @$rec_ids;
+ my $try_count = 0;
+ my $in_count = 0;
+ my $roe = new_editor(xact=> 1, requestor => $requestor);
+
+ for my $rec_id (@$rec_ids) {
+ my $rec = $roe->retrieve_vandelay_queued_bib_record($rec_id);
+ next unless $rec and $rec->import_time;
+ my $item_ids = $roe->search_vandelay_import_item({record => $rec->id}, {idlist=>1});
+
+ for my $item_id (@$item_ids) {
+ my $e = new_editor(requestor => $requestor, xact => 1);
+ my $item = $e->retrieve_vandelay_import_item($item_id);
+ $try_count++;
+
+ # --------------------------------------------------------------------------------
+ # Find or create the volume
+ # --------------------------------------------------------------------------------
+ my ($vol, $evt) =
+ OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
+ $e, $item->call_number, $rec->imported_as, $item->owning_lib);
+
+ if($evt) {
+ respond_with_status($conn, $total, $try_count, $in_count, $evt);
+ next;
+ }
+
+ # --------------------------------------------------------------------------------
+ # Create the new copy
+ # --------------------------------------------------------------------------------
+ my $copy = Fieldmapper::asset::copy->new;
+ $copy->loan_duration(2);
+ $copy->fine_level(2);
+ $copy->barcode($item->barcode);
+ $copy->location($item->location);
+ $copy->circ_lib($item->circ_lib || $item->owning_lib);
+ $copy->status($item->status || OILS_COPY_STATUS_IN_PROCESS);
+ $copy->circulate($item->circulate);
+ $copy->deposit($item->deposit);
+ $copy->deposit_amount($item->deposit_amount);
+ $copy->ref($item->ref);
+ $copy->holdable($item->holdable);
+ $copy->price($item->price);
+ $copy->circ_as_type($item->circ_as_type);
+ $copy->alert_message($item->alert_message);
+ $copy->opac_visible($item->opac_visible);
+ $copy->circ_modifier($item->circ_modifier);
+
+ # --------------------------------------------------------------------------------
+ # see if a valid circ_modifier was provided
+ # --------------------------------------------------------------------------------
+ #if($copy->circ_modifier and not $e->retrieve_config_circ_modifier($item->circ_modifier)) {
+ if($copy->circ_modifier and not $e->search_config_circ_modifier({code=>$item->circ_modifier})->[0]) {
+ respond_with_status($conn, $total, $try_count, $in_count, $e->die_event);
+ next;
+ }
+
+ if($evt = OpenILS::Application::Cat::AssetCommon->create_copy($e, $vol, $copy)) {
+ try { $e->rollback } otherwise {}; # sometimes calls die_event, sometimes not
+ respond_with_status($conn, $total, $try_count, $in_count, $evt);
+ next;
+ }
+
+ # --------------------------------------------------------------------------------
+ # create copy notes
+ # --------------------------------------------------------------------------------
+ $evt = OpenILS::Application::Cat::AssetCommon->create_copy_note(
+ $e, $copy, '', $item->pub_note, 1) if $item->pub_note;
+
+ if($evt) {
+ respond_with_status($conn, $total, $try_count, $in_count, $evt);
+ next;
+ }
+
+ $evt = OpenILS::Application::Cat::AssetCommon->create_copy_note(
+ $e, $copy, '', $item->priv_note, 1) if $item->priv_note;
+
+ if($evt) {
+ respond_with_status($conn, $total, $try_count, $in_count, $evt);
+ next;
+ }
+
+ # --------------------------------------------------------------------------------
+ # Item import succeeded
+ # --------------------------------------------------------------------------------
+ $e->commit;
+ respond_with_status($conn, $total, $try_count, ++$in_count, undef, imported_as => $copy->id);
+ }
+ }
+ $roe->rollback;
+ return undef;
+}
+
+
+sub respond_with_status {
+ my($conn, $total, $try_count, $success_count, $err, %args) = @_;
+ $conn->respond({
+ total => $total,
+ progress => $try_count,
+ err_event => $err,
+ success_count => $success_count, %args }) if $err or ($try_count % 5 == 0);
+}
+
+
+1;
--- /dev/null
+package OpenILS::Const;
+use strict; use warnings;
+use vars qw(@EXPORT_OK %EXPORT_TAGS);
+use Exporter;
+use base qw/Exporter/;
+
+
+# ---------------------------------------------------------------------
+# Shoves defined constants into the export array
+# so they don't have to be listed twice in the code
+# ---------------------------------------------------------------------
+sub econst {
+ my($name, $value) = @_;
+ my $caller = caller;
+ no strict;
+ *{$name} = sub () { $value };
+ push @{$caller.'::EXPORT_OK'}, $name;
+}
+
+# ---------------------------------------------------------------------
+# CONSTANTS
+# ---------------------------------------------------------------------
+
+
+
+# ---------------------------------------------------------------------
+# Copy Statuses
+# ---------------------------------------------------------------------
+econst OILS_COPY_STATUS_AVAILABLE => 0;
+econst OILS_COPY_STATUS_CHECKED_OUT => 1;
+econst OILS_COPY_STATUS_BINDERY => 2;
+econst OILS_COPY_STATUS_LOST => 3;
+econst OILS_COPY_STATUS_MISSING => 4;
+econst OILS_COPY_STATUS_IN_PROCESS => 5;
+econst OILS_COPY_STATUS_IN_TRANSIT => 6;
+econst OILS_COPY_STATUS_RESHELVING => 7;
+econst OILS_COPY_STATUS_ON_HOLDS_SHELF=> 8;
+econst OILS_COPY_STATUS_ON_ORDER => 9;
+econst OILS_COPY_STATUS_ILL => 10;
+econst OILS_COPY_STATUS_CATALOGING => 11;
+econst OILS_COPY_STATUS_RESERVES => 12;
+econst OILS_COPY_STATUS_DISCARD => 13;
+econst OILS_COPY_STATUS_DAMAGED => 14;
+econst OILS_COPY_STATUS_ON_RESV_SHELF => 15;
+
+
+# ---------------------------------------------------------------------
+# Circ defaults for pre-cataloged copies
+# ---------------------------------------------------------------------
+econst OILS_PRECAT_COPY_FINE_LEVEL => 2;
+econst OILS_PRECAT_COPY_LOAN_DURATION => 2;
+econst OILS_PRECAT_CALL_NUMBER => -1;
+econst OILS_PRECAT_RECORD => -1;
+
+
+# ---------------------------------------------------------------------
+# Circ constants
+# ---------------------------------------------------------------------
+econst OILS_CIRC_DURATION_SHORT => 1;
+econst OILS_CIRC_DURATION_NORMAL => 2;
+econst OILS_CIRC_DURATION_EXTENDED => 3;
+econst OILS_REC_FINE_LEVEL_LOW => 1;
+econst OILS_REC_FINE_LEVEL_NORMAL => 2;
+econst OILS_REC_FINE_LEVEL_HIGH => 3;
+econst OILS_STOP_FINES_CHECKIN => 'CHECKIN';
+econst OILS_STOP_FINES_RENEW => 'RENEW';
+econst OILS_STOP_FINES_LOST => 'LOST';
+econst OILS_STOP_FINES_CLAIMSRETURNED => 'CLAIMSRETURNED';
+econst OILS_STOP_FINES_LONGOVERDUE => 'LONGOVERDUE';
+econst OILS_STOP_FINES_MAX_FINES => 'MAXFINES';
+econst OILS_STOP_FINES_CLAIMS_NEVERCHECKEDOUT => 'CLAIMSNEVERCHECKEDOUT';
+econst OILS_UNLIMITED_CIRC_DURATION => 'unlimited';
+
+# ---------------------------------------------------------------------
+# Settings
+# ---------------------------------------------------------------------
+econst OILS_SETTING_LOST_PROCESSING_FEE => 'circ.lost_materials_processing_fee';
+econst OILS_SETTING_DEF_ITEM_PRICE => 'cat.default_item_price';
+econst OILS_SETTING_ORG_BOUNCED_EMAIL => 'org.bounced_emails';
+econst OILS_SETTING_CHARGE_LOST_ON_ZERO => 'circ.charge_lost_on_zero';
+econst OILS_SETTING_VOID_OVERDUE_ON_LOST => 'circ.void_overdue_on_lost';
+econst OILS_SETTING_HOLD_SOFT_STALL => 'circ.hold_stalling.soft';
+econst OILS_SETTING_HOLD_HARD_STALL => 'circ.hold_stalling.hard';
+econst OILS_SETTING_HOLD_SOFT_BOUNDARY => 'circ.hold_boundary.soft';
+econst OILS_SETTING_HOLD_HARD_BOUNDARY => 'circ.hold_boundary.hard';
+econst OILS_SETTING_HOLD_EXPIRE => 'circ.hold_expire_interval';
+econst OILS_SETTING_HOLD_ESIMATE_WAIT_INTERVAL => 'circ.holds.default_estimated_wait_interval';
+econst OILS_SETTING_VOID_LOST_ON_CHECKIN => 'circ.void_lost_on_checkin';
+econst OILS_SETTING_MAX_ACCEPT_RETURN_OF_LOST => 'circ.max_accept_return_of_lost';
+econst OILS_SETTING_VOID_LOST_PROCESS_FEE_ON_CHECKIN => 'circ.void_lost_proc_fee_on_checkin';
+econst OILS_SETTING_RESTORE_OVERDUE_ON_LOST_RETURN => 'circ.restore_overdue_on_lost_return';
+econst OILS_SETTING_LOST_IMMEDIATELY_AVAILABLE => 'circ.lost_immediately_available';
+econst OILS_SETTING_BLOCK_HOLD_FOR_EXPIRED_PATRON => 'circ.holds.expired_patron_block';
+
+
+
+
+econst OILS_HOLD_TYPE_COPY => 'C';
+econst OILS_HOLD_TYPE_FORCE => 'F';
+econst OILS_HOLD_TYPE_RECALL => 'R';
+econst OILS_HOLD_TYPE_ISSUANCE => 'I';
+econst OILS_HOLD_TYPE_VOLUME => 'V';
+econst OILS_HOLD_TYPE_TITLE => 'T';
+econst OILS_HOLD_TYPE_METARECORD => 'M';
+
+
+econst OILS_BILLING_TYPE_OVERDUE_MATERIALS => 'Overdue materials';
+econst OILS_BILLING_TYPE_COLLECTION_FEE => 'Long Overdue Collection Fee';
+econst OILS_BILLING_TYPE_DEPOSIT => 'System: Deposit';
+econst OILS_BILLING_TYPE_RENTAL => 'System: Rental';
+econst OILS_BILLING_NOTE_SYSTEM => 'SYSTEM GENERATED';
+
+econst OILS_ACQ_DEBIT_TYPE_PURCHASE => 'purchase';
+econst OILS_ACQ_DEBIT_TYPE_TRANSFER => 'xfer';
+
+# all penalties with ID < 100 are managed automatically
+econst OILS_PENALTY_AUTO_ID => 100;
+econst OILS_PENALTY_PATRON_EXCEEDS_FINES => 1;
+econst OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT => 2;
+econst OILS_PENALTY_INVALID_PATRON_ADDRESS => 29;
+
+
+econst OILS_BILLING_TYPE_NOTIFICATION_FEE => 9;
+
+
+
+# ---------------------------------------------------------------------
+# finally, export all the constants
+# ---------------------------------------------------------------------
+%EXPORT_TAGS = ( const => [ @EXPORT_OK ] );
+
--- /dev/null
+package OpenILS::Event;
+# vim:noet:ts=4
+use strict; use warnings;
+use XML::LibXML;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger;
+my $logger = "OpenSRF::Utils::Logger";
+
+
+# Returns a new Event data hash (not a blessed object)
+# The first param is the event name
+# Following the first param is an optional hash of params:
+# perm => the name of the permission error for permimssion errors
+# permloc => the location of the permission error for permission errors
+# payload => the payload to be returned on successfull events
+
+
+my $events = undef;
+my $descs = undef;
+
+sub new {
+ my( $class, $event, %params ) = @_;
+ _load_events() unless $events;
+
+ throw OpenSRF::EX ("Bad event name: $event") unless $event;
+ my $e = $events->{$event};
+ $e = '' unless defined $e;
+
+ my( $m, $f, $l ) = caller(0);
+ my( $mm, $ff, $ll ) = caller(1);
+ my( $mmm, $fff, $lll ) = caller(2);
+
+ $f ||= "";
+ $l ||= "";
+ $ff ||= "";
+ $ll ||= "";
+ $fff ||= "";
+ $lll ||= "";
+
+ my $lang = 'en-US'; # assume english for now
+
+ my $t = CORE::localtime();
+
+ return {
+ ilsevent => $e,
+ textcode => $event,
+ stacktrace => "$f:$l $ff:$ll $fff:$lll",
+ desc => $descs->{$lang}->{$e || ''} || '',
+ servertime => $t,
+ pid => $$, %params
+ };
+}
+
+sub _load_events {
+ my $settings_client = OpenSRF::Utils::SettingsClient->new();
+ my $eventsxml = $settings_client->config_value( "ils_events" );
+
+ if(!$eventsxml) {
+ throw OpenSRF::EX ("No ils_events file found in settings config");
+ }
+
+ $logger->info("Loading events xml file $eventsxml");
+
+ my $doc = XML::LibXML->new->parse_file($eventsxml);
+
+ my @nodes = $doc->documentElement->findnodes('//event');
+ for my $node (@nodes) {
+ $events->{$node->getAttribute('textcode')} =
+ $node->getAttribute('code');
+ }
+
+ $descs = {};
+ my @desc = $doc->documentElement->findnodes('//desc');
+ for my $d (@desc) {
+ my $lang = $d->getAttributeNS('http://www.w3.org/XML/1998/namespace', 'lang');
+ my $code = $d->parentNode->getAttribute('code');
+ unless ($descs && $lang && exists $descs->{$lang}) {
+ $descs->{$lang} = {};
+ if (!$descs) {
+ $logger->error("No error description nodes found in $eventsxml.");
+ }
+ if (!$lang) {
+ $logger->error("No xml:lang attribute found for node in $eventsxml.");
+ }
+ }
+ $descs->{$lang}->{$code} = $d->textContent;
+ }
+}
+
+
+1;
--- /dev/null
+package OpenILS::Perm;
+use strict; use warnings;
+use Template;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::EX qw(:try);
+use OpenSRF::AppSession;
+use OpenSRF::Utils::Logger;
+
+# ----------------------------------------------------------------------------------
+# These permission strings
+# ----------------------------------------------------------------------------------
+
+# returns a new fieldmapper::perm_ex
+my $logger = 'OpenSRF::Utils::Logger';
+
+sub new {
+ my($class, $type) = @_;
+ $logger->warn("Returning permission error: $type");
+ return bless( { ilsevent => 5000, ilsperm => $type }, 'OpenILS::Perm');
+}
+
+1;
--- /dev/null
+package OpenILS::Reporter::Proxy;
+use strict; use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(REDIRECT FORBIDDEN OK NOT_FOUND DECLINED :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use CGI;
+use Data::Dumper;
+use Digest::MD5 qw/md5_hex/;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+
+
+# set the bootstrap config and template include directory when
+# this module is loaded
+my $bootstrap;
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+}
+
+sub handler {
+ my $apache = shift;
+ my $cgi = new CGI;
+ my $auth_ses = $cgi->cookie('ses');
+ my $ws_ou = $cgi->cookie('ws_ou') || 1;
+
+ my $url = $cgi->url;
+
+ # push everyone to the secure site
+ if ($url =~ /^http:/o) {
+ $url =~ s/^http:/https:/o;
+ print "Location: $url\n\n";
+ return Apache2::Const::OK;
+ }
+
+ if (!$auth_ses) {
+ my $u = $cgi->param('user');
+ my $p = $cgi->param('passwd');
+
+ if (!$u) {
+
+ print $cgi->header(-type=>'text/html', -expires=>'-1d');
+ print <<" HTML";
+
+<html>
+ <head>
+ <title>Report Output Login</title>
+ </head>
+ <body>
+ <br/><br/><br/>
+ <center>
+ <form method='POST'>
+ <table style='border-collapse: collapse; border: 1px solid black;'>
+ <tr>
+ <th colspan='2' align='center'><u>Please log in to view reports</u></th>
+ </tr>
+ <tr>
+ <th align="right">Username or barcode:</th>
+ <td><input type="text" name="user"/></td>
+ </tr>
+ <tr>
+ <th align="right">Password:</th>
+ <td><input type="password" name="passwd"/></td>
+ </tr>
+ </table>
+ <input type="submit" value="Log in"/>
+ </form>
+ </center>
+ </body>
+</html>
+
+ HTML
+ return Apache2::Const::OK;
+ }
+
+ $auth_ses = oils_login($u, $p);
+ if ($auth_ses) {
+ print $cgi->redirect(
+ -uri=>$url,
+ -cookie=>$cgi->cookie(
+ -name=>'ses',
+ -value=>$auth_ses,
+ -path=>'/',-expires=>'+1h'
+ )
+ );
+ return Apache2::Const::REDIRECT;
+ }
+ }
+
+ my $user = verify_login($auth_ses);
+ return Apache2::Const::FORBIDDEN unless ($user);
+
+ my $failures = OpenSRF::AppSession
+ ->create('open-ils.actor')
+ ->request('open-ils.actor.user.perm.check', $auth_ses, $user->id, $ws_ou, ['VIEW_REPORT_OUTPUT'])
+ ->gather(1);
+
+ return Apache2::Const::FORBIDDEN if (@$failures > 0);
+
+ # they're good, let 'em through
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ # oops, file not found
+ return Apache2::Const::NOT_FOUND;
+}
+
+# returns the user object if the session is valid, 0 otherwise
+sub verify_login {
+ my $auth_token = shift;
+ return undef unless $auth_token;
+
+ my $user = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( "open-ils.auth.session.retrieve", $auth_token )
+ ->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return undef;
+ }
+
+ return $user if ref($user);
+ return undef;
+}
+
+sub oils_login {
+ my( $username, $password, $type ) = @_;
+
+ $type |= "staff";
+ my $nametype = 'username';
+ $nametype = 'barcode' if ($username =~ /^\d+$/o);
+
+ my $seed = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( 'open-ils.auth.authenticate.init', $username )
+ ->gather(1);
+
+ return undef unless $seed;
+
+ my $response = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( 'open-ils.auth.authenticate.complete',
+ { $nametype => $username,
+ password => md5_hex($seed . md5_hex($password)),
+ type => $type })
+ ->gather(1);
+
+ return undef unless $response;
+
+ return $response->{payload}->{authtoken};
+}
+
+
+
+1;
--- /dev/null
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder;
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ return bless { _sql => undef } => $class;
+}
+
+sub register_params {
+ my $self = shift;
+ my $p = shift;
+ $self->{_params} = $p;
+}
+
+sub get_param {
+ my $self = shift;
+ my $p = shift;
+ return $self->{_builder}->{_params}->{$p};
+}
+
+sub set_builder {
+ my $self = shift;
+ $self->{_builder} = shift;
+ return $self;
+}
+
+sub builder {
+ my $self = shift;
+ return $self->{_builder};
+}
+
+sub relative_time {
+ my $self = shift;
+ my $t = shift;
+ $self->builder->{_relative_time} = $t if (defined $t);
+ return $self->builder->{_relative_time};
+}
+
+sub resolve_param {
+ my $self = shift;
+ my $val = shift;
+
+ if (defined($val) && $val =~ /^::(.+)$/o) {
+ $val = $self->get_param($1);
+ }
+
+ if (defined($val) && !ref($val)) {
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/"/\\"/go;
+ }
+
+ return $val;
+}
+
+sub parse_report {
+ my $self = shift;
+ my $report = shift;
+
+ my $rs = OpenILS::Reporter::SQLBuilder::ResultSet->new;
+
+ if (!$report->{order_by} || @{$report->{order_by}} == 0) {
+ $report->{order_by} = $report->{select};
+ }
+
+ $rs->is_subquery( 1 ) if ( $report->{alias} );
+
+ $rs ->set_builder( $self )
+ ->set_subquery_alias( $report->{alias} )
+ ->set_select( $report->{select} )
+ ->set_from( $report->{from} )
+ ->set_where( $report->{where} )
+ ->set_having( $report->{having} )
+ ->set_order_by( $report->{order_by} )
+ ->set_pivot_data( $report->{pivot_data} )
+ ->set_pivot_label( $report->{pivot_label} )
+ ->set_pivot_default( $report->{pivot_default} );
+
+ return $rs;
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::ResultSet;
+use base qw/OpenILS::Reporter::SQLBuilder/;
+
+sub is_subquery {
+ my $self = shift;
+ my $flag = shift;
+ $self->{_is_subquery} = $flag if (defined $flag);
+ return $self->{_is_subquery};
+}
+
+sub pivot_data {
+ my $self = shift;
+ return $self->builder->{_pivot_data};
+}
+
+sub pivot_label {
+ my $self = shift;
+ return $self->builder->{_pivot_label};
+}
+
+sub pivot_default {
+ my $self = shift;
+ return $self->builder->{_pivot_default};
+}
+
+sub set_pivot_default {
+ my $self = shift;
+ my $p = shift;
+ $self->builder->{_pivot_default} = $p if (defined $p);
+ return $self;
+}
+
+sub set_pivot_data {
+ my $self = shift;
+ my $p = shift;
+ $self->builder->{_pivot_data} = $p if (defined $p);
+ return $self;
+}
+
+sub set_pivot_label {
+ my $self = shift;
+ my $p = shift;
+ $self->builder->{_pivot_label} = $p if (defined $p);
+ return $self;
+}
+
+sub set_subquery_alias {
+ my $self = shift;
+ my $alias = shift;
+ $self->{_alias} = $alias if (defined $alias);
+ return $self;
+}
+
+sub set_select {
+ my $self = shift;
+ my @cols = @_;
+
+ $self->{_select} = [];
+
+ return $self unless (@cols && defined($cols[0]));
+ @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
+
+ push @{ $self->{_select} }, map { OpenILS::Reporter::SQLBuilder::Column::Select->new( $_ )->set_builder( $self->builder ) } @cols;
+
+ return $self;
+}
+
+sub set_from {
+ my $self = shift;
+ my $f = shift;
+
+ $self->{_from} = OpenILS::Reporter::SQLBuilder::Relation->parse( $f, $self->builder );
+
+ return $self;
+}
+
+sub set_where {
+ my $self = shift;
+ my @cols = @_;
+
+ $self->{_where} = [];
+
+ return $self unless (@cols && defined($cols[0]));
+ @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
+
+ push @{ $self->{_where} }, map { OpenILS::Reporter::SQLBuilder::Column::Where->new( $_ )->set_builder( $self->builder ) } @cols;
+
+ return $self;
+}
+
+sub set_having {
+ my $self = shift;
+ my @cols = @_;
+
+ $self->{_having} = [];
+
+ return $self unless (@cols && defined($cols[0]));
+ @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
+
+ push @{ $self->{_having} }, map { OpenILS::Reporter::SQLBuilder::Column::Having->new( $_ )->set_builder( $self->builder ) } @cols;
+
+ return $self;
+}
+
+sub set_order_by {
+ my $self = shift;
+ my @cols = @_;
+
+ $self->{_order_by} = [];
+
+ return $self unless (@cols && defined($cols[0]));
+ @cols = @{ $cols[0] } if (@cols == 1 && ref($cols[0]) eq 'ARRAY');
+
+ push @{ $self->{_order_by} }, map { OpenILS::Reporter::SQLBuilder::Column::OrderBy->new( $_ )->set_builder( $self->builder ) } @cols;
+
+ return $self;
+}
+
+sub column_label_list {
+ my $self = shift;
+
+ my @labels;
+ push @labels, $self->resolve_param( $_->{_alias} ) for ( @{ $self->{_select} } );
+ return @labels;
+}
+
+sub group_by_list {
+ my $self = shift;
+ my $base = shift;
+ $base = 1 unless (defined $base);
+
+ my $seen_label = 0;
+ my $gcount = $base;
+ my @group_by;
+ for my $c ( @{ $self->{_select} } ) {
+ if ($base == 0 && !$seen_label && defined($self->pivot_label) && $gcount == $self->pivot_label - 1) {
+ $seen_label++;
+ next;
+ }
+ push @group_by, $gcount if (!$c->is_aggregate);
+ $gcount++;
+ }
+
+ return @group_by;
+}
+
+sub toSQL {
+ my $self = shift;
+
+ return $self->{_sql} if ($self->{_sql});
+
+ my $sql = '';
+
+ if ($self->is_subquery) {
+ $sql = '(';
+ }
+
+ $sql .= "SELECT\t" . join(",\n\t", map { $_->toSQL } @{ $self->{_select} }) . "\n" if (@{ $self->{_select} });
+ $sql .= " FROM\t" . $self->{_from}->toSQL . "\n" if ($self->{_from});
+ $sql .= " WHERE\t" . join("\n\tAND ", map { $_->toSQL } @{ $self->{_where} }) . "\n" if (@{ $self->{_where} });
+
+ my @group_by = $self->group_by_list;
+
+ $sql .= ' GROUP BY ' . join(', ', @group_by) . "\n" if (@group_by);
+ $sql .= " HAVING " . join("\n\tAND ", map { $_->toSQL } @{ $self->{_having} }) . "\n" if (@{ $self->{_having} });
+ $sql .= ' ORDER BY ' . join(', ', map { $_->toSQL } @{ $self->{_order_by} }) . "\n" if (@{ $self->{_order_by} });
+
+ if ($self->is_subquery) {
+ $sql .= ') '. $self->{_alias} . "\n";
+ }
+
+ return $self->{_sql} = $sql;
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input;
+use base qw/OpenILS::Reporter::SQLBuilder/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+
+ my $col_data = shift;
+
+ if (ref($col_data)) {
+ $self->{params} = $col_data->{params};
+ my $trans = $col_data->{transform} || 'Bare';
+ my $pkg = "OpenILS::Reporter::SQLBuilder::Input::Transform::$trans";
+ if (UNIVERSAL::can($pkg => 'toSQL')) {
+ $self->{_transform} = $trans;
+ } else {
+ $self->{_transform} = 'GenericTransform';
+ }
+ } elsif( defined($col_data) ) {
+ $self->{_transform} = 'Bare';
+ $self->{params} = $col_data;
+ } else {
+ $self->{_transform} = 'NULL';
+ }
+
+
+
+ return $self;
+}
+
+sub toSQL {
+ my $self = shift;
+ my $type = $self->{_transform};
+ return $self->{_sql} if ($self->{_sql});
+ my $toSQL = "OpenILS::Reporter::SQLBuilder::Input::Transform::${type}::toSQL";
+ return $self->{_sql} = $self->$toSQL;
+}
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::GenericTransform;
+
+sub toSQL {
+ my $self = shift;
+ my $func = $self->{transform};
+
+ my @params;
+ @params = @{ $self->{params} } if ($self->{params});
+
+ my $sql = $func . '(\'';
+ $sql .= join("','", @params) if (@params);
+ $sql .= '\')';
+
+ return $sql;
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::NULL;
+
+sub toSQL {
+ return "NULL";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::Bare;
+
+sub toSQL {
+ my $self = shift;
+
+ my $val = $self->{params};
+ $val = $$val[0] if (ref($val));
+
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/'/\\'/go;
+
+ return "'$val'";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::age;
+
+sub toSQL {
+ my $self = shift;
+
+ my $val = $self->{params};
+ $val = $$val[0] if (ref($val));
+
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/'/\\'/go;
+
+ return "AGE(NOW(),'" . $val . "'::TIMESTAMPTZ)";
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_year;
+
+sub toSQL {
+ my $self = shift;
+
+ my $rtime = $self->relative_time || 'now';
+
+ $rtime =~ s/\\/\\\\/go;
+ $rtime =~ s/'/\\'/go;
+
+ my $val = $self->{params};
+ $val = $$val[0] if (ref($val));
+
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/'/\\'/go;
+
+ return "EXTRACT(YEAR FROM '$rtime'::TIMESTAMPTZ + '$val years')";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_month;
+
+sub toSQL {
+ my $self = shift;
+
+ my $rtime = $self->relative_time || 'now';
+
+ $rtime =~ s/\\/\\\\/go;
+ $rtime =~ s/'/\\'/go;
+
+ my $val = $self->{params};
+ $val = $$val[0] if (ref($val));
+
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/'/\\'/go;
+
+ return "EXTRACT(YEAR FROM '$rtime'::TIMESTAMPTZ + '$val months')" .
+ " || '-' || LPAD(EXTRACT(MONTH FROM '$rtime'::TIMESTAMPTZ + '$val months')::text,2,'0')";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_date;
+
+sub toSQL {
+ my $self = shift;
+
+ my $rtime = $self->relative_time || 'now';
+
+ $rtime =~ s/\\/\\\\/go;
+ $rtime =~ s/'/\\'/go;
+
+ my $val = $self->{params};
+ $val = $$val[0] if (ref($val));
+
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/'/\\'/go;
+
+ return "DATE('$rtime'::TIMESTAMPTZ + '$val days')";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Input::Transform::relative_week;
+
+sub toSQL {
+ my $self = shift;
+
+ my $rtime = $self->relative_time || 'now';
+
+ $rtime =~ s/\\/\\\\/go;
+ $rtime =~ s/'/\\'/go;
+
+ my $val = $self->{params};
+ $val = $$val[0] if (ref($val));
+
+ $val =~ s/\\/\\\\/go;
+ $val =~ s/'/\\'/go;
+
+ return "EXTRACT(WEEK FROM '$rtime'::TIMESTAMPTZ + '$val weeks')";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column;
+use base qw/OpenILS::Reporter::SQLBuilder/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+
+ my $col_data = shift;
+ $self->{_relation} = $col_data->{relation};
+ $self->{_column} = $col_data->{column};
+
+ $self->{_aggregate} = $col_data->{aggregate};
+
+ if (ref($self->{_column})) {
+ my $trans = $self->{_column}->{transform} || 'Bare';
+ my $pkg = "OpenILS::Reporter::SQLBuilder::Column::Transform::$trans";
+ if (UNIVERSAL::can($pkg => 'toSQL')) {
+ $self->{_transform} = $trans;
+ } else {
+ $self->{_transform} = 'GenericTransform';
+ }
+ } elsif( defined($self->{_column}) ) {
+ $self->{_transform} = 'Bare';
+ } else {
+ $self->{_transform} = 'NULL';
+ }
+
+
+ return $self;
+}
+
+sub find_relation {
+ my $self = shift;
+ return $self->builder->{_rels}->{$self->{_relation}};
+}
+
+sub name {
+ my $self = shift;
+ if (ref($self->{_column})) {
+ return $self->{_column}->{colname};
+ } else {
+ return $self->{_column};
+ }
+}
+
+sub toSQL {
+ my $self = shift;
+ my $type = $self->{_transform};
+ return $self->{_sql} if ($self->{_sql});
+ my $toSQL = "OpenILS::Reporter::SQLBuilder::Column::Transform::${type}::toSQL";
+ return $self->{_sql} = $self->$toSQL;
+}
+
+sub is_aggregate {
+ my $self = shift;
+ my $type = $self->{_transform};
+ my $is_agg = "OpenILS::Reporter::SQLBuilder::Column::Transform::${type}::is_aggregate";
+ return $self->$is_agg;
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::OrderBy;
+use base qw/OpenILS::Reporter::SQLBuilder::Column/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ my $col_data = shift;
+ $self->{_direction} = $col_data->{direction} || 'ascending';
+ return $self;
+}
+
+sub toSQL {
+ my $self = shift;
+ my $dir = ($self->{_direction} =~ /^d/oi) ? 'DESC' : 'ASC';
+ return $self->{_sql} if ($self->{_sql});
+ return $self->{_sql} = $self->SUPER::toSQL . " $dir";
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Select;
+use base qw/OpenILS::Reporter::SQLBuilder::Column/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ my $col_data = shift;
+ $self->{_alias} = $col_data->{alias} || $self->name;
+ return $self;
+}
+
+sub toSQL {
+ my $self = shift;
+ return $self->{_sql} if ($self->{_sql});
+ return $self->{_sql} = $self->SUPER::toSQL . ' AS "' . $self->resolve_param( $self->{_alias} ) . '"';
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::GenericTransform;
+
+sub toSQL {
+ my $self = shift;
+ my $name = $self->name;
+ my $func = $self->{_column}->{transform};
+
+ my @params;
+ @params = @{ $self->resolve_param( $self->{_column}->{params} ) } if ($self->{_column}->{params});
+
+ my $sql = $func . '("' . $self->{_relation} . '"."' . $self->name . '"';
+ $sql .= ",'" . join("','", @params) . "'" if (@params);
+ $sql .= ')';
+
+ return $sql;
+}
+
+sub is_aggregate { return $self->{_aggregate} }
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::Bare;
+
+sub toSQL {
+ my $self = shift;
+ return '"' . $self->{_relation} . '"."' . $self->name . '"';
+}
+
+sub is_aggregate { return 0 }
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::upper;
+
+sub toSQL {
+ my $self = shift;
+ my $params = $self->resolve_param( $self->{_column}->{params} );
+ my $start = $$params[0];
+ my $len = $$params[1];
+ return 'UPPER("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::lower;
+
+sub toSQL {
+ my $self = shift;
+ my $params = $self->resolve_param( $self->{_column}->{params} );
+ my $start = $$params[0];
+ my $len = $$params[1];
+ return 'LOWER("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::substring;
+
+sub toSQL {
+ my $self = shift;
+ my $params = $self->resolve_param( $self->{_column}->{params} );
+ my $start = $$params[0];
+ my $len = $$params[1];
+ return 'SUBSTRING("' . $self->{_relation} . '"."' . $self->name . "\",$start,$len)";
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::day_name;
+
+sub toSQL {
+ my $self = shift;
+ return 'TO_CHAR("' . $self->{_relation} . '"."' . $self->name . '", \'Day\')';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::month_name;
+
+sub toSQL {
+ my $self = shift;
+ return 'TO_CHAR("' . $self->{_relation} . '"."' . $self->name . '", \'Month\')';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::doy;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(DOY FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::woy;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(WEEK FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::moy;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(MONTH FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::qoy;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(QUARTER FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::dom;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(DAY FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::dow;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(DOW FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::year_trunc;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(YEAR FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::month_trunc;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(YEAR FROM "' . $self->{_relation} . '"."' . $self->name . '")' .
+ ' || \'-\' || LPAD(EXTRACT(MONTH FROM "' . $self->{_relation} . '"."' . $self->name . '")::text,2,\'0\')';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::date_trunc;
+
+sub toSQL {
+ my $self = shift;
+ return 'DATE("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::hour_trunc;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(HOUR FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::quarter;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(YEAR FROM "' . $self->{_relation} . '"."' . $self->name . '")' .
+ ' || \'-Q\' || EXTRACT(QUARTER FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::months_ago;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(MONTH FROM AGE(NOW(),"' . $self->{_relation} . '"."' . $self->name . '"))';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::hod;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(HOUR FROM "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::quarters_ago;
+
+sub toSQL {
+ my $self = shift;
+ return 'EXTRACT(QUARTER FROM AGE(NOW(),"' . $self->{_relation} . '"."' . $self->name . '"))';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::age;
+
+sub toSQL {
+ my $self = shift;
+ return 'AGE(NOW(),"' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 0 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::first;
+
+sub toSQL {
+ my $self = shift;
+ return 'FIRST("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::last;
+
+sub toSQL {
+ my $self = shift;
+ return 'LAST("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::min;
+
+sub toSQL {
+ my $self = shift;
+ return 'MIN("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::max;
+
+sub toSQL {
+ my $self = shift;
+ return 'MAX("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::count;
+
+sub toSQL {
+ my $self = shift;
+ return 'COUNT("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::count_distinct;
+
+sub toSQL {
+ my $self = shift;
+ return 'COUNT(DISTINCT "' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::sum;
+
+sub toSQL {
+ my $self = shift;
+ return 'SUM("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Transform::average;
+
+sub toSQL {
+ my $self = shift;
+ return 'AVG("' . $self->{_relation} . '"."' . $self->name . '")';
+}
+
+sub is_aggregate { return 1 }
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Where;
+use base qw/OpenILS::Reporter::SQLBuilder::Column/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+
+ my $col_data = shift;
+ $self->{_condition} = $col_data->{condition};
+
+ return $self;
+}
+
+sub _flesh_conditions {
+ my $cond = shift;
+ my $builder = shift;
+ $cond = [$cond] unless (ref($cond) eq 'ARRAY');
+
+ my @out;
+ for my $c (@$cond) {
+ push @out, OpenILS::Reporter::SQLBuilder::Input->new( $c )->set_builder( $builder );
+ }
+
+ return \@out;
+}
+
+sub toSQL {
+ my $self = shift;
+
+ return $self->{_sql} if ($self->{_sql});
+
+ my $sql = '';
+
+ my $rel = $self->find_relation();
+ if ($rel && $rel->is_nullable) {
+ $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
+ }
+
+ $sql .= $self->SUPER::toSQL;
+
+ my ($op) = keys %{ $self->{_condition} };
+ my $val = _flesh_conditions( $self->resolve_param( $self->{_condition}->{$op} ), $self->builder );
+
+ if (lc($op) eq 'in') {
+ $sql .= " IN (". join(",", map { $_->toSQL } @$val).")";
+
+ } elsif (lc($op) eq 'not in') {
+ $sql .= " NOT IN (". join(",", map { $_->toSQL } @$val).")";
+
+ } elsif (lc($op) eq '= any') {
+ $val = $$val[0] if (ref($val) eq 'ARRAY');
+ $val = $val->toSQL;
+ if ($rel && $rel->is_nullable) { # need to redo this
+ $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
+ } else {
+ $sql = '';
+ }
+ $sql .= "$val = ANY (".$self->SUPER::toSQL.")";
+
+ } elsif (lc($op) eq '<> any') {
+ $val = $$val[0] if (ref($val) eq 'ARRAY');
+ $val = $val->toSQL;
+ if ($rel && $rel->is_nullable) { # need to redo this
+ $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
+ } else {
+ $sql = '';
+ }
+ $sql .= "$val <> ANY (".$self->SUPER::toSQL.")";
+
+ } elsif (lc($op) eq 'is blank') {
+ if ($rel && $rel->is_nullable) { # need to redo this
+ $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
+ } else {
+ $sql = '';
+ }
+ $sql .= '('. $self->SUPER::toSQL ." IS NULL OR ". $self->SUPER::toSQL ." = '')";
+
+ } elsif (lc($op) eq 'is not blank') {
+ if ($rel && $rel->is_nullable) { # need to redo this
+ $sql = "((". $self->SUPER::toSQL .") IS NULL OR ";
+ } else {
+ $sql = '';
+ }
+ $sql .= '('. $self->SUPER::toSQL ." IS NOT NULL AND ". $self->SUPER::toSQL ." <> '')";
+
+ } elsif (lc($op) eq 'between') {
+ $sql .= " BETWEEN ". join(" AND ", map { $_->toSQL } @$val);
+
+ } elsif (lc($op) eq 'not between') {
+ $sql .= " NOT BETWEEN ". join(" AND ", map { $_->toSQL } @$val);
+
+ } elsif (lc($op) eq 'like') {
+ $val = $$val[0] if (ref($val) eq 'ARRAY');
+ $val = $val->toSQL;
+ $val =~ s/^'(.*)'$/$1/o;
+ $val =~ s/%/\\\\%/o;
+ $val =~ s/_/\\\\_/o;
+ $sql .= " LIKE '\%$val\%'";
+
+ } elsif (lc($op) eq 'ilike') {
+ $val = $$val[0] if (ref($val) eq 'ARRAY');
+ $val = $val->toSQL;
+ $val =~ s/^'(.*)'$/$1/o;
+ $val =~ s/%/\\\\%/o;
+ $val =~ s/_/\\\\_/o;
+ $sql .= " ILIKE '\%$val\%'";
+
+ } else {
+ $val = $$val[0] if (ref($val) eq 'ARRAY');
+ $sql .= " $op " . $val->toSQL;
+ }
+
+ if ($rel && $rel->is_nullable) {
+ $sql .= ")";
+ }
+
+ return $self->{_sql} = $sql;
+}
+
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Column::Having;
+use base qw/OpenILS::Reporter::SQLBuilder::Column::Where/;
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Relation;
+use base qw/OpenILS::Reporter::SQLBuilder/;
+
+sub parse {
+ my $self = shift;
+ $self = $self->SUPER::new if (!ref($self));
+
+ my $rel_data = shift;
+ my $b = shift;
+ $self->set_builder($b);
+
+ $self->{_table} = $rel_data->{table};
+ $self->{_alias} = $rel_data->{alias} || $self->{_table};
+ $self->{_join} = [];
+ $self->{_columns} = [];
+
+ $self->builder->{_rels}{$self->{_alias}} = $self;
+
+ if ($rel_data->{join}) {
+ $self->add_join(
+ $_ => OpenILS::Reporter::SQLBuilder::Relation->parse( $rel_data->{join}->{$_}, $b ) => $rel_data->{join}->{$_}->{key} => $rel_data->{join}->{$_}->{type}
+ ) for ( keys %{ $rel_data->{join} } );
+ }
+
+ return $self;
+}
+
+sub add_column {
+ my $self = shift;
+ my $col = shift;
+
+ push @{ $self->{_columns} }, $col;
+}
+
+sub find_column {
+ my $self = shift;
+ my $col = shift;
+ return (grep { $_->name eq $col} @{ $self->{_columns} })[0];
+}
+
+sub add_join {
+ my $self = shift;
+ my $col = shift;
+ my $frel = shift;
+ my $fkey = shift;
+ my $type = lc(shift()) || 'inner';
+
+ if (UNIVERSAL::isa($col,'OpenILS::Reporter::SQLBuilder::Join')) {
+ push @{ $self->{_join} }, $col;
+ } else {
+ push @{ $self->{_join} }, OpenILS::Reporter::SQLBuilder::Join->build( $self => $col, $frel => $fkey, $type );
+ }
+
+ return $self;
+}
+
+sub is_nullable {
+ my $self = shift;
+ return $self->{_nullable};
+}
+
+sub is_join {
+ my $self = shift;
+ my $j = shift;
+ $self->{_is_join} = $j if ($j);
+ return $self->{_is_join};
+}
+
+sub join_type {
+ my $self = shift;
+ my $j = shift;
+ $self->{_join_type} = $j if ($j);
+ return $self->{_join_type};
+}
+
+sub toSQL {
+ my $self = shift;
+ return $self->{_sql} if ($self->{_sql});
+
+ my $sql = $self->{_table} .' AS "'. $self->{_alias} .'"';
+
+ if (!$self->is_join) {
+ for my $j ( @{ $self->{_join} } ) {
+ $sql .= $j->toSQL;
+ }
+ }
+
+ return $self->{_sql} = $sql;
+}
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Join;
+use base qw/OpenILS::Reporter::SQLBuilder/;
+
+sub build {
+ my $class = shift;
+ my $self = $class->SUPER::new if (!ref($class));
+
+ $self->{_left_rel} = shift;
+ ($self->{_left_col}) = split(/-/,shift());
+
+ $self->{_right_rel} = shift;
+ $self->{_right_col} = shift;
+
+ $self->{_join_type} = shift;
+
+ $self->{_right_rel}->set_builder($self->{_left_rel}->builder);
+
+ $self->{_right_rel}->is_join(1);
+ $self->{_right_rel}->join_type($self->{_join_type});
+
+ bless $self => "OpenILS::Reporter::SQLBuilder::Join::$self->{_join_type}";
+
+ if ( $self->{_join_type} eq 'inner' or !$self->{_join_type}) {
+ $self->{_join_type} = 'i';
+ } else {
+ if ($self->{_join_type} eq 'left') {
+ $self->{_right_rel}->{_nullable} = 'l';
+ } elsif ($self->{_join_type} eq 'right') {
+ $self->{_left_rel}->{_nullable} = 'r';
+ } else {
+ $self->{_right_rel}->{_nullable} = 'f';
+ $self->{_left_rel}->{_nullable} = 'f';
+ }
+ }
+
+ return $self;
+}
+
+sub toSQL {
+ my $self = shift;
+ my $dir = shift;
+
+ my $sql = "JOIN " . $self->{_right_rel}->toSQL .
+ ' ON ("' . $self->{_left_rel}->{_alias} . '"."' . $self->{_left_col} .
+ '" = "' . $self->{_right_rel}->{_alias} . '"."' . $self->{_right_col} . '")';
+
+ $sql .= $_->toSQL($dir) for (@{ $self->{_right_rel}->{_join} });
+
+ return $sql;
+}
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Join::left;
+use base qw/OpenILS::Reporter::SQLBuilder::Join/;
+
+sub toSQL {
+ my $self = shift;
+ my $dir = shift;
+ #return $self->{_sql} if ($self->{_sql});
+
+ my $j = $dir && $dir eq 'r' ? 'FULL OUTER' : 'LEFT OUTER';
+
+ my $sql = "\n\t$j ". $self->SUPER::toSQL('l');
+
+ #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
+
+ return $self->{_sql} = $sql;
+}
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Join::right;
+use base qw/OpenILS::Reporter::SQLBuilder::Join/;
+
+sub toSQL {
+ my $self = shift;
+ my $dir = shift;
+ #return $self->{_sql} if ($self->{_sql});
+
+ my $_nullable_rel = $dir && $dir eq 'l' ? '_right_rel' : '_left_rel';
+ $self->{_left_rel}->{_nullable} = 'r';
+ $self->{$_nullable_rel}->{_nullable} = $dir;
+
+ my $j = $dir && $dir eq 'l' ? 'FULL OUTER' : 'RIGHT OUTER';
+
+ my $sql = "\n\t$j ". $self->SUPER::toSQL('r');
+
+ #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
+
+ return $self->{_sql} = $sql;
+}
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Join::inner;
+use base qw/OpenILS::Reporter::SQLBuilder::Join/;
+
+sub toSQL {
+ my $self = shift;
+ my $dir = shift;
+ #return $self->{_sql} if ($self->{_sql});
+
+ my $_nullable_rel = $dir && $dir eq 'l' ? '_right_rel' : '_left_rel';
+ $self->{$_nullable_rel}->{_nullable} = $dir;
+
+ my $j = $dir ? ( $dir eq 'l' ? 'LEFT OUTER' : ( $dir eq 'r' ? 'RIGHT OUTER' : 'FULL OUTER' ) ) : 'INNER';
+
+ my $sql = "\n\t$j ". $self->SUPER::toSQL;
+
+ #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
+
+ return $self->{_sql} = $sql;
+}
+
+#-------------------------------------------------------------------------------------------------
+package OpenILS::Reporter::SQLBuilder::Join::cross;
+use base qw/OpenILS::Reporter::SQLBuilder::Join/;
+
+sub toSQL {
+ my $self = shift;
+ #return $self->{_sql} if ($self->{_sql});
+
+ $self->{_right_rel}->{_nullable} = 'f';
+ $self->{_left_rel}->{_nullable} = 'f';
+
+ my $sql = "\n\tFULL OUTER ". $self->SUPER::toSQL('f');
+
+ #$sql .= $_->toSQL for (@{ $self->{_right_rel}->{_join} });
+
+ return $self->{_sql} = $sql;
+}
+
+1;
--- /dev/null
+#
+# ILS.pm: Test ILS interface module
+#
+
+package OpenILS::SIP;
+use warnings; use strict;
+
+use Sys::Syslog qw(syslog);
+use Time::HiRes q/time/;
+
+use OpenILS::SIP::Item;
+use OpenILS::SIP::Patron;
+use OpenILS::SIP::Transaction;
+use OpenILS::SIP::Transaction::Checkout;
+use OpenILS::SIP::Transaction::Checkin;
+use OpenILS::SIP::Transaction::Renew;
+
+use OpenSRF::System;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils qw/:datetime/;
+use DateTime::Format::ISO8601;
+use Encode;
+use Unicode::Normalize;
+my $U = 'OpenILS::Application::AppUtils';
+
+my $editor;
+my $config;
+my $target_encoding; # FIXME: this is configured at the institution level.
+
+use Digest::MD5 qw(md5_hex);
+
+sub new {
+ my ($class, $institution, $login) = @_;
+ my $type = ref($class) || $class;
+ my $self = {};
+
+ $self->{login} = $login;
+
+ $config = $institution;
+ syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
+ $self->{institution} = $institution;
+
+ my $bsconfig = $institution->{implementation_config}->{bootstrap};
+ $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
+
+ syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
+
+ local $/ = "\n"; # why?
+ OpenSRF::System->bootstrap_client(config_file => $bsconfig);
+ syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
+
+ $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
+
+ Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
+
+ bless( $self, $type );
+
+ return undef unless
+ $self->login( $login->{id}, $login->{password} );
+
+ return $self;
+}
+
+sub fetch_session {
+ my $self = shift;
+
+ my $ses = $U->simplereq(
+ 'open-ils.auth',
+ 'open-ils.auth.session.retrieve', $self->{authtoken});
+
+ return undef if $U->event_code($ses); # auth timed out
+ return $self->{login_session} = $ses;
+}
+
+sub verify_session {
+ my $self = shift;
+
+ return 1 if $self->fetch_session;
+
+ syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
+ return $self->login( $self->{login}->{id}, $self->{login}->{password} );
+}
+
+sub editor {
+ return $editor = make_editor();
+}
+
+sub config {
+ return $config;
+}
+
+sub get_option_value {
+ my($self, $option) = @_;
+ my $ops = $config->{implementation_config}->{options}->{option};
+ $ops = [$ops] unless ref $ops eq 'ARRAY';
+ my @vals = grep { $_->{name} eq $option } @$ops;
+ return @vals ? $vals[0]->{value} : undef;
+}
+
+
+# Creates the global editor object
+my $cstore_init = 1; # call init on first use
+sub make_editor {
+ OpenILS::Utils::CStoreEditor::init() if $cstore_init;
+ $cstore_init = 0;
+ return OpenILS::Utils::CStoreEditor->new;
+}
+
+=head2 clean_text(scalar)
+
+Evergreen uses the UTF8 encoding for everything from the database up. Perl
+doesn't know this, however, so we have to convince it to treat our UTF8 strings
+as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
+for UTF8 text for SIP clients that support such modern options.
+
+The target encoding is set in the <encoding> element of the SIPServer.pm
+configuration file.
+
+=cut
+
+sub clean_text {
+ my $text = shift || '';
+
+ # Convert our incoming UTF8 data into Perl's internal string format
+
+ # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
+ # and latin-1 encodings (at least) require this to substitute
+ # characters rather than simply returning a string truncated
+ # after the first non-ASCII character
+ $text = NFD(decode_utf8($text));
+
+ if ($target_encoding eq 'ascii') {
+
+ # Try to maintain a reasonable version of the content by
+ # stripping diacritics from the text, given that the SIP client
+ # wants just plain ASCII. This is the base requirement according
+ # to the SIP2 specification.
+
+ # Stripping the combining characters converts ""béè♁ts"
+ # into "bee?ts" instead of "b???ts" - better, eh?
+ $text =~ s/\pM+//og;
+ }
+
+ # Characters that cannot be represented in the target encoding will
+ # generally be replaced with a question mark (?) character.
+ $text = encode($target_encoding, $text);
+
+ return $text;
+}
+
+my %org_sn_cache;
+sub shortname_from_id {
+ my $id = shift or return;
+ return $id->shortname if ref $id;
+ return $org_sn_cache{$id} if $org_sn_cache{$id};
+ return $org_sn_cache{$id} = editor()->retrieve_actor_org_unit($id)->shortname;
+}
+sub patron_barcode_from_id {
+ my $id = shift or return;
+ return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
+}
+
+sub format_date {
+ my $class = shift;
+ my $date = shift;
+ my $type = shift || 'dob';
+
+ return "" unless $date;
+
+ $date = DateTime::Format::ISO8601->new->
+ parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
+ my @time = localtime($date->epoch);
+
+ my $year = $time[5]+1900;
+ my $mon = $time[4]+1;
+ my $day = $time[3];
+ my $hour = $time[2];
+ my $minute = $time[1];
+ my $second = $time[0];
+
+ $date = sprintf("%04d%02d%02d", $year, $mon, $day);
+
+ # Due dates need hyphen separators and time of day as well
+ if ($type eq 'due') {
+ $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
+ }
+
+ syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
+ return $date;
+}
+
+
+
+sub login {
+ my( $self, $username, $password ) = @_;
+ syslog('LOG_DEBUG', "OILS: Logging in with username $username");
+
+ my $seed = $U->simplereq(
+ 'open-ils.auth',
+ 'open-ils.auth.authenticate.init', $username );
+
+ my $response = $U->simplereq(
+ 'open-ils.auth',
+ 'open-ils.auth.authenticate.complete',
+ {
+ username => $username,
+ password => md5_hex($seed . md5_hex($password)),
+ type => 'opac',
+ }
+ );
+
+ if( my $code = $U->event_code($response) ) {
+ my $txt = $response->{textcode};
+ syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
+ return undef;
+ }
+
+ my $key = $response->{payload}->{authtoken};
+ syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
+
+ $self->fetch_session; # to cache the login
+
+ return $self->{authtoken} = $key;
+}
+
+
+sub find_patron {
+ my $self = shift;
+ return OpenILS::SIP::Patron->new(@_);
+}
+
+
+sub find_item {
+ my $self = shift;
+ return OpenILS::SIP::Item->new(@_);
+}
+
+
+sub institution {
+ my $self = shift;
+ return $self->{institution}->{id}; # consider making this return the whole institution
+}
+
+sub institution_id {
+ my $self = shift;
+ return $self->{institution}->{id}; # then use this for just the ID
+}
+
+sub supports {
+ my ($self, $op) = @_;
+ my ($i) = grep { $_->{name} eq $op }
+ @{$config->{implementation_config}->{supports}->{item}};
+ return to_bool($i->{value});
+}
+
+sub check_inst_id {
+ my ($self, $id, $whence) = @_;
+ if ($id ne $self->{institution}->{id}) {
+ syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
+ # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
+ }
+}
+
+
+sub to_bool {
+ my $bool = shift;
+ # If it's defined, and matches a true sort of string, or is
+ # a non-zero number, then it's true.
+ defined($bool) or return; # false
+ ($bool =~ /true|y|yes/i) and return 1; # true
+ return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
+}
+
+sub checkout_ok {
+ return to_bool($config->{policy}->{checkout});
+}
+
+sub checkin_ok {
+ return to_bool($config->{policy}->{checkin});
+}
+
+sub renew_ok {
+ return to_bool($config->{policy}->{renew});
+}
+
+sub status_update_ok {
+ return to_bool($config->{policy}->{status_update});
+}
+
+sub offline_ok {
+ return to_bool($config->{policy}->{offline});
+}
+
+
+
+##
+## Checkout(patron_id, item_id, sc_renew):
+## patron_id & item_id are the identifiers send by the terminal
+## sc_renew is the renewal policy configured on the terminal
+## returns a status opject that can be queried for the various bits
+## of information that the protocol (SIP or NCIP) needs to generate
+## the response.
+##
+
+sub checkout {
+ my ($self, $patron_id, $item_id, $sc_renew) = @_;
+ $sc_renew = 0;
+
+ $self->verify_session;
+
+ syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
+
+ my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
+ my $patron = $self->find_patron($patron_id);
+ my $item = $self->find_item($item_id);
+
+ $xact->patron($patron);
+ $xact->item($item);
+
+ if (!$patron) {
+ $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
+ return $xact;
+ }
+
+ if (!$patron->charge_ok) {
+ $xact->screen_msg("Patron Blocked");
+ return $xact;
+ }
+
+ if( !$item ) {
+ $xact->screen_msg("Invalid Item Barcode: '$item_id'");
+ return $xact;
+ }
+
+ syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
+
+ if ($item->{patron} && ($item->{patron} eq $patron_id)) {
+ syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
+ $sc_renew = 1;
+ } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
+ # I can't deal with this right now
+ # XXX check in then check out?
+ $xact->screen_msg("Item checked out to another patron");
+ $xact->ok(0);
+ }
+
+ $xact->do_checkout($sc_renew);
+ $xact->desensitize(!$item->magnetic);
+
+ if( $xact->ok ) {
+ #editor()->commit;
+ syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
+ "patron %s checkout %s succeeded", $patron_id, $item_id);
+ } else {
+ #editor()->xact_rollback;
+ syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
+ "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
+ }
+
+ return $xact;
+}
+
+
+sub checkin {
+ my ($self, $item_id, $inst_id, $trans_date, $return_date,
+ $current_loc, $item_props, $cancel) = @_;
+
+ my $start_time = time();
+
+ $self->verify_session;
+
+ syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
+
+ my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
+ my $item = OpenILS::SIP::Item->new($item_id);
+
+ unless ( $xact->item($item) ) {
+ $xact->ok(0);
+ # $circ->alert(1); $circ->alert_type(99);
+ $xact->screen_msg("Invalid Item Barcode: '$item_id'");
+ syslog('LOG_INFO', "OILS: Checkin failed. " . $xact->screen_msg() );
+ return $xact;
+ }
+
+ $xact->do_checkin( $self, $inst_id, $trans_date, $return_date, $current_loc, $item_props );
+
+ if ($xact->ok) {
+ $xact->patron($self->find_patron(usr => $xact->{circ_user_id}, slim_user => 1)) if $xact->{circ_user_id};
+ delete $item->{patron};
+ delete $item->{due_date};
+ syslog('LOG_INFO', "OILS: Checkin succeeded");
+ } else {
+ syslog('LOG_WARNING', "OILS: Checkin failed");
+ }
+
+ syslog('LOG_INFO', "OILS: SIP Checkin request took %0.3f seconds", (time() - $start_time));
+ return $xact;
+}
+
+## If the ILS caches patron information, this lets it free it up.
+## Also, this could be used for centrally logging session duration.
+## We don't do anything with it.
+sub end_patron_session {
+ my ($self, $patron_id) = @_;
+ return (1, 'Thank you!', '');
+}
+
+
+#sub pay_fee {
+# my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
+# $pay_type, $fee_id, $trans_id, $currency) = @_;
+# my $trans;
+# my $patron;
+#
+# $trans = new ILS::Transaction::FeePayment;
+#
+# $patron = new ILS::Patron $patron_id;
+#
+# $trans->transaction_id($trans_id);
+# $trans->patron($patron);
+# $trans->ok(1);
+#
+# return $trans;
+#}
+#
+#sub add_hold {
+# my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
+# $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
+# my ($patron, $item);
+# my $hold;
+# my $trans;
+#
+#
+# $trans = new ILS::Transaction::Hold;
+#
+# # BEGIN TRANSACTION
+# $patron = new ILS::Patron $patron_id;
+# if (!$patron
+# || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
+# $trans->screen_msg("Invalid Patron.");
+#
+# return $trans;
+# }
+#
+# $item = new ILS::Item ($item_id || $title_id);
+# if (!$item) {
+# $trans->screen_msg("No such item.");
+#
+# # END TRANSACTION (conditionally)
+# return $trans;
+# } elsif ($item->fee && ($fee_ack ne 'Y')) {
+# $trans->screen_msg = "Fee required to place hold.";
+#
+# # END TRANSACTION (conditionally)
+# return $trans;
+# }
+#
+# $hold = {
+# item_id => $item->id,
+# patron_id => $patron->id,
+# expiration_date => $expiry_date,
+# pickup_location => $pickup_location,
+# hold_type => $hold_type,
+# };
+#
+# $trans->ok(1);
+# $trans->patron($patron);
+# $trans->item($item);
+# $trans->pickup_location($pickup_location);
+#
+# push(@{$item->hold_queue}, $hold);
+# push(@{$patron->{hold_items}}, $hold);
+#
+#
+# # END TRANSACTION
+# return $trans;
+#}
+#
+#sub cancel_hold {
+# my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
+# my ($patron, $item, $hold);
+# my $trans;
+#
+# $trans = new ILS::Transaction::Hold;
+#
+# # BEGIN TRANSACTION
+# $patron = new ILS::Patron $patron_id;
+# if (!$patron) {
+# $trans->screen_msg("Invalid patron barcode.");
+#
+# return $trans;
+# } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
+# $trans->screen_msg('Invalid patron password.');
+#
+# return $trans;
+# }
+#
+# $item = new ILS::Item ($item_id || $title_id);
+# if (!$item) {
+# $trans->screen_msg("No such item.");
+#
+# # END TRANSACTION (conditionally)
+# return $trans;
+# }
+#
+# # Remove the hold from the patron's record first
+# $trans->ok($patron->drop_hold($item_id));
+#
+# if (!$trans->ok) {
+# # We didn't find it on the patron record
+# $trans->screen_msg("No such hold on patron record.");
+#
+# # END TRANSACTION (conditionally)
+# return $trans;
+# }
+#
+# # Now, remove it from the item record. If it was on the patron
+# # record but not on the item record, we'll treat that as success.
+# foreach my $i (0 .. scalar @{$item->hold_queue}) {
+# $hold = $item->hold_queue->[$i];
+#
+# if ($hold->{patron_id} eq $patron->id) {
+# # found it: delete it.
+# splice @{$item->hold_queue}, $i, 1;
+# last;
+# }
+# }
+#
+# $trans->screen_msg("Hold Cancelled.");
+# $trans->patron($patron);
+# $trans->item($item);
+#
+# return $trans;
+#}
+#
+#
+## The patron and item id's can't be altered, but the
+## date, location, and type can.
+#sub alter_hold {
+# my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
+# $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
+# my ($patron, $item);
+# my $hold;
+# my $trans;
+#
+# $trans = new ILS::Transaction::Hold;
+#
+# # BEGIN TRANSACTION
+# $patron = new ILS::Patron $patron_id;
+# if (!$patron) {
+# $trans->screen_msg("Invalid patron barcode.");
+#
+# return $trans;
+# }
+#
+# foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
+# $hold = $patron->{hold_items}[$i];
+#
+# if ($hold->{item_id} eq $item_id) {
+# # Found it. So fix it.
+# $hold->{expiration_date} = $expiry_date if $expiry_date;
+# $hold->{pickup_location} = $pickup_location if $pickup_location;
+# $hold->{hold_type} = $hold_type if $hold_type;
+#
+# $trans->ok(1);
+# $trans->screen_msg("Hold updated.");
+# $trans->patron($patron);
+# $trans->item(new ILS::Item $hold->{item_id});
+# last;
+# }
+# }
+#
+# # The same hold structure is linked into both the patron's
+# # list of hold items and into the queue of outstanding holds
+# # for the item, so we don't need to search the hold queue for
+# # the item, since it's already been updated by the patron code.
+#
+# if (!$trans->ok) {
+# $trans->screen_msg("No such outstanding hold.");
+# }
+#
+# return $trans;
+#}
+
+
+sub renew {
+ my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
+ $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
+
+ $self->verify_session;
+
+ my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
+ $trans->patron($self->find_patron($patron_id));
+ $trans->item($self->find_item($item_id));
+
+ if(!$trans->patron) {
+ $trans->screen_msg("Invalid patron barcode.");
+ $trans->ok(0);
+ return $trans;
+ }
+
+ if(!$trans->patron->renew_ok) {
+ $trans->screen_msg("Renewals not allowed.");
+ $trans->ok(0);
+ return $trans;
+ }
+
+ if(!$trans->item) {
+ if( $title_id ) {
+ $trans->screen_msg("Title ID renewal not supported. Use item barcode.");
+ } else {
+ $trans->screen_msg("Invalid item barcode.");
+ }
+ $trans->ok(0);
+ return $trans;
+ }
+
+ if(!$trans->item->{patron} or
+ $trans->item->{patron} ne $patron_id) {
+ $trans->screen_msg("Item not checked out to " . $trans->patron->name);
+ $trans->ok(0);
+ return $trans;
+ }
+
+ # Perform the renewal
+ $trans->do_renew();
+
+ $trans->desensitize(0); # It's already checked out
+ $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
+ $trans->item->{sip_item_properties} = $item_props if $item_props;
+
+ return $trans;
+}
+
+
+
+
+
+#
+#sub renew_all {
+# my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
+# my ($patron, $item_id);
+# my $trans;
+#
+# $trans = new ILS::Transaction::RenewAll;
+#
+# $trans->patron($patron = new ILS::Patron $patron_id);
+# if (defined $patron) {
+# syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
+# $patron->name, $patron->renew_ok);
+# } else {
+# syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
+# $patron_id);
+# }
+#
+# if (!defined($patron)) {
+# $trans->screen_msg("Invalid patron barcode.");
+# return $trans;
+# } elsif (!$patron->renew_ok) {
+# $trans->screen_msg("Renewals not allowed.");
+# return $trans;
+# } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
+# $trans->screen_msg("Invalid patron password.");
+# return $trans;
+# }
+#
+# foreach $item_id (@{$patron->{items}}) {
+# my $item = new ILS::Item $item_id;
+#
+# if (!defined($item)) {
+# syslog("LOG_WARNING",
+# "renew_all: Invalid item id associated with patron '%s'",
+# $patron->id);
+# next;
+# }
+#
+# if (@{$item->hold_queue}) {
+# # Can't renew if there are outstanding holds
+# push @{$trans->unrenewed}, $item_id;
+# } else {
+# $item->{due_date} = time + (14*24*60*60); # two weeks hence
+# push @{$trans->renewed}, $item_id;
+# }
+# }
+#
+# $trans->ok(1);
+#
+# return $trans;
+#}
+
+1;
--- /dev/null
+package OpenILS::SIP::Item;
+use strict; use warnings;
+
+use Sys::Syslog qw(syslog);
+use Carp;
+
+use OpenILS::SIP;
+use OpenILS::SIP::Transaction;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Circ::ScriptBuilder;
+# use Data::Dumper;
+use OpenILS::Const qw/:const/;
+use OpenSRF::Utils qw/:datetime/;
+use DateTime::Format::ISO8601;
+use OpenSRF::Utils::SettingsClient;
+my $U = 'OpenILS::Application::AppUtils';
+
+my %item_db;
+
+# 0 means read-only
+# 1 means read/write Actually, gloves are off. Set what you like.
+
+my %fields = (
+ id => 0,
+# sip_media_type => 0,
+ sip_item_properties => 0,
+# magnetic_media => 0,
+ permanent_location => 0,
+ current_location => 0,
+# print_line => 1,
+# screen_msg => 1,
+# itemnumber => 0,
+# biblionumber => 0,
+ hold => 0,
+ hold_patron_bcode => 0,
+ hold_patron_name => 0,
+ barcode => 0,
+ onloan => 0,
+ collection_code => 0,
+ destination_loc => 0,
+ call_number => 0,
+ enumchron => 0,
+ location => 0,
+ author => 0,
+ title => 0,
+ copy => 0,
+ volume => 0,
+ record => 0,
+ mods => 0,
+);
+
+our $AUTOLOAD;
+sub DESTROY { } # keeps AUTOLOAD from catching inherent DESTROY calls
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $class = ref($self) or croak "$self is not an object";
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*://;
+
+ unless (exists $fields{$name}) {
+ croak "Cannot access '$name' field of class '$class'";
+ }
+
+ if (@_) {
+ # $fields{$name} or croak "Field '$name' of class '$class' is READ ONLY."; # nah, go ahead
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+}
+
+
+sub new {
+ my ($class, $item_id) = @_;
+ my $type = ref($class) || $class;
+ my $self = bless( {}, $type );
+
+ syslog('LOG_DEBUG', "OILS: Loading item $item_id...");
+ return undef unless $item_id;
+
+ my $e = OpenILS::SIP->editor();
+
+ my $copy = $e->search_asset_copy(
+ [
+ { barcode => $item_id, deleted => 'f' },
+ {
+ flesh => 3,
+ flesh_fields => {
+ acp => [ 'circ_lib', 'call_number', 'status' ],
+ acn => [ 'owning_lib', 'record' ],
+ }
+ }
+ ]
+ )->[0];
+
+ if(!$copy) {
+ syslog("LOG_DEBUG", "OILS: Item '%s' : not found", $item_id);
+ return undef;
+ }
+
+ my $circ = $e->search_action_circulation([
+ {
+ target_copy => $copy->id,
+ stop_fines_time => undef,
+ checkin_time => undef
+ },
+ {
+ flesh => 2,
+ flesh_fields => {
+ circ => ['usr'],
+ au => ['card']
+ }
+ }
+ ])->[0];
+
+ if($circ) {
+
+ my $user = $circ->usr;
+ my $bc = ($user->card) ? $user->card->barcode : '';
+ $self->{patron} = $bc;
+ $self->{patron_object} = $user;
+
+ syslog('LOG_DEBUG', "OILS: Open circulation exists on $item_id : user = $bc");
+ }
+
+ $self->{id} = $item_id;
+ $self->{copy} = $copy;
+ $self->{volume} = $copy->call_number;
+ $self->{record} = $copy->call_number->record;
+ $self->{call_number} = $copy->call_number->label;
+ $self->{mods} = $U->record_to_mvr($self->{record}) if $self->{record}->marc;
+ $self->{transit} = $self->fetch_transit;
+ $self->{hold} = $self->fetch_hold;
+
+
+ # use the non-translated version of the copy location as the
+ # collection code, since it may be used for additional routing
+ # purposes by the SIP client. Config option?
+ $self->{collection_code} =
+ $e->retrieve_asset_copy_location([
+ $copy->location, {no_i18n => 1}])->name;
+
+
+ if($self->{transit}) {
+ $self->{destination_loc} = $self->{transit}->dest->shortname;
+
+ } elsif($self->{hold}) {
+ $self->{destination_loc} = $self->{hold}->pickup_lib->shortname;
+ }
+
+ syslog("LOG_DEBUG", "OILS: Item('$item_id'): found with title '%s'", $self->title_id);
+
+ my $config = OpenILS::SIP->config(); # FIXME : will not always match!
+ my $legacy = $config->{implementation_config}->{legacy_script_support} || undef;
+
+ if( defined $legacy ) {
+ $self->{legacy_script_support} = ($legacy =~ /t(rue)?/io) ? 1 : 0;
+ syslog("LOG_DEBUG", "legacy_script_support is set in SIP config: " . $self->{legacy_script_support});
+
+ } else {
+ my $lss = OpenSRF::Utils::SettingsClient->new->config_value(
+ apps => 'open-ils.circ',
+ app_settings => 'legacy_script_support'
+ );
+ $self->{legacy_script_support} = ($lss =~ /t(rue)?/io) ? 1 : 0;
+ syslog("LOG_DEBUG", "legacy_script_support is set in SRF config: " . $self->{legacy_script_support});
+ }
+
+ return $self;
+}
+
+# fetch copy transit
+sub fetch_transit {
+ my $self = shift;
+ my $copy = $self->{copy} or return;
+ my $e = OpenILS::SIP->editor();
+
+ if ($copy->status->id == OILS_COPY_STATUS_IN_TRANSIT) {
+ my $transit = $e->search_action_transit_copy([
+ {
+ target_copy => $copy->id, # NOT barcode ($self->id)
+ dest_recv_time => undef
+ },
+ {
+ flesh => 1,
+ flesh_fields => {
+ atc => ['dest']
+ }
+ }
+ ])->[0];
+
+ syslog('LOG_WARNING', "OILS: Item(".$copy->barcode.
+ ") status is In Transit, but no action.transit_copy found!") unless $transit;
+
+ return $transit;
+ }
+
+ return undef;
+}
+
+# fetch captured hold.
+# Assume transit has already beeen fetched
+sub fetch_hold {
+ my $self = shift;
+ my $copy = $self->{copy} or return;
+ my $e = OpenILS::SIP->editor();
+
+ if( ($copy->status->id == OILS_COPY_STATUS_ON_HOLDS_SHELF) ||
+ ($self->{transit} and $self->{transit}->copy_status == OILS_COPY_STATUS_ON_HOLDS_SHELF) ) {
+ # item has been captured for a hold
+
+ my $hold = $e->search_action_hold_request([
+ {
+ current_copy => $copy->id,
+ capture_time => {'!=' => undef},
+ cancel_time => undef,
+ fulfillment_time => undef
+ },
+ {
+ limit => 1,
+ flesh => 1,
+ flesh_fields => {
+ ahr => ['pickup_lib']
+ }
+ }
+ ])->[0];
+
+ syslog('LOG_WARNING', "OILS: Item(".$copy->barcode.
+ ") is captured for a hold, but there is no matching hold request") unless $hold;
+
+ return $hold;
+ }
+
+ return undef;
+}
+
+sub run_attr_script {
+ my $self = shift;
+ return 1 if $self->{ran_script};
+ $self->{ran_script} = 1;
+
+ if($self->{legacy_script_support}){
+
+ syslog('LOG_DEBUG', "Legacy script support is ON");
+ my $config = OpenILS::SIP->config();
+ my $path = $config->{implementation_config}->{scripts}->{path};
+ my $item_config_script = $config->{implementation_config}->{scripts}->{item_config};
+
+ $path = ref($path) eq 'ARRAY' ? $path : [$path];
+ my $path_str = join(", ", @$path);
+
+ syslog('LOG_DEBUG', "OILS: Script path = [$path_str], Item config script = $item_config_script");
+
+ my $runner = OpenILS::Application::Circ::ScriptBuilder->build({
+ copy => $self->{copy},
+ editor => OpenILS::SIP->editor(),
+ });
+
+ $runner->add_path($_) for @$path;
+ $runner->load($item_config_script);
+
+ unless( $self->{item_config_result} = $runner->run ) { # assignment, not comparison
+ $runner->cleanup;
+ warn "Item config script [$path_str : $item_config_script] failed to run: $@\n";
+ syslog('LOG_ERR', "OILS: Item config script [$path_str : $item_config_script] failed to run: $@");
+ return undef;
+ }
+
+ $runner->cleanup;
+
+ } else {
+
+ # use the in-db circ modifier configuration
+ my $config = {magneticMedia => 'f', SIPMediaType => '001'}; # defaults
+ my $mod = $self->{copy}->circ_modifier;
+
+ if($mod) {
+ my $mod_obj = OpenILS::SIP->editor()->retrieve_config_circ_modifier($mod);
+ if($mod_obj) {
+ $config->{magneticMedia} = $mod_obj->magnetic_media;
+ $config->{SIPMediaType} = $mod_obj->sip2_media_type;
+ }
+ }
+
+ $self->{item_config_result} = { item_config => $config };
+ }
+
+ return 1;
+}
+
+sub magnetic_media {
+ my $self = shift;
+ $self->magnetic(@_);
+}
+sub magnetic {
+ my $self = shift;
+ return 0 unless $self->run_attr_script;
+ my $mag = $self->{item_config_result}->{item_config}->{magneticMedia} || '';
+ syslog('LOG_DEBUG', "OILS: magnetic = $mag");
+ return ($mag and $mag =~ /t(rue)?/io) ? 1 : 0;
+}
+
+sub sip_media_type {
+ my $self = shift;
+ return 0 unless $self->run_attr_script;
+ my $media = $self->{item_config_result}->{item_config}->{SIPMediaType} || '';
+ syslog('LOG_DEBUG', "OILS: media type = $media");
+ return ($media) ? $media : '001';
+}
+
+sub title_id {
+ my $self = shift;
+ my $t = ($self->{mods}) ? $self->{mods}->title : $self->{copy}->dummy_title;
+ return OpenILS::SIP::clean_text($t);
+}
+
+sub permanent_location {
+ my $self = shift;
+ return OpenILS::SIP::clean_text($self->{copy}->circ_lib->shortname);
+}
+
+sub current_location {
+ my $self = shift;
+ return OpenILS::SIP::clean_text($self->{copy}->circ_lib->shortname);
+}
+
+
+# 2 chars 0-99
+# 01 Other
+# 02 On order
+# 03 Available
+# 04 Charged
+# 05 Charged; not to be recalled until earliest recall date
+# 06 In process
+# 07 Recalled
+# 08 Waiting on hold shelf
+# 09 Waiting to be re-shelved
+# 10 In transit between library locations
+# 11 Claimed returned
+# 12 Lost
+# 13 Missing
+sub sip_circulation_status {
+ my $self = shift;
+ my $stat = $self->{copy}->status->id;
+
+ return '02' if $stat == OILS_COPY_STATUS_ON_ORDER;
+ return '03' if $stat == OILS_COPY_STATUS_AVAILABLE;
+ return '04' if $stat == OILS_COPY_STATUS_CHECKED_OUT;
+ return '06' if $stat == OILS_COPY_STATUS_IN_PROCESS;
+ return '08' if $stat == OILS_COPY_STATUS_ON_HOLDS_SHELF;
+ return '09' if $stat == OILS_COPY_STATUS_RESHELVING;
+ return '10' if $stat == OILS_COPY_STATUS_IN_TRANSIT;
+ return '12' if $stat == OILS_COPY_STATUS_LOST;
+ return '13' if $stat == OILS_COPY_STATUS_MISSING;
+
+ return 01;
+}
+
+sub sip_security_marker {
+ return '02'; # FIXME? 00-other; 01-None; 02-Tattle-Tape Security Strip (3M); 03-Whisper Tape (3M)
+}
+
+sub sip_fee_type {
+ return '01'; # FIXME? 01-09 enumerated in spec. We just use O1-other/unknown.
+}
+
+sub fee { # TODO
+ my $self = shift;
+ return 0;
+}
+
+
+sub fee_currency {
+ my $self = shift;
+ return OpenILS::SIP->config()->{implementation_config}->{currency};
+}
+
+sub owner {
+ my $self = shift;
+ return OpenILS::SIP::clean_text($self->{copy}->circ_lib->shortname);
+}
+
+sub hold_queue {
+ my $self = shift;
+ return [];
+}
+
+sub hold_queue_position { # TODO
+ my ($self, $patron_id) = @_;
+ return 1;
+}
+
+sub due_date {
+ my $self = shift;
+
+ # this should force correct circ fetching
+ require OpenILS::Utils::CStoreEditor;
+ my $e = OpenILS::Utils::CStoreEditor->new(xact => 1);
+ #my $e = OpenILS::SIP->editor();
+
+ my $circ = $e->search_action_circulation(
+ { target_copy => $self->{copy}->id, checkin_time => undef } )->[0];
+
+ $e->rollback;
+
+ if( !$circ ) {
+ syslog('LOG_INFO', "OILS: No open circ found for copy");
+ return 0;
+ }
+
+ my $due = OpenILS::SIP->format_date($circ->due_date, 'due');
+ syslog('LOG_DEBUG', "OILS: Found item due date = $due");
+ return $due;
+}
+
+sub recall_date { # TODO
+ my $self = shift;
+ return 0;
+}
+
+
+# Note: If the held item is in transit, this will be an approximation of shelf
+# expire time, since the time is not set until the item is checked in at the pickup location
+my %shelf_expire_setting_cache;
+sub hold_pickup_date {
+ my $self = shift;
+ my $copy = $self->{copy};
+ my $hold = $self->{hold} or return 0;
+
+ my $date = $hold->shelf_expire_time;
+
+ if(!$date) {
+ # hold has not hit the shelf. create a best guess.
+
+ my $interval = $shelf_expire_setting_cache{$hold->pickup_lib->id} ||
+ $U->ou_ancestor_setting_value(
+ $hold->pickup_lib->id,
+ 'circ.holds.default_shelf_expire_interval');
+
+ $shelf_expire_setting_cache{$hold->pickup_lib->id} = $interval;
+
+ if($interval) {
+ my $seconds = OpenSRF::Utils->interval_to_seconds($interval);
+ $date = DateTime->now->add(seconds => $seconds);
+ $date = $date->strftime('%FT%T%z') if $date;
+ }
+ }
+
+ return OpenILS::SIP->format_date($date) if $date;
+
+ return 0;
+}
+
+# message to display on console
+sub screen_msg {
+ my $self = shift;
+ return OpenILS::SIP::clean_text($self->{screen_msg}) || '';
+}
+
+
+# reciept printer
+sub print_line {
+ my $self = shift;
+ return OpenILS::SIP::clean_text($self->{print_line}) || '';
+}
+
+
+# An item is available for a patron if
+# 1) It's not checked out and (there's no hold queue OR patron
+# is at the front of the queue)
+# OR
+# 2) It's checked out to the patron and there's no hold queue
+sub available {
+ my ($self, $for_patron) = @_;
+
+ my $stat = $self->{copy}->status->id;
+ return 1 if
+ $stat == OILS_COPY_STATUS_AVAILABLE or
+ $stat == OILS_COPY_STATUS_RESHELVING;
+
+ return 0;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+OpenILS::SIP::Item - SIP abstraction layer for OpenILS Items.
+
+=head1 DESCRIPTION
+
+=head2 owning_lib vs. circ_lib
+
+In Evergreen, owning_lib is the org unit that purchased the item, the place to which the item
+should return after it's done rotating/floating to other branches (via staff intervention),
+or some combination of those. The owning_lib, however, is not necessarily where the item
+should be going "right now" or where it should return to by default. That would be the copy
+circ_lib or the transit destination. (In fact, the item may B<never> go to the owning_lib for
+its entire existence). In the context of SIP, the circ_lib more accurately describes the item's
+permanent location, i.e. where it needs to be sent if it's not en route to somewhere else.
+
+This confusion extends also to the SIP extension field of "owner". It means that the SIP owner does not
+correspond to EG's asset.volume.owning_lib, mainly because owning_lib is effectively the "ultimate
+owner" but not necessarily the "current owner". Because we populate SIP fields with circ_lib, the
+owning_lib is unused by SIP.
+
+=head1 TODO
+
+Holds queue logic
+
+=cut
--- /dev/null
+package OpenILS::SIP::Msg;
+use strict; use warnings;
+# -------------------------------------------------------
+# Defines the various screen messages
+# Currently they are just constants.. they need to be
+# moved to an external lang-specific source
+# -------------------------------------------------------
+use vars qw(@EXPORT_OK %EXPORT_TAGS);
+use Exporter;
+use base qw/Exporter/;
+
+
+# ---------------------------------------------------------------------
+# Shoves defined constants into the export array
+# so they don't have to be listed twice in the code
+# ---------------------------------------------------------------------
+sub econst {
+ my($name, $value) = @_;
+ my $caller = caller;
+ no strict;
+ *{$name} = sub () { $value };
+ push @{$caller.'::EXPORT_OK'}, $name;
+}
+
+
+econst OILS_SIP_MSG_CIRC_EXISTS => 'This item is already checked out';
+econst OILS_SIP_MSG_CIRC_PERMIT_FAILED => 'Patron is not allowed to check out the selected item';
+
+%EXPORT_TAGS = ( const => [ @EXPORT_OK ] );
+
+
--- /dev/null
+#
+#
+# A Class for hiding the ILS's concept of the patron from the OpenSIP
+# system
+#
+
+package OpenILS::SIP::Patron;
+
+use strict;
+use warnings;
+use Exporter;
+
+use Sys::Syslog qw(syslog);
+use Data::Dumper;
+use Digest::MD5 qw(md5_hex);
+
+use OpenILS::SIP;
+use OpenILS::Application::AppUtils;
+use OpenILS::Application::Actor;
+use OpenSRF::Utils qw/:datetime/;
+use DateTime::Format::ISO8601;
+my $U = 'OpenILS::Application::AppUtils';
+
+our (@ISA, @EXPORT_OK);
+
+@ISA = qw(Exporter);
+
+@EXPORT_OK = qw(invalid_patron);
+
+my $INET_PRIVS;
+
+#
+# OpenILS::SIP::Patron->new($barcode);
+# OpenILS::SIP::Patron->new(barcode => $barcode); # same as above
+# OpenILS::SIP::Patron->new( usr => $id);
+
+sub new {
+ my $class = shift;
+ my $key = (@_ > 1) ? shift : 'barcode'; # if we have multiple args, the first is the key index (default barcode)
+ my $patron_id = shift;
+ my %args = @_;
+
+ if ($key ne 'usr' and $key ne 'barcode') {
+ syslog("LOG_ERROR", "Patron (card) lookup requested by illegeal key '$key'");
+ return undef;
+ }
+
+ unless(defined $patron_id) {
+ syslog("LOG_WARNING", "No patron ID provided to ILS::Patron->new");
+ return undef;
+ }
+
+ my $type = ref($class) || $class;
+ my $self = bless({}, $type);
+
+ syslog("LOG_DEBUG", "OILS: new OpenILS Patron(%s => %s): searching...", $key, $patron_id);
+
+ my $e = OpenILS::SIP->editor();
+
+ my $usr_flesh = {
+ flesh => 2,
+ flesh_fields => {
+ au => [
+ "card",
+ "addresses",
+ "billing_address",
+ "mailing_address",
+ 'profile',
+ ],
+ }
+ };
+
+ # in some cases, we don't need all of this data. Only fetch the user + barcode
+ $usr_flesh = {flesh => 1, flesh_fields => {au => ['card']}} if $args{slim_user};
+
+ my $user;
+ if($key eq 'barcode') { # retrieve user by barcode
+
+ $$usr_flesh{flesh} += 1;
+ $$usr_flesh{flesh_fields}{ac} = ['usr'];
+
+ my $card = $e->search_actor_card([{barcode => $patron_id}, $usr_flesh])->[0];
+
+ if(!$card) {
+ syslog("LOG_WARNING", "No such patron barcode: $patron_id");
+ return undef;
+ }
+
+ $user = $card->usr;
+
+ } else {
+ $user = $e->retrieve_actor_user([$patron_id, $usr_flesh]);
+ }
+
+ if(!$user) {
+ syslog("LOG_WARNING", "OILS: Unable to find patron %s => %s", $key, $patron_id);
+ return undef;
+ }
+
+ # now grab the user's penalties
+
+ $self->flesh_user_penalties($user, $e) unless $args{slim_user};
+
+ $self->{editor} = $e;
+ $self->{user} = $user;
+ $self->{id} = ($key eq 'barcode') ? $patron_id : $user->card->barcode; # The barcode IS the ID to SIP.
+ # We give back the passed barcode if the key was indeed a barcode, just to be safe. Otherwise pull it from the card.
+
+ syslog("LOG_DEBUG", "OILS: new OpenILS Patron(%s => %s): found patron : barred=%s, card:active=%s",
+ $key, $patron_id, $user->barred, $user->card->active );
+
+ return $self;
+}
+
+# grab patron penalties. Only grab non-archived penalties that are for fines,
+# excessive overdues, or otherwise block circluation activity
+sub flesh_user_penalties {
+ my ($self, $user, $e) = @_;
+
+ $user->standing_penalties(
+ $e->search_actor_user_standing_penalty([
+ {
+ usr => $user->id,
+ '-or' => [
+
+ # ignore "archived" penalties
+ {stop_date => undef},
+ {stop_date => {'>' => 'now'}}
+ ],
+
+ org_unit => {
+ in => {
+ select => {
+ aou => [{
+ column => 'id',
+ transform => 'actor.org_unit_ancestors',
+ result_field => 'id'
+ }]
+ },
+ from => 'aou',
+
+ # at this point, there is no concept of "here", so fetch penalties
+ # for the patron's home lib plus ancestors
+ where => {id => $user->home_ou},
+ distinct => 1
+ }
+ },
+
+ # in addition to fines and excessive overdue penalties,
+ # we only care about penalties that result in blocks
+ standing_penalty => {
+ in => {
+ select => {csp => ['id']},
+ from => 'csp',
+ where => {
+ '-or' => [
+ {id => [1,2]}, # fines / overdues
+ {block_list => {'!=' => undef}}
+ ]
+ },
+ }
+ }
+ },
+ ])
+ );
+}
+
+sub id {
+ my $self = shift;
+ return $self->{id};
+}
+
+sub name {
+ my $self = shift;
+ return format_name($self->{user});
+}
+
+sub format_name {
+ my $u = shift;
+ return OpenILS::SIP::clean_text(
+ sprintf('%s %s %s',
+ ($u->first_given_name || ''),
+ ($u->second_given_name || ''),
+ ($u->family_name || '')));
+}
+
+sub home_library {
+ my $self = shift;
+ my $lib = OpenILS::SIP::shortname_from_id($self->{user}->home_ou);
+ syslog('LOG_DEBUG', "OILS: Patron->home_library() = $lib");
+ return $lib;
+}
+
+sub __addr_string {
+ my $addr = shift;
+ return "" unless $addr;
+ my $return = OpenILS::SIP::clean_text(
+ join( ' ', map {$_ || ''} (
+ $addr->street1,
+ $addr->street2,
+ $addr->city . ',',
+ $addr->county,
+ $addr->state,
+ $addr->country,
+ $addr->post_code
+ )
+ )
+ );
+ $return =~ s/\s+/ /sg; # Compress any run of of whitespace to one space
+ return $return;
+}
+
+sub internal_id {
+ my $self = shift;
+ return $self->{user}->id;
+}
+
+sub address {
+ my $self = shift;
+ my $u = $self->{user};
+ my $str = __addr_string($u->billing_address || $u->mailing_address);
+ syslog('LOG_DEBUG', "OILS: Patron address: $str");
+ return $str;
+}
+
+sub email_addr {
+ my $self = shift;
+ return OpenILS::SIP::clean_text($self->{user}->email);
+}
+
+sub home_phone {
+ my $self = shift;
+ return $self->{user}->day_phone;
+}
+
+sub sip_birthdate {
+ my $self = shift;
+ my $dob = OpenILS::SIP->format_date($self->{user}->dob);
+ syslog('LOG_DEBUG', "OILS: Patron DOB = $dob");
+ return $dob;
+}
+
+sub ptype {
+ my $self = shift;
+
+ my $use_code = OpenILS::SIP->get_option_value('patron_type_uses_code') || '';
+
+ # should we use the no_i18n version of patron profile name (as a 'code')?
+ return $self->{editor}->retrieve_permission_grp_tree(
+ [$self->{user}->profile->id, {no_i18n => 1}])->name
+ if $use_code =~ /true/io;
+
+ return OpenILS::SIP::clean_text($self->{user}->profile->name);
+}
+
+sub language {
+ my $self = shift;
+ return '000'; # Unspecified
+}
+
+# How much more detail do we need to check here?
+sub charge_ok {
+ my $self = shift;
+ my $u = $self->{user};
+ return (($u->barred eq 'f') and ($u->card->active eq 't'));
+}
+
+# How much more detail do we need to check here?
+sub renew_ok {
+ my $self = shift;
+ return $self->charge_ok;
+}
+
+sub recall_ok {
+ my $self = shift;
+ return 0;
+}
+
+sub hold_ok {
+ my $self = shift;
+ return $self->charge_ok;
+}
+
+# return true if the card provided is marked as lost
+sub card_lost {
+ my $self = shift;
+ return $self->{user}->card->active eq 'f';
+}
+
+sub recall_overdue { # not implemented
+ my $self = shift;
+ return 0;
+}
+
+sub check_password {
+ my ($self, $pwd) = @_;
+ syslog('LOG_DEBUG', 'OILS: Patron->check_password()');
+ return 0 unless (defined $pwd and $self->{user});
+ return md5_hex($pwd) eq $self->{user}->passwd;
+}
+
+sub currency { # not really implemented
+ my $self = shift;
+ syslog('LOG_DEBUG', 'OILS: Patron->currency()');
+ return 'USD';
+}
+
+sub fee_amount {
+ my $self = shift;
+ syslog('LOG_DEBUG', 'OILS: Patron->fee_amount()');
+ my $user_id = $self->{user}->id;
+
+ my $e = $self->{editor};
+ $e->xact_begin;
+ my $summary = $e->retrieve_money_open_user_summary($user_id);
+ $e->rollback; # xact_rollback + disconnect
+
+ my $total = ($summary) ? $summary->balance_owed : 0;
+ syslog('LOG_INFO', "User ".$self->{id} .":$user_id has a fee amount of \$$total");
+ return $total;
+}
+
+sub screen_msg {
+ my $self = shift;
+ my $u = $self->{user};
+
+ return 'barred' if $u->barred eq 't';
+
+ my $b = 'blocked';
+
+ return $b if $u->active eq 'f';
+ return $b if $u->card->active eq 'f';
+
+ # if we have any penalties at this point, they are blocking penalties
+ return $b if $u->standing_penalties and @{$u->standing_penalties};
+
+ # has the patron account expired?
+ my $expire = DateTime::Format::ISO8601->new->parse_datetime(cleanse_ISO8601($u->expire_date));
+ return $b if CORE::time > $expire->epoch;
+
+ return 'OK';
+}
+
+sub print_line { # not implemented
+ my $self = shift;
+ return '';
+}
+
+sub too_many_charged { # not implemented
+ my $self = shift;
+ return 0;
+}
+
+sub too_many_overdue {
+ my $self = shift;
+ return scalar( # PATRON_EXCEEDS_OVERDUE_COUNT
+ grep { $_->standing_penalty == 2 } @{$self->{user}->standing_penalties}
+ );
+}
+
+# not completely sure what this means
+sub too_many_renewal {
+ my $self = shift;
+ return 0;
+}
+
+# not relevant, handled by fines/fees
+sub too_many_claim_return {
+ my $self = shift;
+ return 0;
+}
+
+# not relevant, handled by fines/fees
+sub too_many_lost {
+ my $self = shift;
+ return 0;
+}
+
+sub excessive_fines {
+ my $self = shift;
+ return scalar( # PATRON_EXCEEDS_FINES
+ grep { $_->standing_penalty == 1 } @{$self->{user}->standing_penalties}
+ );
+}
+
+# Until someone suggests otherwise, fees and fines are the same
+
+sub excessive_fees {
+ my $self = shift;
+ return $self->excessive_fines;
+}
+
+# not relevant, handled by fines/fees
+sub too_many_billed {
+ my $self = shift;
+ return 0;
+}
+
+
+
+#
+# List of outstanding holds placed
+#
+sub hold_items {
+ my ($self, $start, $end) = @_;
+ syslog('LOG_DEBUG', 'OILS: Patron->hold_items()');
+
+ my $holds = $self->{editor}->search_action_hold_request(
+ { usr => $self->{user}->id, fulfillment_time => undef, cancel_time => undef }
+ );
+
+ my @holds;
+ push( @holds, OpenILS::SIP::clean_text($self->__hold_to_title($_)) ) for @$holds;
+
+ return (defined $start and defined $end) ?
+ [ $holds[($start-1)..($end-1)] ] :
+ \@holds;
+}
+
+sub __hold_to_title {
+ my $self = shift;
+ my $hold = shift;
+ my $e = $self->{editor};
+
+ my( $id, $mods, $title, $volume, $copy );
+
+ return __copy_to_title($e,
+ $e->retrieve_asset_copy($hold->target))
+ if $hold->hold_type eq 'C';
+
+ return __volume_to_title($e,
+ $e->retrieve_asset_call_number($hold->target))
+ if $hold->hold_type eq 'V';
+
+ return __record_to_title(
+ $e, $hold->target) if $hold->hold_type eq 'T';
+
+ return __metarecord_to_title(
+ $e, $hold->target) if $hold->hold_type eq 'M';
+}
+
+sub __copy_to_title {
+ my( $e, $copy ) = @_;
+ #syslog('LOG_DEBUG', "OILS: copy_to_title(%s)", $copy->id);
+ return $copy->dummy_title if $copy->call_number == -1;
+
+ my $vol = (ref $copy->call_number) ?
+ $copy->call_number :
+ $e->retrieve_asset_call_number($copy->call_number);
+
+ return __volume_to_title($e, $vol);
+}
+
+
+sub __volume_to_title {
+ my( $e, $volume ) = @_;
+ #syslog('LOG_DEBUG', "OILS: volume_to_title(%s)", $volume->id);
+ return __record_to_title($e, $volume->record);
+}
+
+
+sub __record_to_title {
+ my( $e, $title_id ) = @_;
+ #syslog('LOG_DEBUG', "OILS: record_to_title($title_id)");
+ my $mods = $U->simplereq(
+ 'open-ils.search',
+ 'open-ils.search.biblio.record.mods_slim.retrieve', $title_id );
+ return ($mods) ? $mods->title : "";
+}
+
+sub __metarecord_to_title {
+ my( $e, $m_id ) = @_;
+ #syslog('LOG_DEBUG', "OILS: metarecord_to_title($m_id)");
+ my $mods = $U->simplereq(
+ 'open-ils.search',
+ 'open-ils.search.biblio.metarecord.mods_slim.retrieve', $m_id);
+ return ($U->event_code($mods)) ? "<unknown>" : $mods->title;
+}
+
+
+#
+# remove the hold on item item_id from my hold queue.
+# return true if I was holding the item, false otherwise.
+#
+sub drop_hold {
+ my ($self, $item_id) = @_;
+ return 0;
+}
+
+sub __patron_items_info {
+ my $self = shift;
+ return if $self->{item_info};
+ $self->{item_info} =
+ OpenILS::Application::Actor::_checked_out(
+ 0, $self->{editor}, $self->{user}->id);;
+}
+
+
+
+sub overdue_items {
+ my ($self, $start, $end) = @_;
+
+ $self->__patron_items_info();
+ my @overdues = @{$self->{item_info}->{overdue}};
+ #$overdues[$_] = __circ_to_title($self->{editor}, $overdues[$_]) for @overdues;
+
+ my @o;
+ syslog('LOG_DEBUG', "OILS: overdue_items() fleshing circs @overdues");
+
+ my $return_datatype = OpenILS::SIP->get_option_value('msg64_summary_datatype') || '';
+
+ for my $circid (@overdues) {
+ next unless $circid;
+ if($return_datatype eq 'barcode') {
+ push( @o, __circ_to_barcode($self->{editor}, $circid));
+ } else {
+ push( @o, OpenILS::SIP::clean_text(__circ_to_title($self->{editor}, $circid)));
+ }
+ }
+ @overdues = @o;
+
+ return (defined $start and defined $end) ?
+ [ $overdues[($start-1)..($end-1)] ] : \@overdues;
+}
+
+sub __circ_to_barcode {
+ my ($e, $circ) = @_;
+ return unless $circ;
+ $circ = $e->retrieve_action_circulation($circ);
+ my $copy = $e->retrieve_asset_copy($circ->target_copy);
+ return $copy->barcode;
+}
+
+sub __circ_to_title {
+ my( $e, $circ ) = @_;
+ return unless $circ;
+ $circ = $e->retrieve_action_circulation($circ);
+ return __copy_to_title( $e,
+ $e->retrieve_asset_copy($circ->target_copy) );
+}
+
+sub charged_items {
+ my ($self, $start, $end) = shift;
+
+ $self->__patron_items_info();
+
+ my @charges = (
+ @{$self->{item_info}->{out}},
+ @{$self->{item_info}->{overdue}}
+ );
+
+ #$charges[$_] = __circ_to_title($self->{editor}, $charges[$_]) for @charges;
+
+ my @c;
+ syslog('LOG_DEBUG', "OILS: charged_items() fleshing circs @charges");
+
+ my $return_datatype = OpenILS::SIP->get_option_value('msg64_summary_datatype') || '';
+
+ for my $circid (@charges) {
+ next unless $circid;
+ if($return_datatype eq 'barcode') {
+ push( @c, __circ_to_barcode($self->{editor}, $circid));
+ } else {
+ push( @c, OpenILS::SIP::clean_text(__circ_to_title($self->{editor}, $circid)));
+ }
+ }
+
+ @charges = @c;
+
+ return (defined $start and defined $end) ?
+ [ $charges[($start-1)..($end-1)] ] :
+ \@charges;
+}
+
+sub fine_items {
+ my ($self, $start, $end) = @_;
+ my @fines;
+ syslog('LOG_DEBUG', 'OILS: Patron->fine_items()');
+ return (defined $start and defined $end) ?
+ [ $fines[($start-1)..($end-1)] ] : \@fines;
+}
+
+# not currently supported
+sub recall_items {
+ my ($self, $start, $end) = @_;
+ return [];
+}
+
+sub unavail_holds {
+ my ($self, $start, $end) = @_;
+ my @holds;
+ syslog('LOG_DEBUG', 'OILS: Patron->unavail_holds()');
+ return (defined $start and defined $end) ?
+ [ $holds[($start-1)..($end-1)] ] : \@holds;
+}
+
+sub block {
+ my ($self, $card_retained, $blocked_card_msg) = @_;
+ $blocked_card_msg ||= '';
+
+ my $e = $self->{editor};
+ my $u = $self->{user};
+
+ syslog('LOG_INFO', "OILS: Blocking user %s", $u->card->barcode );
+
+ return $self if $u->card->active eq 'f';
+
+ $e->xact_begin; # connect and start a new transaction
+
+ $u->card->active('f');
+ if( ! $e->update_actor_card($u->card) ) {
+ syslog('LOG_ERR', "OILS: Block card update failed: %s", $e->event->{textcode});
+ $e->rollback; # rollback + disconnect
+ return $self;
+ }
+
+ # retrieve the un-fleshed user object for update
+ $u = $e->retrieve_actor_user($u->id);
+ my $note = OpenILS::SIP::clean_text($u->alert_message) || "";
+ $note = "<sip> CARD BLOCKED BY SELF-CHECK MACHINE. $blocked_card_msg</sip>\n$note"; # XXX Config option
+ $note =~ s/\s*$//; # kill trailng whitespace
+ $u->alert_message($note);
+
+ if( ! $e->update_actor_user($u) ) {
+ syslog('LOG_ERR', "OILS: Block: patron alert update failed: %s", $e->event->{textcode});
+ $e->rollback; # rollback + disconnect
+ return $self;
+ }
+
+ # stay in synch
+ $self->{user}->alert_message( $note );
+
+ $e->commit; # commits and disconnects
+ return $self;
+}
+
+# Testing purposes only
+sub enable {
+ my ($self, $card_retained) = @_;
+ $self->{screen_msg} = "All privileges restored.";
+
+ # Un-mark card as inactive, grep out the patron alert
+ my $e = $self->{editor};
+ my $u = $self->{user};
+
+ syslog('LOG_INFO', "OILS: Unblocking user %s", $u->card->barcode );
+
+ return $self if $u->card->active eq 't';
+
+ $e->xact_begin; # connect and start a new transaction
+
+ $u->card->active('t');
+ if( ! $e->update_actor_card($u->card) ) {
+ syslog('LOG_ERR', "OILS: Unblock card update failed: %s", $e->event->{textcode});
+ $e->rollback; # rollback + disconnect
+ return $self;
+ }
+
+ # retrieve the un-fleshed user object for update
+ $u = $e->retrieve_actor_user($u->id);
+ my $note = OpenILS::SIP::clean_text($u->alert_message) || "";
+ $note =~ s#<sip>.*</sip>##;
+ $note =~ s/^\s*//; # kill leading whitespace
+ $note =~ s/\s*$//; # kill trailng whitespace
+ $u->alert_message($note);
+
+ if( ! $e->update_actor_user($u) ) {
+ syslog('LOG_ERR', "OILS: Unblock: patron alert update failed: %s", $e->event->{textcode});
+ $e->rollback; # rollback + disconnect
+ return $self;
+ }
+
+ # stay in synch
+ $self->{user}->alert_message( $note );
+
+ $e->commit; # commits and disconnects
+ return $self;
+}
+
+#
+# Messages
+#
+
+sub invalid_patron {
+ return "Please contact library staff";
+}
+
+sub charge_denied {
+ return "Please contact library staff";
+}
+
+sub inet_privileges {
+ my( $self ) = @_;
+ my $e = OpenILS::SIP->editor();
+ $INET_PRIVS = $e->retrieve_all_config_net_access_level() unless $INET_PRIVS;
+ my ($level) = grep { $_->id eq $self->{user}->net_access_level } @$INET_PRIVS;
+ my $name = OpenILS::SIP::clean_text($level->name);
+ syslog('LOG_DEBUG', "OILS: Patron inet_privs = $name");
+ return $name;
+}
+
+
+1;
--- /dev/null
+#
+# Transaction: Superclass of all the transactional status objects
+#
+
+package OpenILS::SIP::Transaction;
+
+use Carp;
+use strict; use warnings;
+use Sys::Syslog qw(syslog);
+
+use OpenILS::SIP;
+use OpenILS::SIP::Msg qw/:const/;
+
+
+my %fields = (
+ ok => 0,
+ patron => undef,
+ item => undef,
+ desensitize => 0,
+ alert => '',
+ transation_id => undef,
+ sip_fee_type => '01', # Other/Unknown
+ fee_amount => undef,
+ sip_currency => 'CAD',
+ screen_msg => '',
+ print_line => '',
+ editor => undef,
+ authtoken => '',
+);
+
+our $AUTOLOAD;
+
+sub new {
+ my( $class, %args ) = @_;
+
+ my $self = { _permitted => \%fields, %fields };
+
+ bless $self, $class;
+ $self->authtoken($args{authtoken});
+
+ syslog('LOG_DEBUG', "OILS: Created new transaction with authtoken %s", $self->authtoken);
+
+ my $e = OpenILS::SIP->editor();
+ $e->{authtoken} = $self->authtoken;
+
+ return $self;
+}
+
+sub DESTROY {
+ # be cool
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $class = ref($self) or croak "$self is not an object";
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*://;
+
+ unless (exists $self->{_permitted}->{$name}) {
+ croak "Can't access '$name' field of class '$class'";
+ }
+
+ if (@_) {
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+}
+
+1;
--- /dev/null
+package OpenILS::SIP::Transaction::Checkin;
+use warnings; use strict;
+
+use POSIX qw(strftime);
+use Sys::Syslog qw(syslog);
+use Data::Dumper;
+use Time::HiRes q/time/;
+
+use OpenILS::SIP;
+use OpenILS::SIP::Transaction;
+use OpenILS::Const qw/:const/;
+use OpenILS::Application::AppUtils;
+my $U = 'OpenILS::Application::AppUtils';
+
+use base qw(OpenILS::SIP::Transaction);
+
+my $debug = 0;
+
+my %fields = (
+ magnetic => 0,
+ sort_bin => undef,
+ # 3M extensions: (most of the data is stored under Item)
+# collection_code => undef,
+# call_number => undef,
+ destination_loc => undef,
+ alert_type => undef, # 00,01,02,03,04 or 99
+# hold_patron_id => undef,
+# hold_patron_name => "",
+# hold => undef,
+);
+
+sub new {
+ my $class = shift;;
+ my $self = $class->SUPER::new(@_); # start with an Transaction object
+
+ foreach (keys %fields) {
+ $self->{_permitted}->{$_} = $fields{$_}; # overlaying _permitted
+ }
+
+ @{$self}{keys %fields} = values %fields; # copying defaults into object
+
+ $self->load_override_events;
+
+ return bless $self, $class;
+}
+
+sub resensitize {
+ my $self = shift;
+ return 0 if !$self->{item};
+ return !$self->{item}->magnetic;
+}
+
+my %override_events;
+sub load_override_events {
+ return if %override_events;
+ my $override = OpenILS::SIP->config->{implementation_config}->{checkin_override};
+ return unless $override;
+ my $events = $override->{event};
+ $events = [$events] unless ref $events eq 'ARRAY';
+ $override_events{$_} = 1 for @$events;
+}
+
+my %org_sn_cache;
+sub do_checkin {
+ my $self = shift;
+ my ($sip_handler, $inst_id, $trans_date, $return_date, $current_loc, $item_props) = @_; # most unused
+
+ unless($self->{item}) {
+ $self->ok(0);
+ return undef;
+ }
+
+ $inst_id ||= '';
+
+ # physical location defaults to ws ou of the logged in sip user,
+ # which currently defaults to home_ou, since ws's aren't used.
+ my $phys_location = $sip_handler->{login_session}->ws_ou;
+
+ my $args = {barcode => $self->{item}->id};
+
+ if($return_date) {
+ # SIP date format is YYYYMMDD. Translate to ISO8601
+ $return_date =~ s/(\d{4})(\d{2})(\d{2}).*/$1-$2-$3/;
+ syslog('LOG_INFO', "Checking in with backdate $return_date");
+ $args->{backdate} = $return_date;
+ }
+
+ if($current_loc) { # SIP client specified a physical location
+
+ my $org_id = (defined $org_sn_cache{$current_loc}) ?
+ $org_sn_cache{$current_loc} :
+ OpenILS::SIP->editor()->search_actor_org_unit({shortname => $current_loc}, {idlist => 1})->[0];
+
+ $org_sn_cache{$current_loc} = $org_id;
+
+ # if the caller specifies a physical location, use it as the checkin circ lib
+ $args->{circ_lib} = $phys_location = $org_id if defined $org_id;
+ }
+
+ my $override = 0;
+ my ($resp, $txt, $code);
+
+ while(1) {
+
+ my $method = 'open-ils.circ.checkin';
+ $method .= '.override' if $override;
+
+ my $start_time = time();
+ $resp = $U->simplereq('open-ils.circ', $method, $self->{authtoken}, $args);
+ syslog('LOG_INFO', "OILS: Checkin API call took %0.3f seconds", (time() - $start_time));
+
+ if ($debug) {
+ my $s = Dumper($resp);
+ $s =~ s/\n//mog;
+ syslog('LOG_INFO', "OILS: Checkin response: $s");
+ }
+
+ # In oddball cases, we can receive an array of events.
+ # The first event received should be treated as the main result.
+ $resp = $$resp[0] if ref($resp) eq 'ARRAY';
+ $code = $U->event_code($resp);
+ $txt = (defined $code) ? $resp->{textcode} : '';
+
+ last if $override;
+
+ if ( $override_events{$txt} ) {
+ $override = 1;
+ } else {
+ last;
+ }
+ }
+
+ syslog('LOG_INFO', "OILS: Checkin resulted in event: $txt, phys_location: $phys_location");
+
+ $resp->{org} &&= OpenILS::SIP::shortname_from_id($resp->{org}); # Convert id to shortname
+
+ $self->destination_loc($resp->{org}) if $resp->{org};
+
+ if ($txt eq 'ROUTE_ITEM') {
+ # Note, this alert_type will be overridden below if this is a hold transit
+ $self->alert_type('04'); # send to other branch
+
+ } elsif ($txt and $txt ne 'NO_CHANGE' and $txt ne 'SUCCESS') {
+ syslog('LOG_WARNING', "OILS: Checkin returned unexpected event $code : $txt");
+ $self->alert_type('00'); # unknown
+ }
+
+ my $payload = $resp->{payload} || {};
+
+ my ($circ, $copy);
+
+ if(ref $payload eq 'HASH') {
+
+ # Two places to look for hold data. These are more important and more definitive than above.
+ if ($payload->{remote_hold}) {
+ # actually only used for checkin at non-owning branch w/ hold at same branch
+ $self->item->hold($payload->{remote_hold});
+
+ } elsif ($payload->{hold}) {
+ $self->item->hold($payload->{hold});
+ }
+
+ $circ = $resp->{payload}->{circ} || '';
+ $copy = $resp->{payload}->{copy} || '';
+ }
+
+ if ($self->item->hold) {
+ my ($pickup_lib_id, $pickup_lib_sn);
+
+ my $holder = OpenILS::SIP->editor()->retrieve_actor_user(
+ [$self->item->hold->usr, {flesh => 1, flesh_fields => {au => ['card']}}]);
+
+ my $holder_name = OpenILS::SIP::Patron::format_name($holder);
+
+ if (ref $self->item->hold->pickup_lib) {
+ $pickup_lib_id = $self->item->hold->pickup_lib->id;
+ $pickup_lib_sn = $self->item->hold->pickup_lib->shortname;
+
+ } else {
+ $pickup_lib_id = $self->item->hold->pickup_lib;
+ $pickup_lib_sn = OpenILS::SIP::shortname_from_id($pickup_lib_id);
+ }
+
+ $self->item->hold_patron_bcode( ($holder->card) ? $holder->card->barcode : '');
+ $self->item->hold_patron_name($holder_name);
+ $self->item->destination_loc($pickup_lib_sn);
+
+ my $atype = ($pickup_lib_id == $phys_location) ? '01' : '02';
+ $self->alert_type($atype);
+ }
+
+ $self->alert(1) if defined $self->alert_type; # alert_type could be "00", hypothetically
+
+ if ( $circ ) {
+ $self->{circ_user_id} = $circ->usr;
+ $self->ok(1);
+ } elsif ($txt eq 'NO_CHANGE' or $txt eq 'SUCCESS' or $txt eq 'ROUTE_ITEM') {
+ $self->ok(1); # NO_CHANGE means it wasn't checked out anyway, no problem
+ } else {
+ $self->alert(1);
+ $self->alert_type('00') unless $self->alert_type; # wasn't checked out, but *something* changed
+ # $self->ok(0); # maybe still ok?
+ }
+}
+
+1;
+__END__
+
+Successful Checkin event payload includes:
+ $payload->{copy} (unfleshed)
+ $payload->{record}
+ $payload->{circ}
+ $payload->{transit}
+ $payload->{cancelled_hold_transit}
+ $payload->{hold}
+ $payload->{patron}
+
+Some EVENT strings:
+ SUCCESS => ,
+ ASSET_COPY_NOT_FOUND => ,
+ NO_CHANGE => ,
+ PERM_FAILURE => ,
+ CIRC_CLAIMS_RETURNED => ,
+ COPY_ALERT_MESSAGE => ,
+ COPY_STATUS_LOST => ,
+ COPY_STATUS_MISSING => ,
+ COPY_BAD_STATUS => ,
+ ITEM_DEPOSIT_PAID => ,
+ ROUTE_ITEM => ,
+ DATABASE_UPDATE_FAILED => ,
+ DATABASE_QUERY_FAILED => ,
+
+# alert_type:
+# 00 - Unknown
+# 01 - hold in local library
+# 02 - hold for other branch
+# 03 - hold for ILL (not used in EG)
+# 04 - send to other branch (no hold)
+# 99 - Other
--- /dev/null
+#
+# An object to handle checkout status
+#
+
+package OpenILS::SIP::Transaction::Checkout;
+
+use warnings;
+use strict;
+
+use POSIX qw(strftime);
+
+use OpenILS::SIP;
+use OpenILS::SIP::Transaction;
+use OpenILS::SIP::Msg qw/:const/;
+use Sys::Syslog qw(syslog);
+
+use OpenILS::Application::AppUtils;
+my $U = 'OpenILS::Application::AppUtils';
+
+
+our @ISA = qw(OpenILS::SIP::Transaction);
+
+# Most fields are handled by the Transaction superclass
+my %fields = (
+ security_inhibit => 0,
+ due => undef,
+ renew_ok => 0,
+ );
+
+sub new {
+ my $class = shift;
+
+ my $self = $class->SUPER::new(@_);
+
+ my $element;
+
+ foreach $element (keys %fields) {
+ $self->{_permitted}->{$element} = $fields{$element};
+ }
+
+ @{$self}{keys %fields} = values %fields;
+
+ return bless $self, $class;
+}
+
+
+# if this item is already checked out to the requested patron,
+# renew the item and set $self->renew_ok to true.
+# XXX if it's a renewal and the renewal is not permitted, set
+# $self->screen_msg("Item on Hold for Another User"); (or somesuch)
+# XXX Set $self->ok(0) on any errors
+sub do_checkout {
+ my $self = shift;
+ my $is_renew = shift || 0;
+
+ $self->ok(0);
+
+ my $args = {
+ barcode => $self->{item}->id,
+ patron_barcode => $self->{patron}->id
+ };
+
+ my $resp;
+
+ if ($is_renew) {
+ $resp = $U->simplereq(
+ 'open-ils.circ',
+ 'open-ils.circ.renew', $self->{authtoken},
+ { barcode => $self->item->id, patron_barcode => $self->patron->id });
+ } else {
+ $resp = $U->simplereq(
+ 'open-ils.circ',
+ 'open-ils.circ.checkout.permit',
+ $self->{authtoken}, $args );
+
+ $resp = [$resp] unless ref $resp eq 'ARRAY';
+
+ my $key;
+
+ syslog('LOG_DEBUG', "OILS: Checkout permit returned event: " . OpenSRF::Utils::JSON->perl2JSON($resp));
+
+ if( @$resp == 1 and ! $U->event_code($$resp[0]) ) {
+ $key = $$resp[0]->{payload};
+ syslog('LOG_INFO', "OILS: circ permit key => $key");
+
+ } else {
+
+ # We got one or more non-success events
+ $self->screen_msg('');
+ for my $r (@$resp) {
+
+ if( my $code = $U->event_code($resp) ) {
+ my $txt = $resp->{textcode};
+ syslog('LOG_INFO', "OILS: Checkout permit failed with event $code : $txt");
+
+ if( $txt eq 'OPEN_CIRCULATION_EXISTS' ) {
+ $self->screen_msg(OILS_SIP_MSG_CIRC_EXISTS);
+ return 0;
+ } else {
+ $self->screen_msg(OILS_SIP_MSG_CIRC_PERMIT_FAILED);
+ }
+ }
+ }
+ return 0;
+ }
+
+ # --------------------------------------------------------------------
+ # Now do the actual checkout
+ # --------------------------------------------------------------------
+
+ $args = {
+ permit_key => $key,
+ patron_barcode => $self->{patron}->id,
+ barcode => $self->{item}->id
+ };
+
+ $resp = $U->simplereq(
+ 'open-ils.circ',
+ 'open-ils.circ.checkout', $self->{authtoken}, $args );
+ }
+
+ syslog('LOG_INFO', "OILS: Checkout returned event: " . OpenSRF::Utils::JSON->perl2JSON($resp));
+
+ # XXX Check for events
+ if( $resp ) {
+
+ if( my $code = $U->event_code($resp) ) {
+ my $txt = $resp->{textcode};
+ syslog('LOG_INFO', "OILS: Checkout failed with event $code : $txt");
+ $self->screen_msg('Checkout failed. Please contact a librarian');
+ return 0;
+ }
+
+ syslog('LOG_INFO', "OILS: Checkout succeeded");
+
+ my $circ = $resp->{payload}->{circ};
+ $self->{'due'} = OpenILS::SIP->format_date($circ->due_date, 'due');
+ $self->ok(1);
+
+ return 1;
+ }
+
+ return 0;
+}
+
+
+
+1;
--- /dev/null
+#
+# Status of a Renew Transaction
+#
+
+package OpenILS::SIP::Transaction::Renew;
+use warnings; use strict;
+
+use Sys::Syslog qw(syslog);
+use OpenILS::SIP;
+use OpenILS::SIP::Transaction;
+use OpenILS::Application::AppUtils;
+my $U = 'OpenILS::Application::AppUtils';
+
+our @ISA = qw(OpenILS::SIP::Transaction);
+
+my %fields = (
+ renewal_ok => 0,
+ );
+
+sub new {
+ my $class = shift;;
+ my $self = $class->SUPER::new(@_);
+
+ $self->{_permitted}->{$_} = $fields{$_} for keys %fields;
+ @{$self}{keys %fields} = values %fields;
+
+ return bless $self, $class;
+}
+
+sub do_renew {
+ my $self = shift;
+
+ my $resp = $U->simplereq(
+ 'open-ils.circ',
+ 'open-ils.circ.renew', $self->{authtoken},
+ { barcode => $self->item->id, patron_barcode => $self->patron->id });
+
+ if( my $code = $U->event_code($resp) ) {
+ syslog('LOG_INFO', "OILS: Renewal failed with event $code : " . $resp->{textcode});
+ $self->renewal_ok(0);
+ $self->ok(0);
+ return $self;
+ }
+
+ $self->item->{due_date} = $resp->{payload}->{circ}->due_date;
+ syslog('LOG_INFO', "OILS: Renewal succeeded with due_date = " . $self->item->{due_date});
+
+ $self->renewal_ok(1);
+ $self->ok(1);
+
+ return $self;
+}
+
+
+
+
+1;
--- /dev/null
+package OpenILS::Template::Plugin::Unicode;
+use Unicode::Normalize;
+
+sub new { return bless {}, __PACKAGE__ }
+sub load { return __PACKAGE__ }
+
+sub C { shift; return NFC(@_); }
+sub D { shift; return NFD(@_); }
+sub entityDecode { shift; $_ = shift; s/&#x([0-9a-fA-F]+);/chr(hex($1))/egos; return $_ }
+sub entityEncode { shift; $_ = shift; s/(\PM\pM+)/sprintf('&#x%0.4x;',ord(NFC($1)))/sgoe; return $_ }
+
+1;
--- /dev/null
+package OpenILS::Template::Plugin::WebSession;
+use strict; use warnings;
+use OpenILS::Utils::Fieldmapper;
+
+use Template::Plugin;
+use base qw/Template::Plugin/;
+use OpenSRF::AppSession;
+use OpenSRF::System;
+
+sub new {
+ my ($class) = @_;
+ $class = ref($class) || $class;
+ my $self = {};
+ return bless($self,$class);
+}
+
+my $bootstrapped = 0;
+sub bootstrap_client {
+ my( $self, $config_file ) = @_;
+ if(!$bootstrapped) {
+ OpenSRF::System->bootstrap_client( config_file => $config_file );
+ $bootstrapped = 1;
+ }
+}
+
+sub init_app_session {
+ my($self, $service) = @_;
+ return undef unless $service;
+ return OpenSRF::AppSession->create($service);
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::Template::Plugin::WebUtils;
+use strict; use warnings;
+use OpenILS::Utils::Fieldmapper;
+
+use Template::Plugin;
+use base qw/Template::Plugin/;
+use OpenSRF::AppSession;
+use OpenSRF::System;
+use XML::LibXML;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::JSON;
+
+sub new {
+ my ($class) = @_;
+ $class = ref($class) || $class;
+ my $self = {};
+ return bless($self,$class);
+}
+
+
+sub XML2perl {
+ my( $self, $doc ) = @_;
+ return OpenSRF::Utils::SettingsParser::XML2perl($doc);
+}
+
+
+sub perl2JSON {
+ my( $self, $perl ) = @_;
+ my $json = OpenSRF::Utils::JSON->perl2JSON($perl);
+ warn "Created JSON from perl:\n$json\n";
+ return $json;
+}
+
+sub JSON2perl {
+ my( $self, $perl ) = @_;
+ warn "Turning JSON into perl:\n$perl\n";
+ my $obj = OpenSRF::Utils::JSON->JSON2perl($perl);
+ warn "Created Perl from JSON: $obj \n";
+ return $obj;
+}
+
+sub perl2prettyJSON {
+ my( $self, $perl ) = @_;
+ return OpenSRF::Utils::JSON->perl2prettyJSON($perl);
+}
+
+
+
+1;
--- /dev/null
+use strict; use warnings;
+package OpenILS::Utils::CStoreEditor;
+use OpenILS::Application::AppUtils;
+use OpenSRF::AppSession;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Event;
+use Data::Dumper;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw($logger);
+my $U = "OpenILS::Application::AppUtils";
+my %PERMS;
+my $cache;
+my %xact_ed_cache;
+
+our $always_xact = 0;
+our $_loaded = 1;
+
+#my %PERMS = (
+# 'biblio.record_entry' => { update => 'UPDATE_MARC' },
+# 'asset.copy' => { update => 'UPDATE_COPY'},
+# 'asset.call_number' => { update => 'UPDATE_VOLUME'},
+# 'action.circulation' => { retrieve => 'VIEW_CIRCULATIONS'},
+#);
+
+sub flush_forced_xacts {
+ for my $k ( keys %xact_ed_cache ) {
+ try {
+ $xact_ed_cache{$k}->rollback;
+ } catch Error with {
+ # rollback failed
+ };
+ delete $xact_ed_cache{$k};
+ }
+}
+
+# -----------------------------------------------------------------------------
+# Export some useful functions
+# -----------------------------------------------------------------------------
+use vars qw(@EXPORT_OK %EXPORT_TAGS);
+use Exporter;
+use base qw/Exporter/;
+push @EXPORT_OK, ( 'new_editor', 'new_rstore_editor' );
+%EXPORT_TAGS = ( funcs => [ qw/ new_editor new_rstore_editor / ] );
+
+sub new_editor { return OpenILS::Utils::CStoreEditor->new(@_); }
+
+sub new_rstore_editor {
+ my $e = OpenILS::Utils::CStoreEditor->new(@_);
+ $e->app('open-ils.reporter-store');
+ return $e;
+}
+
+
+# -----------------------------------------------------------------------------
+# Log levels
+# -----------------------------------------------------------------------------
+use constant E => 'error';
+use constant W => 'warn';
+use constant I => 'info';
+use constant D => 'debug';
+use constant A => 'activity';
+
+
+
+# -----------------------------------------------------------------------------
+# Params include:
+# xact=><true> : creates a storage transaction
+# authtoken=>$token : the login session key
+# -----------------------------------------------------------------------------
+sub new {
+ my( $class, %params ) = @_;
+ $class = ref($class) || $class;
+ my $self = bless( \%params, $class );
+ $self->{checked_perms} = {};
+ return $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->reset;
+ return undef;
+}
+
+sub app {
+ my( $self, $app ) = @_;
+ $self->{app} = $app if $app;
+ $self->{app} = 'open-ils.cstore' unless $self->{app};
+ return $self->{app};
+}
+
+
+# -----------------------------------------------------------------------------
+# Log the editor metadata along with the log string
+# -----------------------------------------------------------------------------
+sub log {
+ my( $self, $lev, $str ) = @_;
+ my $s = "editor[";
+ if ($always_xact) {
+ $s .= "!|";
+ } elsif ($self->{xact}) {
+ $s .= "1|";
+ } else {
+ $s .= "0|";
+ }
+ $s .= "0" unless $self->requestor;
+ $s .= $self->requestor->id if $self->requestor;
+ $s .= "]";
+ $logger->$lev("$s $str");
+}
+
+# -----------------------------------------------------------------------------
+# Verifies the auth token and fetches the requestor object
+# -----------------------------------------------------------------------------
+sub checkauth {
+ my $self = shift;
+ $self->log(D, "checking auth token ".$self->authtoken);
+ my ($reqr, $evt) = $U->checkses($self->authtoken);
+ $self->event($evt) if $evt;
+ return $self->{requestor} = $reqr;
+}
+
+
+=head test
+sub checkauth {
+ my $self = shift;
+ $cache = OpenSRF::Utils::Cache->new('global') unless $cache;
+ $self->log(D, "checking cached auth token ".$self->authtoken);
+ my $user = $cache->get_cache("oils_auth_".$self->authtoken);
+ return $self->{requestor} = $user->{userobj} if $user;
+ $self->event(OpenILS::Event->new('NO_SESSION'));
+ return undef;
+}
+=cut
+
+
+# -----------------------------------------------------------------------------
+# Returns the last generated event
+# -----------------------------------------------------------------------------
+sub event {
+ my( $self, $evt ) = @_;
+ $self->{event} = $evt if $evt;
+ return $self->{event};
+}
+
+# -----------------------------------------------------------------------------
+# Destroys the transaction and disconnects where necessary,
+# then returns the last event that occurred
+# -----------------------------------------------------------------------------
+sub die_event {
+ my $self = shift;
+ my $evt = shift;
+ $self->rollback;
+ $self->died(1);
+ $self->event($evt);
+ return $self->event;
+}
+
+
+# -----------------------------------------------------------------------------
+# Clears the last caught event
+# -----------------------------------------------------------------------------
+sub clear_event {
+ my $self = shift;
+ $self->{event} = undef;
+}
+
+sub died {
+ my($self, $died) = @_;
+ $self->{died} = $died if defined $died;
+ return $self->{died};
+}
+
+sub authtoken {
+ my( $self, $auth ) = @_;
+ $self->{authtoken} = $auth if $auth;
+ return $self->{authtoken};
+}
+
+sub timeout {
+ my($self, $to) = @_;
+ $self->{timeout} = $to if defined $to;
+ return defined($self->{timeout}) ? $self->{timeout} : 60;
+}
+
+# -----------------------------------------------------------------------------
+# fetches the session, creating if necessary. If 'xact' is true on this
+# object, a db session is created
+# -----------------------------------------------------------------------------
+sub session {
+ my( $self, $session ) = @_;
+ $self->{session} = $session if $session;
+
+ if(!$self->{session}) {
+ $self->{session} = OpenSRF::AppSession->create($self->app);
+
+ if( ! $self->{session} ) {
+ my $str = "Error creating cstore session with OpenSRF::AppSession->create()!";
+ $self->log(E, $str);
+ throw OpenSRF::EX::ERROR ($str);
+ }
+
+ $self->{session}->connect if $self->{xact} or $self->{connect} or $always_xact;
+ $self->xact_begin if $self->{xact} or $always_xact;
+ }
+
+ $xact_ed_cache{$self->{xact_id}} = $self if $always_xact and $self->{xact_id};
+ return $self->{session};
+}
+
+
+# -----------------------------------------------------------------------------
+# Starts a storage transaction
+# -----------------------------------------------------------------------------
+sub xact_begin {
+ my $self = shift;
+ return $self->{xact_id} if $self->{xact_id};
+ $self->session->connect unless $self->session->state == OpenSRF::AppSession::CONNECTED();
+ $self->log(D, "starting new database transaction");
+ unless($self->{xact_id}) {
+ my $stat = $self->request($self->app . '.transaction.begin');
+ $self->log(E, "error starting database transaction") unless $stat;
+ $self->{xact_id} = $stat;
+ }
+ $self->{xact} = 1;
+ return $self->{xact_id};
+}
+
+# -----------------------------------------------------------------------------
+# Commits a storage transaction
+# -----------------------------------------------------------------------------
+sub xact_commit {
+ my $self = shift;
+ return unless $self->{xact_id};
+ $self->log(D, "comitting db session");
+ my $stat = $self->request($self->app.'.transaction.commit');
+ $self->log(E, "error comitting database transaction") unless $stat;
+ delete $self->{xact_id};
+ delete $self->{xact};
+ return $stat;
+}
+
+# -----------------------------------------------------------------------------
+# Rolls back a storage stransaction
+# -----------------------------------------------------------------------------
+sub xact_rollback {
+ my $self = shift;
+ return unless $self->{session} and $self->{xact_id};
+ $self->log(I, "rolling back db session");
+ my $stat = $self->request($self->app.".transaction.rollback");
+ $self->log(E, "error rolling back database transaction") unless $stat;
+ delete $self->{xact_id};
+ delete $self->{xact};
+ return $stat;
+}
+
+
+# -----------------------------------------------------------------------------
+# Savepoint functions. If no savepoint name is provided, the same name is used
+# for each successive savepoint, in which case only the last savepoint set can
+# be released or rolled back.
+# -----------------------------------------------------------------------------
+sub set_savepoint {
+ my $self = shift;
+ my $name = shift || 'savepoint';
+ return unless $self->{session} and $self->{xact_id};
+ $self->log(I, "setting savepoint '$name'");
+ my $stat = $self->request($self->app.".savepoint.set", $name)
+ or $self->log(E, "error setting savepoint '$name'");
+ return $stat;
+}
+
+sub release_savepoint {
+ my $self = shift;
+ my $name = shift || 'savepoint';
+ return unless $self->{session} and $self->{xact_id};
+ $self->log(I, "releasing savepoint '$name'");
+ my $stat = $self->request($self->app.".savepoint.release", $name)
+ or $self->log(E, "error releasing savepoint '$name'");
+ return $stat;
+}
+
+sub rollback_savepoint {
+ my $self = shift;
+ my $name = shift || 'savepoint';
+ return unless $self->{session} and $self->{xact_id};
+ $self->log(I, "rollback savepoint '$name'");
+ my $stat = $self->request($self->app.".savepoint.rollback", $name)
+ or $self->log(E, "error rolling back savepoint '$name'");
+ return $stat;
+}
+
+
+# -----------------------------------------------------------------------------
+# Rolls back the transaction and disconnects
+# -----------------------------------------------------------------------------
+sub rollback {
+ my $self = shift;
+ my $err;
+ my $ret;
+ try {
+ $self->xact_rollback;
+ } catch Error with {
+ $err = shift
+ } finally {
+ $ret = $self->disconnect
+ };
+ throw $err if ($err);
+ return $ret;
+}
+
+sub disconnect {
+ my $self = shift;
+ $self->session->disconnect if
+ $self->{session} and
+ $self->{session}->state == OpenSRF::AppSession::CONNECTED();
+ delete $self->{session};
+}
+
+
+# -----------------------------------------------------------------------------
+# commits the db session and destroys the session
+# returns the status of the commit call
+# -----------------------------------------------------------------------------
+sub commit {
+ my $self = shift;
+ return unless $self->{xact_id};
+ my $stat = $self->xact_commit;
+ $self->disconnect;
+ return $stat;
+}
+
+# -----------------------------------------------------------------------------
+# clears all object data. Does not commit the db transaction.
+# -----------------------------------------------------------------------------
+sub reset {
+ my $self = shift;
+ $self->disconnect;
+ $$self{$_} = undef for (keys %$self);
+}
+
+
+# -----------------------------------------------------------------------------
+# commits and resets
+# -----------------------------------------------------------------------------
+sub finish {
+ my $self = shift;
+ my $err;
+ my $ret;
+ try {
+ $self->commit;
+ } catch Error with {
+ $err = shift
+ } finally {
+ $ret = $self->reset
+ };
+ throw $err if ($err);
+ return $ret;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Does a simple storage request
+# -----------------------------------------------------------------------------
+sub request {
+ my( $self, $method, @params ) = @_;
+
+ my $val;
+ my $err;
+ my $argstr = __arg_to_string( (scalar(@params)) == 1 ? $params[0] : \@params);
+ my $locale = $self->session->session_locale;
+
+ $self->log(I, "request $locale $method $argstr");
+
+ if( ($self->{xact} or $always_xact) and
+ $self->session->state != OpenSRF::AppSession::CONNECTED() ) {
+ #$logger->error("CStoreEditor lost it's connection!!");
+ throw OpenSRF::EX::ERROR ("CStore connection timed out - transaction cannot continue");
+ }
+
+
+ try {
+
+ my $req = $self->session->request($method, @params);
+
+ if($self->substream) {
+ $self->log(D,"running in substream mode");
+ $val = [];
+ while( my $resp = $req->recv(timeout => $self->timeout) ) {
+ push(@$val, $resp->content) if $resp->content and not $self->discard;
+ }
+
+ } else {
+ my $resp = $req->recv(timeout => $self->timeout);
+ if($req->failed) {
+ $err = $resp;
+ $self->log(E, "request error $method : $argstr : $err");
+ } else {
+ $val = $resp->content if $resp;
+ }
+ }
+
+ $req->finish;
+
+ } catch Error with {
+ $err = shift;
+ $self->log(E, "request error $method : $argstr : $err");
+ };
+
+ throw $err if $err;
+ return $val;
+}
+
+sub substream {
+ my( $self, $bool ) = @_;
+ $self->{substream} = $bool if defined $bool;
+ return $self->{substream};
+}
+
+# -----------------------------------------------------------------------------
+# discard response data instead of returning it to the caller. currently only
+# works in conjunction with substream mode.
+# -----------------------------------------------------------------------------
+sub discard {
+ my( $self, $bool ) = @_;
+ $self->{discard} = $bool if defined $bool;
+ return $self->{discard};
+}
+
+
+# -----------------------------------------------------------------------------
+# Sets / Returns the requestor object. This is set when checkauth succeeds.
+# -----------------------------------------------------------------------------
+sub requestor {
+ my($self, $requestor) = @_;
+ $self->{requestor} = $requestor if $requestor;
+ return $self->{requestor};
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Holds the last data received from a storage call
+# -----------------------------------------------------------------------------
+sub data {
+ my( $self, $data ) = @_;
+ $self->{data} = $data if defined $data;
+ return $self->{data};
+}
+
+
+# -----------------------------------------------------------------------------
+# True if this perm has already been checked at this org
+# -----------------------------------------------------------------------------
+sub perm_checked {
+ my( $self, $perm, $org ) = @_;
+ $self->{checked_perms}->{$org} = {}
+ unless $self->{checked_perms}->{$org};
+ my $checked = $self->{checked_perms}->{$org}->{$perm};
+ if(!$checked) {
+ $self->{checked_perms}->{$org}->{$perm} = 1;
+ return 0;
+ }
+ return 1;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Returns true if the requested perm is allowed. If the perm check fails,
+# $e->event is set and undef is returned
+# The perm user is $e->requestor->id and perm org defaults to the requestor's
+# ws_ou
+# if perm is an array of perms, method will return true at the first allowed
+# permission. If none of the perms are allowed, the perm_failure event
+# is created with the last perm to fail
+# -----------------------------------------------------------------------------
+my $PERM_QUERY = {
+ select => {
+ au => [ {
+ transform => 'permission.usr_has_perm',
+ alias => 'has_perm',
+ column => 'id',
+ params => []
+ } ]
+ },
+ from => 'au',
+ where => {},
+};
+
+my $OBJECT_PERM_QUERY = {
+ select => {
+ au => [ {
+ transform => 'permission.usr_has_object_perm',
+ alias => 'has_perm',
+ column => 'id',
+ params => []
+ } ]
+ },
+ from => 'au',
+ where => {},
+};
+
+sub allowed {
+ my( $self, $perm, $org, $object, $hint ) = @_;
+ my $uid = $self->requestor->id;
+ $org ||= $self->requestor->ws_ou;
+
+ my $perms = (ref($perm) eq 'ARRAY') ? $perm : [$perm];
+
+ for $perm (@$perms) {
+ $self->log(I, "checking perms user=$uid, org=$org, perm=$perm");
+
+ if($object) {
+ my $params;
+ if(ref $object) {
+ # determine the ID field and json_hint from the object
+ my $id_field = $object->Identity;
+ $params = [$perm, $object->json_hint, $object->$id_field];
+ } else {
+ # we were passed an object-id and json_hint
+ $params = [$perm, $hint, $object];
+ }
+ push(@$params, $org) if $org;
+ $OBJECT_PERM_QUERY->{select}->{au}->[0]->{params} = $params;
+ $OBJECT_PERM_QUERY->{where}->{id} = $uid;
+ return 1 if $U->is_true($self->json_query($OBJECT_PERM_QUERY)->[0]->{has_perm});
+
+ } else {
+ $PERM_QUERY->{select}->{au}->[0]->{params} = [$perm, $org];
+ $PERM_QUERY->{where}->{id} = $uid;
+ return 1 if $U->is_true($self->json_query($PERM_QUERY)->[0]->{has_perm});
+ }
+ }
+
+ # set the perm failure event if the permission check returned false
+ my $e = OpenILS::Event->new('PERM_FAILURE', ilsperm => $perm, ilspermloc => $org);
+ $self->event($e);
+ return undef;
+}
+
+
+# -----------------------------------------------------------------------------
+# Returns the list of object IDs this user has object-specific permissions for
+# -----------------------------------------------------------------------------
+sub objects_allowed {
+ my($self, $perm, $obj_type) = @_;
+
+ my $perms = (ref($perm) eq 'ARRAY') ? $perm : [$perm];
+ my @ids;
+
+ for $perm (@$perms) {
+ my $query = {
+ select => {puopm => ['object_id']},
+ from => {
+ puopm => {
+ ppl => {field => 'id',fkey => 'perm'}
+ }
+ },
+ where => {
+ '+puopm' => {usr => $self->requestor->id, object_type => $obj_type},
+ '+ppl' => {code => $perm}
+ }
+ };
+
+ my $list = $self->json_query($query);
+ push(@ids, 0+$_->{object_id}) for @$list;
+ }
+
+ my %trim;
+ $trim{$_} = 1 for @ids;
+ return [ keys %trim ];
+}
+
+
+# -----------------------------------------------------------------------------
+# checks the appropriate perm for the operation
+# -----------------------------------------------------------------------------
+sub _checkperm {
+ my( $self, $ptype, $action, $org ) = @_;
+ $org ||= $self->requestor->ws_ou;
+ my $perm = $PERMS{$ptype}{$action};
+ if( $perm ) {
+ return undef if $self->perm_checked($perm, $org);
+ return $self->event unless $self->allowed($perm, $org);
+ } else {
+ $self->log(I, "no perm provided for $ptype.$action");
+ }
+ return undef;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Logs update actions to the activity log
+# -----------------------------------------------------------------------------
+sub log_activity {
+ my( $self, $type, $action, $arg ) = @_;
+ my $str = "$type.$action";
+ $str .= _prop_string($arg);
+ $self->log(A, $str);
+}
+
+
+
+sub _prop_string {
+ my $obj = shift;
+ my @props = $obj->properties;
+ my $str = "";
+ for(@props) {
+ my $prop = $obj->$_() || "";
+ $prop = substr($prop, 0, 128) . "..." if length $prop > 131;
+ $str .= " $_=$prop";
+ }
+ return $str;
+}
+
+
+sub __arg_to_string {
+ my $arg = shift;
+ return "" unless defined $arg;
+ if( UNIVERSAL::isa($arg, "Fieldmapper") ) {
+ my $idf = $arg->Identity;
+ return (defined $arg->$idf) ? $arg->$idf : '<new object>';
+ }
+ return OpenSRF::Utils::JSON->perl2JSON($arg);
+ return "";
+}
+
+
+# -----------------------------------------------------------------------------
+# This does the actual storage query.
+#
+# 'search' calls become search_where calls and $arg can be a search hash or
+# an array-ref of storage search options.
+#
+# 'retrieve' expects an id
+# 'update' expects an object
+# 'create' expects an object
+# 'delete' expects an object
+#
+# All methods return true on success and undef on failure. On failure,
+# $e->event is set to the generated event.
+# Note: this method assumes that updating a non-changed object and
+# thereby receiving a 0 from storage, is a successful update.
+#
+# The method will therefore return true so the caller can just do
+# $e->update_blah($x) or return $e->event;
+# The true value returned from storage for all methods will be stored in
+# $e->data, until the next method is called.
+#
+# not-found events are generated on retrieve and serach methods.
+# action=search methods will return [] (==true) if no data is found. If the
+# caller is interested in the not found event, they can do:
+# return $e->event unless @$results;
+# -----------------------------------------------------------------------------
+sub runmethod {
+ my( $self, $action, $type, $arg, $options ) = @_;
+
+ $options ||= {};
+
+ if( $action eq 'retrieve' ) {
+ if(! defined($arg) ) {
+ $self->log(W,"$action $type called with no ID...");
+ $self->event(_mk_not_found($type, $arg));
+ return undef;
+ } elsif( ref($arg) =~ /Fieldmapper/ ) {
+ $self->log(D,"$action $type called with an object.. attempting Identity retrieval..");
+ my $idf = $arg->Identity;
+ $arg = $arg->$idf;
+ }
+ }
+
+ my @arg = ( ref($arg) eq 'ARRAY' ) ? @$arg : ($arg);
+ my $method = $self->app.".direct.$type.$action";
+
+ if( $action eq 'search' ) {
+ $method .= '.atomic';
+
+ } elsif( $action eq 'batch_retrieve' ) {
+ $action = 'search';
+ @arg = ( { id => $arg } );
+ $method =~ s/batch_retrieve/search/o;
+ $method .= '.atomic';
+
+ } elsif( $action eq 'retrieve_all' ) {
+ $action = 'search';
+ $method =~ s/retrieve_all/search/o;
+ my $tt = $type;
+ $tt =~ s/\./::/og;
+ my $fmobj = "Fieldmapper::$tt";
+ @arg = ( { $fmobj->Identity => { '!=' => undef } } );
+ $method .= '.atomic';
+ }
+
+ $method =~ s/search/id_list/o if $options->{idlist};
+
+ $method =~ s/\.atomic$//o if $self->substream($$options{substream} || 0);
+ $self->timeout($$options{timeout});
+ $self->discard($$options{discard});
+
+ # remove any stale events
+ $self->clear_event;
+
+ if( $action eq 'update' or $action eq 'delete' or $action eq 'create' ) {
+ if(!($self->{xact} or $always_xact)) {
+ $logger->error("Attempt to update DB while not in a transaction : $method");
+ throw OpenSRF::EX::ERROR ("Attempt to update DB while not in a transaction : $method");
+ }
+ $self->log_activity($type, $action, $arg);
+ }
+
+ if($$options{checkperm}) {
+ my $a = ($action eq 'search') ? 'retrieve' : $action;
+ my $e = $self->_checkperm($type, $a, $$options{permorg});
+ if($e) {
+ $self->event($e);
+ return undef;
+ }
+ }
+
+ my $obj;
+ my $err = '';
+
+ try {
+ $obj = $self->request($method, @arg);
+ } catch Error with { $err = shift; };
+
+
+ if(!defined $obj) {
+ $self->log(I, "request returned no data : $method");
+
+ if( $action eq 'retrieve' ) {
+ $self->event(_mk_not_found($type, $arg));
+
+ } elsif( $action eq 'update' or
+ $action eq 'delete' or $action eq 'create' ) {
+ my $evt = OpenILS::Event->new(
+ 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
+ $self->event($evt);
+ }
+
+ if( $err ) {
+ $self->event(
+ OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
+ payload => $arg, debug => "$err" ));
+ return undef;
+ }
+
+ return undef;
+ }
+
+ if( $action eq 'create' and $obj == 0 ) {
+ my $evt = OpenILS::Event->new(
+ 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
+ $self->event($evt);
+ return undef;
+ }
+
+ # If we havn't dealt with the error in a nice way, go ahead and throw it
+ if( $err ) {
+ $self->event(
+ OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
+ payload => $arg, debug => "$err" ));
+ return undef;
+ }
+
+ if( $action eq 'search' ) {
+ $self->log(I, "$type.$action : returned ".scalar(@$obj). " result(s)");
+ $self->event(_mk_not_found($type, $arg)) unless @$obj;
+ }
+
+ if( $action eq 'create' ) {
+ my $idf = $obj->Identity;
+ $self->log(I, "created a new $type object with Identity " . $obj->$idf);
+ $arg->$idf($obj->$idf);
+ }
+
+ $self->data($obj); # cache the data for convenience
+
+ return ($obj) ? $obj : 1;
+}
+
+
+sub _mk_not_found {
+ my( $type, $arg ) = @_;
+ (my $t = $type) =~ s/\./_/og;
+ $t = uc($t);
+ return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
+}
+
+
+
+# utility method for loading
+sub __fm2meth {
+ my $str = shift;
+ my $sep = shift;
+ $str =~ s/Fieldmapper:://o;
+ $str =~ s/::/$sep/g;
+ return $str;
+}
+
+
+# -------------------------------------------------------------
+# Load up the methods from the FM classes
+# -------------------------------------------------------------
+
+sub init {
+ no warnings; # Here we potentially redefine subs via eval
+ my $map = $Fieldmapper::fieldmap;
+ for my $object (keys %$map) {
+ my $obj = __fm2meth($object, '_');
+ my $type = __fm2meth($object, '.');
+ foreach my $command (qw/ update retrieve search create delete batch_retrieve retrieve_all /) {
+ eval "sub ${command}_$obj {return shift()->runmethod('$command', '$type', \@_);}\n";
+ }
+ # TODO: performance test against concatenating a big string of all the subs and eval'ing only ONCE.
+ }
+}
+
+init(); # Add very many subs to this namespace
+
+sub json_query {
+ my( $self, $arg, $options ) = @_;
+ $options ||= {};
+ my @arg = ( ref($arg) eq 'ARRAY' ) ? @$arg : ($arg);
+ my $method = $self->app.'.json_query.atomic';
+ $method =~ s/\.atomic$//o if $self->substream($$options{substream} || 0);
+
+ $self->timeout($$options{timeout});
+ $self->discard($$options{discard});
+ $self->clear_event;
+ my $obj;
+ my $err;
+
+ try {
+ $obj = $self->request($method, @arg);
+ } catch Error with { $err = shift; };
+
+ if( $err ) {
+ $self->event(
+ OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
+ payload => $arg, debug => "$err" ));
+ return undef;
+ }
+
+ $self->log(I, "json_query : returned ".scalar(@$obj). " result(s)") if (ref($obj));
+ return $obj;
+}
+
+
+
+1;
+
+
--- /dev/null
+package OpenILS::Utils::Cronscript;
+
+# ---------------------------------------------------------------
+# Copyright (C) 2010 Equinox Software, Inc
+# Author: Joe Atzberger <jatzberger@esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+# The purpose of this module is to consolidate the common aspects
+# of various cron tasks that all need the same things:
+# ~ non-duplicative processing, i.e. lockfiles and lockfile checking
+# ~ opensrf_core.xml file location
+# ~ common options like help and debug
+
+use strict;
+use warnings;
+
+use Getopt::Long qw(:DEFAULT GetOptionsFromArray);
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use OpenSRF::Utils::JSON;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Utils::Lockfile;
+use OpenILS::Utils::CStoreEditor q/:funcs/;
+
+use File::Basename qw/fileparse/;
+
+use Data::Dumper;
+use Carp;
+
+our @extra_opts = ( # additional keys are stored here
+ # 'addlopt'
+);
+
+our $debug = 0;
+
+sub _default_self {
+ return {
+ # opts => {},
+ # opts_clean => {},
+ # default_opts_clean => {},
+ default_opts => {
+ 'lock-file=s' => OpenILS::Utils::Lockfile::default_filename,
+ 'osrf-config=s' => '@sysconfdir@/opensrf_core.xml',
+ 'debug' => 0,
+ 'verbose+' => 0,
+ 'help' => 0,
+ # 'internal_var' => 'XYZ',
+ },
+ # lockfile => undef,
+ # session => undef,
+ # bootstrapped => 0,
+ # got_options => 0,
+ auto_get_options_4_bootstrap => 1,
+ };
+}
+
+sub is_clean {
+ my $key = shift or return 1;
+ $key =~ /[=:].*$/ and return 0;
+ $key =~ /[+!]$/ and return 0;
+ return 1;
+}
+
+sub clean {
+ my $key = shift or return;
+ $key =~ s/[=:].*$//;
+ $key =~ s/[+!]$//;
+ return $key;
+}
+
+sub fuzzykey { # when you know the hash you want from, but not the exact key
+ my $self = shift or return;
+ my $key = shift or return;
+ my $target = @_ ? shift : 'opts_clean';
+ foreach (map {clean($_)} keys %{$self->{default_opts}}) { # TODO: cache
+ $key eq $_ and return $self->{$target}->{$_};
+ }
+}
+
+# MyGetOptions
+# A wrapper around GetOptions
+# {opts} does two things for GetOptions (see Getopt::Long)
+# (1) maps command-line options to the *other* variables where values are stored (in opts_clean)
+# (2) provides hashspace for the rest of the arbitrary options from the command-line
+#
+# TODO: allow more options to be passed here, maybe mimic Getopt::Long::GetOptions style
+#
+# If an arrayref argument is passed, then @ARGV will NOT be touched.
+# Instead, the array will be passed to GetOptionsFromArray.
+#
+
+sub MyGetOptions {
+ my $self = shift;
+ my $arrayref = @_ ? shift : undef;
+ if ($arrayref and ref($arrayref) ne 'ARRAY') {
+ carp "MyGetOptions argument is not an array ref. Expect GetOptionsFromArray to explode";
+ }
+ $self->{got_options} and carp "MyGetOptions called after options were already retrieved previously";
+ my @keys = sort {is_clean($b) <=> is_clean($a)} keys %{$self->{default_opts}};
+ $debug and print "KEYS: ", join(", ", @keys), "\n";
+ foreach (@keys) {
+ my $clean = clean($_);
+ my $place = $self->{default_opts_clean}->{$clean};
+ $self->{opts_clean}->{$clean} = $place; # prepopulate default
+ # $self->{opts}->{$_} = $self->{opts_clean}->{$clean}; # pointer for GetOptions
+ $self->{opts}->{$_} = sub {
+ my $opt = shift;
+ my $val = shift;
+ ref ( $self->{opts_clean}->{$opt} ) and ref($self->{opts_clean}->{$opt}) eq 'SCALAR'
+ and ${$self->{opts_clean}->{$opt}} = $val; # set the referent's value
+ $self->{opts_clean}->{$opt} = $val; # burn the map, stick the value there
+ }; # pointer for GetOptions
+ }
+ $arrayref ? GetOptionsFromArray($arrayref, $self->{opts}, @keys)
+ : GetOptions( $self->{opts}, @keys) ;
+
+ foreach (@keys) {
+ delete $self->{opts}->{$_}; # now remove the mappings from (1) so we just have (2)
+ }
+ $self->clean_mirror('opts'); # populate clean_opts w/ cleaned versions of (2), plus everything else
+
+ print $self->help() and exit if $self->{opts_clean}->{help};
+ $self->new_lockfile();
+ $self->{got_options}++;
+ return wantarray ? %{$self->{opts_clean}} : $self->{opts_clean};
+}
+
+sub new_lockfile {
+ my $self = shift;
+ $debug and $OpenILS::Utils::Lockfile::debug = $debug;
+ unless ($self->{opts_clean}->{nolockfile} || $self->{default_opts_clean}->{nolockfile}) {
+ $self->{lockfile_obj} = OpenILS::Utils::Lockfile->new($self->first_defined('lock-file'));
+ $self->{lockfile} = $self->{lockfile_obj}->filename;
+ }
+}
+
+sub first_defined {
+ my $self = shift;
+ my $key = shift or return;
+ foreach (qw(opts_clean opts default_opts_clean default_opts)) {
+ defined $self->{$_}->{$key} and return $self->{$_}->{$key};
+ }
+ return;
+}
+
+sub clean_mirror {
+ my $self = shift;
+ my $dirty = @_ ? shift : 'default_opts';
+ foreach (keys %{$self->{$dirty}}) {
+ defined $self->{$dirty}->{$_} or next;
+ $self->{$dirty . '_clean'}->{clean($_)} = $self->{$dirty}->{$_};
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $self = _default_self;
+ bless ($self, $class);
+ $self->init(@_);
+ $debug and print "new ", __PACKAGE__, " obj: ", Dumper($self);
+ return $self;
+}
+
+sub add_and_purge {
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+ my $clean = clean($key);
+ my @others = grep {/$clean/ and $_ ne $key} keys %{$self->{default_opts}};
+ unless (@others) {
+ $debug and print "unique key $key => $val\n";
+ $self->{default_opts}->{$key} = $val; # no purge, just add
+ return;
+ }
+ foreach (@others) {
+ $debug and print "variant of $key => $_\n";
+ if ($key ne $clean) { # if it is a dirtier key, delete the clean one
+ delete $self->{default_opts}->{$_};
+ $self->{default_opts}->{$key} = $val;
+ } else { # else update the dirty one
+ $self->{default_opts}->{$_} = $val;
+ }
+ }
+}
+
+sub init { # not INIT
+ my $self = shift;
+ my $opts = @_ ? shift : {}; # user can specify more default options to constructor
+# TODO: check $opts is hashref; then check verbose/debug first. maybe check negations e.g. "no-verbose" ?
+ @extra_opts = keys %$opts;
+ foreach (@extra_opts) { # add any other keys w/ default values
+ $debug and print "init() adding option $_, default value: $opts->{$_}\n";
+ $self->add_and_purge($_, $opts->{$_});
+ }
+ $self->clean_mirror;
+ return $self;
+}
+
+sub usage {
+ # my $self = shift;
+ return "\nUSAGE: $0 [OPTIONS]";
+}
+
+sub options_help {
+ my $self = shift;
+ my $chunk = @_ ? shift : '';
+ return <<HELP
+
+COMMON OPTIONS:
+ --osrf-config </path/to/config_file> Default: $self->{default_opts_clean}->{'osrf-config'}
+ Specify OpenSRF core config file.
+
+ --lock-file </path/to/file_name> Default: $self->{default_opts_clean}->{'lock-file'}
+ Specify lock file.
+
+HELP
+ . $chunk . <<HELP;
+ --debug Print server responses to STDOUT for debugging
+ --verbose Set verbosity
+ --help Show this help message
+HELP
+}
+
+sub help {
+ my $self = shift;
+ return $self->usage() . "\n" . $self->options_help(@_) . $self->example();
+}
+
+sub example {
+ return "\n\nEXAMPLES:\n\n $0 --osrf-config /my/other/opensrf_core.xml\n";
+}
+
+# the proper order is: MyGetOptions, bootstrap, session.
+# But the latter subs will check to see if they need to call the preceeding one(s).
+
+sub session {
+ my $self = shift or return;
+ $self->{bootstrapped} or $self->bootstrap();
+ @_ or croak "session() called without required argument (app_name, e.g. 'open-ils.acq')";
+ return ($self->{session} ||= OpenSRF::AppSession->create(@_));
+}
+
+sub bootstrap {
+ my $self = shift or return;
+ if ($self->{auto_get_options_4_bootstrap} and not $self->{got_options}) {
+ $debug and print "Automatically calling MyGetOptions before bootstrap\n";
+ $self->MyGetOptions();
+ }
+ try {
+ $debug and print "bootstrap lock-file : ", $self->first_defined('lock-file'), "\n";
+ $debug and print "bootstrap osrf-config: ", $self->first_defined('osrf-config'), "\n";
+ OpenSRF::System->bootstrap_client(config_file => $self->first_defined('osrf-config'));
+ Fieldmapper->import(IDL => OpenSRF::Utils::SettingsClient->new->config_value("IDL"));
+ $self->{bootstrapped} = 1;
+ } otherwise {
+ $self->{bootstrapped} = 0;
+ warn shift;
+ };
+}
+
+sub editor_init {
+ my $self = shift or return;
+ OpenILS::Utils::CStoreEditor::init(); # no return value to check
+ $self->{editor_inited} = 1;
+}
+
+sub editor {
+ my $self = shift or return;
+ $self->{bootstrapped} or $self->bootstrap();
+ $self->{editor_inited} or $self->editor_init();
+ return new_editor(@_);
+}
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+OpenILS::Utils::Cronscript - Consolidated options handling for any script (not just cron, really)
+
+=head1 SYNOPSIS
+
+ use OpenILS::Utils::Cronscript;
+
+ my %defaults = (
+ 'min=i' => 0, # keys are Getopt::Long style options
+ 'max=i' => 999, # values are default values
+ 'user=s' => 'admin',
+ 'password=s' => '',
+ 'nolockfile' => 1,
+ };
+
+ my $core = OpenILS::Utils::Cronscript->new(\%defaults);
+ my $opts = $core->MyGetOptions(); # options now in, e.g.: $opts->{max}
+ $core->bootstrap;
+
+Or if you don't need any additional options and just want to get a session going:
+
+ use OpenILS::Utils::Cronscript;
+ my $session = OpenILS::Utils::Cronscript->new()->session('open-ils.acq');
+
+=head1 DESCRIPTION
+
+There are a few main problems when writing a new script for Evergreen.
+
+=head2 Initialization
+
+The runtime
+environment for the application requires a lot of initialization, but during normal operation it
+has already occured (when Evergreen was started). So most of the EG code never has to deal with
+this problem, but standalone scripts do. The timing and sequence of requisite events is important and not obvious.
+
+=head2 Common Options, Consistent Options
+
+We need several common options for each script that accesses the database or
+uses EG data objects and methods. Logically, these options often deal with initialization. They
+should take the B<exact> same form(s) for each script and should not be
+dependent on the local author to copy and paste them from some reference source. We really don't want to encourage (let alone force)
+admins to use C<--config>, C<--osrf-confg>, C<-c>, and C<@ARGV[2]> for the same purpose in different scripts, with different
+default handling, help descriptions and error messages (or lack thereof).
+
+This suggests broader problem of UI consistency and uniformity, also partially addressed by this module.
+
+=head2 Lockfiles
+
+A lockfile is necessary for a script that wants to prevent possible simultaneous execution. For example, consider a script
+that is scheduled to run frequently, but that experiences occasional high load: you wouldn't want crontab to start running
+it again if the first instance had not yet finished.
+
+But the code for creating, writing to, checking for, reading and cleaning up a lockfile for the script bloats what might otherwise be a terse
+method call. Conscript handles lockfile generation and removal automatically.
+
+=head1 OPTIONS
+
+The common options (and default values) are:
+
+ 'lock-file=s' => OpenILS::Utils::Lockfile::default_filename,
+ 'osrf-config=s' => '/openils/conf/opensrf_core.xml',
+ 'debug' => 0,
+ 'verbose+' => 0,
+ 'help' => 0,
+
+=head1 TODO
+
+More docs here.
+
+=head1 SEE ALSO
+
+ Getopt::Long
+ OpenILS::Utils::Lockfile
+ oils_header.pl
+
+=head1 AUTHOR
+
+Joe Atzberger <jatzberger@esilibrary.com>
+
+=cut
+
--- /dev/null
+use strict; use warnings;
+package OpenILS::Utils::Editor;
+use OpenILS::Application::AppUtils;
+use OpenSRF::AppSession;
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Event;
+use Data::Dumper;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils::Logger qw($logger);
+my $U = "OpenILS::Application::AppUtils";
+
+
+# -----------------------------------------------------------------------------
+# Export some useful functions
+# -----------------------------------------------------------------------------
+use vars qw(@EXPORT_OK %EXPORT_TAGS);
+use Exporter;
+use base qw/Exporter/;
+push @EXPORT_OK, 'new_editor';
+%EXPORT_TAGS = ( funcs => [ qw/ new_editor / ] );
+
+sub new_editor { return OpenILS::Utils::Editor->new(@_); }
+
+
+# -----------------------------------------------------------------------------
+# These need to be auto-generated
+# -----------------------------------------------------------------------------
+my %PERMS = (
+ 'biblio.record_entry' => { update => 'UPDATE_MARC' },
+ 'asset.copy' => { update => 'UPDATE_COPY' },
+ 'asset.call_number' => { update => 'UPDATE_VOLUME' },
+ 'action.circulation' => { retrieve => 'VIEW_CIRCULATIONS' },
+);
+
+use constant E => 'error';
+use constant W => 'warn';
+use constant I => 'info';
+use constant D => 'debug';
+use constant A => 'activity';
+
+
+
+# -----------------------------------------------------------------------------
+# Params include:
+# xact=><true> : creates a storage transaction
+# authtoken=>$token : the login session key
+# -----------------------------------------------------------------------------
+sub new {
+ my( $class, %params ) = @_;
+ $class = ref($class) || $class;
+ my $self = bless( \%params, $class );
+ $self->{checked_perms} = {};
+ return $self;
+}
+
+# -----------------------------------------------------------------------------
+# Log the editor metadata along with the log string
+# -----------------------------------------------------------------------------
+sub log {
+ my( $self, $lev, $str ) = @_;
+ my $s = "editor[";
+ $s .= "0|" unless $self->{xact};
+ $s .= "1|" if $self->{xact};
+ $s .= "0" unless $self->requestor;
+ $s .= $self->requestor->id if $self->requestor;
+ $s .= "]";
+ $logger->$lev("$s $str");
+}
+
+# -----------------------------------------------------------------------------
+# Verifies the auth token and fetches the requestor object
+# -----------------------------------------------------------------------------
+sub checkauth {
+ my $self = shift;
+ $self->log(D, "checking auth token ".$self->authtoken);
+ my ($reqr, $evt) = $U->checkses($self->authtoken);
+ $self->event($evt) if $evt;
+ return $self->{requestor} = $reqr;
+}
+
+
+# -----------------------------------------------------------------------------
+# Returns the last generated event
+# -----------------------------------------------------------------------------
+sub event {
+ my( $self, $evt ) = @_;
+ $self->{event} = $evt if $evt;
+ return $self->{event};
+}
+
+# -----------------------------------------------------------------------------
+# Clears the last caught event
+# -----------------------------------------------------------------------------
+sub clear_event {
+ my $self = shift;
+ $self->{event} = undef;
+}
+
+sub authtoken {
+ my( $self, $auth ) = @_;
+ $self->{authtoken} = $auth if $auth;
+ return $self->{authtoken};
+}
+
+# -----------------------------------------------------------------------------
+# fetches the session, creating if necessary. If 'xact' is true on this
+# object, a db session is created
+# -----------------------------------------------------------------------------
+sub session {
+ my( $self, $session ) = @_;
+ $self->{session} = $session if $session;
+
+ if(!$self->{session}) {
+ $self->{session} = OpenSRF::AppSession->create('open-ils.storage');
+
+ if( ! $self->{session} ) {
+ my $str = "Error creating storage session with OpenSRF::AppSession->create()!";
+ $self->log(E, $str);
+ throw OpenSRF::EX::ERROR ($str);
+ }
+
+ $self->{session}->connect if $self->{xact} or $self->{connect};
+ $self->xact_start if $self->{xact};
+ }
+ return $self->{session};
+}
+
+
+# -----------------------------------------------------------------------------
+# Starts a storage transaction
+# -----------------------------------------------------------------------------
+sub xact_start {
+ my $self = shift;
+ $self->log(D, "starting new db session");
+ my $stat = $self->request('open-ils.storage.transaction.begin');
+ $self->log(E, "error starting database transaction") unless $stat;
+ return $stat;
+}
+
+# -----------------------------------------------------------------------------
+# Commits a storage transaction
+# -----------------------------------------------------------------------------
+sub xact_commit {
+ my $self = shift;
+ $self->log(D, "comitting db session");
+ my $stat = $self->request('open-ils.storage.transaction.commit');
+ $self->log(E, "error comitting database transaction") unless $stat;
+ return $stat;
+}
+
+# -----------------------------------------------------------------------------
+# Rolls back a storage stransaction
+# -----------------------------------------------------------------------------
+sub xact_rollback {
+ my $self = shift;
+ $self->log(I, "rolling back db session");
+ return $self->request("open-ils.storage.transaction.rollback");
+}
+
+
+# -----------------------------------------------------------------------------
+# commits the db session and destroys the session
+# -----------------------------------------------------------------------------
+sub commit {
+ my $self = shift;
+ return unless $self->{xact};
+ $self->xact_commit;
+ $self->session->disconnect;
+ $self->{session} = undef;
+}
+
+# -----------------------------------------------------------------------------
+# clears all object data. Does not commit the db transaction.
+# -----------------------------------------------------------------------------
+sub reset {
+ my $self = shift;
+ $self->session->disconnect if $self->{session};
+ $$self{$_} = undef for (keys %$self);
+}
+
+
+# -----------------------------------------------------------------------------
+# commits and resets
+# -----------------------------------------------------------------------------
+sub finish {
+ my $self = shift;
+ $self->commit;
+ $self->reset;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Does a simple storage request
+# -----------------------------------------------------------------------------
+sub request {
+ my( $self, $method, @params ) = @_;
+
+ my $val;
+ my $err;
+ my $argstr = __arg_to_string( (scalar(@params)) == 1 ? $params[0] : \@params);
+
+ $self->log(I, "request $method : $argstr");
+
+ try {
+ $val = $self->session->request($method, @params)->gather(1);
+
+ } catch Error with {
+ $err = shift;
+ $self->log(E, "request error $method : $argstr : $err");
+ };
+
+ throw $err if $err;
+ return $val;
+}
+
+
+# -----------------------------------------------------------------------------
+# Sets / Returns the requstor object. This is set when checkauth succeeds.
+# -----------------------------------------------------------------------------
+sub requestor {
+ my($self, $requestor) = @_;
+ $self->{requestor} = $requestor if $requestor;
+ return $self->{requestor};
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Holds the last data received from a storage call
+# -----------------------------------------------------------------------------
+sub data {
+ my( $self, $data ) = @_;
+ $self->{data} = $data if defined $data;
+ return $self->{data};
+}
+
+
+# -----------------------------------------------------------------------------
+# True if this perm has already been checked at this org
+# -----------------------------------------------------------------------------
+sub perm_checked {
+ my( $self, $perm, $org ) = @_;
+ $self->{checked_perms}->{$org} = {}
+ unless $self->{checked_perms}->{$org};
+ my $checked = $self->{checked_perms}->{$org}->{$perm};
+ if(!$checked) {
+ $self->{checked_perms}->{$org}->{$perm} = 1;
+ return 0;
+ }
+ return 1;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Returns true if the requested perm is allowed. If the perm check fails,
+# $e->event is set and undef is returned
+# The perm user is $e->requestor->id and perm org defaults to the requestor's
+# ws_ou
+# If this perm at the given org has already been verified, true is returned
+# and the perm is not re-checked
+# -----------------------------------------------------------------------------
+sub allowed {
+ my( $self, $perm, $org ) = @_;
+ my $uid = $self->requestor->id;
+ $org ||= $self->requestor->ws_ou;
+ $self->log(I, "checking perms user=$uid, org=$org, perm=$perm");
+ return 1 if $self->perm_checked($perm, $org);
+ return $self->checkperm($uid, $org, $perm);
+}
+
+sub checkperm {
+ my($self, $userid, $org, $perm) = @_;
+ my $s = $self->request(
+ "open-ils.storage.permission.user_has_perm", $userid, $perm, $org );
+
+ if(!$s) {
+ my $e = OpenILS::Event->new('PERM_FAILURE', ilsperm => $perm, ilspermloc => $org);
+ $self->event($e);
+ return undef;
+ }
+
+ return 1;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# checks the appropriate perm for the operation
+# -----------------------------------------------------------------------------
+sub _checkperm {
+ my( $self, $ptype, $action, $org ) = @_;
+ $org ||= $self->requestor->ws_ou;
+ my $perm = $PERMS{$ptype}{$action};
+ if( $perm ) {
+ return undef if $self->perm_checked($perm, $org);
+ return $self->event unless $self->allowed($perm, $org);
+ } else {
+ $self->log(E, "no perm provided for $ptype.$action");
+ }
+ return undef;
+}
+
+
+
+# -----------------------------------------------------------------------------
+# Logs update actions to the activity log
+# -----------------------------------------------------------------------------
+sub log_activity {
+ my( $self, $type, $action, $arg ) = @_;
+ my $str = "$type.$action";
+ $str .= _prop_string($arg);
+ $self->log(A, $str);
+}
+
+
+
+sub _prop_string {
+ my $obj = shift;
+ my @props = $obj->properties;
+ my $str = "";
+ for(@props) {
+ my $prop = $obj->$_() || "";
+ $prop = substr($prop, 0, 128) . "..." if length $prop > 131;
+ $str .= " $_=$prop";
+ }
+ return $str;
+}
+
+
+sub __arg_to_string {
+ my $arg = shift;
+ return "" unless defined $arg;
+ return $arg->id if UNIVERSAL::isa($arg, "Fieldmapper");
+ return OpenSRF::Utils::JSON->perl2JSON($arg);
+}
+
+
+# -----------------------------------------------------------------------------
+# This does the actual storage query.
+#
+# 'search' calls become search_where calls and $arg can be a search hash or
+# an array-ref of storage search options.
+#
+# 'retrieve' expects an id
+# 'update' expects an object
+# 'create' expects an object
+# 'delete' expects an object
+#
+# All methods return true on success and undef on failure. On failure,
+# $e->event is set to the generated event.
+# Note: this method assumes that updating a non-changed object and
+# thereby receiving a 0 from storage, is a successful update.
+#
+# The method will therefore return true so the caller can just do
+# $e->update_blah($x) or return $e->event;
+# The true value returned from storage for all methods will be stored in
+# $e->data, until the next method is called.
+#
+# not-found events are generated on retrieve and serach methods.
+# action=search methods will return [] (==true) if no data is found. If the
+# caller is interested in the not found event, they can do:
+# return $e->event unless @$results;
+# -----------------------------------------------------------------------------
+sub runmethod {
+ my( $self, $action, $type, $arg, $options ) = @_;
+
+ my @arg = ($arg);
+ my $method = "open-ils.storage.direct.$type.$action";
+
+ if( $action eq 'search' ) {
+ $method =~ s/search/search_where/o;
+ $method =~ s/direct/id_list/o if $options->{idlist};
+ $method = "$method.atomic";
+ @arg = @$arg if ref($arg) eq 'ARRAY';
+
+ } elsif( $action eq 'batch_retrieve' ) {
+ $method =~ s/batch_retrieve/batch.retrieve/o;
+ $method = "$method.atomic";
+ @arg = @$arg if ref($arg) eq 'ARRAY';
+
+ } elsif( $action eq 'retrieve_all' ) {
+ $method =~ s/retrieve_all/retrieve.all.atomic/o;
+ }
+
+ # remove any stale events
+ $self->clear_event;
+
+ if( $action eq 'update' or $action eq 'delete' or $action eq 'create' ) {
+ $self->log_activity($type, $action, $arg);
+ }
+
+ if($$options{checkperm}) {
+ my $a = ($action eq 'search' or
+ $action eq 'batch_retrieve' or $action eq 'retrieve_all') ? 'retrieve' : $action;
+ my $e = $self->_checkperm($type, $a, $$options{permorg});
+ if($e) {
+ $self->event($e);
+ return undef;
+ }
+ }
+
+ my $obj;
+ my $err;
+
+ try {
+ $obj = $self->request($method, @arg);
+ } catch Error with { $err = shift; };
+
+
+ if(!defined $obj) {
+ $self->log(I, "request returned no data");
+
+ if( $action eq 'retrieve' ) {
+ $self->event(_mk_not_found($type, $arg));
+
+ } elsif( $action eq 'update' or
+ $action eq 'delete' or $action eq 'create' ) {
+ my $evt = OpenILS::Event->new(
+ 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
+ $self->event($evt);
+ }
+
+ if( $err ) {
+ $self->event(
+ OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
+ payload => $arg, debug => "$err" ));
+ return undef;
+ }
+
+ return undef;
+ }
+
+ if( $action eq 'create' and $obj == 0 ) {
+ my $evt = OpenILS::Event->new(
+ 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
+ $self->event($evt);
+ return undef;
+ }
+
+ # If we havn't dealt with the error in a nice way, go ahead and throw it
+ if( $err ) {
+ $self->event(
+ OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
+ payload => $arg, debug => "$err" ));
+ return undef;
+ }
+
+ if( $action eq 'search' or $action eq 'batch_retrieve' or $action eq 'retrieve_all') {
+ $self->log(I, "$type.$action : returned ".scalar(@$obj). " result(s)");
+ $self->event(_mk_not_found($type, $arg)) unless @$obj;
+ }
+
+ $arg->id($obj) if $action eq 'create'; # grabs the id on create
+ $self->data($obj); # cache the data for convenience
+
+ return ($obj) ? $obj : 1;
+}
+
+
+sub _mk_not_found {
+ my( $type, $arg ) = @_;
+ (my $t = $type) =~ s/\./_/og;
+ $t = uc($t);
+ return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
+}
+
+
+
+# utility method for loading
+sub __fm2meth {
+ my $str = shift;
+ my $sep = shift;
+ $str =~ s/Fieldmapper:://o;
+ $str =~ s/::/$sep/g;
+ return $str;
+}
+
+
+# -------------------------------------------------------------
+# Load up the methods from the FM classes
+# -------------------------------------------------------------
+my $map = $Fieldmapper::fieldmap;
+for my $object (keys %$map) {
+ my $obj = __fm2meth($object,'_');
+ my $type = __fm2meth($object, '.');
+
+ my $update = "update_$obj";
+ my $updatef =
+ "sub $update {return shift()->runmethod('update', '$type', \@_);}";
+ eval $updatef;
+
+ my $retrieve = "retrieve_$obj";
+ my $retrievef =
+ "sub $retrieve {return shift()->runmethod('retrieve', '$type', \@_);}";
+ eval $retrievef;
+
+ my $search = "search_$obj";
+ my $searchf =
+ "sub $search {return shift()->runmethod('search', '$type', \@_);}";
+ eval $searchf;
+
+ my $create = "create_$obj";
+ my $createf =
+ "sub $create {return shift()->runmethod('create', '$type', \@_);}";
+ eval $createf;
+
+ my $delete = "delete_$obj";
+ my $deletef =
+ "sub $delete {return shift()->runmethod('delete', '$type', \@_);}";
+ eval $deletef;
+
+ my $bretrieve = "batch_retrieve_$obj";
+ my $bretrievef =
+ "sub $bretrieve {return shift()->runmethod('batch_retrieve', '$type', \@_);}";
+ eval $bretrievef;
+
+ my $retrieveall = "retrieve_all_$obj";
+ my $retrieveallf =
+ "sub $retrieveall {return shift()->runmethod('retrieve_all', '$type', \@_);}";
+ eval $retrieveallf;
+
+
+}
+
+
+
+1;
+
+
--- /dev/null
+package Fieldmapper;
+use OpenSRF::Utils::JSON;
+use Data::Dumper;
+use base 'OpenSRF::Application';
+use OpenSRF::Utils::Logger;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::System;
+use XML::LibXML;
+
+my $log = 'OpenSRF::Utils::Logger';
+
+use vars qw/$fieldmap $VERSION/;
+
+sub publish_fieldmapper {
+ my ($self,$client,$class) = @_;
+
+ return $fieldmap unless (defined $class);
+ return undef unless (exists($$fieldmap{$class}));
+ return {$class => $$fieldmap{$class}};
+}
+__PACKAGE__->register_method(
+ api_name => 'opensrf.open-ils.system.fieldmapper',
+ api_level => 1,
+ method => 'publish_fieldmapper',
+);
+
+#
+# To dump the Javascript version of the fieldmapper struct use the command:
+#
+# PERL5LIB=:~/vcs/ILS/Open-ILS/src/perlmods/lib/ GEN_JS=1 perl -MOpenILS::Utils::Fieldmapper -e 'print "\n";'
+#
+# ... adjusted for your VCS sandbox of choice, of course.
+#
+
+sub classes {
+ return () unless (defined $fieldmap);
+ return keys %$fieldmap;
+}
+
+sub get_attribute {
+ my $attr_list = shift;
+ my $attr_name = shift;
+
+ my $attr = $attr_list->getNamedItem( $attr_name );
+ if( defined( $attr ) ) {
+ return $attr->getValue();
+ }
+ return undef;
+}
+
+sub load_fields {
+ my $field_list = shift;
+ my $fm = shift;
+
+ # Get attributes of the field list. Since there is only one
+ # <field> per class, these attributes logically belong to the
+ # enclosing class, and that's where we load them.
+
+ my $field_attr_list = $field_list->attributes();
+
+ my $sequence = get_attribute( $field_attr_list, 'oils_persist:sequence' );
+ if( ! defined( $sequence ) ) {
+ $sequence = '';
+ }
+ my $primary = get_attribute( $field_attr_list, 'oils_persist:primary' );
+
+ # Load attributes into the Fieldmapper ----------------------
+
+ $$fieldmap{$fm}{ sequence } = $sequence;
+ $$fieldmap{$fm}{ identity } = $primary;
+
+ # Load each field -------------------------------------------
+
+ my $array_position = 0;
+ for my $field ( $field_list->childNodes() ) { # For each <field>
+ if( $field->nodeName eq 'field' ) {
+
+ my $attribute_list = $field->attributes();
+
+ my $name = get_attribute( $attribute_list, 'name' );
+ next if( $name eq 'isnew' || $name eq 'ischanged' || $name eq 'isdeleted' );
+ my $required = get_attribute( $attribute_list, 'oils_obj:required' );
+ my $validate = get_attribute( $attribute_list, 'oils_obj:validate' );
+ my $virtual = get_attribute( $attribute_list, 'oils_persist:virtual' );
+ if( ! defined( $virtual ) ) {
+ $virtual = "false";
+ }
+ my $selector = get_attribute( $attribute_list, 'reporter:selector' );
+
+ $$fieldmap{$fm}{fields}{ $name } =
+ { virtual => ( $virtual eq 'true' ) ? 1 : 0,
+ required => ( $required eq 'true' ) ? 1 : 0,
+ position => $array_position,
+ };
+
+ $$fieldmap{$fm}{fields}{ $name }{validate} = qr/$validate/ if (defined($validate));
+
+ # The selector attribute, if present at all, attaches to only one
+ # of the fields in a given class. So if we see it, we store it at
+ # the level of the enclosing class.
+
+ if( defined( $selector ) ) {
+ $$fieldmap{$fm}{selector} = $selector;
+ }
+
+ ++$array_position;
+ }
+ }
+
+ # Load the standard 3 virtual fields ------------------------
+
+ for my $vfield ( qw/isnew ischanged isdeleted/ ) {
+ $$fieldmap{$fm}{fields}{ $vfield } =
+ { position => $array_position,
+ virtual => 1
+ };
+ ++$array_position;
+ }
+}
+
+sub load_links {
+ my $link_list = shift;
+ my $fm = shift;
+
+ for my $link ( $link_list->childNodes() ) { # For each <link>
+ if( $link->nodeName eq 'link' ) {
+ my $attribute_list = $link->attributes();
+
+ my $field = get_attribute( $attribute_list, 'field' );
+ my $reltype = get_attribute( $attribute_list, 'reltype' );
+ my $key = get_attribute( $attribute_list, 'key' );
+ my $class = get_attribute( $attribute_list, 'class' );
+
+ $$fieldmap{$fm}{links}{ $field } =
+ { class => $class,
+ reltype => $reltype,
+ key => $key,
+ };
+ }
+ }
+}
+
+sub load_class {
+ my $class_node = shift;
+
+ # Get attributes ---------------------------------------------
+
+ my $attribute_list = $class_node->attributes();
+
+ my $fm = get_attribute( $attribute_list, 'oils_obj:fieldmapper' );
+ $fm = 'Fieldmapper::' . $fm;
+ my $id = get_attribute( $attribute_list, 'id' );
+ my $controller = get_attribute( $attribute_list, 'controller' );
+ my $virtual = get_attribute( $attribute_list, 'virtual' );
+ if( ! defined( $virtual ) ) {
+ $virtual = 'false';
+ }
+ my $tablename = get_attribute( $attribute_list, 'oils_persist:tablename' );
+ if( ! defined( $tablename ) ) {
+ $tablename = '';
+ }
+ my $restrict_primary = get_attribute( $attribute_list, 'oils_persist:restrict_primary' );
+
+ # Load the attributes into the Fieldmapper --------------------
+
+ $log->debug("Building Fieldmapper class for [$fm] from IDL");
+
+ $$fieldmap{$fm}{ hint } = $id;
+ $$fieldmap{$fm}{ virtual } = ( $virtual eq 'true' ) ? 1 : 0;
+ $$fieldmap{$fm}{ table } = $tablename;
+ $$fieldmap{$fm}{ controller } = [ split ' ', $controller ];
+ $$fieldmap{$fm}{ restrict_primary } = $restrict_primary;
+
+ # Load fields and links
+
+ for my $child ( $class_node->childNodes() ) {
+ my $nodeName = $child->nodeName;
+ if( $nodeName eq 'fields' ) {
+ load_fields( $child, $fm );
+ } elsif( $nodeName eq 'links' ) {
+ load_links( $child, $fm );
+ }
+ }
+}
+
+import();
+sub import {
+ my $class = shift;
+ my %args = @_;
+
+ return if (keys %$fieldmap);
+ return if (!OpenSRF::System->connected && !$args{IDL});
+
+ # parse the IDL ...
+ my $parser = XML::LibXML->new();
+ my $file = $args{IDL} || OpenSRF::Utils::SettingsClient->new->config_value( 'IDL' );
+ my $fmdoc = $parser->parse_file( $file );
+ my $rootnode = $fmdoc->documentElement();
+
+ for my $child ( $rootnode->childNodes() ) { # For each <class>
+ my $nodeName = $child->nodeName;
+ if( $nodeName eq 'class' ) {
+ load_class( $child );
+ }
+ }
+
+ #-------------------------------------------------------------------------------
+ # Now comes the evil! Generate classes
+
+ for my $pkg ( __PACKAGE__->classes ) {
+ (my $cdbi = $pkg) =~ s/^Fieldmapper:://o;
+
+ eval <<" PERL";
+ package $pkg;
+ use base 'Fieldmapper';
+ PERL
+
+ if (exists $$fieldmap{$pkg}{proto_fields}) {
+ for my $pfield ( sort keys %{ $$fieldmap{$pkg}{proto_fields} } ) {
+ $$fieldmap{$pkg}{fields}{$pfield} = { position => $pos, virtual => $$fieldmap{$pkg}{proto_fields}{$pfield} };
+ $pos++;
+ }
+ }
+
+ OpenSRF::Utils::JSON->register_class_hint(
+ hint => $pkg->json_hint,
+ name => $pkg,
+ type => 'array',
+ );
+
+ }
+}
+
+sub new {
+ my $self = shift;
+ my $value = shift;
+ $value = [] unless (defined $value);
+ return bless $value => $self->class_name;
+}
+
+sub decast {
+ my $self = shift;
+ return [ @$self ];
+}
+
+sub DESTROY {}
+
+sub AUTOLOAD {
+ my $obj = shift;
+ my $value = shift;
+ (my $field = $AUTOLOAD) =~ s/^.*://o;
+ my $class_name = $obj->class_name;
+
+ my $fpos = $field;
+ $fpos =~ s/^clear_//og ;
+
+ my $pos = $$fieldmap{$class_name}{fields}{$fpos}{position};
+
+ if ($field =~ /^clear_/o) {
+ { no strict 'subs';
+ *{$obj->class_name."::$field"} = sub {
+ my $self = shift;
+ $self->[$pos] = undef;
+ return 1;
+ };
+ }
+ return $obj->$field();
+ }
+
+ die "No field by the name $field in $class_name!"
+ unless (exists $$fieldmap{$class_name}{fields}{$field} && defined($pos));
+
+
+ { no strict 'subs';
+ *{$obj->class_name."::$field"} = sub {
+ my $self = shift;
+ my $new_val = shift;
+ $self->[$pos] = $new_val if (defined $new_val);
+ return $self->[$pos];
+ };
+ }
+ return $obj->$field($value);
+}
+
+sub Selector {
+ my $self = shift;
+ return $$fieldmap{$self->class_name}{selector};
+}
+
+sub Identity {
+ my $self = shift;
+ return $$fieldmap{$self->class_name}{identity};
+}
+
+sub RestrictPrimary {
+ my $self = shift;
+ return $$fieldmap{$self->class_name}{restrict_primary};
+}
+
+sub Sequence {
+ my $self = shift;
+ return $$fieldmap{$self->class_name}{sequence};
+}
+
+sub Table {
+ my $self = shift;
+ return $$fieldmap{$self->class_name}{table};
+}
+
+sub Controller {
+ my $self = shift;
+ return $$fieldmap{$self->class_name}{controller};
+}
+
+sub RequiredField {
+ my $self = shift;
+ my $f = shift;
+ return undef unless ($f);
+ return $$fieldmap{$self->class_name}{fields}{$f}{required};
+}
+
+sub ValidateField {
+ my $self = shift;
+ my $f = shift;
+ return undef unless ($f);
+ return 1 if (!exists($$fieldmap{$self->class_name}{fields}{$f}{validate}));
+ return $self->$f =~ $$fieldmap{$self->class_name}{fields}{$f}{validate};
+}
+
+sub class_name {
+ my $class_name = shift;
+ return ref($class_name) || $class_name;
+}
+
+sub real_fields {
+ my $self = shift;
+ my $class_name = $self->class_name;
+ my $fields = $$fieldmap{$class_name}{fields};
+
+ my @f = grep {
+ !$$fields{$_}{virtual}
+ } sort {$$fields{$a}{position} <=> $$fields{$b}{position}} keys %$fields;
+
+ return @f;
+}
+
+sub has_field {
+ my $self = shift;
+ my $field = shift;
+ my $class_name = $self->class_name;
+ return 1 if grep { $_ eq $field } keys %{$$fieldmap{$class_name}{fields}};
+ return 0;
+}
+
+sub properties {
+ my $self = shift;
+ my $class_name = $self->class_name;
+ return keys %{$$fieldmap{$class_name}{fields}};
+}
+
+sub to_bare_hash {
+ my $self = shift;
+
+ my %hash = ();
+ for my $f ($self->properties) {
+ my $val = $self->$f;
+ $hash{$f} = $val;
+ }
+
+ return \%hash;
+}
+
+sub clone {
+ my $self = shift;
+ return $self->new( [@$self] );
+}
+
+sub api_level {
+ my $self = shift;
+ return $fieldmap->{$self->class_name}->{api_level};
+}
+
+sub cdbi {
+ my $self = shift;
+ return $fieldmap->{$self->class_name}->{cdbi};
+}
+
+sub is_virtual {
+ my $self = shift;
+ my $field = shift;
+ return $fieldmap->{$self->class_name}->{proto_fields}->{$field} if ($field);
+ return $fieldmap->{$self->class_name}->{virtual};
+}
+
+sub is_readonly {
+ my $self = shift;
+ my $field = shift;
+ return $fieldmap->{$self->class_name}->{readonly};
+}
+
+sub json_hint {
+ my $self = shift;
+ return $fieldmap->{$self->class_name}->{hint};
+}
+
+
+1;
--- /dev/null
+package OpenILS::Utils::ISBN;
+
+# ---------------------------------------------------------------
+# Copyright (C) 2010 Equinox Software, Inc
+# Author: Joe Atzberger <jatzberger@esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+use strict;
+use warnings;
+
+use Business::ISBN;
+
+use base qw/Exporter/;
+our $VERSION = '0.01';
+our @EXPORT_OK = qw/isbn_upconvert/;
+
+# Jason Stephenson <jstephenson@mvlc.org> at Merrimack Valley Library Consortium
+# Dan Scott <dscott@laurentian.ca> at Laurentian University
+
+sub isbn_upconvert {
+ my $in = @_ ? shift : return;
+ my $pretty = @_ ? shift : 0;
+ $in =~ s/\s*//g;
+ $in =~ s/-//g;
+ length($in) or return;
+ my $isbn = Business::ISBN->new($in) or return;
+ $isbn->fix_checksum() if $isbn->is_valid_checksum() == Business::ISBN::BAD_CHECKSUM;
+ $isbn->is_valid() or return;
+ return $pretty ? $isbn->as_isbn13->as_string : $isbn->as_isbn13->isbn;
+}
+
+1;
+__END__
+
+For example, if you have a file isbns.txt with these lines:
+
+1598884093
+ 1598884093
+ 15 988 840 93
+0446357197
+ 0 446 3 5 7 1 9 7
+ 0 446 3 5 7 1 9 1
+0596526857
+0786222735
+0446360015
+0446350109
+0446314129
+0439139597
+0743294394
+159143047X
+1590203097
+075480965X
+0393048799
+0446831832
+0446310069
+1598883275
+0446313033
+0446360279
+
+And you run:
+ perl -pe 'use OpenILS::Utils::ISBN qw/isbn_upconvert/; $_ = isbn_upconvert($_) . "\n";' <isbns.txt
+
+You get this output:
+9781598884098
+9781598884098
+9781598884098
+9780446357197
+9780446357197
+9780446357197
+9780596526856
+9780786222735
+9780446360012
+9780446350105
+9780446314121
+9780439139595
+9780743294393
+9781591430476
+9781590203095
+9780754809654
+9780393048797
+9780446831833
+9780446310062
+9781598883275
+9780446313032
+9780446360272
+
--- /dev/null
+package OpenILS::Utils::Lockfile;
+
+# ---------------------------------------------------------------
+# Copyright (C) 2010 Equinox Software, Inc
+# Author: Joe Atzberger <jatzberger@esilibrary.com>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+# The purpose of this module is to consolidate
+# non-duplicative processing, i.e. lockfiles and lockfile checking
+
+use strict;
+use warnings;
+use Carp;
+
+use File::Basename qw/fileparse/;
+
+sub _tempdir {
+ return $ENV{TEMP} || $ENV{TMP} || '/tmp';
+}
+
+our $debug = 0;
+
+sub default_filename {
+ my $tempdir = _tempdir;
+ my $filename = fileparse($0, '.pl');
+ return "$tempdir/$filename-LOCK";
+}
+
+sub new {
+ my $class = shift;
+ my $lockfile = @_ ? shift : default_filename;
+
+ croak "Script already running with lockfile $lockfile" if -e $lockfile;
+ $debug and print "Writing lockfile $lockfile (PID: $$)\n";
+
+ open (F, ">$lockfile") or croak "Cannot write to lockfile '$lockfile': $!";
+ print F $$;
+ close F;
+
+ my $self = {
+ filename => $lockfile,
+ contents => $$,
+ };
+ return bless ($self, $class);
+}
+
+sub filename {
+ my $self = shift;
+ return $self->{filename};
+}
+sub contents {
+ my $self = shift;
+ return $self->{contents};
+}
+
+DESTROY {
+ my $self = shift;
+ # lockfile cleanup
+ if (-e $self->{filename}) {
+ open LF, $self->{filename};
+ my $contents = <LF>;
+ close LF;
+ $debug and print "deleting lockfile $self->{filename}\n";
+ if ($contents == $self->{contents}) {
+ unlink $self->{filename} or carp "Failed to remove lockfile '$self->{filename}'";
+ } else {
+ carp "Lockfile contents '$contents' no longer match '$self->{contents}'. Cannot remove $self->{filename}";
+ }
+
+ }
+}
+
+1;
--- /dev/null
+package MFHD;
+use strict;
+use warnings;
+use integer;
+use Carp;
+use DateTime::Format::Strptime;
+use Data::Dumper;
+
+# for inherited methods to work properly, we need to force a
+# MARC::Record version greater than 2.0.0
+use MARC::Record "2.0.1";
+use base 'MARC::Record';
+
+use OpenILS::Utils::MFHD::Caption;
+use OpenILS::Utils::MFHD::Holding;
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = shift;
+
+ $self->{_strp_date} = new DateTime::Format::Strptime(pattern => '%F');
+
+ $self->{_mfhd_CAPTIONS} = {};
+ $self->{_mfhd_COMPRESSIBLE} = (substr($self->leader, 17, 1) =~ /[45]/);
+
+ foreach my $field ('853', '854', '855') {
+ my $captions = {};
+ foreach my $caption ($self->field($field)) {
+ my $cap_id;
+
+ $cap_id = $caption->subfield('8') || '0';
+
+ if (exists $captions->{$cap_id}) {
+ carp "Multiple MFHD captions with label '$cap_id'";
+ }
+
+ $captions->{$cap_id} = new MFHD::Caption($caption);
+ if ($self->{_mfhd_COMPRESSIBLE}) {
+ $self->{_mfhd_COMPRESSIBLE} &&=
+ $captions->{$cap_id}->compressible;
+ }
+ }
+ $self->{_mfhd_CAPTIONS}->{$field} = $captions;
+ }
+
+ foreach my $field ('863', '864', '865') {
+ my $holdings = {};
+ my $cap_field;
+
+ ($cap_field = $field) =~ s/6/5/;
+
+ foreach my $hfield ($self->field($field)) {
+ my ($linkage, $link_id, $seqno);
+ my $holding;
+
+ $linkage = $hfield->subfield('8');
+ ($link_id, $seqno) = split(/\./, $linkage);
+
+ if (!exists $holdings->{$link_id}) {
+ $holdings->{$link_id} = {};
+ }
+ $holding =
+ new MFHD::Holding($seqno, $hfield,
+ $self->{_mfhd_CAPTIONS}->{$cap_field}->{$link_id});
+ $holdings->{$link_id}->{$seqno} = $holding;
+
+ if ($self->{_mfhd_COMPRESSIBLE}) {
+ $self->{_mfhd_COMPRESSIBLE} &&= $holding->validate;
+ }
+ }
+ $self->{_mfhd_HOLDINGS}->{$field} = $holdings;
+ }
+
+ bless($self, $class);
+ return $self;
+}
+
+sub compressible {
+ my $self = shift;
+
+ return $self->{_mfhd_COMPRESSIBLE};
+}
+
+sub caption_link_ids {
+ my $self = shift;
+ my $field = shift;
+
+ return sort keys %{$self->{_mfhd_CAPTIONS}->{$field}};
+}
+
+# optional argument to get back a 'hashref' or an 'array' (default)
+sub captions {
+ my $self = shift;
+ my $tag = shift;
+ my $return_type = shift;
+
+ # TODO: add support for caption types as argument? (base, index, supplement)
+ my @sorted_ids = $self->caption_link_ids($tag);
+
+ if (defined($return_type) and $return_type eq 'hashref') {
+ my %captions;
+ foreach my $link_id (@sorted_ids) {
+ $captions{$link_id} = $self->{_mfhd_CAPTIONS}{$tag}{$link_id};
+ }
+ return \%captions;
+ } else {
+ my @captions;
+ foreach my $link_id (@sorted_ids) {
+ push(@captions, $self->{_mfhd_CAPTIONS}{$tag}{$link_id});
+ }
+ return @captions;
+ }
+}
+
+sub append_fields {
+ my $self = shift;
+
+ my $field_count = $self->SUPER::append_fields(@_);
+ if ($field_count) {
+ foreach my $field (@_) {
+ $self->_avoid_link_collision($field);
+ my $field_type = ref $field;
+ if ($field_type eq 'MFHD::Holding') {
+ $self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno} = $field;
+ } elsif ($field_type eq 'MFHD::Caption') {
+ $self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id} = $field;
+ }
+ }
+ return $field_count;
+ } else {
+ return;
+ }
+}
+
+sub delete_field {
+ my $self = shift;
+ my $field = shift;
+
+ my $field_count = $self->SUPER::delete_field($field);
+ if ($field_count) {
+ my $field_type = ref($field);
+ if ($field_type eq 'MFHD::Holding') {
+ delete($self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno});
+ } elsif ($field_type eq 'MFHD::Caption') {
+ delete($self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id});
+ }
+ return $field_count;
+ } else {
+ return;
+ }
+}
+
+sub insert_fields_before {
+ my $self = shift;
+ my $before = shift;
+
+ my $field_count = $self->SUPER::insert_fields_before($before, @_);
+ if ($field_count) {
+ foreach my $field (@_) {
+ $self->_avoid_link_collision($field);
+ my $field_type = ref $field;
+ if ($field_type eq 'MFHD::Holding') {
+ $self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno} = $field;
+ } elsif ($field_type eq 'MFHD::Caption') {
+ $self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id} = $field;
+ }
+ }
+ return $field_count;
+ } else {
+ return;
+ }
+}
+
+sub insert_fields_after {
+ my $self = shift;
+ my $after = shift;
+
+ my $field_count = $self->SUPER::insert_fields_after($after, @_);
+ if ($field_count) {
+ foreach my $field (@_) {
+ $self->_avoid_link_collision($field);
+ my $field_type = ref $field;
+ if ($field_type eq 'MFHD::Holding') {
+ $self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$field->seqno} = $field;
+ } elsif ($field_type eq 'MFHD::Caption') {
+ $self->{_mfhd_CAPTIONS}{$field->tag}{$field->link_id} = $field;
+ }
+ }
+ return $field_count;
+ } else {
+ return;
+ }
+}
+
+sub _avoid_link_collision {
+ my $self = shift;
+ my $field = shift;
+
+ my $fieldref = ref($field);
+ if ($fieldref eq 'MFHD::Holding') {
+ my $seqno = $field->seqno;
+ my $changed_seqno = 0;
+ if (exists($self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$seqno})) {
+ $changed_seqno = 1;
+ do {
+ $seqno++;
+ } while (exists($self->{_mfhd_HOLDINGS}{$field->tag}{$field->caption->link_id}{$seqno}));
+ }
+ $field->seqno($seqno) if $changed_seqno;
+ } elsif ($fieldref eq 'MFHD::Caption') {
+ my $link_id = $field->link_id;
+ my $changed_link_id = 0;
+ if (exists($self->{_mfhd_CAPTIONS}{$field->tag}{$link_id})) {
+ $link_id++;
+ $changed_link_id = 1;
+ do {
+ $link_id++;
+ } while (exists($self->{_mfhd_CAPTIONS}{$field->tag}{$link_id}));
+ }
+ $field->link_id($link_id) if $changed_link_id;
+ }
+}
+
+sub active_captions {
+ my $self = shift;
+ my $tag = shift;
+
+ # TODO: add support for caption types as argument? (basic, index, supplement)
+ my @captions;
+ my @active_captions;
+
+ @captions = $self->captions($tag);
+
+ # TODO: for now, we will assume the last 85X field is active
+ # and the rest are historical. The standard is hazy about
+ # how multiple active patterns of the same 85X type should be
+ # handled. We will, however, return as an array for future
+ # use.
+ push(@active_captions, $captions[-1]);
+
+ return @active_captions;
+}
+
+sub holdings {
+ my $self = shift;
+ my $field = shift;
+ my $capid = shift;
+
+ return
+ sort { $a->seqno <=> $b->seqno }
+ values %{$self->{_mfhd_HOLDINGS}->{$field}->{$capid}};
+}
+
+sub _holding_date {
+ my $self = shift;
+ my $holding = shift;
+
+ return $self->{_strp_date}->parse_datetime($holding->chron_to_date);
+}
+
+#
+# generate_predictions()
+# Accepts a hash ref of options initially defined as:
+# base_holding : reference to the holding field to predict from
+# num_to_predict : the number of issues you wish to predict
+# OR
+# end_holding : holding field ref, keep predicting until you meet or exceed it
+# OR
+# end_date : keep predicting until you exceed this
+#
+# The basic method is to first convert to a single holding if compressed, then
+# increment the holding and save the resulting values to @predictions.
+#
+# returns @predictions, an array of holding field refs (including end_holding
+# if applicable but NOT base_holding)
+#
+sub generate_predictions {
+ my ($self, $options) = @_;
+
+ my $base_holding = $options->{base_holding};
+ my $num_to_predict = $options->{num_to_predict};
+ my $end_holding = $options->{end_holding};
+ my $end_date = $options->{end_date};
+ my $max_to_predict = $options->{max_to_predict} || 10000; # fail-safe
+
+ if (!defined($base_holding)) {
+ carp("Base holding not defined in generate_predictions, returning empty set");
+ return ();
+ }
+ if ($base_holding->is_compressed) {
+ carp("Ambiguous compressed base holding in generate_predictions, returning empty set");
+ return ();
+ }
+ my $curr_holding = $base_holding->clone; # prevent side-effects
+
+ my @predictions;
+
+ if ($num_to_predict) {
+ for (my $i = 0; $i < $num_to_predict; $i++) {
+ push(@predictions, $curr_holding->increment->clone);
+ }
+ } elsif (defined($end_holding)) {
+ $end_holding = $end_holding->clone; # prevent side-effects
+ my $next_holding = $curr_holding->increment->clone;
+ my $num_predicted = 0;
+ while ($next_holding le $end_holding) {
+ push(@predictions, $next_holding);
+ $num_predicted++;
+ if ($num_predicted >= $max_to_predict) {
+ carp("Maximum prediction count exceeded");
+ last;
+ }
+ $next_holding = $curr_holding->increment->clone;
+ }
+ } elsif (defined($end_date)) {
+ my $next_holding = $curr_holding->increment->clone;
+ my $num_predicted = 0;
+ while ($self->_holding_date($next_holding) <= $end_date) {
+ push(@predictions, $next_holding);
+ $num_predicted++;
+ if ($num_predicted >= $max_to_predict) {
+ carp("Maximum prediction count exceeded");
+ last;
+ }
+ $next_holding = $curr_holding->increment->clone;
+ }
+ }
+
+ return @predictions;
+}
+
+#
+# create an array of compressed holdings from all holdings for a given caption,
+# compressing as needed
+#
+# Optionally you can skip sorting, but the resulting compression will be compromised
+# if the current holdings are out of order
+#
+# TODO: gap marking, gap preservation
+#
+# TODO: some of this could be moved to the Caption object to allow for
+# decompression in the absense of an overarching MFHD object
+#
+sub get_compressed_holdings {
+ my $self = shift;
+ my $caption = shift;
+ my $opts = shift;
+ my $skip_sort = $opts->{'skip_sort'};
+
+ # make sure none are compressed
+ my @decomp_holdings;
+ if ($skip_sort) {
+ @decomp_holdings = $self->get_decompressed_holdings($caption, {'skip_sort' => 1});
+ } else {
+ # sort for best algorithm
+ @decomp_holdings = $self->get_decompressed_holdings($caption, {'dedupe' => 1});
+ }
+
+ my $runner = $decomp_holdings[0]->clone->increment;
+ my $curr_holding = shift(@decomp_holdings);
+ $curr_holding = $curr_holding->clone;
+ my $seqno = 1;
+ $curr_holding->seqno($seqno);
+ my @comp_holdings;
+# my $last_holding;
+ foreach my $holding (@decomp_holdings) {
+ if ($runner eq $holding) {
+ $curr_holding->extend;
+ $runner->increment;
+# } elsif ($holding eq $last_holding) {
+# carp("Found duplicate holding in compression set, skipping");
+ } elsif ($runner gt $holding) { # should not happen unless holding is not in series
+ carp("Found unexpected holding, skipping");
+ } else {
+ push(@comp_holdings, $curr_holding);
+ while ($runner le $holding) {
+ $runner->increment;
+ }
+ $curr_holding = $holding->clone;
+ $seqno++;
+ $curr_holding->seqno($seqno);
+ }
+# $last_holding = $holding;
+ }
+ push(@comp_holdings, $curr_holding);
+
+ return @comp_holdings;
+}
+
+#
+# create an array of single holdings from all holdings for a given caption,
+# decompressing as needed
+#
+# resulting array is returned as they come in the record, unsorted
+#
+# optional argument will reorder and renumber the holdings before returning
+#
+# TODO: some of this could be moved to the Caption (and/or Holding) object to
+# allow for decompression in the absense of an overarching MFHD object
+#
+sub get_decompressed_holdings {
+ my $self = shift;
+ my $caption = shift;
+ my $opts = shift;
+ my $skip_sort = $opts->{'skip_sort'};
+ my $dedupe = $opts->{'dedupe'};
+
+ if ($dedupe and $skip_sort) {
+ carp("Attempted deduplication without sorting, failure likely");
+ }
+
+ my $htag = $caption->tag;
+ my $link_id = $caption->link_id;
+ $htag =~ s/^85/86/;
+ my @holdings = $self->holdings($htag, $link_id);
+ my @decomp_holdings;
+
+ foreach my $holding (@holdings) {
+ if (!$holding->is_compressed) {
+ push(@decomp_holdings, $holding->clone);
+ } else {
+ my $base_holding = $holding->clone->compressed_to_first;
+ my @new_holdings = $self->generate_predictions(
+ {'base_holding' => $base_holding,
+ 'end_holding' => $holding->clone->compressed_to_last});
+ push(@decomp_holdings, $base_holding, @new_holdings);
+ }
+ }
+
+ unless ($skip_sort) {
+ my @temp_holdings = sort {$a cmp $b} @decomp_holdings;
+ @decomp_holdings = @temp_holdings;
+ }
+
+ my @return_holdings = (shift(@decomp_holdings));
+ $return_holdings[0]->seqno(1);
+ my $seqno = 2;
+ foreach my $holding (@decomp_holdings) { # renumber sequence
+ if ($holding eq $return_holdings[-1] and $dedupe) {
+ carp("Found duplicate holding in decompression set, discarding");
+ next;
+ }
+ $holding->seqno($seqno);
+ $seqno++;
+ push(@return_holdings, $holding);
+ }
+
+ return @return_holdings;
+}
+
+#
+# format_holdings(): Generate textual display of all holdings in record
+# for given type of caption (853--855) taking into account all the
+# captions, holdings statements, and textual
+# holdings.
+#
+# returns string formatted holdings as one very long line.
+# Caller must provide any label (such as "library has:" and insert
+# line breaks as appropriate.
+
+# Translate caption field labels to the corresponding textual holdings
+# statement labels. That is, convert 853 "Basic bib unit" caption to
+# 866 "basic bib unit" text holdings label.
+
+my %cap_to_txt = (
+ '853' => '866',
+ '854' => '867',
+ '855' => '868',
+ );
+
+sub format_holdings {
+ my $self = shift;
+ my $field = shift;
+ my $holdings_field;
+ my @txt_holdings;
+ my %txt_link_ids;
+ my $holdings_stmt = '';
+ my ($l, $start);
+
+ # convert caption field id to holdings field id
+ ($holdings_field = $field) =~ s/5/6/;
+
+ # Textual holdings statements complicate the basic algorithm for
+ # formatting the holdings: If there's a textual holdings statement
+ # with the subfield "$80", then that overrides ALL the MFHD holdings
+ # information and is all that is displayed. Otherwise, the textual
+ # holdings statements will either replace some of the MFHD holdings
+ # information, or supplement it, depending on the value of the
+ # $8 linkage subfield.
+
+ if (defined $self->field($cap_to_txt{$field})) {
+ @txt_holdings = $self->field($cap_to_txt{$field});
+
+ foreach my $txt (@txt_holdings) {
+
+ # if there's a $80 subfield, then we're done, it's
+ # all the formatted holdings
+ if ($txt->subfield('8') eq '0') {
+ # textual holdings statement that completely
+ # replaces MFHD holdings in 853/863, etc.
+ $holdings_stmt = $txt->subfield('a');
+
+ if (defined $txt->subfield('z')) {
+ $holdings_stmt .= ' -- ' . $txt->subfield('z');
+ }
+
+ printf("# format_holdings() returning %s txt holdings\n",
+ $cap_to_txt{$field});
+ return $holdings_stmt;
+ }
+
+ # If there are non-$80 subfields in the textual holdings
+ # then we need to keep track of the subfields, so we can
+ # intersperse the textual holdings in with the the calculated
+ # holdings from the 853/863 fields.
+ foreach my $linkid ($txt->subfield('8')) {
+ $txt_link_ids{$linkid} = $txt;
+ }
+ }
+ }
+
+ # Now loop through all the captions, finding the corresponding
+ # holdings statements (either MFHD or textual), and build up the
+ # complete formatted holdings statement. The textual holdings statements
+ # have either the same link id field as a caption, which means that
+ # the text holdings win, or they have ids that are interfiled with
+ # the captions, which mean they go into the middle.
+
+ my @ids = sort($self->caption_link_ids($field), keys %txt_link_ids);
+ foreach my $cap_id (@ids) {
+ my $last_txt = undef;
+
+ if (exists $txt_link_ids{$cap_id}) {
+ # there's a textual holding statement with this caption ID,
+ # so just use that. This covers both the "replaces" and
+ # the "supplements" holdings information options.
+
+ # a single textual holdings statement can replace multiple
+ # captions. If the _last_ caption we saw had a textual
+ # holdings statement, and this caption has the same one, then
+ # we don't add the holdings again.
+ if (!defined $last_txt || ($last_txt != $txt_link_ids{$cap_id})) {
+ my $txt = $txt_link_ids{$cap_id};
+ $holdings_stmt .= ',' if $holdings_stmt;
+ $holdings_stmt .= $txt->subfield('a');
+ if (defined $txt->subfield('z')) {
+ $holdings_stmt .= ' -- ' . $txt->subfield('z');
+ }
+
+ $last_txt = $txt;
+ }
+ next;
+ }
+
+ # We found a caption that doesn't have a corresponding textual
+ # holdings statement, so reset $last_txt to undef.
+ $last_txt = undef;
+
+ my @holdings = $self->holdings($holdings_field, $cap_id);
+
+ next unless scalar @holdings;
+
+ # XXX Need to format compressed holdings. see code in test.pl
+ # for example. Try to do it without indexing?
+ $holdings_stmt .= ',' if $holdings_stmt;
+
+ if ($self->compressible) {
+ $start = $l = shift @holdings;
+ $holdings_stmt .= $l->format;
+
+ while (my $h = shift @holdings) {
+ if (!$h->matches($l->next)) {
+ # this item is not part of the current run,
+ # close out the run and record this item
+ if ($l != $start) {
+ $holdings_stmt .= '-' . $l->format;
+ }
+
+ $holdings_stmt .= ',' . $h->format;
+ $start = $h
+ } elsif (!scalar(@holdings) || defined($h->subfield('z'))) {
+ # This is the end of the holdings for this caption
+ # or this item has a public note that we want
+ # to display
+ $holdings_stmt .= '-' . $h->format;
+ }
+
+ if (defined $h->subfield('z')) {
+ $holdings_stmt .= ' -- ' . $h->subfield('z');
+ }
+
+ $l = $h;
+ }
+ } else {
+ $holdings_stmt .= ',' if $holdings_stmt;
+ $holdings_stmt .= (shift @holdings)->format;
+ foreach my $h (@holdings) {
+ $holdings_stmt .= ',' . $h->format;
+ if (defined $h->subfield('z')) {
+ $holdings_stmt .= ' -- ' . $h->subfield('z');
+ }
+ }
+ }
+ }
+
+ return $holdings_stmt;
+}
+
+1;
--- /dev/null
+package MFHD::Caption;
+use strict;
+use integer;
+use Carp;
+
+use Data::Dumper;
+
+use OpenILS::Utils::MFHD::Date;
+
+use base 'MARC::Field';
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = shift;
+ my $last_enum = undef;
+
+ $self->{_mfhdc_ENUMS} = {};
+ $self->{_mfhdc_CHRONS} = {};
+ $self->{_mfhdc_PATTERN} = {};
+ $self->{_mfhdc_COPY} = undef;
+ $self->{_mfhdc_UNIT} = undef;
+ $self->{_mfhdc_LINK_ID} = undef;
+ $self->{_mfhdc_COMPRESSIBLE} = 1; # until proven otherwise
+
+ foreach my $subfield ($self->subfields) {
+ my ($key, $val) = @$subfield;
+ if ($key eq '8') {
+ $self->{_mfhdc_LINK_ID} = $val;
+ } elsif ($key =~ /[a-h]/) {
+ # Enumeration Captions
+ $self->{_mfhdc_ENUMS}->{$key} = {
+ CAPTION => $val,
+ COUNT => undef,
+ RESTART => undef
+ };
+ if ($key =~ /[ag]/) {
+ $last_enum = undef;
+ } else {
+ $last_enum = $key;
+ }
+ } elsif ($key =~ /[i-m]/) {
+ # Chronology captions
+ $self->{_mfhdc_CHRONS}->{$key} = $val;
+ } elsif ($key eq 'u') {
+ # Bib units per next higher enumeration level
+
+ # Some files seem to have "empty" $u subfields,
+ # especially for top level of enumeration. Just drop them
+ next if (!defined($val) || !$val);
+
+ carp('$u specified for top-level enumeration')
+ unless defined($last_enum);
+ $self->{_mfhdc_ENUMS}->{$last_enum}->{COUNT} = $val;
+ } elsif ($key eq 'v') {
+ # Is this level of enumeration continuous, or does it restart?
+
+ # Some files seem to have "empty" $v subfields,
+ # especially for top level of enumeration. Just drop them
+ next if (!defined($val) || !$val);
+
+ carp '$v specified for top-level enumeration'
+ unless defined($last_enum);
+ $self->{_mfhdc_ENUMS}->{$last_enum}->{RESTART} = ($val eq 'r');
+ } elsif ($key =~ /[npwz]/) {
+ # Publication Pattern info ('o' == type of unit, 'q'..'t' undefined)
+ $self->{_mfhdc_PATTERN}->{$key} = $val;
+ } elsif ($key =~ /x/) {
+ # Calendar change can have multiple comma-separated values
+ $self->{_mfhdc_PATTERN}->{x} = [split /,/, $val];
+ } elsif ($key eq 'y') {
+ $self->{_mfhdc_PATTERN}->{y} = {}
+ unless exists $self->{_mfhdc_PATTERN}->{y};
+ update_pattern($self, $val);
+ } elsif ($key eq 'o') {
+ # Type of unit
+ $self->{_mfhdc_UNIT} = $val;
+ } elsif ($key eq 't') {
+ $self->{_mfhdc_COPY} = $val;
+ } else {
+ carp "Unknown caption subfield '$key'";
+ }
+ }
+
+ # subsequent levels of enumeration (primary and alternate)
+ # If an enumeration level doesn't document the number
+ # of "issues" per "volume", or whether numbering of issues
+ # restarts, then we can't compress.
+ foreach my $key ('b', 'c', 'd', 'e', 'f', 'h') {
+ if (exists $self->{_mfhdc_ENUMS}->{$key}) {
+ my $pattern = $self->{_mfhdc_ENUMS}->{$key};
+ if ( !$pattern->{RESTART}
+ || !$pattern->{COUNT}
+ || ($pattern->{COUNT} eq 'var')
+ || ($pattern->{COUNT} eq 'und')) {
+ $self->{_mfhdc_COMPRESSIBLE} = 0;
+ last;
+ }
+ }
+ }
+
+ my $pat = $self->{_mfhdc_PATTERN};
+
+ # Sanity check publication frequency vs publication pattern:
+ # if the frequency is a number, then the pattern better
+ # have that number of values associated with it.
+ if ( exists($pat->{w})
+ && ($pat->{w} =~ /^\d+$/)
+ && ($pat->{w} != scalar(@{$pat->{y}->{p}}))) {
+ carp(
+"Caption::new: publication frequency '$pat->{w}' != publication pattern @{$pat->{y}->{p}}"
+ );
+ }
+
+ # If there's a $x subfield and a $j, then it's compressible
+ if (exists $pat->{x} && exists $self->{_mfhdc_CHRONS}->{'j'}) {
+ $self->{_mfhdc_COMPRESSIBLE} = 1;
+ }
+
+ bless($self, $class);
+
+ return $self;
+}
+
+sub update_pattern {
+ my $self = shift;
+ my $val = shift;
+ my $pathash = $self->{_mfhdc_PATTERN}->{y};
+ my ($pubcode, $pat) = unpack("a1a*", $val);
+
+ $pathash->{$pubcode} = [] unless exists $pathash->{$pubcode};
+ push @{$pathash->{$pubcode}}, $pat;
+}
+
+sub decode_pattern {
+ my $self = shift;
+ my $pattern = $self->{_mfhdc_PATTERN}->{y};
+
+ # XXX WRITE ME (?)
+}
+
+sub compressible {
+ my $self = shift;
+
+ return $self->{_mfhdc_COMPRESSIBLE};
+}
+
+sub chrons {
+ my $self = shift;
+ my $key = shift;
+
+ if (exists $self->{_mfhdc_CHRONS}->{$key}) {
+ return $self->{_mfhdc_CHRONS}->{$key};
+ } else {
+ return undef;
+ }
+}
+
+sub capfield {
+ my $self = shift;
+ my $key = shift;
+
+ if (exists $self->{_mfhdc_ENUMS}->{$key}) {
+ return $self->{_mfhdc_ENUMS}->{$key};
+ } elsif (exists $self->{_mfhdc_CHRONS}->{$key}) {
+ return $self->{_mfhdc_CHRONS}->{$key};
+ } else {
+ return undef;
+ }
+}
+
+sub capstr {
+ my $self = shift;
+ my $key = shift;
+ my $val = $self->capfield($key);
+
+ if (ref $val) {
+ return $val->{CAPTION};
+ } else {
+ return $val;
+ }
+}
+
+sub type_of_unit {
+ my $self = shift;
+
+ return $self->{_mfhdc_UNIT};
+}
+
+sub link_id {
+ my $self = shift;
+
+ return $self->{_mfhdc_LINK_ID};
+}
+
+sub calendar_change {
+ my $self = shift;
+
+ return $self->{_mfhdc_PATTERN}->{x};
+}
+
+# If items are identified by chronology only, with no separate
+# enumeration (eg, a newspaper issue), then the chronology is
+# recorded in the enumeration subfields $a - $f. We can tell
+# that this is the case if there are $a - $f subfields and no
+# chronology subfields ($i-$k), and none of the $a-$f subfields
+# have associated $u or $v subfields, but there's a $w and no $x
+
+sub enumeration_is_chronology {
+ my $self = shift;
+
+ # There is always a '$a' subfield in well-formed fields.
+ return 0
+ if exists $self->{_mfhdc_CHRONS}->{i}
+ || exists $self->{_mfhdc_PATTERN}->{x};
+
+ foreach my $key ('a'..'f') {
+ my $enum;
+
+ last if !exists $self->{_mfhdc_ENUMS}->{$key};
+
+ $enum = $self->{_mfhdc_ENUMS}->{$key};
+ return 0 if defined $enum->{COUNT} || defined $enum->{RESTART};
+ }
+
+ return (exists $self->{_mfhdc_PATTERN}->{w});
+}
+
+sub regularity_match {
+ my $self = shift;
+ my $pubcode = shift;
+ my @date = @_;
+
+ # we can't match something that doesn't exist.
+ return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{$pubcode};
+
+ foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{$pubcode}}) {
+ my $chroncode = substr($regularity, 0, 1);
+ my $matchfunc = MFHD::Date::dispatch($chroncode);
+ my @pats = split(/,/, substr($regularity, 1));
+
+ if (!defined $matchfunc) {
+ carp "Unrecognized chroncode '$chroncode'";
+ return 0;
+ }
+
+ # XXX WRITE ME
+ foreach my $pat (@pats) {
+ $pat =~ s|/.+||; # If it's a combined date, match the start
+ if ($matchfunc->($pat, @date)) {
+ return 1;
+ }
+ }
+ }
+
+ return 0;
+}
+
+sub is_omitted {
+ my $self = shift;
+ my @date = @_;
+
+ # printf("# is_omitted: testing date %s: %d\n", join('/', @date),
+ # $self->regularity_match('o', @date));
+ return $self->regularity_match('o', @date);
+}
+
+sub is_published {
+ my $self = shift;
+ my @date = @_;
+
+ return $self->regularity_match('p', @date);
+}
+
+sub is_combined {
+ my $self = shift;
+ my @date = @_;
+
+ return $self->regularity_match('c', @date);
+}
+
+sub enum_is_combined {
+ my $self = shift;
+ my $subfield = shift;
+ my $iss = shift;
+ my $level = ord($subfield) - ord('a') + 1;
+
+ return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{c};
+
+ foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{c}}) {
+ next unless $regularity =~ m/^e$level/o;
+
+ my @pats = split(/,/, substr($regularity, 2));
+
+ foreach my $pat (@pats) {
+ $pat =~ s|/.+||; # if it's a combined issue, match the start
+ return 1 if ($iss eq $pat);
+ }
+ }
+
+ return 0;
+}
+
+# Test to see if $dt1 is on or after $dt2
+# if length(@{$dt2} == 2, then just month/day are compared
+# if length(@{$dt2} == 1, then just the months are compared
+sub on_or_after {
+ my $dt1 = shift;
+ my $dt2 = shift;
+
+# printf("# on_or_after(%s, %s): ", join('/', @{$dt1}), join('/', @{$dt2}));
+
+ foreach my $i (0..(scalar(@{$dt2}) - 1)) {
+ if ($dt1->[$i] > $dt2->[$i]) {
+ # printf("after - pass\n");
+ # $dt1 occurs AFTER $dt2
+ return 1;
+ } elsif ($dt1->[$i] < $dt2->[$i]) {
+ # printf("before - fail\n");
+ # $dt1 occurs BEFORE $dt2
+ return 0;
+ }
+ # both are still equal, keep going
+ }
+
+ # We fell out of the loop with them being equal, so it's 'on'
+ # printf("on - pass\n");
+ return 1;
+}
+
+sub calendar_increment {
+ my $self = shift;
+ my $cur = shift;
+ my $new = shift;
+ my $cal_change = $self->calendar_change;
+ my $month;
+ my $day;
+ my $cur_before;
+ my $new_on_or_after;
+
+ # A calendar change is defined, need to check if it applies
+ if (scalar(@{$new}) == 1) {
+ carp "Can't calculate date change for ", $self->as_string;
+ return 0;
+ }
+
+ foreach my $change (@{$cal_change}) {
+ my $incr;
+
+ if (length($change) == 2) {
+ $month = $change;
+ } elsif (length($change) == 4) {
+ ($month, $day) = unpack("a2a2", $change);
+ }
+
+ # printf("# calendar_increment('%s', '%s'): change on '%s/%s'\n",
+ # join('/', @{$cur}), join('/', @{$new}),
+ # $month, defined($day) ? $day : 'UNDEF');
+
+ if ($cur->[0] == $new->[0]) {
+ # Same year, so a 'simple' month/day comparison will be fine
+ $incr =
+ ( !on_or_after([$cur->[1], $cur->[2]], [$month, $day])
+ && on_or_after([$new->[1], $new->[2]], [$month, $day]));
+ } else {
+ # @cur is in the year before @new. There are
+ # two possible cases for the calendar change date that
+ # indicate that it's time to change the volume:
+ # (1) the change date is AFTER @cur in the year, or
+ # (2) the change date is BEFORE @new in the year.
+ #
+ # -------|------|------X------|------|
+ # @cur (1) Jan 1 (2) @new
+
+ $incr =
+ (on_or_after([$new->[1], $new->[2]], [$month, $day])
+ || !on_or_after([$cur->[1], $cur->[2]], [$month, $day]));
+ }
+ return $incr if $incr;
+ }
+
+ return 0;
+}
+
+sub next_chron {
+ my $self = shift;
+ my $next = shift;
+ my $carry = shift;
+ my @keys = @_;
+ my @cur;
+ my @new;
+ my @newend; # only used for combined issues
+ my $incr;
+
+ my $reg = $self->{_mfhdc_REGULARITY};
+ my $pattern = $self->{_mfhdc_PATTERN};
+ my $freq = $pattern->{w};
+
+ foreach my $i (0..$#keys) {
+ $cur[$i] = $next->{$keys[$i]} if exists $next->{$keys[$i]};
+ }
+
+ # If the current issue has a combined date (eg, May/June)
+ # get rid of the first date and base the calculation
+ # on the final date in the combined issue.
+ $cur[-1] =~ s|^[^/]+/||;
+
+ if (defined $pattern->{y}->{p}) {
+ # There is a $y publication pattern defined in the record:
+ # use it to calculate the next issue date.
+
+ foreach my $pubpat (@{$pattern->{y}->{p}}, @{$pattern->{y}->{c}}) {
+ my $chroncode = substr($pubpat, 0, 1);
+ my $genfunc = MFHD::Date::generator($chroncode);
+ my @pats = split(/,/, substr($pubpat, 1));
+
+ next if $chroncode eq 'e';
+
+ if (!defined $genfunc) {
+ carp "Unrecognized chroncode '$chroncode'";
+ return undef;
+ }
+
+ foreach my $pat (@pats) {
+ my $combined = $pat =~ m|/|;
+ my ($start, $end);
+ my @candidate;
+
+ # printf("# next_date: generating with pattern '%s'\n", $pat);
+
+ if ($combined) {
+ ($start, $end) = split('/', $pat, 2);
+ } else {
+ ($start, $end) = (undef, undef);
+ }
+
+ @candidate = $genfunc->($start || $pat, @cur);
+
+ while ($self->is_omitted(@candidate)) {
+ # printf("# pubpat omitting date '%s'\n",
+ # join('/', @candidate));
+ @candidate = $genfunc->($start || $pat, @candidate);
+ }
+
+ # printf("# testing new candidate '%s' against '%s'\n",
+ # join('/', @candidate), join('/', @new));
+
+ if (!defined($new[0]) || !on_or_after(\@candidate, \@new)) {
+ # first time through the loop
+ # or @candidate is before @new =>
+ # @candidate is the next issue.
+ @new = @candidate;
+ if (defined $end) {
+ @newend = $genfunc->($end, @cur);
+ } else {
+ $newend[0] = undef;
+ }
+
+ # printf("# selecting candidate date '%s'\n", join('/', @new));
+ }
+ }
+ }
+
+ if (defined($newend[0])) {
+ # The best match was a combined issue
+ foreach my $i (0..$#new) {
+ # don't combine identical fields
+ next if $new[$i] eq $newend[$i];
+ $new[$i] .= '/' . $newend[$i];
+ }
+ }
+ }
+
+ if (scalar @new == 0) {
+ # There was no suitable publication pattern defined,
+ # so use the $w frequency to figure out the next date
+ if (!defined($freq)) {
+ carp "Undefined frequency in next_chron!";
+ } elsif (!MFHD::Date::can_increment($freq)) {
+ carp "Don't know how to deal with frequency '$freq'!";
+ } else {
+ # One of the standard defined issue frequencies
+ @new = MFHD::Date::incr_date($freq, @cur);
+
+ while ($self->is_omitted(@new)) {
+ @new = MFHD::Date::incr_date($freq, @new);
+ }
+
+ if ($self->is_combined(@new)) {
+ my @second_date = MFHD::Date::incr_date($freq, @new);
+
+ # I am cheating: This code assumes that only the smallest
+ # time increment is combined. So, no "Apr 15/May 1" allowed.
+ $new[-1] = $new[-1] . '/' . $second_date[-1];
+ }
+ }
+ }
+
+ for my $i (0..$#new) {
+ $next->{$keys[$i]} = $new[$i];
+ }
+ # Figure out if we need to adjust volume number
+ # right now just use the $carry that was passed in.
+ # in long run, need to base this on ($carry or date_change)
+ if ($carry) {
+ # if $carry is set, the date doesn't matter: we're not
+ # going to increment the v. number twice at year-change.
+ $next->{a} += $carry;
+ } elsif (defined $pattern->{x}) {
+ $next->{a} += $self->calendar_increment(\@cur, \@new);
+ }
+}
+
+sub next_alt_enum {
+ my $self = shift;
+ my $next = shift;
+
+ # First handle any "alternative enumeration", since they're
+ # a lot simpler, and don't depend on the the calendar
+ foreach my $key ('h', 'g') {
+ next if !exists $next->{$key};
+ if (!$self->capstr($key)) {
+ warn "Holding data exists for $key, but no caption specified";
+ $next->{$key} += 1;
+ last;
+ }
+
+ my $cap = $self->capfield($key);
+ if ( $cap->{RESTART}
+ && $cap->{COUNT}
+ && ($next->{$key} == $cap->{COUNT})) {
+ $next->{$key} = 1;
+ } else {
+ $next->{$key} += 1;
+ last;
+ }
+ }
+}
+
+# Check caption for $ype subfield, specifying that there's a
+# particular publication pattern for the given level of enumeration
+# returns the pattern string or undef
+sub enum_pubpat {
+ my $self = shift;
+ my $level = shift;
+
+ return undef if !exists $self->{_mfhdc_PATTERN}->{y}->{p};
+
+ foreach my $reg (@{$self->{_mfhdc_PATTERN}->{y}->{p}}) {
+ if ($reg =~ m/^e$level/o) {
+ return substr($reg, 2);
+ }
+ }
+ return undef;
+}
+
+sub next_enum {
+ my $self = shift;
+ my $next = shift;
+ my $carry;
+
+ # $carry keeps track of whether we need to carry into the next
+ # higher level of enumeration. It's not actually necessary except
+ # for when the loop ends: if we need to carry from $b into $a
+ # then $carry will be set when the loop ends.
+ #
+ # We need to keep track of this because there are two different
+ # reasons why we might increment the highest level of enumeration ($a)
+ # 1) we hit the correct number of items in $b (ie, 5th iss of quarterly)
+ # 2) it's the right time of the year.
+ #
+
+ # If there's a subfield b, then we will go through the loop at
+ # least once. If there's no subfield b, then there's only a single
+ # level of enumeration, so we just add one to it and we're done.
+ if (exists $next->{b}) {
+ $carry = 0;
+ } else {
+ $carry = 1;
+ }
+ foreach my $key (reverse('b'..'f')) {
+ my $level;
+ my $pubpat;
+
+ next if !exists $next->{$key};
+
+ # If the current issue has a combined issue number (eg, 2/3)
+ # get rid of the first issue number and base the calculation
+ # on the final issue number in the combined issue.
+ if ($next->{$key} =~ m|/|) {
+ $next->{$key} =~ s|^[^/]+/||;
+ }
+
+ $level = ord($key) - ord('a') + 1; # enumeration level
+
+ $pubpat = $self->enum_pubpat($level);
+
+ if ($pubpat) {
+ # printf("# next_enum: found pubpat '%s' for subfield '%s'\n",
+ # $pubpat, $key);
+ my @pats = split(/,/, $pubpat);
+
+ # If we fall out the bottom of the loop, then $carry
+ # will still be 1, and we will reset the current
+ # level to the first value in @pats and increment
+ # then next higher level.
+ $carry = 1;
+
+ foreach my $pat (@pats) {
+ my $combined = $pat =~ m|/|;
+ my $end;
+
+ # printf("# next_enum: checking current '%s' against pat '%s'\n",
+ # $next->{$key}, $pat);
+
+ if ($combined) {
+ ($pat, $end) = split('/', $pat, 2);
+ } else {
+ $end = undef;
+ }
+
+ if ($pat > $next->{$key}) {
+ $carry = 0;
+ $next->{$key} = $pat;
+ $next->{$key} .= '/' . $end if $end;
+ # printf("# next_enum: selecting new issue no. %s\n", $next->{$key});
+ last; # We've found the correct next issue number
+ }
+ }
+ if ($carry) {
+ $next->{$key} = $pats[0];
+ } else {
+ last; # exit the top level loop because we're done
+ }
+
+ } else {
+ # No enumeration publication pattern specified for this level,
+ # just keep adding one.
+
+ if (!$self->capstr($key)) {
+ # Just assume that it increments continuously and give up
+ warn "Holding data exists for $key, but no caption specified";
+ $next->{$key} += 1;
+ $carry = 0;
+ last;
+ }
+
+ # printf("# next_enum: no publication pattern, using frequency\n");
+
+ my $cap = $self->capfield($key);
+ if ( $cap->{RESTART}
+ && $cap->{COUNT}
+ && ($next->{$key} eq $cap->{COUNT})) {
+ $next->{$key} = 1;
+ $carry = 1;
+ } else {
+ # If I don't need to "carry" beyond here, then I just increment
+ # this level of the enumeration and stop looping, since the
+ # "next" hash has been initialized with the current values
+
+ $next->{$key} += 1;
+ $carry = 0;
+ }
+
+ # You can't have a combined issue that spans two volumes: no.12/1
+ # is forbidden
+ if ($self->enum_is_combined($key, $next->{$key})) {
+ $next->{$key} .= '/' . ($next->{$key} + 1);
+ }
+
+ last if !$carry;
+ }
+ }
+
+ # The easy part is done. There are two things left to do:
+ # 1) Calculate the date of the next issue, if necessary
+ # 2) Increment the highest level of enumeration (either by date
+ # or because $carry is set because of the above loop
+
+ if (!$self->subfield('i') || !$next->{i}) {
+ # The simple case: if there is no chronology specified
+ # then just check $carry and return
+ $next->{'a'} += $carry;
+ } else {
+ # Figure out date of next issue, then decide if we need
+ # to adjust top level enumeration based on that
+ $self->next_chron($next, $carry, ('i'..'m'));
+ }
+}
+
+sub next {
+ my $self = shift;
+ my $holding = shift;
+ my $next = {};
+
+ # If the holding is compressed and not open ended, base next() on the
+ # closing date. If the holding is open-ended, next() is undefined
+ my $index;
+ if ($holding->is_compressed) {
+ return undef if $holding->is_open_ended;
+ # TODO: error on next for open-ended holdings?
+ $index = 1;
+ } else {
+ $index = 0;
+ }
+
+ # Initialize $next with current enumeration & chronology, then
+ # we can just operate on $next, based on the contents of the caption
+ foreach my $key ('a'..'m') {
+ my $holding_values = $holding->field_values($key);
+ $next->{$key} = ${$holding_values}[$index] if defined $holding_values;
+ }
+
+ if ($self->enumeration_is_chronology) {
+ $self->next_chron($next, 0, ('a'..'h'));
+ return $next;
+ }
+
+ if (exists $next->{'h'}) {
+ $self->next_alt_enum($next);
+ }
+
+ $self->next_enum($next);
+
+ return ($next);
+}
+
+# return a simple subfields list
+sub subfields_list {
+ my $self = shift;
+ my @subfields;
+
+ foreach my $subfield ($self->subfields) {
+ push(@subfields, $subfield->[0], $subfield->[1]);
+ }
+ return @subfields;
+}
+
+1;
--- /dev/null
+package MFHD::Date;
+use strict;
+use integer;
+use Carp;
+
+use Data::Dumper;
+use DateTime;
+
+use base 'Exporter';
+
+our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
+
+my %daynames = (
+ 'mo' => 1,
+ 'tu' => 2,
+ 'we' => 3,
+ 'th' => 4,
+ 'fr' => 5,
+ 'sa' => 6,
+ 'su' => 7,
+);
+
+my $daypat = '(mo|tu|we|th|fr|sa|su)';
+my $weekpat = '(99|98|97|00|01|02|03|04|05)';
+my $weeknopat;
+my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
+my $seasonpat = '(21|22|23|24)';
+
+# Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
+$weeknopat = '(';
+foreach my $weekno (1..52) {
+ $weeknopat .= sprintf('%02d|', $weekno);
+}
+$weeknopat .= '53)';
+
+sub match_day {
+ my $pat = shift;
+ my @date = @_;
+ # Translate daynames into day of week for DateTime
+ # also used to check if dayname is valid.
+
+ if (exists $daynames{$pat}) {
+ # dd
+ # figure out day of week for date and compare
+ my $dt = DateTime->new(
+ year => $date[0],
+ month => $date[1],
+ day => $date[2]
+ );
+ return ($dt->day_of_week == $daynames{$pat});
+ } elsif (length($pat) == 2) {
+ # DD
+ return $pat == $date[2];
+ } elsif (length($pat) == 4) {
+ # MMDD
+ my ($mon, $day) = unpack("a2a2", $pat);
+
+ return (($mon == $date[1]) && ($day == $date[2]));
+ } else {
+ carp "Invalid day pattern '$pat'";
+ return 0;
+ }
+}
+
+sub subsequent_day {
+ my $pat = shift;
+ my @cur = @_;
+ my $dt = DateTime->new(
+ year => $cur[0],
+ month => $cur[1],
+ day => $cur[2]
+ );
+
+ # printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
+
+ if (exists $daynames{$pat}) {
+ # dd: published on the given weekday
+ my $dow = $dt->day_of_week;
+ my $corr = ($daynames{$pat} - $dow + 7) % 7;
+
+ if ($dow == $daynames{$pat}) {
+ # the next one is one week hence
+ $dt->add(days => 7);
+ } else {
+ # the next one is later this week,
+ # or it is next week (ie, on or after next Monday)
+ # $corr will take care of it.
+ $dt->add(days => $corr);
+ }
+ @cur = ($dt->year, $dt->month, $dt->day);
+ } elsif (length($pat) == 2) {
+ # DD: published on the give day of every month
+ if ($dt->day >= $pat) {
+ # current date is on or after $pat: next one is next month
+ $dt->set(day => $pat);
+ $dt->add(months => 1);
+ @cur = ($dt->year, $dt->month, $dt->day);
+ } else {
+ # current date is before $pat: set day to pattern
+ $cur[2] = $pat;
+ }
+ } elsif (length($pat) == 4) {
+ # MMDD: published on the given day of the given month
+ my ($mon, $day) = unpack("a2a2", $pat);
+
+ if (on_or_after($mon, $day, $cur[1], $cur[2])) {
+ # Current date is on or after pattern; next one is next year
+ $cur[0] += 1;
+ }
+ # Year is now right. Either it's next year (because of on_or_after)
+ # or it's this year, because the current date is NOT on or after
+ # the pattern. Just fix the month and day
+ $cur[1] = $mon;
+ $cur[2] = $day;
+ } else {
+ carp "Invalid day pattern '$pat'";
+ return undef;
+ }
+
+ foreach my $i (0..$#cur) {
+ $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
+ }
+
+ # printf("subsequent_day: returning '%s'\n", join('/', @cur));
+
+ return @cur;
+}
+
+# Calculate date of 3rd Friday of the month (for example)
+# 1-5: count from beginning of month
+# 99-97: count back from end of month
+sub nth_week_of_month {
+ my $dt = shift;
+ my $week = shift;
+ my $day = shift;
+ my ($nth_day, $dow);
+
+ # printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
+
+ if (0 < $week && $week <= 5) {
+ $nth_day = $dt->clone->set(day => 1);
+ } elsif ($week >= 97) {
+ $nth_day = DateTime->last_day_of_month(
+ year => $dt->year,
+ month => $dt->month
+ );
+ } else {
+ return undef;
+ }
+
+ $dow = $nth_day->day_of_week();
+
+ # If a particular day was passed in (eg, we want 3rd friday)
+ # then use that day for the calculations, otherwise, just use
+ # the day of the week of the original date (the date $dt).
+ if (defined($day)) {
+ $day = $daynames{$day};
+ } else {
+ $day = $dt->day_of_week;
+ }
+
+ if ($week <= 5) {
+ # count forwards
+ $nth_day->add(
+ days => ($day - $dow + 7) % 7,
+ weeks => $week - 1
+ );
+ } else {
+ # count backwards
+ $nth_day->subtract(days => ($day - $dow + 7) % 7);
+
+ # 99: last week of month, 98: second last, etc.
+ for (my $i = 99 - $week; $i > 0; $i--) {
+ $nth_day->subtract(weeks => 1);
+ }
+ }
+
+ # There is no nth "day" in the month!
+ return undef if ($dt->month != $nth_day->month);
+
+ return $nth_day;
+}
+
+#
+# Internal utility function to match the various different patterns
+# of month, week, and day
+#
+sub check_date {
+ my $dt = shift;
+ my $month = shift;
+ my $weekno = shift;
+ my $day = shift;
+
+ # printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
+
+ if (!defined $day) {
+ # MMWW
+ return (
+ ($dt->month == $month)
+ && (
+ ($dt->week_of_month == $weekno)
+ || (
+ $weekno >= 97
+ && ($dt->week_of_month ==
+ nth_week_of_month($dt, $weekno, $day)->week_of_month)
+ )
+ )
+ );
+ }
+
+ # simple cases first
+ if ($daynames{$day} != $dt->day_of_week) {
+ # if it's the wrong day of the week, rest doesn't matter
+ return 0;
+ }
+
+ if (!defined $month) {
+ # WWdd
+ return (
+ ($weekno == 0) # Every week
+ || ($dt->weekday_of_month == $weekno) # this week
+ || (
+ ($weekno >= 97)
+ && ($dt->weekday_of_month ==
+ nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
+ )
+ );
+ }
+
+ # MMWWdd
+ if ($month != $dt->month) {
+ # If it's the wrong month, then we're done
+ return 0;
+ }
+
+ # It's the right day of the week
+ # It's the right month
+
+ if (($weekno == 0) || ($weekno == $dt->weekday_of_month)) {
+ # If this matches, then we're counting from the beginning
+ # of the month and it matches and we're done.
+ return 1;
+ }
+
+ # only case left is that the week number is counting from
+ # the end of the month: eg, second last wednesday
+ return (
+ ($weekno >= 97)
+ && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
+ $dt->weekday_of_month)
+ );
+}
+
+sub match_week {
+ my $pat = shift;
+ my @date = @_;
+ my $dt = DateTime->new(
+ year => $date[0],
+ month => $date[1],
+ day => $date[2]
+ );
+
+ if ($pat =~ m/^$weekpat$daypat$/) {
+ # WWdd: 03we = Third Wednesday
+ return check_date($dt, undef, $1, $2);
+ } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
+ # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
+ return check_date($dt, $1, $2, $3);
+ } elsif ($pat =~ m/^$monthpat$weekpat$/) {
+ # MMWW: 1204: Fourth week in December XXX WRITE ME
+ return check_date($dt, $1, $2, undef);
+ } else {
+ carp "invalid week pattern '$pat'";
+ return 0;
+ }
+}
+
+#
+# Use $pat to calcuate the date of the issue following $cur
+#
+sub subsequent_week {
+ my $pat = shift;
+ my @cur = @_;
+ my $candidate;
+ my $dt;
+
+ # printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
+
+ $dt = DateTime->new(
+ year => $cur[0],
+ month => $cur[1],
+ day => $cur[2]
+ );
+
+ if ($pat =~ m/^$weekpat$daypat$/o) {
+ # WWdd: published on given weekday of given week of every month
+ my ($week, $day) = ($1, $2);
+
+ # printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
+ # $week, $day);
+
+ if ($week eq '00') {
+ # Every week
+ $candidate = $dt->clone;
+
+ if ($dt->day_of_week == $daynames{$day}) {
+ # Current is right day, next one is a week hence
+ $candidate->add(days => 7);
+ } else {
+ $candidate->add(
+ days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
+ }
+ } else {
+ # 3rd Friday of the month (eg)
+ $candidate = nth_week_of_month($dt, $week, $day);
+ }
+
+ if ($candidate <= $dt) {
+# If the n'th week of the month happens on before the
+# current issue, then the next issue is published next
+# month, otherwise, it's published this month.
+# This will never happen for the "00: every week" pattern
+# printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
+# join('/', $candidate->year, $candidate->month, $candidate->day),
+# join('/', $dt->year, $dt->month, $dt->day));
+ $candidate->set(day => 1);
+ $candidate->add(months => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ }
+ } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
+ # MMWWdd: published on given weekday of given week of given month
+ my ($month, $week, $day) = ($1, $2, $3);
+
+# printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
+# $month, $week, $day);
+
+ $candidate = DateTime->new(
+ year => $dt->year,
+ month => $month,
+ day => 1
+ );
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ if ($candidate <= $dt) {
+ # We've missed it for this year, next one that matches
+ # will be next year
+ $candidate->add(years => 1)->set(day => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ }
+ } elsif ($pat =~ m/^$monthpat$weekpat$/) {
+ # MMWW: published during given week of given month
+ my ($month, $week) = ($1, $2);
+
+ $candidate = nth_week_of_month(
+ DateTime->new(
+ year => $dt->year,
+ month => $month,
+ day => 1
+ ),
+ $week, 'th'
+ );
+ if ($candidate <= $dt) {
+ # Already past the pattern date this year, move to next year
+ $candidate->add(years => 1)->set(day => 1);
+ $candidate = nth_week_of_month($candidate, $week, 'th');
+ }
+ } else {
+ carp "invalid week pattern '$pat'";
+ return undef;
+ }
+
+ $cur[0] = $candidate->year;
+ $cur[1] = $candidate->month;
+ $cur[2] = $candidate->day;
+
+ foreach my $i (0..$#cur) {
+ $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
+ }
+
+ return @cur;
+}
+
+sub match_month {
+ my $pat = shift;
+ my @date = @_;
+
+ return ($pat eq $date[1]);
+}
+
+sub subsequent_month {
+ my $pat = shift;
+ my @cur = @_;
+
+ if ($cur[1] >= $pat) {
+ # Current date is on or after the patter date, so the next
+ # occurence is next year
+ $cur[0] += 1;
+ }
+
+ # The year is right, just set the month to the pattern date.
+ $cur[1] = $pat;
+
+ return @cur;
+}
+
+sub match_season {
+ my $pat = shift;
+ my @date = @_;
+
+ return ($pat eq $date[1]);
+}
+
+sub subsequent_season {
+ my $pat = shift;
+ my @cur = @_;
+
+# printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
+
+ if (($pat < 21) || ($pat > 24)) {
+ carp "Unexpected season '$pat'";
+ return undef;
+ }
+
+ if ($cur[1] >= $pat) {
+ # current season is on or past pattern season in this year,
+ # advance to next year
+ $cur[0] += 1;
+ }
+ # Either we've advanced to the next year or the current season
+ # is before the pattern season in the current year. Either way,
+ # all that remains is to set the season properly
+ $cur[1] = $pat;
+
+ return @cur;
+}
+
+sub match_year {
+ my $pat = shift;
+ my @date = @_;
+
+ # XXX WRITE ME
+ return 0;
+}
+
+sub subsequent_year {
+ my $pat = shift;
+ my $cur = shift;
+
+ # XXX WRITE ME
+ return undef;
+}
+
+sub match_issue {
+ my $pat = shift;
+ my @date = @_;
+
+ # We handle enumeration patterns separately. This just
+ # ensures that when we're processing chronological patterns
+ # we don't match an enumeration pattern.
+ return 0;
+}
+
+sub subsequent_issue {
+ my $pat = shift;
+ my $cur = shift;
+
+ # Issue generation is handled separately
+ return undef;
+}
+
+my %dispatch = (
+ d => \&match_day,
+ e => \&match_issue, # not really a "chron" code
+ w => \&match_week,
+ m => \&match_month,
+ s => \&match_season,
+ y => \&match_year,
+);
+
+my %generators = (
+ d => \&subsequent_day,
+ e => \&subsequent_issue, # not really a "chron" code
+ w => \&subsequent_week,
+ m => \&subsequent_month,
+ s => \&subsequent_season,
+ y => \&subsequent_year,
+);
+
+sub dispatch {
+ my $chroncode = shift;
+
+ return $dispatch{$chroncode};
+}
+
+sub generator {
+ my $chroncode = shift;
+
+ return $generators{$chroncode};
+}
+
+my %increments = (
+ a => {years => 1}, # annual
+ b => {months => 2}, # bimonthly
+ c => {days => 3}, # semiweekly
+ d => {days => 1}, # daily
+ e => {weeks => 2}, # biweekly
+ f => {months => 6}, # semiannual
+ g => {years => 2}, # biennial
+ h => {years => 3}, # triennial
+ i => {days => 2}, # three times / week
+ j => {days => 10}, # three times /month
+ # k => continuous
+ m => {months => 1}, # monthly
+ q => {months => 3}, # quarterly
+ s => {days => 15}, # semimonthly
+ t => {months => 4}, # three times / year
+ w => {weeks => 1}, # weekly
+ # x => completely irregular
+);
+
+sub can_increment {
+ my $freq = shift;
+
+ return exists $increments{$freq};
+}
+
+# TODO: add support for weeks as chron level?
+sub incr_date {
+ my $freq = shift;
+ my $incr = $increments{$freq};
+ my @new = @_;
+
+ if (scalar(@new) == 1) {
+ # only a year is specified. Next date is easy
+ $new[0] += $incr->{years} || 1;
+ } elsif (scalar(@new) == 2) {
+ # Year and month or season
+ if ($new[1] > 20) {
+ # season
+ $new[1] += ($incr->{months} / 3) || 1;
+ if ($new[1] > 24) {
+ # carry
+ $new[0] += 1;
+ $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
+ }
+ } else {
+ # month
+ $new[1] += $incr->{months} || 1;
+ if ($new[1] > 12) {
+ # carry
+ $new[0] += 1;
+ $new[1] -= 12;
+ }
+ }
+ } elsif (scalar(@new) == 3) {
+ # Year, Month, Day: now it gets complicated.
+
+ if ($new[2] =~ /^[0-9]+$/) {
+ # A single number for the day of month, relatively simple
+ my $dt = DateTime->new(
+ year => $new[0],
+ month => $new[1],
+ day => $new[2]
+ );
+ $dt->add(%{$incr});
+ $new[0] = $dt->year;
+ $new[1] = $dt->month;
+ $new[2] = $dt->day;
+ }
+ } else {
+ warn("Don't know how to cope with @new");
+ }
+
+ foreach my $i (0..$#new) {
+ $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;
+ }
+
+ return @new;
+}
+
+1;
--- /dev/null
+# MFHD::Holding provides some additional holdings logic to a MARC::Field
+# object. In its current state it is primarily read-only, as direct changes
+# to the underlying MARC::Field are not reflected in the MFHD logic layer, and
+# only the 'increment', 'notes', and 'seqno' methods do updates to the
+# MARC::Field layer.
+
+package MFHD::Holding;
+use strict;
+use integer;
+
+use Carp;
+use DateTime;
+use Data::Dumper;
+
+use base 'MARC::Field';
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $seqno = shift;
+ my $self = shift;
+ my $caption = shift;
+ my $last_enum = undef;
+
+ $self->{_mfhdh_SEQNO} = $seqno;
+ $self->{_mfhdh_CAPTION} = $caption;
+ $self->{_mfhdh_DESCR} = {};
+ $self->{_mfhdh_COPY} = undef;
+ $self->{_mfhdh_BREAK} = undef;
+ $self->{_mfhdh_NOTES} = {};
+ $self->{_mfhdh_NOTES}{public} = [];
+ $self->{_mfhdh_NOTES}{private} = [];
+ $self->{_mfhdh_COPYRIGHT} = [];
+ $self->{_mfhdh_COMPRESSED} = ($self->indicator(2) eq '0' || $self->indicator(2) eq '2') ? 1 : 0;
+ # TODO: full support for second indicators 2, 3, and 4
+ $self->{_mfhdh_OPEN_ENDED} = 0;
+
+ foreach my $subfield ($self->subfields) {
+ my ($key, $val) = @$subfield;
+
+ if ($key =~ /[a-m]/) {
+ if (exists($self->{_mfhdh_FIELDS}->{$key})) {
+ carp("Duplicate, non-repeatable subfield '$key' found, ignoring");
+ next;
+ }
+ if ($self->{_mfhdh_COMPRESSED}) {
+ $self->{_mfhdh_FIELDS}->{$key}{HOLDINGS} = [split(/\-/, $val)];
+ } else {
+ $self->{_mfhdh_FIELDS}->{$key}{HOLDINGS} = [$val];
+ }
+ if ($key =~ /[a-h]/) {
+ # Enumeration specific details of holdings
+ $self->{_mfhdh_FIELDS}->{$key}{UNIT} = undef;
+ $last_enum = $key;
+ }
+ } elsif ($key eq 'o') {
+ warn '$o specified prior to first enumeration'
+ unless defined($last_enum);
+ $self->{_mfhdh_FIELDS}->{$last_enum}->{UNIT} = $val;
+ $last_enum = undef;
+ } elsif ($key =~ /[npq]/) {
+ $self->{_mfhdh_DESCR}->{$key} = $val;
+ } elsif ($key eq 's') {
+ push @{$self->{_mfhdh_COPYRIGHT}}, $val;
+ } elsif ($key eq 't') {
+ $self->{_mfhdh_COPY} = $val;
+ } elsif ($key eq 'w') {
+ carp "Unrecognized break indicator '$val'"
+ unless $val =~ /^[gn]$/;
+ $self->{_mfhdh_BREAK} = $val;
+ } elsif ($key eq 'x') {
+ push @{$self->{_mfhdh_NOTES}{private}}, $val;
+ } elsif ($key eq 'z') {
+ push @{$self->{_mfhdh_NOTES}{public}}, $val;
+ }
+ }
+
+ if ( $self->{_mfhdh_COMPRESSED}
+ && $self->{_mfhdh_FIELDS}{'a'}{HOLDINGS}[1] eq '') {
+ $self->{_mfhdh_OPEN_ENDED} = 1;
+ }
+ bless($self, $class);
+ return $self;
+}
+
+#
+# accessor to the object's field hash
+#
+# We are avoiding calling these elements 'subfields' because they are more
+# than simply the MARC subfields, although in the current implementation they
+# are indexed on the subfield key
+#
+# TODO: this accessor should probably be replaced with methods which hide the
+# underlying structure of {_mfhdh_FIELDS} (see field_values for a start)
+#
+sub fields {
+ my $self = shift;
+
+ return $self->{_mfhdh_FIELDS};
+}
+
+#
+# Given a field key, returns an array ref of one (for single statements)
+# or two (for compressed statements) values
+#
+# TODO: add setter functionality to replace direct {HOLDINGS} access in other
+# methods. It also makes sense to override some of the MARC::Field setter
+# methods (such as update()) to accomplish this level of encapsulation.
+#
+sub field_values {
+ my ($self, $key) = @_;
+
+ if (exists $self->fields->{$key}) {
+ my @values = @{$self->fields->{$key}{HOLDINGS}};
+ return \@values;
+ } else {
+ return undef;
+ }
+}
+
+sub seqno {
+ my $self = shift;
+
+ if (@_) {
+ $self->{_mfhdh_SEQNO} = $_[0];
+ $self->update(8 => $self->caption->link_id . '.' . $_[0]);
+ }
+
+ return $self->{_mfhdh_SEQNO};
+}
+
+#
+# Optionally accepts a true/false value to set the 'compressed' attribute
+# Returns 'compressed' attribute
+#
+sub is_compressed {
+ my $self = shift;
+ my $is_compressed = shift;
+
+ if (defined($is_compressed)) {
+ if ($is_compressed) {
+ $self->{_mfhdh_COMPRESSED} = 1;
+ $self->update(ind2 => '0');
+ } else {
+ $self->{_mfhdh_COMPRESSED} = 0;
+ $self->update(ind2 => '1');
+ }
+ }
+
+ return $self->{_mfhdh_COMPRESSED};
+}
+
+sub is_open_ended {
+ my $self = shift;
+
+ return $self->{_mfhdh_OPEN_ENDED};
+}
+
+sub caption {
+ my $self = shift;
+
+ return $self->{_mfhdh_CAPTION};
+}
+
+#
+# notes: If called with no arguments, returns the public notes array ref.
+# If called with a single argument, it returns either 'public' or
+# 'private' notes based on the passed string.
+#
+# If called with more than one argument, it sets the proper note field, with
+# type being the first argument and the note value(s) as the remaining
+# argument(s).
+#
+# It is also optional to pass in an array ref of note values as the third
+# argument rather than a list.
+#
+sub notes {
+ my $self = shift;
+ my $type = shift;
+ my @notes = @_;
+
+ if (!$type) {
+ $type = 'public';
+ } elsif ($type ne 'public' && $type ne 'private') {
+ carp("Notes being applied without specifying type");
+ unshift(@notes, $type);
+ $type = 'public';
+ }
+
+ if (ref($notes[0])) {
+ $self->{_mfhdh_NOTES}{$type} = $notes[0];
+ $self->_replace_note_subfields($type, @{$notes[0]});
+ } elsif (@notes) {
+ if ($notes[0]) {
+ $self->{_mfhdh_NOTES}{$type} = \@notes;
+ } else {
+ $self->{_mfhdh_NOTES}{$type} = [];
+ }
+ $self->_replace_note_subfields($type, @notes);
+ }
+
+ return $self->{_mfhdh_NOTES}{$type};
+}
+
+#
+# utility function for 'notes' method
+#
+sub _replace_note_subfields {
+ my $self = shift;
+ my $type = shift;
+ my @notes = @_;
+ my %note_subfield_ids = ('public' => 'z', 'private' => 'x');
+
+ $self->delete_subfield(code => $note_subfield_ids{$type});
+
+ foreach my $note (@notes) {
+ $self->add_subfields($note_subfield_ids{$type} => $note);
+ }
+}
+
+#
+# return a simple subfields list (for easier revivification from database)
+#
+sub subfields_list {
+ my $self = shift;
+ my @subfields;
+
+ foreach my $subfield ($self->subfields) {
+ push(@subfields, $subfield->[0], $subfield->[1]);
+ }
+ return @subfields;
+}
+
+#
+# Called by method 'format_part' for formatting the chronology portion of
+# the holding statement
+#
+sub format_chron {
+ my $self = shift;
+ my $holdings = shift;
+ my $caption = $self->caption;
+ my @keys = @_;
+ my $str = '';
+ my %month = (
+ '01' => 'Jan.',
+ '02' => 'Feb.',
+ '03' => 'Mar.',
+ '04' => 'Apr.',
+ '05' => 'May ',
+ '06' => 'Jun.',
+ '07' => 'Jul.',
+ '08' => 'Aug.',
+ '09' => 'Sep.',
+ '10' => 'Oct.',
+ '11' => 'Nov.',
+ '12' => 'Dec.',
+ '21' => 'Spring',
+ '22' => 'Summer',
+ '23' => 'Autumn',
+ '24' => 'Winter'
+ );
+
+ foreach my $i (0..@keys) {
+ my $key = $keys[$i];
+ my $capstr;
+ my $chron;
+ my $sep;
+
+ last if !defined $caption->capstr($key);
+
+ $capstr = $caption->capstr($key);
+ if (substr($capstr, 0, 1) eq '(') {
+ # a caption enclosed in parentheses is not displayed
+ $capstr = '';
+ }
+
+ # If this is the second level of chronology, then it's
+ # likely to be a month or season, so we should use the
+ # string name rather than the number given.
+ if (($i == 1)) {
+ # account for possible combined issue chronology
+ my @chron_parts = split('/', $holdings->{$key});
+ for (my $i = 0; $i < @chron_parts; $i++) {
+ $chron_parts[$i] = $month{$chron_parts[$i]} if exists $month{$chron_parts[$i]};
+ }
+ $chron = join('/', @chron_parts);
+ } else {
+ $chron = $holdings->{$key};
+ }
+
+ $str .= (($i == 0 || $str =~ /[. ]$/) ? '' : ':') . $capstr . $chron;
+ }
+
+ return $str;
+}
+
+#
+# Called by method 'format' for each member of a possibly compressed holding
+#
+sub format_part {
+ my $self = shift;
+ my $holding_values = shift;
+ my $caption = $self->caption;
+ my $str = '';
+
+ if ($caption->type_of_unit) {
+ $str = $caption->type_of_unit . ' ';
+ }
+
+ if ($caption->enumeration_is_chronology) {
+ # if issues are identified by chronology only, then the
+ # chronology data is stored in the enumeration subfields,
+ # so format those fields as if they were chronological.
+ $str = $self->format_chron($holding_values, 'a'..'f');
+ } else {
+ # OK, there is enumeration data and maybe chronology
+ # data as well, format both parts appropriately
+
+ # Enumerations
+ foreach my $key ('a'..'f') {
+ my $capstr;
+ my $chron;
+ my $sep;
+
+ last if !defined $caption->capstr($key);
+
+ $capstr = $caption->capstr($key);
+ if (substr($capstr, 0, 1) eq '(') {
+ # a caption enclosed in parentheses is not displayed
+ $capstr = '';
+ }
+ $str .=
+ ($key eq 'a' ? '' : ':') . $capstr . $holding_values->{$key};
+ }
+
+ # Chronology
+ if (defined $caption->capstr('i')) {
+ $str .= '(';
+ $str .= $self->format_chron($holding_values, 'i'..'l');
+ $str .= ')';
+ }
+
+ if ($caption->capstr('g')) {
+ # There's at least one level of alternative enumeration
+ $str .= '=';
+ foreach my $key ('g', 'h') {
+ $str .=
+ ($key eq 'g' ? '' : ':')
+ . $caption->capstr($key)
+ . $holding_values->{$key};
+ }
+
+ # This assumes that alternative chronology is only ever
+ # provided if there is an alternative enumeration.
+ if ($caption->capstr('m')) {
+ # Alternative Chronology
+ $str .= '(';
+ $str .= $caption->capstr('m') . $holding_values->{'m'};
+ $str .= ')';
+ }
+ }
+ }
+
+ # Breaks in the sequence
+ if (defined($self->{_mfhdh_BREAK})) {
+ if ($self->{_mfhdh_BREAK} eq 'n') {
+ $str .= ' non-gap break';
+ } elsif ($self->{_mfhdh_BREAK} eq 'g') {
+ $str .= ' gap';
+ } else {
+ warn "unrecognized break indicator '$self->{_mfhdh_BREAK}'";
+ }
+ }
+
+ return $str;
+}
+
+#
+# Create and return a string which conforms to display standard Z39.71
+#
+sub format {
+ my $self = shift;
+ my $subfields = $self->fields;
+ my %holding_start;
+ my %holding_end;
+ my $formatted;
+
+ foreach my $key (keys %$subfields) {
+ ($holding_start{$key}, $holding_end{$key}) =
+ @{$self->field_values($key)};
+ }
+
+ if ($self->is_compressed) {
+ # deal with open-ended statements
+ my $formatted_end;
+ if ($self->is_open_ended) {
+ $formatted_end = '';
+ } else {
+ $formatted_end = $self->format_part(\%holding_end);
+ }
+ $formatted =
+ $self->format_part(\%holding_start) . ' - ' . $formatted_end;
+ } else {
+ $formatted = $self->format_part(\%holding_start);
+ }
+
+ # Public Note
+ if (@{$self->notes}) {
+ $formatted .= ' -- ' . join(', ', @{$self->notes});
+ }
+
+ return $formatted;
+}
+
+# next: Given a holding statement, return a hash containing the
+# enumeration values for the next issues, whether we hold it or not
+# Just pass through to Caption::next
+#
+sub next {
+ my $self = shift;
+ my $caption = $self->caption;
+
+ return $caption->next($self);
+}
+
+#
+# matches($pat): check to see if $self matches the enumeration hashref passed
+# in as $pat, as returned by the 'next' method. e.g.:
+# $holding2->matches($holding1->next) # true if $holding2 directly follows
+# $holding1
+#
+# Always returns false if $self is compressed
+#
+sub matches {
+ my $self = shift;
+ my $pat = shift;
+
+ return 0 if $self->is_compressed;
+
+ foreach my $key ('a'..'f') {
+ # If a subfield exists in $self but not in $pat, or vice versa
+ # or if the field has different values, then fail
+ if (
+ defined($self->field_values($key)) != exists($pat->{$key})
+ || (exists $pat->{$key}
+ && ($self->field_values($key)->[0] ne $pat->{$key}))
+ ) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+#
+# Check that all the fields in a holdings statement are
+# included in the corresponding caption.
+#
+sub validate {
+ my $self = shift;
+
+ foreach my $key (keys %{$self->fields}) {
+ if (!$self->caption || !$self->caption->capfield($key)) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+#
+# Replace a single holding with it's next prediction
+# and return itself
+#
+sub increment {
+ my $self = shift;
+
+ if ($self->is_open_ended) {
+ carp "Holding is open-ended, cannot increment";
+ return $self;
+ } elsif ($self->is_compressed) {
+ carp "Incrementing a compressed holding is deprecated, use extend instead";
+ return $self->extend;
+ }
+
+ my $next = $self->next();
+
+ foreach my $key (keys %{$next}) {
+ $self->fields->{$key}{HOLDINGS}[0] = $next->{$key};
+ }
+
+ $self->seqno($self->seqno + 1);
+ $self->update(%{$next}); # update underlying subfields
+ return $self;
+}
+
+#
+# Extends a holding (compressing if needed) to include the next
+# prediction and returns itself
+#
+sub extend {
+ my $self = shift;
+
+ if ($self->is_open_ended) {
+ carp "Holding is open-ended, cannot extend";
+ return $self;
+ }
+
+ my $next = $self->next();
+
+ if (!$self->is_compressed) {
+ $self->is_compressed(1); # add compressed state
+ }
+
+ foreach my $key (keys %{$next}) {
+ my @values = @{$self->field_values($key)};
+ $values[1] = $next->{$key};
+ $self->fields->{$key}{HOLDINGS} = \@values;
+ $next->{$key} = join('-', @values);
+ }
+
+ $self->update(%{$next}); # update underlying subfields
+ return $self;
+}
+
+#
+# Turns a compressed holding into the singular form of the first member
+# in the range
+#
+sub compressed_to_first {
+ my $self = shift;
+
+ if (!$self->is_compressed) {
+ carp "Holding not compressed, cannot convert to first member";
+ return $self;
+ }
+
+ my %changes;
+ foreach my $key (keys %{$self->fields}) {
+ my @values = @{$self->field_values($key)};
+ $self->fields->{$key}{HOLDINGS} = [$values[0]];
+ $changes{$key} = $values[0];
+ }
+
+ $self->update(%changes); # update underlying subfields
+ $self->is_compressed(0); # remove compressed state
+
+ return $self;
+}
+
+#
+# Turns a compressed holding into the singular form of the last member
+# in the range
+#
+sub compressed_to_last {
+ my $self = shift;
+
+ if (!$self->is_compressed) {
+ carp "Holding not compressed, cannot convert to last member";
+ return $self;
+ } elsif ($self->is_open_ended) {
+ carp "Holding is open-ended, cannot convert to last member";
+ return $self;
+ }
+
+ my %changes;
+ foreach my $key (keys %{$self->fields}) {
+ my @values = @{$self->field_values($key)};
+ $self->fields->{$key}{HOLDINGS} = [$values[1]];
+ $changes{$key} = $values[1];
+ }
+
+ $self->update(%changes); # update underlying subfields
+ $self->is_compressed(0); # remove compressed state
+
+ return $self;
+}
+
+#
+# Basic, working, unoptimized clone operation
+#
+sub clone {
+ my $self = shift;
+
+ my $clone_field = $self->SUPER::clone();
+ return new MFHD::Holding($self->seqno, $clone_field, $self->caption);
+}
+
+#
+# Turn a chronology instance into date(s) in YYYY-MM-DD format
+#
+# In list context it returns a list of start and (possibly undefined)
+# end dates
+#
+# In scalar context, it returns a YYYY-MM-DD date string of either the
+# single date or the (possibly undefined) end date of a compressed holding
+#
+sub chron_to_date {
+ my $self = shift;
+ my $caption = $self->caption;
+
+ my @keys;
+ if ($caption->enumeration_is_chronology) {
+ @keys = ('a'..'f');
+ } else {
+ @keys = ('i'..'m');
+ }
+
+ # @chron_start and @chron_end will hold the (year, month, day) values
+ # represented by the start and optional end of the chronology instance.
+ # Default to January 1 with a year of 0 as initial values.
+ my @chron_start = (0, 1, 1);
+ my @chron_end = (0, 1, 1);
+ my @chrons = (\@chron_start, \@chron_end);
+ foreach my $key (@keys) {
+ my $capstr = $caption->capstr($key);
+ last if !defined($capstr);
+ if ($capstr =~ /year/) {
+ ($chron_start[0], $chron_end[0]) = @{$self->field_values($key)};
+ } elsif ($capstr =~ /month/) {
+ ($chron_start[1], $chron_end[1]) = @{$self->field_values($key)};
+ } elsif ($capstr =~ /day/) {
+ ($chron_start[2], $chron_end[2]) = @{$self->field_values($key)};
+ } elsif ($capstr =~ /season/) {
+ # chrons defined as season-only will use the astronomical season
+ # dates as a basic estimate.
+ my @seasons = @{$self->field_values($key)};
+ for (my $i = 0; $i < @seasons; $i++) {
+ $seasons[$i] = &_uncombine($seasons[$i], 0);
+ if ($seasons[$i] == 21) {
+ $chrons[$i]->[1] = 3;
+ $chrons[$i]->[2] = 20;
+ } elsif ($seasons[$i] == 22) {
+ $chrons[$i]->[1] = 6;
+ $chrons[$i]->[2] = 21;
+ } elsif ($seasons[$i] == 23) {
+ $chrons[$i]->[1] = 9;
+ $chrons[$i]->[2] = 22;
+ } elsif ($seasons[$i] == 24) {
+ $chrons[$i]->[1] = 12;
+ $chrons[$i]->[2] = 21;
+ }
+ }
+ }
+ }
+
+ my @dates;
+ foreach my $chron (@chrons) {
+ my $date = undef;
+ if ($chron->[0] != 0) {
+ $date =
+ &_uncombine($chron->[0], 0) . '-'
+ . sprintf('%02d', $chron->[1]) . '-'
+ . sprintf('%02d', $chron->[2]);
+ }
+ push(@dates, $date);
+ }
+
+ if (wantarray()) {
+ return @dates;
+ } elsif ($self->is_compressed) {
+ return $dates[1];
+ } else {
+ return $dates[0];
+ }
+}
+
+#
+# utility function for uncombining instance parts
+#
+sub _uncombine {
+ my ($combo, $pos) = @_;
+
+ if (ref($combo)) {
+ carp("Function '_uncombine' is not an instance method");
+ return;
+ }
+
+ my @parts = split('/', $combo);
+ return $parts[$pos];
+}
+
+#
+# Overload string comparison operators
+#
+# We are not overloading '<=>' because '==' is used liberally in MARC::Record
+# to compare field identity (i.e. is this the same exact Field object?), not value
+#
+# Other string operators are auto-generated from 'cmp'
+#
+# Please note that this comparison is based on what the holding represents,
+# not whether it is strictly identical (e.g. the seqno and link may vary)
+#
+use overload ('cmp' => \&_compare,
+ 'fallback' => 1);
+sub _compare {
+ my ($holding_1, $holding_2) = @_;
+
+ # TODO: this needs some more consideration
+ # fall back to 'built-in' comparison
+ if (!UNIVERSAL::isa($holding_2, ref $holding_1)) {
+ if (defined $holding_2) {
+ carp("Use of non-holding in holding comparison operation");
+ return ( "$holding_1" cmp "$holding_2" );
+ } else {
+ carp("Use of undefined value in holding comparison operation");
+ return 1; # similar to built-in, something is "greater than" nothing
+ }
+ }
+
+ # special cases for compressed holdings
+ my ($holding_1_first, $holding_1_last, $holding_2_first, $holding_2_last, $found_compressed);
+ # 0 for no compressed, 1 for first compressed, 2 for second compressed, 3 for both compressed
+ $found_compressed = 0;
+ if ($holding_1->is_compressed) {
+ $holding_1_last = $holding_1->clone->compressed_to_last;
+ $found_compressed += 1;
+ } else {
+ $holding_1_first = $holding_1;
+ $holding_1_last = $holding_1;
+ }
+ if ($holding_2->is_compressed) {
+ $holding_2_first = $holding_2->clone->compressed_to_first;
+ $found_compressed += 2;
+ } else {
+ $holding_2_first = $holding_2;
+ $holding_2_last = $holding_2;
+ }
+
+ if ($found_compressed) {
+ my $cmp = ($holding_1_last cmp $holding_2_first); # 1 ends before 2 starts
+ if ($cmp == -1) {
+ return -1; # 1 is fully lt
+ } elsif ($cmp == 0) {
+ carp("Overlapping holdings in comparison, lt and gt based on start value only");
+ return -1;
+ } else { # check the opposite, 2 ends before 1 starts
+ # clone is expensive, wait until we need it (here)
+ if (!defined($holding_2_last)) {
+ $holding_2_last = $holding_2->clone->compressed_to_last;
+ }
+ if (!defined($holding_1_first)) {
+ $holding_1_first = $holding_1->clone->compressed_to_first;
+ }
+ $cmp = ($holding_2_last cmp $holding_1_first);
+ if ($cmp == -1) {
+ return 1; # 1 is fully gt
+ } elsif ($cmp == 0) {
+ carp("Overlapping holdings in comparison, lt and gt based on start value only");
+ return 1;
+ } else {
+ $cmp = ($holding_1_first cmp $holding_2_first);
+ if (!$cmp) { # they are not equal
+ carp("Overlapping holdings in comparison, lt and gt based on start value only");
+ return $cmp;
+ } elsif ($found_compressed == 1) {
+ carp("Compressed holding found with start equal to non-compressed holding");
+ return 1; # compressed (first holding) is 'greater than' non-compressed
+ } elsif ($found_compressed == 2) {
+ carp("Compressed holding found with start equal to non-compressed holding");
+ return -1; # compressed (second holding) is 'greater than' non-compressed
+ } else { # both holdings compressed, check for full equality
+ $cmp = ($holding_1_last cmp $holding_2_last);
+ if (!$cmp) { # they are not equal
+ carp("Compressed holdings in comparison have equal starts, lt and gt based on end value only");
+ return $cmp;
+ } else {
+ return 0; # both are compressed, both ends are equal
+ }
+ }
+ }
+ }
+ }
+
+ # start doing the actual comparison
+ my $result;
+ foreach my $key ('a'..'f') {
+ if (defined($holding_1->field_values($key))) {
+ if (!defined($holding_2->field_values($key))) {
+ return 1; # more details equals 'greater' (?)
+ } else {
+ $result = $holding_1->field_values($key)->[0] <=> $holding_2->field_values($key)->[0];
+ }
+ } elsif (defined($holding_2->field_values($key))) {
+ return -1; # more details equals 'greater' (?)
+ }
+
+ return $result if $result;
+ }
+
+ # got through, return 0 for equal
+ return 0;
+}
+
+1;
--- /dev/null
+test:
+ perl -I../../../.. mfhd.t
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Data::Dumper;
+use Test::More 'no_plan';
+
+use MARC::Record;
+use OpenILS::Utils::MFHD;
+
+use testlib;
+
+my $testno = 1;
+
+sub right_answer {
+ my $holding = shift;
+ my $answer = {};
+
+ foreach my $subfield (split(/\|/, $holding->subfield('x'))) {
+ next unless $subfield;
+
+ my ($key, $val) = unpack('aa*', $subfield);
+ $answer->{$key} = $val;
+ }
+
+ return $answer;
+}
+
+
+my $rec;
+my @captions;
+
+open(my $testdata, "<mfhddata.txt") or die("Cannot open 'mfhddata.txt': $!");
+
+while ($rec = testlib::load_MARC_rec($testdata, $testno++)) {
+ $rec = MFHD->new($rec);
+
+ foreach my $cap (sort { $a->tag <=> $b->tag } $rec->field('85.')) {
+ my $htag;
+ my @holdings;
+
+ ($htag = $cap->tag) =~ s/^85/86/;
+ @holdings = $rec->holdings($htag, $cap->subfield('8'));
+
+ if (!ok(scalar @holdings, "holdings defined " . $cap->subfield('8'))) {
+ next;
+ }
+
+ foreach my $field (@holdings) {
+ TODO: {
+ local $TODO = "unimplemented"
+ if ($field->subfield('z') =~ /^TODO/);
+ is_deeply($field->next, right_answer($field),
+ $field->subfield('8') . ': ' . $field->subfield('z'));
+ }
+ }
+ }
+}
+
+1;
--- /dev/null
+245 00 $aMonthly, issue no. restarts, calendar change: Jan
+853 20 $81$av.$bno.$u12$vr$i(year)$j(month)$wm$x01
+863 41 $81.1$a1$b6$i1990$j06$x|a1|b7|i1990|j07$zMiddle of year, middle of vol.
+863 41 $81.2$a1$b11$i1990$j11$x|a1|b12|i1990|j12$zEnd of year, end of vol.
+863 41 $81.3$a1$b12$i1990$j12$x|a2|b1|i1991|j01$zWrap at end of year/vol.
+
+245 00 $aMonthly, issue no. restarts, calendar change: Mar
+853 20 $82$av.$bno.$u12$vr$i(year)$j(month)$wm$x03
+863 41 $82.1$a1$b6$i1990$j08$x|a1|b7|i1990|j09$zMiddle of year, middle of vol.
+863 41 $82.2$a1$b10$i1990$j12$x|a1|b11|i1991|j01$zEnd of year, middle of vol.
+863 41 $82.3$a1$b11$i1991$j01$x|a1|b12|i1991|j02$zMiddle of year, end of vol.
+863 41 $82.3$a1$b12$i1991$j02$x|a2|b1|i1991|j03$zWrap vol in mid-year
+
+245 00 $aMonthly, issue no. continuous, calendar change: Jan
+853 20 $83$av.$bno.$u12$vc$i(year)$j(month)$wm$x01
+863 41 $83.1$a1$b6$i1990$j06$x|a1|b7|i1990|j07$zMiddle of year, middle of vol.
+863 41 $83.2$a1$b11$i1990$j11$x|a1|b12|i1990|j12$zEnd of year, end of vol.
+863 41 $83.3$a1$b12$i1990$j12$x|a2|b13|i1991|j01$zwrap vol @ end of year
+
+245 00 $aMonthly, issue no. continuous, calendar change: Mar
+853 20 $84$av.$bno.$u12$vc$i(year)$j(month)$wm$x03
+863 41 $84.1$a1$b6$i1990$j08$x|a1|b7|i1990|j09$zMiddle of year, middle of vol.
+863 41 $84.2$a1$b10$i1990$j12$x|a1|b11|i1991|j01$zEnd of year, middle of vol.
+863 41 $84.3$a1$b11$i1991$j01$x|a1|b12|i1991|j02$zMiddle of year, end of vol.
+863 41 $84.4$a1$b12$i1991$j02$x|a2|b13|i1991|j03$zwrap vol mid-year
+
+245 00 $aMonthly, issue no. restarts, Calendar change: Jan, Jul
+853 20 $85$av.$bno.$u6$vr$i(year)$j(month)$wm$x01,07
+863 41 $85.1$a1$b5$i1990$j05$x|a1|b6|i1990|j06$zMiddle of year, near end of vol.
+863 41 $85.2$a1$b6$i1990$j06$x|a2|b1|i1990|j07$zMiddle of year, end of vol.
+863 41 $85.3$a2$b6$i1990$j12$x|a3|b1|i1991|j01$zEnd of year, end of vol.
+
+245 00 $aMonthly, issue no. continuous, Calendar change: Jan, Jul
+853 20 $86$av.$bno.$u6$vc$i(year)$j(month)$wm$x01,07
+863 41 $86.1$a1$b5$i1990$j05$x|a1|b6|i1990|j06$zMiddle of year, end of vol.
+863 41 $86.2$a1$b6$i1990$j06$x|a2|b7|i1990|j07$zMiddle of year, end of vol.
+863 41 $86.3$a2$b12$i1990$j12$x|a3|b13|i1991|j01$zEnd of year, end of vol.
+
+245 00 $aMonthly, issue no. restarts, Calendar change: Jan, Combined issue: Jan/Feb
+853 20 $87$av.$bno.$u11$vr$i(year)$j(month)$wm$x01$ycm01/02
+863 41 $87.1$a1$b11$i1990$j12$x|a2|b1|i1991|j01/02$z End of year, end of vol.
+863 41 $87.2$a2$b1$i1991$j01/02$x|a2|b2|i1991|j03$z Beginning of year, beginning of vol.
+
+245 00 $aMonthly, iss no. restarts, Calendar change: Jan, Combined iss: Nov/Dec
+853 20 $88$av.$bno.$u11$vr$i(year)$j(month)$wm$x01$ycm11/12
+863 41 $88.1$a1$b10$i1990$j10$x|a1|b11|i1990|j11/12$z end of year, end of vol.
+863 41 $88.2$a1$b11$i1990$j11/12$x|a2|b1|i1991|j01$z wrap vol at year end
+
+245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: Jan/Feb, Nov/Dec
+853 20 $89$av.$bno.$u10$vr$i(year)$j(month)$wm$x01$ycm01/02,11/12
+863 41 $89.1$a1$b1$i1990$j01/02$x|a1|b2|i1990|j03$z beg. of year, beg. of vol.
+863 41 $89.2$a1$b9$i1990$j10$x|a1|b10|i1990|j11/12$z end of year, end of vol.
+863 41 $89.3$a1$b10$i1990$j11/12$x|a2|b1|i1991|j01/02$z zwrap vol at year end
+
+245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: May/Jun, Jul/Aug
+853 20 $810$av.$bno.$u10$vr$i(year)$j(month)$wm$x01$ycm05/06,07/08
+863 41 $810.1$a1$b4$i1990$j04$x|a1|b5|i1990|j05/06$z next iss is combined.
+863 41 $810.2$a1$b5$i1990$j05/06$x|a1|b6|i1990|j07/08$z combined to combined
+863 41 $810.3$a1$b6$i1990$j07/08$x|a1|b7|i1990|j09$z combined to reg
+
+245 00 $aMonthly, issue no. restarts, Calendar change: Jan, Combined issue: 1/2 Jan/Feb
+853 20 $811$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm01/02$yce21/2
+863 41 $811.1$a1$b12$i1990$j12$x|a2|b1/2|i1991|j01/02$znew vol at year end regular iss to combined
+863 41 $811.2$a2$b1/2$i1991$j01/02$x|a2|b3|i1991|j03$zcombined iss to regular
+
+245 00 $aMonthly, iss no. restarts, Calendar change: Jan, Combined iss: 11/12 Nov/Dec
+853 20 $812$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm11/12$yce211/12
+863 41 $812.1$a1$b10$i1990$j10$x|a1|b11/12|i1990|j11/12$zregular to combined iss
+863 41 $812.2$a1$b11/12$i1990$j11/12$x|a2|b1|i1991|j01$zend of vol: combined to regular issue
+
+245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: 1/2 Jan/Feb, 11/12 Nov/Dec
+853 20 $813$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm01/02,11/12$yce21/2,11/12
+863 41 $813.1$a1$b10$i1990$j10$x|a1|b11/12|i1990|j11/12$zend of vol regular to combined iss
+863 41 $813.2$a1$b11/12$i1990$j11/12$x|a2|b1/2|i1991|j01/02$zwrap at volume end: combined to combined
+863 41 $813.3$a2$b1/2$i1991$j01/02$x|a2|b3|i1991|j03$zbeginning of vol: combined to regular
+
+245 00 $aMonthly, iss no. restarts, Cal. change: Jan, Combined iss: 5/6 May/Jun, 7/8 Jul/Aug
+853 20 $814$av.$bno.$u12$vr$i(year)$j(month)$wm$x01$ycm05/06,07/08$yce25/6,7/8
+863 41 $814.1$a1$b4$i1990$j04$x|a1|b5/6|i1990|j05/06$zmid year: reg to combined
+863 41 $814.2$a1$b5/6$i1990$j05/06$x|a1|b7/8|i1990|j07/08$zmid year: combined to combined
+863 41 $814.3$a1$b7/8$i1990$j07/08$x|a1|b9|i1990|j09$zmid year: combined to regular
+
+245 00 $aMonthly, iss no. restarts, Cal change: Jan, July issue omitted
+853 20 $815$av.$bno.$u11$vr$i(year)$j(month)$wm$x01$yom07
+863 41 $815.1$a1$b6$i1990$j06$x|a1|b7|i1990|j08$zskip july issue
+
+245 00 $aQuarterly, chronology in enumeration fields
+853 20 $816$a(year)$b(season)$wq$yps21,22,23,24
+863 41 $816.1$a2007$b21$x|a2007|b22$zChron in enum: simple case: quarterly in mid-volume
+863 41 $816.2$a2007$b24$x|a2008|b21$zChron in enum: Roll over to new year
+
+245 00 $aFour issues a year, chronology in enum fields, combined Sum/Fall issue
+853 20 $817$a(year)$b(season)$wq$ycs22/23
+863 41 $817.1$a2007$b21$x|a2007|b22/23$zChron in enum: Spring to Summer/Fall
+863 41 $817.2$a2007$b22/23$x|a2007|b24$zChron in enum: Summer/Fall to Winter
+
+245 00 $aLibrary Journal: 20 times a year, semimonthly except Jan, Jul, Aug, Dec
+853 20 $818$av.$bno.$u20$vr$i(year)$j(month)$k(day)$ws$x01$ypd01,15$yod0115,0715,0815,1215
+863 41 $818.1$a132$b20$i2007$j12$k1$x|a133|b1|i2008|j01|k01$zSkipping over missed date to beginning of next year/volume.
+863 41 $818.2$a133$b1$i2008$j01$k01$x|a133|b2|i2008|j02|k01$zSkipping over missed date at beginning of year
+863 41 $818.3$a133$b2$i2008$j02$k01$x|a133|b3|i2008|j02|k15$zPublished semimonthly, going from 1st to 15th
+863 41 $818.4$a133$b3$i2008$j02$k15$x|a133|b4|i2008|j03|k01$zPublished semimonthly, going from 15th to 1st
+
+245 00 $aBimonthly: Feb, Apr, June, Aug, Oct, Dec
+853 20 $819$av.$bno.$u6$vr$i(year)$j(month)$wb$x02$ypm02,04,06,08,10,12
+863 41 $819.1$a1$b3$i1990$j06$x|a1|b4|i1990|j08$zMiddle of year, middle of vol.
+863 41 $819.2$a1$b5$i1990$j10$x|a1|b6|i1990|j12$zEnd of year, end of vol.
+863 41 $819.3$a1$b6$i1990$j12$x|a2|b1|i1991|j02$zWrap at end of year/vol.
+
+245 00 $aBimonthly, published 5 times with combined summer issue: Feb, Apr, June/Aug, Oct, Dec
+853 20 $820$av.$bno.$u5$vr$i(year)$j(month)$wb$x02$ypm02,04,10,12$ycm06/08
+863 41 $820.1$a1$b2$i1990$j04$x|a1|b3|i1990|j06/08$zFrom Apr to Jun/Aug
+863 41 $820.2$a1$b3$i1990$j06/08$x|a1|b4|i1990|j10$zFrom Jun/Aug to Oct
+863 41 $820.3$a1$b5$i1990$j12$x|a2|b1|i1991|j02$zWrap at end of year/vol.
+
+245 00 $aEconomist: pub. w on Sa, except combined iss on last two weeks of year
+853 20 $821$av.$bno.$u12$vc$i(year)$j(month)$k(day)$ww$x01,04,07,10$ypdsa$yow1299
+863 41 $821.1$a100$b1200$i2008$j12$k06$x|a100|b1201|i2008|j12|k13$zwithin vol.
+863 41 $821.2$a100$b1201$i2008$j12$k13$x|a100|b1202|i2008|j12|k20$zwithin vol. combined iss.
+863 41 $821.3$a100$b1202$i2008$j12$k20$x|a101|b1203|i2009|j01|k03$zvolume change over omitted iss.
+
+245 00 $aMFHD example: monthly, pub. 2nd Wed of month except in April: 2nd Thu; May:1st Wednesday.
+853 20 $822$av.$bno.$u12$vr$i(year)$j(month)$k(day)$wm$x01$ypw02we$ypw0402th,0501we$yow0402we,0502we
+863 41 $822.1$a1$b2$i2009$j02$k11$x|a1|b3|i2009|j03|k11$zpublished on 2nd Wed in Mar
+863 41 $822.2$a1$b3$i2009$j03$k11$x|a1|b4|i2009|j04|k09$zpublished on 2nd Thu in Apr
+863 41 $822.3$a1$b4$i2009$j04$k09$x|a1|b5|i2009|j05|k06$zpublished on 1st Wed in May
+863 41 $822.4$a2$b4$i2013$j04$k11$x|a2|b5|i2013|j05|k01$zpublished on Wed May 1st
+
+245 00 $aMFHD example: pub. every Mon, Thu, except on New Years, July 4, Labor Day, Thanksgiving, Christmas
+853 20 $823$av.$bno.$uvar$vr$i(year)$j(month)$k(day)$wc$x07$ypw00mo,00th$yod0101,0704,1225$yow0901mo,1104th
+863 41 $823.1$a1$b100$i2009$j02$k02$x|a1|b101|i2009|j02|k05$znormal: Mon to Thu
+863 41 $823.2$a1$b101$i2009$j02$k05$x|a1|b102|i2009|j02|k09$znormal: Thu to Mon
+863 41 $823.3$a1$b150$i2009$j06$k29$x|a2|b151|i2009|j07|k02$znormal: calendar change
+863 41 $823.4$a2$b180$i2009$j09$k03$x|a2|b181|i2009|j09|k10$zSkip Labor Day
+863 41 $823.5$a2$b200$i2009$j11$k23$x|a2|b201|i2009|j11|k30$zSkip (US) Thanksgiving
+
+#
+# According to the specification and the examples at
+# http://www.loc.gov/marc/chrono_patterns.html it is possible to
+# document a combined issue in a $yp publication regularity definition,
+# like this: $yps21,22/23,24
+245 00 $aCombined date documented in publication pattern rather than combined pattern
+853 20 $824$av.$bno.$u3$vr$i(year)$j(season)$wq$x21$yps21,22/23,24
+863 41 $824.1$a1$b1$i2009$j21$x|a1|b2|i2009|j22/23$zSpring to Summer/Fall
+863 41 $824.2$a1$b2$i2009$j22/23$x|a1|b3|i2009|j24$zSummer/Fall to Winter
+
+# Item is published 6 times/year whose enumeration "skips" numbers
+# at the second level using only odd numbers that restart
+# at the turn of the calendar year.
+# (From www.loc.gov/marc/chrono_patterns.html)
+245 00 $aFunky enumeration
+853 20 $825$av.$bno.$u6$vr$i(year)$j(month)$wb$ype21,3,5,7,9,11
+863 41 $825.1$a1$b1$i1990$j01$x|a1|b3|i1990|j03$zJan to Mar
+863 41 $825.2$a1$b11$i1990$j11$x|a2|b1|i1991|j01$zNov to Jan, year & vol wrap
+
+
+# Monthly, one volume per year, issue numbering restarts in January
+# Annual supplement published in September, annual index published in
+# February
+245 00 $aSupplements and Indexes: Oh My
+853 20 $826$av.$bno.$u12$vr$i(year)$j(month)$wm
+854 20 $827$av.$i(year)$j(month)$wa$ypm09$oSupplement
+855 20 $828$av.$i(year)$j(month)$ypm02$oIndex
+863 41 $826.1$a1$b1$i1990$j01$x|a1|b2|i1990|j02$znormal issue
+864 41 $827.1$a1$i1990$j09$x|a2|i1991|j09$zAnnual supplement
+865 41 $828.1$a1$i1990$j02$x|a2|i1991|j02$zAnnual Index
--- /dev/null
+package testlib;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+our @EXPORT_OK = qw(load_MARC_rec);
+
+use Data::Dumper;
+
+use MARC::Record;
+
+sub load_MARC_rec {
+ my $fh = shift;
+ my $testno = shift;
+ my $rec;
+ my $line;
+ my $marc = undef;
+
+ # skim to beginning of record (a non-blank, non comment line)
+ while ($line = <$fh>) {
+ chomp $line;
+ last if (!($line =~ /^\s*$/) && !($line =~ /^#/));
+ }
+
+ return undef if !$line;
+
+ $marc = MARC::Record->new();
+ carp('No record created!') unless $marc;
+
+ $marc->leader('01119nas 22003134a 4500');
+ $marc->append_fields(
+ MARC::Field->new('008', '970701c18439999enkwr p 0 a0eng '));
+ $marc->append_fields(
+ MARC::Field->new('035', '', '', a => sprintf('%04d', $testno)));
+
+ while ($line) {
+ next if $line =~ /^#/; # allow embedded comments
+
+ return $marc if $line =~ /^\s*$/;
+
+ my ($fieldno, $indicators, $rest) = split(/ /, $line, 3);
+ my @inds = unpack('aa', $indicators);
+ my $field;
+ my @subfields;
+
+ @subfields = ();
+ foreach my $subfield (split(/\$/, $rest)) {
+ next unless $subfield;
+
+ my ($key, $val) = unpack('aa*', $subfield);
+ push @subfields, $key, $val;
+ }
+
+ $field = MARC::Field->new(
+ $fieldno, $inds[0], $inds[1],
+ @subfields
+ );
+
+ $marc->append_fields($field);
+
+ $line = <$fh>;
+ chomp $line if $line;
+ }
+ return $marc;
+}
+
+1;
--- /dev/null
+package OpenILS::Utils::MFHDParser;
+use strict;
+use warnings;
+
+use OpenSRF::EX qw/:try/;
+use Time::HiRes qw(time);
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use OpenILS::Utils::MFHD;
+use MARC::File::XML (BinaryEncoding => 'utf8');
+use Data::Dumper;
+
+sub new { return bless({}, shift()); }
+
+=head1 Subroutines
+
+=over
+
+=item * format_textual_holdings($field)
+
+=back
+
+Returns concatenated subfields $a with $z for textual holdings (866-868)
+
+=cut
+
+sub format_textual_holdings {
+ my ($self, $field) = @_;
+ my $holdings;
+ my $public_note;
+
+ $holdings = $field->subfield('a');
+ if (!$holdings) {
+ return undef;
+ }
+
+ $public_note = $field->subfield('z');
+ if ($public_note) {
+ return "$holdings -- $public_note";
+ }
+ return $holdings;
+}
+
+=over
+
+=item * mfhd_to_hash($mfhd_xml)
+
+=back
+
+Returns a Perl hash containing fields of interest from the MFHD record
+
+=cut
+
+sub mfhd_to_hash {
+ my ($self, $mfhd_xml) = @_;
+
+ my $marc;
+ my $mfhd;
+
+ my $location = '';
+ my $basic_holdings = [];
+ my $supplement_holdings = [];
+ my $index_holdings = [];
+ my $basic_holdings_add = [];
+ my $supplement_holdings_add = [];
+ my $index_holdings_add = [];
+ my $online = []; # Laurentian extension to MFHD standard
+ my $missing = []; # Laurentian extension to MFHD standard
+ my $incomplete = []; # Laurentian extension to MFHD standard
+
+ try {
+ $marc = MARC::Record->new_from_xml($mfhd_xml);
+ }
+ otherwise {
+ $logger->error("Failed to convert MFHD XML to MARC: " . shift());
+ $logger->error("Failed MFHD XML: $mfhd_xml");
+ };
+
+ if (!$marc) {
+ return undef;
+ }
+
+ try {
+ $mfhd = MFHD->new($marc);
+ }
+ otherwise {
+ $logger->error("Failed to parse MFHD: " . shift());
+ $logger->error("Failed MFHD XML: $mfhd_xml");
+ };
+
+ if (!$mfhd) {
+ return undef;
+ }
+
+ try {
+ foreach my $field ($marc->field('852')) {
+ foreach my $subfield_ref ($field->subfields) {
+ my ($subfield, $data) = @$subfield_ref;
+ $location .= $data . " -- ";
+ }
+ }
+ }
+ otherwise {
+ $logger->error("MFHD location parsing error: " . shift());
+ };
+
+ $location =~ s/ -- $//;
+
+ # TODO: for now, we will assume that textual holdings are in addition to the
+ # computable holdings (that is, they have link IDs greater than the 85X fields)
+ # or that they fully replace the computable holdings (checking for link ID '0').
+ # Eventually this may be handled better by format_holdings() in MFHD.pm
+ my %skip_computable;
+ try {
+ foreach my $field ($marc->field('866')) {
+ my $textual_holdings = $self->format_textual_holdings($field);
+ if ($textual_holdings) {
+ push @$basic_holdings_add, $textual_holdings;
+ if ($field->subfield('8') eq '0') {
+ $skip_computable{'basic'} = 1; # link ID 0 trumps computable fields
+ }
+ }
+ }
+ foreach my $field ($marc->field('867')) {
+ my $textual_holdings = $self->format_textual_holdings($field);
+ if ($textual_holdings) {
+ push @$supplement_holdings_add, $textual_holdings;
+ if ($field->subfield('8') eq '0') {
+ $skip_computable{'supplement'} = 1; # link ID 0 trumps computable fields
+ }
+ }
+ }
+ foreach my $field ($marc->field('868')) {
+ my $textual_holdings = $self->format_textual_holdings($field);
+ if ($textual_holdings) {
+ push @$index_holdings_add, $textual_holdings;
+ if ($field->subfield('8') eq '0') {
+ $skip_computable{'index'} = 1; # link ID 0 trumps computable fields
+ }
+ }
+ }
+
+ if (!exists($skip_computable{'basic'})) {
+ foreach my $cap_id ($mfhd->caption_link_ids('853')) {
+ my @holdings = $mfhd->holdings('863', $cap_id);
+ next unless scalar @holdings;
+ foreach (@holdings) {
+ push @$basic_holdings, $_->format();
+ }
+ }
+ if (!@$basic_holdings) { # no computed holdings found
+ $basic_holdings = $basic_holdings_add;
+ $basic_holdings_add = [];
+ }
+ } else { # textual are non additional, but primary
+ $basic_holdings = $basic_holdings_add;
+ $basic_holdings_add = [];
+ }
+
+ if (!exists($skip_computable{'supplement'})) {
+ foreach my $cap_id ($mfhd->caption_link_ids('854')) {
+ my @supplements = $mfhd->holdings('864', $cap_id);
+ next unless scalar @supplements;
+ foreach (@supplements) {
+ push @$supplement_holdings, $_->format();
+ }
+ }
+ if (!@$supplement_holdings) { # no computed holdings found
+ $supplement_holdings = $supplement_holdings_add;
+ $supplement_holdings_add = [];
+ }
+ } else { # textual are non additional, but primary
+ $supplement_holdings = $supplement_holdings_add;
+ $supplement_holdings_add = [];
+ }
+
+ if (!exists($skip_computable{'index'})) {
+ foreach my $cap_id ($mfhd->caption_link_ids('855')) {
+ my @indexes = $mfhd->holdings('865', $cap_id);
+ next unless scalar @indexes;
+ foreach (@indexes) {
+ push @$index_holdings, $_->format();
+ }
+ }
+ if (!@$index_holdings) { # no computed holdings found
+ $index_holdings = $index_holdings_add;
+ $index_holdings_add = [];
+ }
+ } else { # textual are non additional, but primary
+ $index_holdings = $index_holdings_add;
+ $index_holdings_add = [];
+ }
+
+ # Laurentian extensions
+ foreach my $field ($marc->field('530')) {
+ my $online_stmt = $self->format_textual_holdings($field);
+ if ($online_stmt) {
+ push @$online, $online_stmt;
+ }
+ }
+
+ foreach my $field ($marc->field('590')) {
+ my $missing_stmt = $self->format_textual_holdings($field);
+ if ($missing_stmt) {
+ push @$missing, $missing_stmt;
+ }
+ }
+
+ foreach my $field ($marc->field('591')) {
+ my $incomplete_stmt = $self->format_textual_holdings($field);
+ if ($incomplete_stmt) {
+ push @$incomplete, $incomplete_stmt;
+ }
+ }
+ }
+ otherwise {
+ $logger->error("MFHD statement parsing error: " . shift());
+ };
+
+ return {
+ location => $location,
+ basic_holdings => $basic_holdings,
+ basic_holdings_add => $basic_holdings_add,
+ supplement_holdings => $supplement_holdings,
+ supplement_holdings_add => $supplement_holdings_add,
+ index_holdings => $index_holdings,
+ index_holdings_add => $index_holdings_add,
+ missing => $missing,
+ incomplete => $incomplete,
+ online => $online
+ };
+}
+
+=over
+
+=item * init_holdings_virtual_record()
+
+=back
+
+Initialize the serial virtual record (svr) instance
+
+=cut
+
+sub init_holdings_virtual_record {
+ my $record = Fieldmapper::serial::virtual_record->new;
+ $record->sre_id();
+ $record->location();
+ $record->owning_lib();
+ $record->basic_holdings([]);
+ $record->basic_holdings_add([]);
+ $record->supplement_holdings([]);
+ $record->supplement_holdings_add([]);
+ $record->index_holdings([]);
+ $record->index_holdings_add([]);
+ $record->online([]);
+ $record->missing([]);
+ $record->incomplete([]);
+ return $record;
+}
+
+=over
+
+=item * init_holdings_virtual_record($mfhd)
+
+=back
+
+Given an MFHD record, return a populated svr instance
+
+=cut
+
+sub generate_svr {
+ my ($self, $id, $mfhd, $owning_lib) = @_;
+
+ if (!$mfhd) {
+ return undef;
+ }
+
+ my $record = init_holdings_virtual_record();
+ my $holdings = $self->mfhd_to_hash($mfhd);
+
+ $record->sre_id($id);
+ $record->owning_lib($owning_lib);
+
+ if (!$holdings) {
+ return $record;
+ }
+
+ $record->location($holdings->{location});
+ $record->basic_holdings($holdings->{basic_holdings});
+ $record->basic_holdings_add($holdings->{basic_holdings_add});
+ $record->supplement_holdings($holdings->{supplement_holdings});
+ $record->supplement_holdings_add($holdings->{supplement_holdings_add});
+ $record->index_holdings($holdings->{index_holdings});
+ $record->index_holdings_add($holdings->{index_holdings_add});
+ $record->online($holdings->{online});
+ $record->missing($holdings->{missing});
+ $record->incomplete($holdings->{incomplete});
+
+ return $record;
+}
+
+1;
+
+# vim: ts=4:sw=4:noet
--- /dev/null
+package OpenILS::Utils::ModsParser;
+use strict; use warnings;
+
+use OpenSRF::EX qw/:try/;
+use XML::LibXML;
+use XML::LibXSLT;
+use Time::HiRes qw(time);
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/$logger/;
+use Data::Dumper;
+
+my $parser = XML::LibXML->new();
+my $xslt = XML::LibXSLT->new();
+my $mods_sheet;
+
+# ----------------------------------------------------------------------------------------
+# XPATH for extracting info from a MODS doc
+my $isbn_xpath = "//mods:mods/mods:identifier[\@type='isbn']";
+my $resource_xpath = "//mods:mods/mods:typeOfResource";
+my $pub_xpath = "//mods:mods/mods:originInfo//mods:dateIssued[\@encoding='marc']|" .
+ "//mods:mods/mods:originInfo//mods:dateIssued[1]";
+my $tcn_xpath = "//mods:mods/mods:recordInfo/mods:recordIdentifier";
+my $publisher_xpath = "//mods:mods/mods:originInfo//mods:publisher[1]";
+my $edition_xpath = "//mods:mods/mods:originInfo//mods:edition[1]";
+my $abstract_xpath = "//mods:mods/mods:abstract";
+my $related_xpath = "";
+my $online_loc_xpath = "//mods:location/mods:url";
+my $physical_desc = "(//mods:mods/mods:physicalDescription/mods:form|//mods:mods/mods:physicalDescription/mods:extent|".
+ "//mods:mods/mods:physicalDescription/mods:reformattingQuality|//mods:mods/mods:physicalDescription/mods:internetMediaType|".
+ "//mods:mods/mods:physicalDescription/mods:digitalOrigin)";
+my $toc_xpath = "//mods:tableOfContents";
+
+my $xpathset = {
+
+ title => {
+ abbreviated =>
+ "//mods:mods/mods:titleInfo[mods:title and (\@type='abbreviated')]",
+ translated =>
+ "//mods:mods/mods:titleInfo[mods:title and (\@type='translated')]",
+ uniform =>
+ "//mods:mods/mods:titleInfo[mods:title and (\@type='uniform')]",
+ proper =>
+ "//mods:mods/mods:titleInfo[mods:title and not (\@type)]",
+ any =>
+ "//mods:mods/mods:titleInfo",
+ },
+
+ author => {
+ corporate =>
+ "//mods:mods/mods:name[\@type='corporate']/*[local-name()='namePart']".
+ "[../mods:role/mods:text[text()='creator']".
+ " or ../mods:role/mods:roleTerm[".
+ " \@type='text'".
+ " and \@authority='marcrelator'".
+ " and text()='creator']".
+ "][1]",
+ personal =>
+ "//mods:mods/mods:name[\@type='personal']/*[local-name()='namePart']".
+ "[../mods:role/mods:text[text()='creator']".
+ " or ../mods:role/mods:roleTerm[".
+ " \@type='text'".
+ " and \@authority='marcrelator'".
+ " and text()='creator']".
+ "][1]",
+ conference =>
+ "//mods:mods/mods:name[\@type='conference']/*[local-name()='namePart']".
+ "[../mods:role/mods:text[text()='creator']".
+ " or ../mods:role/mods:roleTerm[".
+ " \@type='text'".
+ " and \@authority='marcrelator'".
+ " and text()='creator']".
+ "][1]",
+ other =>
+ "//mods:mods/mods:name[\@type='personal']/*[local-name()='namePart']",
+ any =>
+ "//mods:mods/mods:name/*[local-name()='namePart'][1]",
+ },
+
+ subject => {
+
+ topic =>
+ "//mods:mods/mods:subject/*[".
+ " local-name()='geographic'".
+ " or local-name()='name'".
+ " or local-name()='temporal'".
+ " or local-name()='topic'".
+ "]/parent::mods:subject",
+
+# geographic =>
+# "//mods:mods/*[local-name()='subject']/*[local-name()='geographic']",
+# name =>
+# "//mods:mods/*[local-name()='subject']/*[local-name()='name']",
+# temporal =>
+# "//mods:mods/*[local-name()='subject']/*[local-name()='temporal']",
+# topic =>
+# "//mods:mods/*[local-name()='subject']/*[local-name()='topic']",
+ },
+ #keyword => { keyword => "//mods:mods/*[not(local-name()='originInfo')]", },
+
+ series => {
+ series => "//mods:mods/mods:relatedItem[\@type='series']/mods:titleInfo"
+ }
+};
+# ----------------------------------------------------------------------------------------
+
+
+
+sub new { return bless( {}, shift() ); }
+
+sub get_field_value {
+
+ my( $self, $mods, $xpath, $type) = @_;
+
+ my @string;
+
+ my $root = $mods->documentElement;
+ $root->setNamespace( "http://www.loc.gov/mods/v3", "mods", 1 );
+
+ try {
+ # grab the set of matching nodes
+ my @nodes = $root->findnodes( $xpath );
+ for my $value (@nodes) {
+
+ # grab all children of the node
+ my @children = $value->childNodes();
+ my @child_text;
+ for my $child (@children) {
+ # MODS strips the punctuation from 245abc, which often
+ # results in "title subtitle" rather than "title : subtitle";
+ # this hack gets it back for us
+ if ($type && $type eq 'title' && $child->nodeName =~ m/subTitle/) {
+ push(@child_text, " : ");
+ }
+ next unless( $child->nodeType != 3 );
+
+ if($child->childNodes) {
+ my @a;
+ for my $c (@{$child->childNodes}){
+ push @a, $c->textContent;
+ }
+ push(@child_text, join(' ', @a));
+
+ } else {
+ push(@child_text, $child->textContent);
+ }
+
+ }
+ if(@child_text) {
+ push(@string, \@child_text);
+ }
+
+ if( !@child_text ) {
+ push(@string, $value->textContent );
+ }
+ }
+ } otherwise {
+ $logger->info("MODS-izing failure: ".shift());
+ $logger->info("Failed MODS xml: ".$root->toString);
+ $logger->info("Failed MODS xpath: $xpath");
+ };
+ return @string;
+}
+
+=head
+sub _modsdoc_to_values {
+ my( $self, $mods ) = @_;
+ my $data = {};
+ for my $class (keys %$xpathset) {
+ $data->{$class} = {};
+ for my $type(keys %{$xpathset->{$class}}) {
+ my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
+ if( $class eq "subject" ) {
+ push( @{$data->{$class}->{$type}}, @value );
+ } else {
+ $data->{$class}->{$type} = $value[0];
+ }
+ }
+ }
+ return $data;
+}
+=cut
+
+sub modsdoc_to_values {
+ my( $self, $mods ) = @_;
+ my $data = {};
+
+ {
+ my $class = "subject";
+ $data->{$class} = {};
+ for my $type(keys %{$xpathset->{$class}}) {
+ my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
+ for my $arr (@value) {
+ push( @{$data->{$class}->{$type}}, $arr);
+ }
+ }
+ }
+
+ {
+ my $class = "title";
+ $data->{$class} = {};
+ for my $type(keys %{$xpathset->{$class}}) {
+ my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type}, "title" );
+ for my $arr (@value) {
+ if( ref($arr) ) {
+ $data->{$class}->{$type} = shift @$arr;
+
+ my $t = lc($data->{$class}->{$type});
+ if($t and $t =~ /^l[eoa]s|l[ae]|el|the|un[ae]?|an?\s?$/o ) {
+ my $val = shift @$arr || "";
+ $data->{$class}->{$type} .= " $val" if $data->{$class}->{$type};
+ $data->{$class}->{$type} = " $val" unless $data->{$class}->{$type};
+ }
+
+ for my $t (@$arr) {
+ $data->{$class}->{$type} .= " $t";
+ }
+ } else {
+ $data->{$class}->{$type} = $arr;
+ }
+ }
+ $data->{$class}->{$type} =~ s/\s+/ /go if ($data->{$class}->{$type});
+ }
+ }
+
+ {
+ my $class = "author";
+ $data->{$class} = {};
+ for my $type(keys %{$xpathset->{$class}}) {
+ my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
+ $data->{$class}->{$type} = $value[0];
+ }
+ }
+
+ {
+ my $class = "series";
+ $data->{$class} = {};
+ for my $type(keys %{$xpathset->{$class}}) {
+ my @value = $self->get_field_value( $mods, $xpathset->{$class}->{$type} );
+ for my $arr (@value) {
+ if( ref($arr) ) {
+ push(@{$data->{$class}->{$type}}, join(" ", @$arr));
+ } else {
+ push( @{$data->{$class}->{$type}}, $arr );
+ }
+ }
+ }
+
+ }
+
+ return $data;
+}
+
+
+
+
+# ---------------------------------------------------------------------------
+# Grabs the data 'we want' from the MODS doc and returns it in hash form
+# ---------------------------------------------------------------------------
+sub mods_values_to_mods_slim {
+ my( $self, $modsperl ) = @_;
+
+ my $title = "";
+ my $author = "";
+ my $subject = [];
+ my $series = [];
+
+ my $tmp = $modsperl->{title};
+
+
+ if(!$tmp) { $title = ""; }
+ else {
+ ($title = $tmp->{proper}) ||
+ ($title = $tmp->{translated}) ||
+ ($title = $tmp->{abbreviated}) ||
+ ($title = $tmp->{uniform}) ||
+ ($title = $tmp->{any});
+ }
+
+ $tmp = $modsperl->{author};
+ if(!$tmp) { $author = ""; }
+ else {
+ ($author = $tmp->{personal}) ||
+ ($author = $tmp->{corporate}) ||
+ ($author = $tmp->{conference}) ||
+ ($author = $tmp->{other}) ||
+ ($author = $tmp->{any});
+ }
+
+ $tmp = $modsperl->{subject};
+ if(!$tmp) { $subject = {}; }
+ else {
+ for my $key( keys %{$tmp}) {
+ push(@$subject, @{$tmp->{$key}}) if ($tmp->{$key});
+ }
+ my $subh = {};
+ for my $s (@$subject) {
+ if(defined($subh->{$s})) { $subh->{$s->[0]}++ } else { $subh->{$s->[0]} = 1;}
+ }
+ $subject = $subh
+ }
+
+ $tmp = $modsperl->{'series'};
+ if(!$tmp) { $series = []; }
+ else { $series = $tmp->{'series'}; }
+
+
+ return { series => $series, title => $title,
+ author => $author, subject => $subject };
+}
+
+
+
+# ---------------------------------------------------------------------------
+# Initializes a MARC -> Unified MODS batch process
+# ---------------------------------------------------------------------------
+
+sub start_mods_batch {
+
+ my( $self, $master_doc ) = @_;
+
+ if(!$master_doc) {
+ $self->{master_doc} = undef;
+ return;
+ }
+
+ if(!$mods_sheet) {
+ my $xslt_doc = $parser->parse_file(
+ OpenSRF::Utils::SettingsClient->new->config_value(dirs => 'xsl') . "/MARC21slim2MODS32.xsl");
+ $mods_sheet = $xslt->parse_stylesheet( $xslt_doc );
+ }
+
+
+ my $xmldoc = $parser->parse_string($master_doc);
+ my $mods = $mods_sheet->transform($xmldoc);
+
+ $self->{master_doc} = $self->modsdoc_to_values( $mods );
+ $self->{master_doc} = $self->mods_values_to_mods_slim( $self->{master_doc} );
+
+ ($self->{master_doc}->{isbn}) =
+ $self->get_field_value( $mods, $isbn_xpath );
+
+ $self->{master_doc}->{type_of_resource} =
+ [ $self->get_field_value( $mods, $resource_xpath ) ];
+
+ ($self->{master_doc}->{tcn}) =
+ $self->get_field_value( $mods, $tcn_xpath );
+
+ ($self->{master_doc}->{pubdate}) =
+ $self->get_field_value( $mods, $pub_xpath );
+
+ ($self->{master_doc}->{publisher}) =
+ $self->get_field_value( $mods, $publisher_xpath );
+
+ ($self->{master_doc}->{edition}) =
+ $self->get_field_value( $mods, $edition_xpath );
+
+
+
+# ------------------------------
+ # holds an array of [ link, title, link, title, ... ]
+ $self->{master_doc}->{online_loc} = [];
+ for my $url ($mods->findnodes($online_loc_xpath)) {
+ push(@{$self->{master_doc}->{online_loc}}, $url->textContent);
+ push(@{$self->{master_doc}->{online_loc}}, $url->getAttribute('displayLabel') || '');
+ push(@{$self->{master_doc}->{online_loc}}, $url->getAttribute('note') || '');
+ }
+
+ ($self->{master_doc}->{synopsis}) =
+ $self->get_field_value( $mods, $abstract_xpath );
+
+ $self->{master_doc}->{physical_description} = [];
+ push(@{$self->{master_doc}->{physical_description}},
+ $self->get_field_value( $mods, $physical_desc ) );
+ $self->{master_doc}->{physical_description} =
+ join( ' ', @{$self->{master_doc}->{physical_description}});
+
+ ($self->{master_doc}->{toc}) = $self->get_field_value($mods, $toc_xpath);
+
+}
+
+
+
+# ---------------------------------------------------------------------------
+# Takes a MARCXML string and adds it to the growing MODS doc
+# ---------------------------------------------------------------------------
+sub push_mods_batch {
+ my( $self, $marcxml ) = @_;
+
+ my $xmldoc = $parser->parse_string($marcxml);
+ my $mods = $mods_sheet->transform($xmldoc);
+
+ my $xmlperl = $self->modsdoc_to_values( $mods );
+ $xmlperl = $self->mods_values_to_mods_slim( $xmlperl );
+
+ # for backwards compatibility, remove the array part when all is decided
+ if(ref($xmlperl->{subject}) eq 'ARRAY' ) {
+ for my $subject( @{$xmlperl->{subject}} ) {
+ push @{$self->{master_doc}->{subject}}, $subject;
+ }
+ } else {
+ for my $subject ( keys %{$xmlperl->{subject}} ) {
+ my $s = $self->{master_doc}->{subject};
+ if(defined($s->{$subject})) { $s->{$subject}++; } else { $s->{$subject} = 1; }
+ }
+ }
+
+ push( @{$self->{master_doc}->{type_of_resource}},
+ $self->get_field_value( $mods, $resource_xpath ));
+
+ if(!($self->{master_doc}->{isbn}) ) {
+ ($self->{master_doc}->{isbn}) =
+ $self->get_field_value( $mods, $isbn_xpath );
+ }
+}
+
+
+# ---------------------------------------------------------------------------
+# Completes a MARC -> Unified MODS batch process and returns the perl hash
+# ---------------------------------------------------------------------------
+sub init_virtual_record {
+ my $record = Fieldmapper::metabib::virtual_record->new;
+ $record->subject([]);
+ $record->types_of_resource([]);
+ $record->call_numbers([]);
+ return $record;
+}
+
+sub finish_mods_batch {
+ my $self = shift;
+
+ return undef unless $self->{master_doc};
+
+ my $perl = $self->{master_doc};
+ my $record = init_virtual_record();
+
+ # turn the hash into a fieldmapper object
+ #(my $title = $perl->{title}) =~ s/\[.*?\]//og;
+ #(my $author = $perl->{author}) =~ s/\(.*?\)//og;
+ my $title = $perl->{title};
+ my $author = $perl->{author};
+
+ my @series;
+ for my $s (@{$perl->{series}}) {
+ push @series, (split( /\s*;/, $s ))[0];
+ }
+
+ # uniquify the types of resource
+ my $rtypes = $perl->{type_of_resource};
+ my %hash = map { ($_ => 1) } @$rtypes;
+ $rtypes = [ keys %hash ];
+
+ $record->title($title);
+ $record->author($author);
+
+ $record->doc_id($perl->{doc_id});
+ $record->isbn($perl->{isbn});
+ $record->pubdate($perl->{pubdate});
+ $record->publisher($perl->{publisher});
+ $record->tcn($perl->{tcn});
+
+ $record->edition($perl->{edition});
+
+ $record->subject($perl->{subject});
+ $record->types_of_resource($rtypes);
+ $record->series(\@series);
+
+ $record->online_loc($perl->{online_loc});
+ $record->synopsis($perl->{synopsis});
+ $record->physical_description($perl->{physical_description});
+ $record->toc($perl->{toc});
+
+ $self->{master_doc} = undef;
+ return $record;
+}
+
+
+
--- /dev/null
+package OpenILS::Utils::Normalize;
+use strict;
+use warnings;
+use Unicode::Normalize;
+use Encode;
+
+use Exporter 'import';
+our @EXPORT_OK = qw( naco_normalize );
+
+sub naco_normalize {
+
+ my $str = decode_utf8(shift);
+ my $sf = shift;
+
+ # Apply NACO normalization to input string; based on
+ # http://www.loc.gov/catdir/pcc/naco/SCA_PccNormalization_Final_revised.pdf
+ #
+ # Note that unlike a strict reading of the NACO normalization rules,
+ # output is returned as lowercase instead of uppercase for compatibility
+ # with previous versions of the Evergreen naco_normalize routine.
+
+ # Convert to upper-case first; even though final output will be lowercase, doing this will
+ # ensure that the German eszett (ß) and certain ligatures (ff, fi, ffl, etc.) will be handled correctly.
+ # If there are any bugs in Perl's implementation of upcasing, they will be passed through here.
+ $str = uc $str;
+
+ # remove non-filing strings
+ $str =~ s/\x{0098}.*?\x{009C}//g;
+
+ $str = NFKD($str);
+
+ # additional substitutions - 3.6.
+ $str =~ s/\x{00C6}/AE/g;
+ $str =~ s/\x{00DE}/TH/g;
+ $str =~ s/\x{0152}/OE/g;
+ $str =~ tr/\x{0110}\x{00D0}\x{00D8}\x{0141}\x{2113}\x{02BB}\x{02BC}]['/DDOLl/d;
+
+ # transformations based on Unicode category codes
+ $str =~ s/[\p{Cc}\p{Cf}\p{Co}\p{Cs}\p{Lm}\p{Mc}\p{Me}\p{Mn}]//g;
+
+ if ($sf && $sf =~ /^a/o) {
+ my $commapos = index($str, ',');
+ if ($commapos > -1) {
+ if ($commapos != length($str) - 1) {
+ $str =~ s/,/\x07/; # preserve first comma
+ }
+ }
+ }
+
+ # since we've stripped out the control characters, we can now
+ # use a few as placeholders temporarily
+ $str =~ tr/+&@\x{266D}\x{266F}#/\x01\x02\x03\x04\x05\x06/;
+ $str =~ s/[\p{Pc}\p{Pd}\p{Pe}\p{Pf}\p{Pi}\p{Po}\p{Ps}\p{Sk}\p{Sm}\p{So}\p{Zl}\p{Zp}\p{Zs}]/ /g;
+ $str =~ tr/\x01\x02\x03\x04\x05\x06\x07/+&@\x{266D}\x{266F}#,/;
+
+ # decimal digits
+ $str =~ tr/\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{07C0}-\x{07C9}\x{0966}-\x{096F}\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}\x{0BE6}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}\x{1040}-\x{1049}\x{1090}-\x{1099}\x{17E0}-\x{17E9}\x{1810}-\x{1819}\x{1946}-\x{194F}\x{19D0}-\x{19D9}\x{1A80}-\x{1A89}\x{1A90}-\x{1A99}\x{1B50}-\x{1B59}\x{1BB0}-\x{1BB9}\x{1C40}-\x{1C49}\x{1C50}-\x{1C59}\x{A620}-\x{A629}\x{A8D0}-\x{A8D9}\x{A900}-\x{A909}\x{A9D0}-\x{A9D9}\x{AA50}-\x{AA59}\x{ABF0}-\x{ABF9}\x{FF10}-\x{FF19}/0-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-90-9/;
+
+ # intentionally skipping step 8 of the NACO algorithm; if the string
+ # gets normalized away, that's fine.
+
+ # leading and trailing spaces
+ $str =~ s/\s+/ /g;
+ $str =~ s/^\s+//;
+ $str =~ s/\s+$//g;
+
+ return lc $str;
+}
+
+1;
--- /dev/null
+package OpenILS::Utils::OfflineStore;
+use strict; use warnings;
+
+use UNIVERSAL::require;
+if ('Class::DBI::Frozen::301'->use) {
+ use parent 'Class::DBI::Frozen::301';
+} elsif ('Class::DBI'->use) {
+ use parent 'Class::DBI';
+} else {
+ die $@;
+}
+
+use DBI;
+use OpenSRF::Utils::Config;
+
+our ($_dsn,$_u,$_p);
+sub DBFile {
+ my $class = shift;
+ my $dsn = shift;
+ my $u = shift;
+ my $p = shift;
+ if ($dsn) {
+ $_dsn = $dsn;
+ $_u = $u;
+ $_p = $p;
+ }
+ return $_dsn;
+}
+
+our $_dbh;
+sub db_Main {
+ my $self = shift;
+ return $_dbh if ($_dbh);
+
+ $_dbh = DBI->connect($_dsn,$_u,$_p,
+ {
+ RootClass => 'DBIx::ContextualFetch'
+ }
+ );
+
+ return $_dbh;
+}
+
+
+sub disconnect {
+ $_dbh->disconnect;
+ $_dbh = undef;
+}
+
+
+package OpenILS::Utils::OfflineStore::Session;
+use parent 'OpenILS::Utils::OfflineStore';
+
+sub _create_table {
+ my $self = shift;
+ $self->db_Main->do( <<" SQL" );
+
+CREATE TABLE session (
+ key TEXT UNIQUE PRIMARY KEY,
+ org INTEGER NOT NULL,
+ description TEXT,
+ creator INTEGER NOT NULL,
+ create_time INTEGER NOT NULL,
+ in_process INTEGER NOT NULL DEFAULT 0,
+ start_time INTEGER,
+ end_time INTEGER,
+ num_complete INTEGER NOT NULL DEFAULT 0
+);
+CREATE INDEX IF NOT EXISTS session_pkey ON session (key);
+CREATE INDEX IF NOT EXISTS session_org ON session (org);
+CREATE INDEX IF NOT EXISTS session_creation ON session (create_time);
+
+ SQL
+}
+
+__PACKAGE__->table('offline.session');
+__PACKAGE__->columns( Essential => qw/key org description
+ creator create_time in_process start_time end_time num_complete/);
+__PACKAGE__->has_many(scripts => 'OpenILS::Utils::OfflineStore::Script');
+
+
+package OpenILS::Utils::OfflineStore::Script;
+use parent 'OpenILS::Utils::OfflineStore';
+
+sub _create_table {
+ my $self = shift;
+ $self->db_Main->do( <<" SQL" );
+
+CREATE TABLE script (
+ id INTEGER UNIQUE PRIMARY KEY AUTOINCREMENT,
+ session TEXT NOT NULL,
+ requestor INTEGER NOT NULL,
+ create_time INTEGER NOT NULL,
+ workstation TEXT NOT NULL,
+ logfile TEXT NOT NULL,
+ time_delta INTEGER NOT NULL DEFAULT 0,
+ count INTEGER NOT NULL DEFAULT 0
+);
+CREATE INDEX IF NOT EXISTS script_pkey ON script (id);
+CREATE INDEX IF NOT EXISTS script_ws ON script (workstation);
+CREATE INDEX IF NOT EXISTS script_session ON script (session);
+
+ SQL
+}
+
+__PACKAGE__->table('offline.script');
+__PACKAGE__->columns( Essential => qw/id session requestor create_time workstation logfile time_delta count/);
+__PACKAGE__->has_a(session => 'OpenILS::Utils::OfflineStore::Session');
+__PACKAGE__->sequence(qw/offline.script_id_seq/);
+
+
+
+
+
--- /dev/null
+package OpenILS::Utils::Penalty;
+use strict; use warnings;
+use DateTime;
+use Data::Dumper;
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Cache;
+use OpenSRF::Utils qw/:datetime/;
+use OpenILS::Application::AppUtils;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Const qw/:const/;
+my $U = "OpenILS::Application::AppUtils";
+
+
+# calculate and update the well-known penalties
+sub calculate_penalties {
+ my($class, $e, $user_id, $context_org) = @_;
+
+ my $commit = 0;
+ unless($e) {
+ $e = new_editor(xact =>1);
+ $commit = 1;
+ }
+
+ my $penalties = $e->json_query({from => ['actor.calculate_system_penalties',$user_id, $context_org]});
+
+ my $user = $e->retrieve_actor_user( $user_id );
+ my @existing_penalties = grep { defined $_->{id} } @$penalties;
+ my @wanted_penalties = grep { !defined $_->{id} } @$penalties;
+ my @trigger_events;
+
+ my %csp;
+ for my $pen_obj (@wanted_penalties) {
+
+ my $pen = Fieldmapper::actor::user_standing_penalty->new;
+ $pen->$_($pen_obj->{$_}) for keys %$pen_obj;
+
+ # let's see if this penalty is accounted for already
+ my ($existing) = grep {
+ $_->{org_unit} == $pen_obj->{org_unit} and
+ $_->{standing_penalty} == $pen_obj->{standing_penalty}
+ } @existing_penalties;
+
+ if($existing) {
+ # we have one of these already. Leave it be, but remove it from the
+ # existing set so it's not deleted in the subsequent loop
+ @existing_penalties = grep { $_->{id} ne $existing->{id} } @existing_penalties;
+
+ } else {
+
+ # this is a new penalty
+ $e->create_actor_user_standing_penalty($pen) or return $e->die_event;
+
+ my $csp_obj = $csp{$pen->standing_penalty} ||
+ $e->retrieve_config_standing_penalty( $pen->standing_penalty );
+
+ # cache for later
+ $csp{$pen->standing_penalty} = $csp_obj;
+
+ push(@trigger_events, ['penalty.' . $csp_obj->name, $pen, $pen->org_unit]);
+ }
+ }
+
+ # at this point, any penalties remaining in the existing
+ # penalty set are unaccounted for and should be removed
+ for my $pen_obj (@existing_penalties) {
+ my $pen = Fieldmapper::actor::user_standing_penalty->new;
+ $pen->$_($pen_obj->{$_}) for keys %$pen_obj;
+ $e->delete_actor_user_standing_penalty($pen) or return $e->die_event;
+ }
+
+ $e->commit if $commit;
+
+ $U->create_events_for_hook($$_[0], $$_[1], $$_[2]) for @trigger_events;
+ return undef;
+}
+
+# any penalties whose block_list has an item from @fatal_mask will be sorted
+# into the fatal_penalties set. Others will be sorted into the info_penalties set
+sub retrieve_penalties {
+ my($class, $e, $user_id, $context_org, @fatal_mask) = @_;
+
+ my(@info, @fatal);
+ my $penalties = $class->retrieve_usr_penalties($e, $user_id, $context_org);
+
+ for my $p (@$penalties) {
+ my $pushed = 0;
+ if($p->standing_penalty->block_list) {
+ for my $m (@fatal_mask) {
+ if($p->standing_penalty->block_list =~ /$m/) {
+ push(@fatal, $p->standing_penalty);
+ $pushed = 1;
+ last;
+ }
+ }
+ }
+ push(@info, $p->standing_penalty) unless $pushed;
+ }
+
+ return {fatal_penalties => \@fatal, info_penalties => \@info};
+}
+
+
+# Returns a list of actor_user_standing_penalty objects
+sub retrieve_usr_penalties {
+ my($class, $e, $user_id, $context_org) = @_;
+
+ return $e->search_actor_user_standing_penalty([
+ {
+ usr => $user_id,
+ org_unit => $U->get_org_ancestors($context_org),
+ '-or' => [
+ {stop_date => undef},
+ {stop_date => {'>' => 'now'}}
+ ],
+ },
+ {flesh => 1, flesh_fields => {ausp => ['standing_penalty']}}
+ ]);
+}
+
+1;
+
+
--- /dev/null
+package OpenILS::Utils::PermitHold;
+use strict; use warnings;
+use Data::Dumper;
+use OpenSRF::Utils;
+use OpenSRF::Utils::SettingsClient;
+use OpenILS::Utils::ScriptRunner;
+use OpenILS::Application::AppUtils;
+use DateTime::Format::ISO8601;
+use OpenILS::Application::Circ::ScriptBuilder;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenILS::Event;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+my $U = "OpenILS::Application::AppUtils";
+
+my $script; # - the permit script
+my $script_libs; # - extra script libs
+my $legacy_script_support;
+
+# mental note: open-ils.storage.biblio.record_entry.ranged_tree
+
+
+# params within a hash are: copy, patron,
+# requestor, request_lib, title, title_descriptor
+sub permit_copy_hold {
+ my $params = shift;
+ my @allevents;
+
+ unless(defined $legacy_script_support) {
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ $legacy_script_support = $conf->config_value(
+ apps => 'open-ils.circ' => app_settings => 'legacy_script_support');
+ $legacy_script_support = ($legacy_script_support and
+ $legacy_script_support =~ /true/i) ? 1 : 0;
+ }
+
+ return indb_hold_permit($params) unless $legacy_script_support;
+
+ my $ctx = {
+ patron_id => $$params{patron_id},
+ patron => $$params{patron},
+ copy => $$params{copy},
+ requestor => $$params{requestor},
+ title => $$params{title},
+ volume => $$params{volume},
+ flesh_age_protect => 1,
+ _direct => {
+ requestLib => $$params{request_lib},
+ pickupLib => $$params{pickup_lib},
+ newHold => $$params{new_hold},
+ }
+ };
+
+ my $runner = OpenILS::Application::Circ::ScriptBuilder->build($ctx);
+
+ my $ets = $ctx->{_events};
+
+ # --------------------------------------------------------------
+ # Strip the expired event since holds are still allowed to be
+ # captured on expired patrons.
+ # --------------------------------------------------------------
+ if( $ets and @$ets ) {
+ $ets = [ grep { $_->{textcode} ne 'PATRON_ACCOUNT_EXPIRED' } @$ets ];
+ } else { $ets = []; }
+
+ if( @$ets ) {
+ push( @allevents, @$ets);
+
+ # --------------------------------------------------------------
+ # If scriptbuilder returned any events, then the script context
+ # is undefined and should not be used
+ # --------------------------------------------------------------
+
+ } else {
+
+ # check the various holdable flags
+ push( @allevents, OpenILS::Event->new('ITEM_NOT_HOLDABLE') )
+ unless $U->is_true($ctx->{copy}->holdable);
+
+ push( @allevents, OpenILS::Event->new('ITEM_NOT_HOLDABLE') )
+ unless $U->is_true($ctx->{copy}->location->holdable);
+
+ push( @allevents, OpenILS::Event->new('ITEM_NOT_HOLDABLE') )
+ unless $U->is_true($ctx->{copy}->status->holdable);
+
+ my $evt;
+
+ # grab the data safely
+ my $rlib = ref($$params{request_lib}) ? $$params{request_lib}->id : $$params{request_lib};
+ my $olib = ref($ctx->{volume}) ? $ctx->{volume}->owning_lib : -1;
+ my $rid = ref($ctx->{requestor}) ? $ctx->{requestor}->id : -2;
+ my $pid = ($params->{patron}) ? $params->{patron}->id : $params->{patron_id};
+
+ if( ($rid ne $pid) and ($olib eq $rlib) ) {
+ $logger->info("Item owning lib $olib is the same as the request lib. No age_protection will be checked");
+ } else {
+ $logger->info("item owning lib = $olib, request lib = $rlib, requestor=$rid, patron=$pid. checking age_protection");
+ $evt = check_age_protect($ctx->{patron}, $ctx->{copy});
+ push( @allevents, $evt ) if $evt;
+ }
+
+ $logger->debug("Running permit_copy_hold on copy " . $$params{copy}->id);
+
+ load_scripts($runner);
+ my $result = $runner->run or
+ throw OpenSRF::EX::ERROR ("Hold Copy Permit Script Died: $@");
+
+ # --------------------------------------------------------------
+ # Extract and uniquify the event list
+ # --------------------------------------------------------------
+ my $events = $result->{events};
+ $logger->debug("circ_permit_hold for user $pid returned events: [@$events]");
+
+ push( @allevents, OpenILS::Event->new($_)) for @$events;
+ }
+
+ my %hash = map { ($_->{ilsevent} => $_) } @allevents;
+ @allevents = values %hash;
+
+ $runner->cleanup;
+
+ return \@allevents if $$params{show_event_list};
+ return 1 unless @allevents;
+ return 0;
+}
+
+
+sub load_scripts {
+ my $runner = shift;
+
+ if(!$script) {
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my @pfx = ( "apps", "open-ils.circ","app_settings" );
+ my $libs = $conf->config_value(@pfx, 'script_path');
+ $script = $conf->config_value(@pfx, 'scripts', 'circ_permit_hold');
+ $script_libs = (ref($libs)) ? $libs : [$libs];
+ }
+
+ $runner->add_path($_) for(@$script_libs);
+ $runner->load($script);
+}
+
+
+sub check_age_protect {
+ my( $patron, $copy ) = @_;
+
+ return undef unless $copy and $copy->age_protect and $patron;
+
+ my $hou = (ref $patron->home_ou) ? $patron->home_ou->id : $patron->home_ou;
+
+ my $prox = $U->storagereq(
+ 'open-ils.storage.asset.copy.proximity', $copy->id, $hou );
+
+ # If this copy is within the appropriate proximity,
+ # age protect does not apply
+ return undef if $prox <= $copy->age_protect->prox;
+
+ my $protection_list = $U->storagereq(
+ 'open-ils.storage.direct.config.rules.age_hold_protect.search_where.atomic',
+ { age => { '>=' => $copy->age_protect->age },
+ prox => { '>=' => $copy->age_protect->prox },
+ },
+ { order_by => 'age' }
+ );
+
+ # Now, now many seconds old is this copy
+ my $create_date = DateTime::Format::ISO8601
+ ->new
+ ->parse_datetime( OpenSRF::Utils::cleanse_ISO8601($copy->create_date) )
+ ->epoch;
+
+ my $age = time - $create_date;
+
+ for my $protection ( @$protection_list ) {
+
+ $logger->info("analyzing age protect ".$protection->name);
+
+ # age protect does not apply if within the proximity
+ last if $prox <= $protection->prox;
+
+ # How many seconds old does the copy have to be to escape age protection
+ my $interval = OpenSRF::Utils::interval_to_seconds($protection->age);
+
+ $logger->info("age_protect interval=$interval, create_date=$create_date, age=$age");
+
+ if( $interval > $age ) {
+ # if age of the item is less than the protection interval,
+ # the item falls within the age protect range
+ $logger->info("age_protect prevents copy from having a hold placed on it: ".$copy->id);
+ return OpenILS::Event->new('ITEM_AGE_PROTECTED', copy => $copy->id );
+ }
+ }
+
+ return undef;
+}
+
+my $LEGACY_HOLD_EVENT_MAP = {
+ 'config.hold_matrix_test.holdable' => 'ITEM_NOT_HOLDABLE',
+ 'transit_range' => 'ITEM_NOT_HOLDABLE',
+ 'no_matchpoint' => 'NO_POLICY_MATCHPOINT',
+ 'config.hold_matrix_test.max_holds' => 'MAX_HOLDS',
+ 'config.rule_age_hold_protect.prox' => 'ITEM_AGE_PROTECTED'
+};
+
+sub indb_hold_permit {
+ my $params = shift;
+
+ my $function = $$params{retarget} ? 'action.hold_retarget_permit_test' : 'action.hold_request_permit_test';
+ my $patron_id =
+ ref($$params{patron}) ? $$params{patron}->id : $$params{patron_id};
+ my $request_lib =
+ ref($$params{request_lib}) ? $$params{request_lib}->id : $$params{request_lib};
+
+ my $HOLD_TEST = {
+ from => [
+ $function,
+ $$params{pickup_lib},
+ $request_lib,
+ $$params{copy}->id,
+ $patron_id,
+ $$params{requestor}->id
+ ]
+ };
+
+ my $e = new_editor(xact=>1);
+ my $results = $e->json_query($HOLD_TEST);
+ $e->rollback;
+
+ unless($$params{show_event_list}) {
+ return 1 if $U->is_true($results->[0]->{success});
+ return 0;
+ }
+
+ return [
+ new OpenILS::Event(
+ "NO_POLICY_MATCHPOINT",
+ "payload" => {"fail_part" => "no_matchpoint"}
+ )
+ ] unless @$results;
+
+ return [] if $U->is_true($results->[0]->{success});
+
+ return [
+ map {
+ my $event = new OpenILS::Event(
+ $LEGACY_HOLD_EVENT_MAP->{$_->{"fail_part"}} || $_->{"fail_part"}
+ );
+ $event->{"payload"} = {"fail_part" => $_->{"fail_part"}};
+ $event;
+ } @$results
+ ];
+}
+
+
+23;
--- /dev/null
+package OpenILS::Utils::RemoteAccount;
+
+# use OpenSRF::Utils::SettingsClient;
+use OpenSRF::Utils::Logger qw/:logger/;
+
+use Data::Dumper;
+use Net::FTP;
+use Net::SSH2;
+use File::Temp;
+use File::Basename;
+use File::Spec;
+use Text::Glob qw( match_glob glob_to_regex );
+# use Error;
+
+$Data::Dumper::Indent = 0;
+
+use strict;
+use warnings;
+
+use Carp;
+
+our $AUTOLOAD;
+
+our %keyfiles = ();
+
+my %fields = (
+ account_object => undef,
+ remote_host => undef,
+ remote_user => undef,
+ remote_password => undef,
+ remote_account => undef,
+ remote_file => undef,
+ remote_path => undef, # not really doing anything with this... yet.
+ ssh_privatekey => undef,
+ ssh_publickey => undef,
+ type => undef,
+ port => undef,
+ content => undef,
+ local_file => undef,
+ tempfile => undef,
+ error => undef,
+ single_ext => undef,
+ specific => 0,
+ debug => 0,
+);
+
+
+=head1 NAME
+
+OpenILS::Utils::RemoteAccount - Encapsulate FTP, SFTP and SSH file transactions for Evergreen
+
+=head1 DESCRIPTION
+
+The Remote Account module attempts to transfer a file to/from a remote server.
+Either Net::FTP or Net::SSH2 is used.
+
+=head1 PARAMETERS
+
+All information is expected to be supplied by the caller via parameters:
+ ~ remote_host (required)
+ ~ remote_user
+ ~ remote_password
+ ~ remote_account
+ ~ ssh_privatekey
+ ~ ssh_publickey
+ ~ type (FTP, SFTP or SCP -- default FTP)
+ ~ port
+ ~ debug
+
+Note: none of the parameters are actually required, except remote_host.
+That is because remote_user, remote_password and remote_account can all be
+extrapolated from other sources, as the Net::FTP docs describe:
+
+ If no arguments are given then Net::FTP uses the Net::Netrc package
+ to lookup the login information for the connected host.
+
+ If no information is found then a login of anonymous is used.
+
+ If no password is given and the login is anonymous then anonymous@
+ will be used for password.
+
+Note that specifying a password will require you to specify a user.
+Similarly, specifying an account requires both user and password.
+That is, there are no assumed defaults when the latter arguments are used.
+
+=head2 SSH KEYS:
+
+The use of ssh keys is preferred. Explicit specification of connection type will prevent
+multiple attempts to the same server. Therefore, using the type parameter is also recommended.
+
+If the type is not explicit, we attempt to use SSH keys where they are specified or otherwise found
+in the runtime environment. If only one key is specified, we attempt to derive
+the corresponding filename based on the ssh-keygen defaults. If either key is
+specified, but both are not found (and readable) then the result is failure. If
+no key or type is specified, but keys are found, the key-based connections will be attempted,
+but failure will be non-fatal.
+
+=cut
+
+sub plausible_dirs {
+ # returns plausible locations of a .ssh subdir where SSH keys might be stashed
+ # NOTE: these would need to be properly genericized w/ Makefile vars
+ # in order to support Debian packaging and multiple EG's on one box.
+ # Until that happens, we just rely on $HOME
+
+ my @bases = (
+ # '/openils/conf', # __EG_CONFIG_DIR__
+ );
+ ($ENV{HOME}) and unshift @bases, $ENV{HOME};
+
+ return grep {-d $_} map {"$_/.ssh"} @bases;
+}
+
+sub local_keyfiles {
+ # populates %keyfiles hash
+ # %keyfiles maps SSH_PRIVATEKEY => SSH_PUBLICKEY
+ my $self = shift;
+ my $force = (@_ ? shift : 0);
+ return %keyfiles if (%keyfiles and not $force); # caching
+ $logger->info("Checking for SSH keyfiles" . ($force ? ' (ignoring cache)' : ''));
+ %keyfiles = (); # reset to empty
+ my @dirs = plausible_dirs();
+ $logger->debug(scalar(@dirs) . " plausible dirs: " . join(', ', @dirs));
+ foreach my $dir (@dirs) {
+ foreach my $key (qw/rsa dsa/) {
+ my $private = "$dir/id_$key";
+ my $public = "$dir/id_$key.pub";
+ unless (-r $private) {
+ $logger->debug("Key '$private' cannot be read: $!");
+ next;
+ }
+ unless (-r $public) {
+ $logger->debug("Key '$public' cannot be read: $!");
+ next;
+ }
+ $keyfiles{$private} = $public;
+ }
+ }
+ return %keyfiles;
+}
+
+sub param_keys {
+ my $self = shift;
+ my %keys = ();
+ if ($self->ssh_publickey and not $self->ssh_privatekey) {
+ my $private = $self->ssh_publickey;
+ unless ($private and $private =~ s/\.pub$// and -r $self->ssh_privatekey) { # try to guess missing private key name
+ $logger->error("No ssh_privatekey specified or found to pair with " . $self->ssh_publickey);
+ return;
+ }
+ $self->ssh_privatekey($private);
+ }
+ if ($self->ssh_privatekey and not $self->ssh_publickey) {
+ my $pub = $self->ssh_privatekey . '.pub'; # guess missing public key name
+ unless (-r $pub) {
+ $logger->error("No ssh_publickey specified or found to pair with " . $self->ssh_privatekey);
+ return;
+ }
+ $self->ssh_publickey($pub);
+ }
+
+ # so now, we have either both ssh_p*keys params or neither
+ foreach (qw/ssh_publickey ssh_privatekey/) {
+ unless (-r $self->{$_}) {
+ $logger->error("$_ '" . $self->{$_} . "' cannot be read: $!");
+ return; # quit w/ error if we fail on any user-specified key
+ }
+ }
+ $keys{$self->ssh_privatekey} = $self->ssh_publickey;
+ return %keys;
+}
+
+sub new_tempfile {
+ my $self = shift;
+ my $text = shift || $self->content || '';
+ my $tmp = File::Temp->new(); # magical self-destructing tempfile
+ # print $tmp "THIS IS TEXT\n";
+ print $tmp $text or $logger->error($self->_error("could not write to tempfile '$tmp'"));
+ close $tmp;
+ $self->tempfile($tmp); # save the object
+ $self->local_file($tmp->filename); # save the filename
+ $logger->info(_pkg("using tempfile $tmp"));
+ return $self->local_file; # return the filename
+}
+
+sub outbound_file {
+ my $self = shift;
+ my $params = shift;
+
+ unless (defined $self->content or $self->local_file) { # content can be emptystring
+ $logger->error($self->_error("No content or local_file specified -- nothing to send"));
+ return;
+ }
+
+ # tricky subtlety: we want to use the most recently specified options
+ # with priority order: filename, content, old filename, old content.
+ #
+ # The $params->{x} will already match $self->x after the secondary init,
+ # so the checks using $params below are for whether the value was specified NOW (e.g. via put()) or not.
+ #
+ # if we got a new local_file value, we use it
+ # else if the content is new to this call, build a new tempfile w/ it,
+ # else use existing local_file,
+ # else build new tempfile w/ content already specified via new()
+
+ return $params->{local_file} || (
+ (defined $params->{content}) ?
+ $self->new_tempfile($self->content) : # $self->content is same value as $params->{content}
+ ($self->local_file || $self->new_tempfile($self->content))
+ );
+}
+
+sub key_check {
+ my $self = shift;
+ my $params = shift;
+
+ return if ($params->{type} and $params->{type} eq 'FTP'); # Forget it, user specified regular FTP
+ return if ( $self->type and $self->type eq 'FTP'); # Forget it, user specified regular FTP
+
+ if ($self->ssh_publickey || $self->ssh_privatekey) {
+ $self->specific(1);
+ return $self->param_keys(); # we got one or both params, but they didn't pan out
+ }
+ return local_keyfiles(); # optional "force" arg could be used here to empty cache
+}
+
+
+# TOP LEVEL methods
+# TODO: delete for both FTP and SSH2
+
+sub get {
+ my $self = shift;
+ my $params = shift;
+ if (! ref $params) {
+ $params = {remote_file => $params} ;
+ }
+
+ $self->init($params); # secondary init
+
+ $self->{get_args} = [$self->remote_file]; # same for scp_put and FTP put
+ push @{$self->{get_args}}, $self->local_file if defined $self->local_file;
+
+ # $self->content($content);
+
+ if ($self->type eq "FTP") {
+ return $self->get_ftp(@{$self->{get_args}});
+ } else {
+ my %keys = $self->key_check($params);
+ return $self->get_ssh2(\%keys, @{$self->{get_args}});
+ }
+}
+
+sub put {
+ my $self = shift;
+ my $params = shift;
+ if (! ref $params) {
+ $params = {local_file => $params} ;
+ }
+
+ $self->init($params); # secondary init
+
+ my $local_file = $self->outbound_file($params) or return;
+
+ $self->{put_args} = [$local_file]; # same for scp_put and FTP put
+ if (defined $self->remote_path and not defined $self->remote_file) {
+ my $rpath = $self->remote_path;
+ my $fname = basename($local_file);
+ if ($rpath =~ /^(.*)\*+(.*)$/) { # if the path has an asterisk in it, like './incoming/*.tst'
+ my $head = $1;
+ my $tail = $2;
+ if ($tail =~ /\//) {
+ $logger->warn($self->_error("remote path '$rpath' has dir slashes AFTER an asterisk. Cannot determine target dir"));
+ return;
+ }
+ if ($self->single_ext) {
+ $tail =~ /\./ and $fname =~ s/\./_/g; # if dot in tail, replace dots in fname (w/ _)
+ }
+ $self->remote_file($head . $fname . $tail);
+ } else {
+ $self->remote_file($rpath . '/' . $fname); # if we know just the dir
+ }
+ }
+
+ if (defined $self->remote_file) {
+ push @{$self->{put_args}}, $self->remote_file; # user can specify remote_file name, optionally
+ }
+
+ if ($self->type eq "FTP") {
+ return $self->put_ftp(@{$self->{put_args}});
+ } else {
+ my %keys = $self->key_check($params);
+ $self->put_ssh2(\%keys, @{$self->{put_args}}) and return $self->remote_file;
+ }
+}
+
+sub ls {
+ my $self = shift;
+ my $params = shift;
+ my @targets = @_;
+ if (! ref $params) {
+ unshift @targets, ($params || '.'); # If it was just a string, it's the first target, else default pwd
+ delete $self->{remote_file}; # overriding any target in the object previously.
+ $params = {}; # make params a normal hashref again
+ } else {
+ if ($params->{remote_file} and @_) {
+ $logger->warn($self->_error("Ignoring ls parameter remote_file for subsequent args"));
+ delete $params->{remote_file};
+ }
+ $self->init($params); # secondary init
+ $self->remote_file and (! @targets) and push @targets, $self->remote_file; # if remote_file is there, and there's nothing else, use it
+ delete $self->{remote_file};
+ }
+
+ $self->{ls_args} = \@targets;
+
+ if ($self->type eq "FTP") {
+ return $self->ls_ftp(@targets);
+ } else {
+ my %keys = $self->key_check($params);
+ # $logger->info("*** calling ls_ssh2(keys, '" . join("', '", (scalar(@targets) ? map {defined $_ ? $_ : '' } @targets : ())) . "') with ssh keys");
+ return $self->ls_ssh2(\%keys, @targets);
+ }
+}
+
+# Checks if the filename part of a pathname has one or more glob characters
+# We split out the filename portion of the path
+# Detect glob or no glob.
+# returns: directory, regex for matching filenames
+sub glob_parse {
+ my $self = shift;
+ my $path = shift or return;
+ my ($vol, $dir, $file) = File::Spec->splitpath($path); # we don't care about attempted globs in mid-filepath
+ my $front = $vol ? File::Spec->catdir($vol, $dir) : $dir;
+ $file =~ /\*/ and return ($front, glob_to_regex($file));
+ $file =~ /\?/ and return ($front, glob_to_regex($file));
+ $logger->debug("No glob detected in '$path'");
+ return;
+}
+
+
+# Internal Mechanics
+
+sub _ssh2 {
+ my $self = shift;
+ $self->{ssh2} and return $self->{ssh2}; # caching
+ my $keys = shift;
+
+ my $ssh2 = Net::SSH2->new();
+ unless($ssh2->connect($self->remote_host)) {
+ $logger->warn($self->error("SSH2 connect FAILED: $! " . join(" ", $ssh2->error)));
+ return; # we cannot connect
+ }
+
+ my $success = 0;
+ my @privates = keys %$keys;
+ my $count = scalar @privates;
+
+ if ($count) {
+ foreach (@privates) {
+ if ($self->auth_ssh2($ssh2,$self->auth_ssh2_args($_,$keys->{$_}))) {
+ $success++;
+ last;
+ }
+ }
+ unless ($success) {
+ $logger->error(
+ $self->error(
+ "All ($count) keypair(s) FAILED for " . $self->remote_host
+ )
+ );
+ return;
+ }
+ } else {
+ $logger->error(
+ $self->error("Login FAILED for " . $self->remote_host)
+ ) unless $self->auth_ssh2($ssh2, $self->auth_ssh2_args);
+ }
+ return $self->{ssh2} = $ssh2;
+}
+
+sub auth_ssh2 {
+ my $self = shift;
+ my $ssh2 = shift;
+ my %auth_args = @_;
+ $ssh2 or return;
+
+ my $host = $auth_args{hostname} || 'UNKNOWN';
+ my $key = $auth_args{privatekey} || 'UNKNOWN';
+ my $msg = "ssh2->auth by keypair for $host using $key";
+ if ($ssh2->auth(%auth_args)) {
+ $logger->info("Successful $msg");
+ return 1;
+ }
+
+ if ($self->specific) {
+ $logger->error($self->error("Aborting. FAILED $msg: " . ($ssh2->error || '')));
+ } else {
+ $logger->warn($self->error("Unsuccessful keypair: FAILED $msg: " . ($ssh2->error || '')));
+ }
+ return;
+}
+
+sub auth_ssh2_args {
+ my $self = shift;
+ my %auth_args = (
+ privatekey => shift,
+ publickey => shift,
+ rank => [qw/ publickey hostbased password /],
+ );
+ $self->remote_user and $auth_args{username} = $self->remote_user ;
+ $self->remote_password and $auth_args{password} = $self->remote_password;
+ $self->remote_host and $auth_args{hostname} = $self->remote_host ;
+ return %auth_args;
+}
+
+sub put_ssh2 {
+ my $self = shift;
+ my $keys = shift; # could have many keypairs here
+ unless (@_) {
+ $logger->error($self->_error("put_ssh2 called without target: nothing to put!"));
+ return;
+ }
+
+ $logger->info("*** attempting put (" . join(", ", @_) . ") with ssh keys");
+ my $ssh2 = $self->_ssh2($keys) or return;
+ my $res;
+ if ($res = $ssh2->scp_put( @_ )) {
+ $logger->info(_pkg("successfully sent", $self->remote_host, join(' --> ', @_ )));
+ return $res;
+ }
+ $logger->error($self->_error(sprintf "put with keys to %s failed with error: $!", $self->remote_host));
+ return;
+}
+
+sub get_ssh2 {
+ my $self = shift;
+ my $keys = shift; # could have many keypairs here
+ unless (@_) {
+ $logger->error($self->_error("get_ssh2 called without target: nothing to get!"));
+ return;
+ }
+
+ $logger->info("*** get args: " . Dumper(\@_));
+ $logger->info("*** attempting get (" . join(", ", map {$_ =~ /\S/ ? $_ : '*Object'} map {defined($_) ? $_ : '*Object'} @_) . ") with ssh keys");
+ my $ssh2 = $self->_ssh2($keys) or return;
+ my $res;
+ if ($res = $ssh2->scp_get( @_ )) {
+ $logger->info(_pkg("successfully got", $self->remote_host, join(' --> ', @_ )));
+ return $res;
+ }
+ $logger->error($self->_error(sprintf "get with keys from %s failed with error: $!", $self->remote_host));
+ return;
+}
+
+sub ls_ssh2 {
+ my $self = shift;
+ my @list = $self->ls_ssh2_full(@_);
+ @list and return sort map {$_->{slash_path}} @list;
+# @list and return sort grep {$_->{name} !~ /./ and {$_->{name} !~ /./ } map {$_->{slash_path}} @list;
+}
+
+sub ls_ssh2_full {
+ my $self = shift;
+ my $keys = shift; # could have many keypairs here
+ my @targets = grep {defined} @_;
+
+ $logger->info("*** attempting ls ('" . join("', '", @targets) . "') with ssh keys");
+ my $ssh2 = $self->_ssh2($keys) or return;
+ my $sftp = $ssh2->sftp or return;
+
+ my @list = ();
+ foreach my $target (@targets) {
+ my ($dir, $file);
+ my ($dirpath, $regex) = $self->glob_parse($target);
+ $dir = $sftp->opendir($dirpath || $target); # Try to open it like a directory
+ unless ($dir) {
+ $file = $sftp->stat($target); # Otherwise, check it like a file
+ if ($file) {
+ $file->{slash_path} = $self->_slash_path($target, $file->{name}); # it was a file, not a dir. That's OK.
+ push @list, $file;
+ } else {
+ $logger->warn($self->_error("sftp->opendir($target) failed: " . $sftp->error));
+ }
+ next;
+ }
+ my @pool = ();
+ while ($file = $dir->read()) {
+ $file->{slash_path} = $self->_slash_path($target, $file->{name});
+ push @pool, $file;
+ }
+ if ($regex) {
+ my $count = scalar(@pool);
+ @pool = grep {$_->{name} =~ /$regex/} @pool;
+ $logger->info("SSH ls: Glob regex($regex) matches " . scalar(@pool) . " of $count files");
+ } # else { $logger->info("SSH ls: No Glob regex in '$target'. Just a regular ls"); }
+ push @list, @pool;
+ }
+ return @list;
+
+}
+
+sub _slash_path {
+ my $self = shift;
+ my $dir = shift || '.';
+ my $file = shift || '';
+ my ($dirpath, $regex) = $self->glob_parse($dir);
+ $dir = $dirpath if $dirpath;
+ return $dir . ($dir =~ /\/$/ ? '' : '/') . $file;
+}
+
+sub _ftp {
+ my $self = shift;
+ my %options = ();
+ $self->{ftp} and return $self->{ftp}; # caching
+ foreach (qw/debug port/) {
+ $options{ucfirst($_)} = $self->{$_} if $self->{$_};
+ }
+
+ my $ftp = new Net::FTP($self->remote_host, %options);
+ unless ($ftp) {
+ $logger->error(
+ $self->_error(
+ "new Net::FTP('" . $self->remote_host . ", ...) FAILED: $@"
+ )
+ );
+ return;
+ }
+
+ my @login_args = ();
+ foreach (qw/remote_user remote_password remote_account/) {
+ $self->{$_} or last;
+ push @login_args, $self->{$_};
+ }
+ my $login_ok = 0;
+ eval { $login_ok = $ftp->login(@login_args) };
+ if ($@ or !$login_ok) {
+ $logger->error(
+ $self->_error(
+ "failed login to", $self->remote_host, "w/ args(" .
+ join(',', @login_args) . ") : $@"
+ )
+ ); # XXX later, maybe keep passwords out of the logs?
+ return;
+ }
+ return $self->{ftp} = $ftp;
+}
+
+sub put_ftp {
+ my $self = shift;
+ my $filename;
+
+ eval { $filename = $self->_ftp->put(@{$self->{put_args}}) };
+ if ($@ or not $filename) {
+ $logger->error(
+ $self->_error(
+ "put to", $self->remote_host, "failed with error: $@"
+ )
+ );
+ return;
+ }
+
+ $self->remote_file($filename);
+ $logger->info(
+ _pkg(
+ "successfully sent", $self->remote_host, $self->local_file, '-->',
+ $filename
+ )
+ );
+ return $filename;
+}
+
+sub get_ftp {
+ my $self = shift;
+ my $filename;
+
+ eval { $filename = $self->_ftp->get(@{$self->{get_args}}) };
+ if ($@ or not $filename) {
+ $logger->error(
+ $self->_error(
+ "get from", $self->remote_host, "failed with error: $@"
+ )
+ );
+ return;
+ }
+
+ $self->local_file($filename);
+ $logger->info(
+ _pkg(
+ "successfully retrieved $filename <--", $self->remote_host . '/' .
+ $self->remote_file
+ )
+ );
+ return $self->local_file;
+}
+
+sub ls_ftp { # returns full path like: dir/path/file.ext
+ my $self = shift;
+ my @list;
+
+ foreach (@_) {
+ my @part;
+ my ($dirpath, $regex) = $self->glob_parse($_);
+ my $dirtarget = $dirpath || $_;
+ $dirtarget =~ s/\/+$//;
+ eval { @part = $self->_ftp->ls($dirtarget) }; # this ls returns relative/path/filenames. defer filename glob filtering for below.
+ if ($@) {
+ $logger->error(
+ $self->_error(
+ "ls from", $self->remote_host, "failed with error: $@"
+ )
+ );
+ next;
+ }
+ if ($dirtarget and $dirtarget ne '.' and $dirtarget ne './' and
+ $self->_ftp->is_dir($dirtarget)) {
+ foreach my $file (@part) { # we ensure full(er) path
+ $file =~ /^$dirtarget\// and next;
+ $logger->debug("ls_ftp: prepending $dirtarget/ to $file");
+ $file = File::Spec->catdir($dirtarget, $file);
+ }
+ }
+ if ($regex) {
+ my $count = scalar(@part);
+ # @part = grep {my @a = split('/',$_); scalar(@a) ? /$regex/ : ($a[-1] =~ /$regex/)} @part;
+ my @bulk = @part;
+ @part = grep {
+ my ($vol, $dir, $file) = File::Spec->splitpath($_);
+ $file =~ /$regex/
+ } @part;
+ $logger->info("FTP ls: Glob regex($regex) matches " . scalar(@part) . " of $count files");
+ } # else {$logger->info("FTP ls: No Glob regex in '$_'. Just a regular ls");}
+ push @list, @part;
+ }
+ return @list;
+}
+
+sub delete_ftp { # XXX not yet used
+ $_[0]->_ftp->delete($_[1]);
+}
+
+sub _pkg { # Not OO
+ return __PACKAGE__ . ' : ' unless @_;
+ return __PACKAGE__ . ' : ' . join(' ', @_);
+}
+
+sub _error {
+ my $self = shift;
+ return _pkg($self->error(join(' ',@_)));
+}
+
+sub init {
+ my $self = shift;
+ my $params = shift;
+ my @required = @_; # qw(remote_host) ; # nothing required now
+
+ if ($params->{account_object}) { # if we got passed an object, we initialize off that first
+ $self->{remote_host } = $params->{account_object}->host;
+ $self->{remote_user } = $params->{account_object}->username;
+ $self->{remote_password} = $params->{account_object}->password;
+ $self->{remote_account } = $params->{account_object}->account;
+ $self->{remote_path } = $params->{account_object}->path; # not really the same as remote_file, maybe expand on this later
+ }
+
+ foreach (keys %{$self->{_permitted}}) {
+ $self->{$_} = $params->{$_} if defined $params->{$_}; # possibly override settings from object
+ }
+
+ foreach (@required) {
+ unless ($self->{$_}) {
+ $logger->error("Required parameter $_ not specified");
+ return;
+ }
+ }
+ return $self;
+}
+
+sub new {
+ my ($class, %args) = @_;
+ my $self = { _permitted => \%fields, %fields };
+
+ bless $self, $class;
+
+ $self->init(\%args); # or croak "Initialization error caused by bad args";
+ return $self;
+}
+
+sub DESTROY {
+ # in order to create, we must first ...
+ my $self = shift;
+ $self->{ssh2} and $self->{ssh2}->disconnect(); # let the other end know we're done.
+ $self->{ftp} and $self->{ftp}->quit(); # let the other end know we're done.
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $class = ref($self) or croak "AUTOLOAD error: $self is not an object";
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*://; # strip leading package stuff
+
+ unless (exists $self->{_permitted}->{$name}) {
+ croak "AUTOLOAD error: Cannot access '$name' field of class '$class'";
+ }
+
+ if (@_) {
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+}
+
+1;
+
--- /dev/null
+package OpenILS::Utils::ScriptRunner;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::JSON;
+use JavaScript::SpiderMonkey;
+use LWP::UserAgent;
+use XML::LibXML;
+use Time::HiRes qw/time/;
+use vars qw/%_paths/;
+
+sub DESTROY {
+ my $self = shift;
+ $logger->info("script_runner: destroying self: $self");
+}
+
+sub cleanup {
+ my $runner = shift;
+ $logger->info("script_runner: destroying context...");
+ $runner->context->destroy;
+ delete($$runner{$_}) for (keys %$runner);
+}
+
+sub new {
+ my $class = shift;
+ my %params = @_;
+ $class = ref($class) || $class;
+ $params{paths} ||= [];
+ $params{reset_count} ||= 0;
+
+ my $self = bless { file => $params{file},
+ libs => $params{libs},
+ reset_count => $params{reset_count},
+ _runs => 0,
+ _path => {%_paths} } => $class;
+
+ $self->add_path($_) for @{$params{paths}};
+ return $self->init;
+}
+
+sub context {
+ my( $self, $context ) = @_;
+ $self->{ctx} = $context if $context;
+ return $self->{ctx};
+}
+
+sub init {
+ my $self = shift;
+ $self->context( new JavaScript::SpiderMonkey );
+ $self->context->init();
+
+ $self->{_runs} = 0;
+
+ # eating our own dog food with insert
+ $self->insert(log_stdout => sub { print "@_\n"; } );
+ $self->insert(log_stderr => sub { warn "@_\n"; } );
+ $self->insert(log_activity => sub { $logger->activity("script_runner: @_"); return 1;} );
+ $self->insert(log_error => sub { $logger->error("script_runner: @_"); return 1;} );
+ $self->insert(log_warn => sub { $logger->warn("script_runner: @_"); return 1;} );
+ $self->insert(log_info => sub { $logger->info("script_runner: @_"); return 1;} );
+ $self->insert(log_debug => sub { $logger->debug("script_runner: @_"); return 1;} );
+ $self->insert(log_internal => sub { $logger->internal("script_runner: @_"); return 1;} );
+ $self->insert(debug => sub { $logger->debug("script_runner: @_"); return 1;} );
+ $self->insert(alert => sub { $logger->warn("script_runner: @_"); return 1;} );
+ $self->insert(load_lib => sub { $self->load_lib(@_); return 1;});
+
+ # OpenSRF support functions
+ $self->insert(
+ _OILS_FUNC_jsonopensrfrequest_send =>
+ sub { $self->_jsonopensrfrequest_send(@_); }
+ );
+ $self->insert(
+ _OILS_FUNC_jsonopensrfrequest_connect =>
+ sub { $self->_jsonopensrfrequest_connect(@_); }
+ );
+ $self->insert(
+ _OILS_FUNC_jsonopensrfrequest_disconnect =>
+ sub { $self->_jsonopensrfrequest_disconnect(@_); }
+ );
+ $self->insert(
+ _OILS_FUNC_jsonopensrfrequest_finish =>
+ sub { $self->_jsonopensrfrequest_finish(@_); }
+ );
+
+ # XML support functions
+ $self->insert(
+ _OILS_FUNC_xmlhttprequest_send =>
+ sub { $self->_xmlhttprequest_send(@_); }
+ );
+ $self->insert(
+ _OILS_FUNC_xml_parse_string =>
+ sub { $self->_parse_xml_string(@_); }
+ );
+
+ while ( my $e = shift @{$self->{_env}} ) {
+ $self->insert( @$e{ qw/key value readonly/ } => 1 );
+ }
+
+ while ( my $e = shift @{$self->{_methods}} ) {
+ $self->insert_method( @$e{ qw/key name meth/ } => 1 );
+ }
+
+ $self->load_lib($_) for @{$self->{libs}};
+
+ return $self;
+}
+
+sub refresh_context {
+ my $self = shift;
+ $logger->debug("Refreshing JavaScript Context...");
+ $self->context->destroy;
+ $logger->debug("Context destroyed");
+ $self->{_loaded} = {};
+ $logger->debug("Loaded scripts removed");
+ $self->init;
+ $logger->debug("New Context initialized");
+ return $self;
+}
+
+sub load {
+ my( $self, $filename ) = @_;
+ $self->{file} = $filename;
+}
+
+sub runs { shift()->{_runs} }
+
+sub reset_count {
+ my $self = shift;
+ my $count = shift;
+
+ $self->{reset_count} = $count if ($count);
+ return $self->{reset_count};
+}
+
+sub run {
+ my $self = shift;
+ my $file = shift();
+
+ my $_real = 0;
+ if(!$file) {
+ $_real = 1;
+ $file = $self->{file};
+ }
+
+ $self->refresh_context
+ if ($self->reset_count && $self->runs > $self->reset_count);
+
+ $self->{_runs}++ if ($_real);
+
+ $file = $self->_find_file($file);
+ $logger->debug("full script file path: $file");
+
+ if( ! open(F, $file) ) {
+ $logger->error("Error opening script file: $file");
+ return 0;
+ }
+
+ my $js = $self->context;
+
+ my $res = '';
+ { local $/ = undef;
+
+ $self->insert('environment.result' => {});
+
+ my $content = <F>;
+ #print ( "full script is [$content]" );
+
+ my $s = time();
+ if( !$js || !$content || !$js->eval($content) ) {
+ $logger->error("$file Eval failed: $@");
+ return 0;
+ }
+ $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
+
+ if ($_real) {
+ $self->insert('__' => {'OILS_RESULT' => ''});
+ $js->eval("__.OILS_RESULT = js2JSON(environment.result);");
+ $res = $self->retrieve('__.OILS_RESULT');
+ }
+ }
+
+ close(F);
+ $logger->debug( "script result is [$res]" );
+ return OpenSRF::Utils::JSON->JSON2perl( $res );
+}
+
+sub remove_path {
+ my( $self, $path ) = @_;
+ if (ref($self)) {
+ if ($self->{_path}{$path}) {
+ $self->{_path}{$path} = 0;
+ }
+ return $self->{_path}{$path};
+ } else {
+ if ($_paths{$path}) {
+ $_paths{$path} = 0;
+ }
+ return $_paths{$path};
+ }
+}
+
+sub add_path {
+ my( $self, $path ) = @_;
+ if (ref($self)) {
+ if (!$self->{_path}{$path}) {
+ $self->{_path}{$path} = 1;
+ }
+ } else {
+ if (!$_paths{$path}) {
+ $_paths{$path} = 1;
+ }
+ }
+ return $self;
+}
+
+sub _find_file {
+ my $self = shift;
+ my $file = shift;
+ for my $p ( keys %{ $self->{_path} } ) {
+ next unless ($self->{_path}{$p});
+ my $full = join('/',$p,$file);
+ return $full if (-e $full);
+ }
+}
+
+sub load_lib {
+ my( $self, $file ) = @_;
+
+ my @paths = keys %{$self->{_path}};
+ $logger->debug("script_runner: Loading lib file $file : paths=[@paths]");
+
+ push @{ $self->{libs} }, $file
+ if (! grep {$_ eq $file} @{ $self->{libs} });
+
+ if (!$self->{_loaded}{$file}) {
+ $self->run( $file );
+ $self->{_loaded}{$file} = 1;
+ }
+ return $self->{_loaded}{$file};
+}
+
+sub _js_prop_name {
+ my $name = shift;
+ $name =~ s/^.*\.//o;
+ return $name;
+}
+
+sub retrieve {
+ my( $self, $key ) = @_;
+ return $self->context->property_get($key);
+}
+
+sub insert_method {
+ my( $self, $obj_key, $meth_name, $sub, $stop) = @_;
+
+ push @{$self->{_methods}}, { key => $obj_key => name => $meth_name, meth => $sub } unless ($stop);
+
+ my $obj = $self->context->object_by_path( $obj_key );
+ $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
+}
+
+
+sub insert {
+ my( $self, $key, $val, $RO, $stop ) = @_;
+ return unless defined($key);
+
+ push @{$self->{_env}}, { key => $key => value => $val, readonly => $RO } unless ($stop);
+
+ if (ref($val) =~ /^Fieldmapper/o) {
+ $self->insert_fm($key, $val, $RO);
+ } elsif (ref($val) and $val =~ /ARRAY/o) {
+ $self->insert_array($key, $val, $RO);
+ } elsif (ref($val) and $val =~ /HASH/o) {
+ $self->insert_hash($key, $val, $RO);
+ } elsif (ref($val) and $val =~ /CODE/o) {
+ $self->context->function_set( $key, $val );
+ } elsif (!ref($val)) {
+ if( defined($val) ) {
+ $self->context->property_by_path(
+ $key, $val,
+ ( !$RO ? (sub { $val }, sub { my( $k, $v ) = @_; $val = $v; }) : () )
+ );
+ } else {
+ $self->context->property_by_path($key, "");
+ }
+
+ } else {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub insert_fm {
+
+ my( $self, $key, $fm, $RO ) = @_;
+ my $ctx = $self->context;
+ return undef unless ($ctx and $key and $fm);
+ my $o = $ctx->object_by_path($key);
+
+ for my $f ( $fm->properties ) {
+ my $val = $fm->$f();
+ if (ref $val) {
+ $self->insert("$key.$f", $val);
+ } else {
+ $ctx->property_by_path(
+ "$key.$f",
+ $val,
+ ( !$RO ?
+ (sub {
+ my $k = _js_prop_name(shift());
+ $fm->$k();
+ },
+ sub {
+ my $k = _js_prop_name(shift());
+ $fm->ischanged(1);
+ $fm->$k(@_);
+ }) :
+ ()
+ )
+ );
+ }
+ }
+}
+
+sub insert_hash {
+
+ my( $self, $key, $hash, $RO ) = @_;
+ my $ctx = $self->context;
+ return undef unless ($ctx and $key and $hash);
+ $ctx->object_by_path($key);
+
+ for my $k ( keys %$hash ) {
+ my $v = $hash->{$k};
+ if (ref $v) {
+ $self->insert("$key.$k", $v);
+ } else {
+ $ctx->property_by_path(
+ "$key.$k", $v,
+ ( !$RO ?
+ (sub { $hash->{_js_prop_name(shift())} },
+ sub {
+ my( $hashkey, $val ) = @_;
+ $hash->{_js_prop_name($hashkey)} = $val;
+ }) :
+ ()
+ )
+ );
+ }
+ }
+}
+
+my $__array_id = 0;
+sub insert_array {
+
+ my( $self, $key, $array ) = @_;
+ my $ctx = $self->context;
+ return undef unless ($ctx and $key and $array);
+
+ my $a = $ctx->array_by_path($key);
+
+ my $ind = 0;
+ for my $v ( @$array ) {
+ if (ref $v) {
+ my $tmp_index = $__array_id++;
+ my $elobj = $ctx->object_by_path('__tmp_arr_el'.$tmp_index);
+ $self->insert('__tmp_arr_el'.$tmp_index, $v);
+ $ctx->array_set_element_as_object( $a, $ind, $elobj );
+ } else {
+ $ctx->array_set_element( $a, $ind, $v ) if defined($v);
+ }
+ $ind++;
+ }
+}
+
+sub _xmlhttprequest_send {
+ my $self = shift;
+ my $id = shift;
+ my $method = shift;
+ my $url = shift;
+ my $blocking = shift;
+ my $headerlist = shift;
+ my $data = shift;
+
+ my $ctx = $self->context;
+
+ # just so perl has access to it...
+ $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
+
+ my $headers = new HTTP::Headers;
+ my @lines = split(/\n/so, $headerlist);
+ for my $line (@lines) {
+ if ($line =~ /^(.+?)|(.+)$/o) {
+ $headers->header($1 => $2);
+ }
+ }
+
+ my $ua = LWP::UserAgent->new;
+ $ua->agent("OpenILS/0.1");
+
+ my $req = HTTP::Request->new($method => $url => $headers => $data);
+ my $res = $ua->request($req);
+
+ if ($res->is_success) {
+
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
+
+ }
+
+}
+
+our %_jsonopensrfrequest_cache = ();
+
+sub _jsonopensrfrequest_connect {
+ my $self = shift;
+ my $id = shift;
+ my $service = shift;
+
+ my $ctx = $self->context;
+ $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
+
+ my $ses = $_jsonopensrfrequest_cache{$id} ||
+ do { $_jsonopensrfrequest_cache{$id} = OpenSRF::AppSession->create($service) };
+
+ if($ses->connect) {
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.connected', 1);
+ } else {
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.connected', 0);
+ }
+}
+
+sub _jsonopensrfrequest_disconnect {
+ my $self = shift;
+ my $id = shift;
+
+ my $ctx = $self->context;
+ $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
+
+ my $ses = $_jsonopensrfrequest_cache{$id};
+ return unless $ses;
+
+ $ses->disconnect;
+}
+
+sub _jsonopensrfrequest_finish {
+ my $self = shift;
+ my $id = shift;
+
+ my $ctx = $self->context;
+ $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
+
+ my $ses = $_jsonopensrfrequest_cache{$id};
+ return unless $ses;
+
+ $ses->finish;
+ delete $_jsonopensrfrequest_cache{$id};
+}
+
+sub _jsonopensrfrequest_send {
+ my $self = shift;
+ my $id = shift;
+ my $service = shift;
+ my $method = shift;
+ my $blocking = shift;
+ my $params = shift;
+
+ my @p = @{ OpenSRF::Utils::JSON->JSON2perl($params) };
+
+ my $ctx = $self->context;
+
+ # just so perl has access to it...
+ $ctx->object_by_path('__jsonopensrfreq_hash.id'.$id);
+
+ my $ses = $_jsonopensrfrequest_cache{$id} ||
+ do { $_jsonopensrfrequest_cache{$id} = OpenSRF::AppSession->create($service) };
+ my $req = $ses->request($method,@p);
+
+ $req->wait_complete;
+ if (!$req->failed) {
+ my $res = $req->recv->content;
+
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.responseText', OpenSRF::Utils::JSON->perl2JSON($res));
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.readyState', 4);
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.statusText', 'OK');
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.status', '200');
+
+ } else {
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.responseText', '');
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.readyState', 4);
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.statusText', $req->failed->status );
+ $ctx->property_by_path('__jsonopensrfreq_hash.id'.$id.'.status', $req->failed->statusCode );
+ }
+
+ $req->finish;
+
+}
+
+sub _parse_xml_string {
+ my $self = shift;
+ my $string = shift;
+ my $key = shift;
+
+
+ my $doc;
+ my $s = 0;
+ try {
+ $doc = XML::LibXML->new->parse_string( $string );
+ $s = 1;
+ } catch Error with {
+ my $e = shift;
+ warn "Could not parse document: $e\n";
+ };
+ return unless ($s);
+
+ _JS_DOM($self->context, $key, $doc);
+}
+
+sub _JS_DOM {
+ my $ctx = shift;
+ my $key = shift;
+ my $node = shift;
+
+ if ($node->nodeType == 9) {
+ $node = $node->documentElement;
+
+ my $n = $node->nodeName;
+ my $ns = $node->namespaceURI;
+ $ns =~ s/'/\'/gso if ($ns);
+ $ns = "'$ns'" if ($ns);
+ $ns = 'null' unless ($ns);
+ $n =~ s/'/\'/gso;
+
+ #warn("$key = DOMImplementation().createDocument($ns,'$n');");
+ $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
+
+ $key = $key.'.documentElement';
+ }
+
+ for my $a ($node->attributes) {
+ my $n = $a->nodeName;
+ my $v = $a->value;
+ $n =~ s/'/\'/gso;
+ $v =~ s/'/\'/gso;
+ #warn("$key.setAttribute('$n','$v');");
+ $ctx->eval("$key.setAttribute('$n','$v');");
+
+ }
+
+ my $k = 0;
+ for my $c ($node->childNodes) {
+ if ($c->nodeType == 1) {
+ my $n = $c->nodeName;
+ my $ns = $node->namespaceURI;
+
+ $n =~ s/'/\'/gso;
+ $ns =~ s/'/\'/gso if ($ns);
+ $ns = "'$ns'" if ($ns);
+ $ns = 'null' unless ($ns);
+
+ #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
+ _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
+
+ } elsif ($c->nodeType == 3) {
+ my $n = $c->data;
+ $n =~ s/'/\'/gso;
+ #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
+ #warn("path is $key.item($k);");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
+
+ } elsif ($c->nodeType == 4) {
+ my $n = $c->data;
+ $n =~ s/'/\'/gso;
+ #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
+
+ } elsif ($c->nodeType == 8) {
+ my $n = $c->data;
+ $n =~ s/'/\'/gso;
+ #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
+
+ } else {
+ warn "ACK! I don't know how to handle node type ".$c->nodeType;
+ }
+
+
+ $k++;
+ }
+
+ return 1;
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::Utils::SpiderMonkey;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw(:logger);
+use OpenSRF::EX qw(:try);
+use OpenILS::Utils::ScriptRunner;
+use base 'OpenILS::Utils::ScriptRunner';
+use JavaScript::SpiderMonkey;
+use LWP::UserAgent;
+use XML::LibXML;
+use Time::HiRes qw/time/;
+use vars qw/%_paths/;
+
+sub new {
+ my ( $class, %params ) = @_;
+ $class = ref($class) || $class;
+ $params{paths} ||= [];
+
+ my $self = { file => $params{file}, libs => $params{libs}, _path => {%_paths} };
+ bless( $self, $class );
+
+ $self->add_path($_) for @{$params{paths}};
+ return $self;
+}
+
+sub context {
+ my( $self, $context ) = @_;
+ $self->{ctx} = $context if $context;
+ return $self->{ctx};
+}
+
+sub init {
+ my $self = shift;
+ my $js = JavaScript::SpiderMonkey->new();
+ $js->init();
+
+ $js->function_set(perl_print => sub { print "@_\n"; } );
+ $js->function_set(perl_warn => sub { warn @_; } );
+ $js->function_set(log_activity => sub { $logger->activity(@_); return 1;} );
+ $js->function_set(log_error => sub { $logger->error(@_); return 1;} );
+ $js->function_set(log_warn => sub { $logger->warn(@_); return 1;} );
+ $js->function_set(log_info => sub { $logger->info(@_); return 1;} );
+ $js->function_set(log_debug => sub { $logger->debug(@_); return 1;} );
+ $js->function_set(log_internal => sub { $logger->internal(@_); return 1;} );
+ $js->function_set(debug => sub { $logger->debug(@_); return 1;} );
+ $js->function_set(alert => sub { $logger->warn(@_); return 1;} );
+
+ $js->function_set(load_lib => sub { $self->load_lib(@_); });
+
+ # XML support functions
+ $js->function_set(
+ _OILS_FUNC_xmlhttprequest_send => sub { $self->_xmlhttprequest_send(@_); });
+ $js->function_set(
+ _OILS_FUNC_xml_parse_string => sub { $self->_parse_xml_string(@_); });
+
+ $self->context($js);
+ $self->load_lib($_) for @{$self->{libs}};
+
+ return $self;
+}
+
+
+sub load {
+ my( $self, $filename ) = @_;
+ $self->{file} = $filename;
+}
+
+sub run {
+ my $self = shift;
+ my $file = shift() || $self->{file};
+ my $js = $self->context;
+
+ $file = $self->_find_file($file);
+
+ if( ! open(F, $file) ) {
+ $logger->error("Error opening script file: $file");
+ return 0;
+ }
+
+ { local $/ = undef;
+ my $content = <F>;
+ my $s = time();
+ if( !$js || !$content || !$js->eval($content) ) {
+ $logger->error("$file Eval failed: $@");
+ return 0;
+ }
+ $logger->debug("eval of $file took ". sprintf('%0.3f', time - $s) . " seconds");
+ }
+
+ close(F);
+ return 1;
+}
+
+sub remove_path {
+ my( $self, $path ) = @_;
+ if (ref($self)) {
+ if ($self->{_path}{$path}) {
+ $self->{_path}{$path} = 0;
+ }
+ return $self->{_path}{$path};
+ } else {
+ if ($_paths{$path}) {
+ $_paths{$path} = 0;
+ }
+ return $_paths{$path};
+ }
+}
+
+sub add_path {
+ my( $self, $path ) = @_;
+ if (ref($self)) {
+ if (!$self->{_path}{$path}) {
+ $self->{_path}{$path} = 1;
+ }
+ } else {
+ if (!$_paths{$path}) {
+ $_paths{$path} = 1;
+ }
+ }
+ return $self;
+}
+
+sub _find_file {
+ my $self = shift;
+ my $file = shift;
+ for my $p ( keys %{ $self->{_path} } ) {
+ next unless ($self->{_path}{$p});
+ my $full = join('/',$p,$file);
+ return $full if (-e $full);
+ }
+}
+
+sub load_lib {
+ my( $self, $file ) = @_;
+ if (!$self->{_loaded}{$file} && $self->run( $file )) {
+ $self->{_loaded}{$file} = 1;
+ }
+ return $self->{_loaded}{$file};
+}
+
+sub _js_prop_name {
+ my $name = shift;
+ $name =~ s/^.*\.//o;
+ return $name;
+}
+
+sub retrieve {
+ my( $self, $key ) = @_;
+ return $self->context->property_get($key);
+}
+
+sub insert_method {
+ my( $self, $obj_key, $meth_name, $sub ) = @_;
+ my $obj = $self->context->object_by_path( $obj_key );
+ $self->context->function_set( $meth_name, $sub, $obj ) if $obj;
+}
+
+
+sub insert {
+ my( $self, $key, $val ) = @_;
+ return unless defined($key);
+
+ if (ref($val) =~ /^Fieldmapper/o) {
+ $self->insert_fm($key, $val);
+ } elsif (ref($val) and $val =~ /ARRAY/o) {
+ $self->insert_array($key, $val);
+ } elsif (ref($val) and $val =~ /HASH/o) {
+ $self->insert_hash($key, $val);
+ } elsif (ref($val) and $val =~ /CODE/o) {
+ $self->context->function_set( $key, $val );
+ } elsif (!ref($val)) {
+ if( defined($val) ) {
+ $self->context->property_by_path(
+ $key, $val,
+ sub { $val },
+ sub { my( $k, $v ) = @_; $val = $v; }
+ );
+ } else {
+ $self->context->property_by_path($key);
+ }
+
+ } else {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub insert_fm {
+
+ my( $self, $key, $fm ) = @_;
+ my $ctx = $self->context;
+ return undef unless ($ctx and $key and $fm);
+ my $o = $ctx->object_by_path($key);
+
+ for my $f ( $fm->properties ) {
+ my $val = $fm->$f();
+ if (ref $val) {
+ $self->insert("$key.$f", $val);
+ } else {
+ $ctx->property_by_path(
+ "$key.$f",
+ $val,
+ sub {
+ my $k = _js_prop_name(shift());
+ $fm->$k();
+ },
+
+ sub {
+ my $k = _js_prop_name(shift());
+ $fm->ischanged(1);
+ $fm->$k(@_);
+ }
+ );
+ }
+ }
+}
+
+sub insert_hash {
+
+ my( $self, $key, $hash ) = @_;
+ my $ctx = $self->context;
+ return undef unless ($ctx and $key and $hash);
+ $ctx->object_by_path($key);
+
+ for my $k ( keys %$hash ) {
+ my $v = $hash->{$k};
+ if (ref $v) {
+ $self->insert("$key.$k", $v);
+ } else {
+ $ctx->property_by_path(
+ "$key.$k", $v,
+ sub { $hash->{_js_prop_name(shift())} },
+ sub {
+ my( $key, $val ) = @_;
+ $hash->{_js_prop_name($key)} = $val; }
+ );
+ }
+ }
+}
+
+my $__array_id = 0;
+sub insert_array {
+
+ my( $self, $key, $array ) = @_;
+ my $ctx = $self->context;
+ return undef unless ($ctx and $key and $array);
+
+ my $a = $ctx->array_by_path($key);
+
+ my $ind = 0;
+ for my $v ( @$array ) {
+ if (ref $v) {
+ my $elobj = $ctx->object_by_path('__tmp_arr_el'.$__array_id);
+ $self->insert('__tmp_arr_el'.$__array_id, $v);
+ $ctx->array_set_element_as_object( $a, $ind, $elobj );
+ $__array_id++;
+ } else {
+ $ctx->array_set_element( $a, $ind, $v ) if defined($v);
+ }
+ $ind++;
+ }
+}
+
+sub _xmlhttprequest_send {
+ my $self = shift;
+ my $id = shift;
+ my $method = shift;
+ my $url = shift;
+ my $blocking = shift;
+ my $headerlist = shift;
+ my $data = shift;
+
+ my $ctx = $self->context;
+
+ # just so perl has access to it...
+ $ctx->object_by_path('__xmlhttpreq_hash.id'.$id);
+
+ my $headers = new HTTP::Headers;
+ my @lines = split(/\n/so, $headerlist);
+ for my $line (@lines) {
+ if ($line =~ /^(.+?)|(.+)$/o) {
+ $headers->header($1 => $2);
+ }
+ }
+
+ my $ua = LWP::UserAgent->new;
+ $ua->agent("OpenILS/0.1");
+
+ my $req = HTTP::Request->new($method => $url => $headers => $data);
+ my $res = $ua->request($req);
+
+ if ($res->is_success) {
+
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.responseText', $res->content);
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.readyState', 4);
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.statusText', $res->status_line);
+ $ctx->property_by_path('__xmlhttpreq_hash.id'.$id.'.status', $res->code);
+
+ }
+
+}
+
+sub _parse_xml_string {
+ my $self = shift;
+ my $string = shift;
+ my $key = shift;
+
+
+ my $doc;
+ my $s = 0;
+ try {
+ $doc = XML::LibXML->new->parse_string( $string );
+ $s = 1;
+ } catch Error with {
+ my $e = shift;
+ warn "Could not parse document: $e\n";
+ };
+ return unless ($s);
+
+ _JS_DOM($self->context, $key, $doc);
+}
+
+sub _JS_DOM {
+ my $ctx = shift;
+ my $key = shift;
+ my $node = shift;
+
+ if ($node->nodeType == 9) {
+ $node = $node->documentElement;
+
+ my $n = $node->nodeName;
+ my $ns = $node->namespaceURI;
+ $ns =~ s/'/\'/gso if ($ns);
+ $ns = "'$ns'" if ($ns);
+ $ns = 'null' unless ($ns);
+ $n =~ s/'/\'/gso;
+
+ #warn("$key = DOMImplementation().createDocument($ns,'$n');");
+ $ctx->eval("$key = new DOMImplementation().createDocument($ns,'$n');");
+
+ $key = $key.'.documentElement';
+ }
+
+ for my $a ($node->attributes) {
+ my $n = $a->nodeName;
+ my $v = $a->value;
+ $n =~ s/'/\'/gso;
+ $v =~ s/'/\'/gso;
+ #warn("$key.setAttribute('$n','$v');");
+ $ctx->eval("$key.setAttribute('$n','$v');");
+
+ }
+
+ my $k = 0;
+ for my $c ($node->childNodes) {
+ if ($c->nodeType == 1) {
+ my $n = $c->nodeName;
+ my $ns = $node->namespaceURI;
+
+ $n =~ s/'/\'/gso;
+ $ns =~ s/'/\'/gso if ($ns);
+ $ns = "'$ns'" if ($ns);
+ $ns = 'null' unless ($ns);
+
+ #warn("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createElementNS($ns,'$n'));");
+ _JS_DOM($ctx, "$key.childNodes.item($k)",$c);
+
+ } elsif ($c->nodeType == 3) {
+ my $n = $c->data;
+ $n =~ s/'/\'/gso;
+ #warn("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
+ #warn("path is $key.item($k);");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createTextNode('$n'));");
+
+ } elsif ($c->nodeType == 4) {
+ my $n = $c->data;
+ $n =~ s/'/\'/gso;
+ #warn("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createCDATASection('$n'));");
+
+ } elsif ($c->nodeType == 8) {
+ my $n = $c->data;
+ $n =~ s/'/\'/gso;
+ #warn("$key.appendChild($key.ownerDocument.createComment('$n'));");
+ $ctx->eval("$key.appendChild($key.ownerDocument.createComment('$n'));");
+
+ } else {
+ warn "ACK! I don't know how to handle node type ".$c->nodeType;
+ }
+
+
+ $k++;
+ }
+
+ return 1;
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::Utils::ZClient;
+use UNIVERSAL::require;
+
+sub DESTROY {};
+
+use overload 'bool' => sub { return $_[0]->{connection} ? 1 : 0 };
+
+sub EVENT_NONE { 0 }
+sub EVENT_CONNECT { 1 }
+sub EVENT_SEND_DATA { 2 }
+sub EVENT_RECV_DATA { 3 }
+sub EVENT_TIMEOUT { 4 }
+sub EVENT_UNKNOWN { 5 }
+sub EVENT_SEND_APDU { 6 }
+sub EVENT_RECV_APDU { 7 }
+sub EVENT_RECV_RECORD { 8 }
+sub EVENT_RECV_SEARCH { 9 }
+sub EVENT_END { 10 }
+
+our $conn_class = 'ZOOM::Connection';
+our $imp_class = 'ZOOM';
+our $AUTOLOAD;
+
+# Detect the installed z client, prefering ZOOM.
+if (!$imp_class->use()) {
+
+ $imp_class = 'Net::Z3950'; # Try Net::Z3950
+ if ($imp_class->use()) {
+
+ # Tell 'new' how to build the connection
+ $conn_class = 'Net::Z3950::Connection';
+
+ } else {
+ die "Cannot load a z39.50 client implementation! Please install either ZOOM or Net::Z3950.\n";
+ }
+}
+
+# 'new' is called thusly:
+# my $conn = OpenILS::Utils::ZClient->new( $host, $port, databaseName => $db, user => $username )
+
+sub new {
+ my $class = shift();
+ my @args = @_;
+
+ if ($class ne __PACKAGE__) { # NOT called OO-ishly
+ # put the first param back if called like OpenILS::Utils::ZClient::new()
+ unshift @args, $class;
+ }
+
+ return bless { connection => $conn_class->new(@_) } => __PACKAGE__;
+}
+
+sub search {
+ my $self = shift;
+ my $r = $imp_class eq 'Net::Z3950' ?
+ $self->{connection}->search( @_ ) :
+ $self->{connection}->search_pqf( @_ );
+
+ return OpenILS::Utils::ZClient::ResultSet->new( $r );
+}
+
+sub event {
+ my $list = shift;
+ if ($imp_class eq 'Net::Z3950') {
+ if (defined $$list[0]{_async_index}) {
+ return 0 if ($$list[0]{_async_index} == @$list);
+ return ++$$list[0]{_async_index};
+ } else {
+ return $$list[0]{_async_index} = 1;
+ }
+ }
+
+ return ZOOM::event([map { ($_->{connection}) } @$list]);
+}
+
+*{__PACKAGE__ . '::search_pqf'} = \&search;
+
+sub AUTOLOAD {
+ my $self = shift;
+
+ my $method = $AUTOLOAD;
+ $method =~ s/.*://; # strip fully-qualified portion
+
+ return $self->{connection}->$method( @_ );
+}
+
+#-------------------------------------------------------------------------------
+package OpenILS::Utils::ZClient::ResultSet;
+
+sub DESTROY {};
+our $AUTOLOAD;
+
+sub new {
+ my $class = shift;
+ my @args = @_;
+
+ if ($class ne __PACKAGE__) { # NOT called OO-ishly
+ # put the first param back if called like OpenILS::Utils::ZClient::ResultSet::new()
+ unshift @args, $class;
+ }
+
+
+ return bless { result => $args[0] } => __PACKAGE__;
+}
+
+sub record {
+ my $self = shift;
+ my $offset = shift;
+ my $r = $imp_class eq 'Net::Z3950' ?
+ $self->{result}->record( ++$offset ) :
+ $self->{result}->record( $offset );
+
+ return OpenILS::Utils::ZClient::Record->new( $r );
+}
+
+sub last_event {
+ my $self = shift;
+ return OpenILS::Utils::ZClient::EVENT_END() if ($imp_class eq 'Net::Z3950');
+ $self->{result}->last_event();
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+
+ my $method = $AUTOLOAD;
+ $method =~ s/.*://; # strip fully-qualified portion
+
+ return $self->{result}->$method( @_ );
+}
+
+#-------------------------------------------------------------------------------
+package OpenILS::Utils::ZClient::Record;
+
+sub DESTROY {};
+our $AUTOLOAD;
+
+sub new {
+ my $class = shift;
+ my @args = @_;
+
+ if ($class ne __PACKAGE__) { # NOT called OO-ishly
+ # put the first param back if called like OpenILS::Utils::ZClient::ResultSet::new()
+ unshift @args, $class;
+ }
+
+
+ return bless { record => shift() } => __PACKAGE__;
+}
+
+sub rawdata {
+ my $self = shift;
+ return $OpenILS::Utils::ZClient::imp_class eq 'Net::Z3950' ?
+ $self->{record}->rawdata( @_ ) :
+ $self->{record}->raw( @_ );
+}
+
+*{__PACKAGE__ . '::raw'} = \&rawdata;
+
+sub AUTOLOAD {
+ my $self = shift;
+
+ my $method = $AUTOLOAD;
+ $method =~ s/.*://; # strip fully-qualified portion
+
+ return $self->{record}->$method( @_ );
+}
+
+1;
+
--- /dev/null
+package OpenILS::WWW::AddedContent;
+use strict; use warnings;
+
+use lib qw(/usr/lib/perl5/Bundle/);
+
+use CGI;
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use Data::Dumper;
+use UNIVERSAL::require;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Cache;
+use OpenSRF::System;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use LWP::UserAgent;
+use MIME::Base64;
+
+my $AC = __PACKAGE__;
+
+
+# set the bootstrap config when this module is loaded
+my $bs_config;
+
+sub import {
+ my $self = shift;
+ $bs_config = shift;
+}
+
+
+my $handler; # added content handler class handle
+my $cache; # memcache handle
+my $net_timeout; # max seconds to wait for a response from the added content vendor
+my $max_errors; # max consecutive lookup failures before added content is temporarily disabled
+my $error_countdown; # current consecutive errors countdown
+
+# number of seconds to wait before next lookup
+# is attempted after lookups have been disabled
+my $error_retry_timeout;
+
+
+sub child_init {
+
+ OpenSRF::System->bootstrap_client( config_file => $bs_config );
+ $cache = OpenSRF::Utils::Cache->new;
+
+ my $sclient = OpenSRF::Utils::SettingsClient->new();
+ my $ac_data = $sclient->config_value("added_content");
+
+ return unless $ac_data;
+ my $ac_handler = $ac_data->{module};
+ return unless $ac_handler;
+
+ $net_timeout = $ac_data->{timeout} || 1;
+ $error_countdown = $max_errors = $ac_data->{max_errors} || 10;
+ $error_retry_timeout = $ac_data->{retry_timeout} || 600;
+
+ $logger->debug("Attempting to load Added Content handler: $ac_handler");
+
+ $ac_handler->use;
+
+ if($@) {
+ $logger->error("Unable to load Added Content handler [$ac_handler]: $@");
+ return;
+ }
+
+ $handler = $ac_handler->new($ac_data);
+ $logger->debug("added content loaded handler: $handler");
+}
+
+
+sub handler {
+
+ my $r = shift;
+ return Apache2::Const::DECLINED if (-e $r->filename);
+
+ my $cgi = CGI->new;
+ my $path = $r->path_info;
+ my $res;
+
+ my( undef, $type, $format, $key ) = split(/\//, $r->path_info);
+
+ child_init() unless $handler;
+
+ return Apache2::Const::NOT_FOUND unless $handler and $type and $format and $key;
+
+ my $err;
+ my $data;
+ my $method = "${type}_${format}";
+
+ return Apache2::Const::NOT_FOUND unless $handler->can($method);
+ return $res if defined($res = $AC->serve_from_cache($type, $format, $key));
+ return Apache2::Const::NOT_FOUND unless $AC->lookups_enabled;
+
+ try {
+ $data = $handler->$method($key);
+ } catch Error with {
+ $err = shift;
+ decr_error_countdown();
+ $logger->debug("added content handler failed: $method($key) => $err");
+ };
+
+ return Apache2::Const::NOT_FOUND if $err;
+
+ if(!$data) {
+ # if the AC lookup found no corresponding data, cache that information
+ $logger->debug("added content handler returned no results $method($key)") unless $data;
+ $AC->cache_result($type, $format, $key, {nocontent=>1});
+ return Apache2::Const::NOT_FOUND;
+ }
+
+ $AC->print_content($data);
+ $AC->cache_result($type, $format, $key, $data);
+
+ reset_error_countdown();
+ return Apache2::Const::OK;
+}
+
+sub print_content {
+ my($class, $data, $from_cache) = @_;
+ return Apache2::Const::NOT_FOUND if $data->{nocontent};
+
+ my $ct = $data->{content_type};
+ my $content = $data->{content};
+ print "Content-type: $ct\n\n";
+
+ if($data->{binary}) {
+ binmode STDOUT;
+ # if it hasn't been cached yet, it's still in binary form
+ print( ($from_cache) ? decode_base64($content) : $content );
+ } else {
+ print $content;
+ }
+
+
+ return Apache2::Const::OK;
+}
+
+
+
+
+# returns an HTPP::Response object
+sub get_url {
+ my( $self, $url ) = @_;
+
+ $logger->info("added content getting [timeout=$net_timeout, errors_remaining=$error_countdown] URL = $url");
+ my $agent = LWP::UserAgent->new(timeout => $net_timeout);
+
+ my $res = $agent->get($url);
+ $logger->info("added content request returned with code " . $res->code);
+ die "added content request failed: " . $res->status_line ."\n" unless $res->is_success;
+
+ return $res;
+}
+
+sub lookups_enabled {
+ if( $cache->get_cache('ac.no_lookup') ) {
+ $logger->info("added content lookup disabled");
+ return undef;
+ }
+ return 1;
+}
+
+sub disable_lookups {
+ $cache->put_cache('ac.no_lookup', 1, $error_retry_timeout);
+}
+
+sub decr_error_countdown {
+ $error_countdown--;
+ if($error_countdown < 1) {
+ $logger->warn("added content error count exhausted. Disabling lookups for $error_retry_timeout seconds");
+ $AC->disable_lookups;
+ }
+}
+
+sub reset_error_countdown {
+ $error_countdown = $max_errors;
+}
+
+sub cache_result {
+ my($class, $type, $format, $key, $data) = @_;
+ $logger->debug("caching $type/$format/$key");
+ $data->{content} = encode_base64($data->{content}) if $data->{binary};
+ return $cache->put_cache("ac.$type.$format.$key", $data);
+}
+
+sub serve_from_cache {
+ my($class, $type, $format, $key) = @_;
+ my $data = $cache->get_cache("ac.$type.$format.$key");
+ return undef unless $data;
+ $logger->debug("serving $type/$format/$key from cache");
+ return $class->print_content($data, 1);
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::WWW::AddedContent::Amazon;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils::SettingsParser;
+use OpenILS::WWW::AddedContent;
+use OpenSRF::Utils::JSON;
+use OpenSRF::EX qw/:try/;
+use XML::LibXML;
+
+my $AC = 'OpenILS::WWW::AddedContent';
+
+sub new {
+ my( $class, $args ) = @_;
+ $class = ref $class || $class;
+ return bless($args, $class);
+}
+
+sub base_url {
+ my $self = shift;
+ return $self->{base_url};
+}
+
+sub userid {
+ my $self = shift;
+ return $self->{userid};
+}
+
+
+# --------------------------------------------------------------------------
+sub jacket_small {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_response('_SCMZZZZZZZ_.jpg', $key));
+}
+
+sub jacket_medium {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_response('_SCMZZZZZZZ_.jpg', $key));
+
+}
+sub jacket_large {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_response('_SCZZZZZZZ_.jpg', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub send_img {
+ my($self, $response) = @_;
+ return {
+ content_type => $response->header('Content-type'),
+ content => $response->content,
+ binary => 1
+ };
+}
+
+# returns the raw content returned from the URL fetch
+sub fetch_content {
+ my( $self, $page, $key ) = @_;
+ return $self->fetch_response($page, $key)->content;
+}
+
+# returns the HTTP response object from the URL fetch
+sub fetch_response {
+ my( $self, $page, $key ) = @_;
+ my $uname = $self->userid;
+ my $url = $self->base_url . "$key.01.$page";
+ return $AC->get_url($url);
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::WWW::AddedContent::ContentCafe;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::JSON;
+use OpenSRF::EX qw/:try/;
+use OpenILS::WWW::AddedContent;
+use XML::LibXML;
+use MIME::Base64;
+
+my $AC = 'OpenILS::WWW::AddedContent';
+
+my $base_url = 'http://contentcafe2.btol.com/ContentCafe/ContentCafe.asmx/Single';
+my $cover_base_url = 'http://contentcafe2.btol.com/ContentCafe/Jacket.aspx';
+
+sub new {
+ my( $class, $args ) = @_;
+ $class = ref $class || $class;
+ return bless($args, $class);
+}
+
+sub userid {
+ my $self = shift;
+ return $self->{ContentCafe}->{userid};
+}
+
+sub password {
+ my $self = shift;
+ return $self->{ContentCafe}->{password};
+}
+
+sub return_behavior_on_no_jacket_image {
+ my $self = shift;
+ return $self->{ContentCafe}->{return_behavior_on_no_jacket_image};
+}
+
+# --------------------------------------------------------------------------
+sub jacket_small {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_cover_response('S', $key));
+}
+
+sub jacket_medium {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_cover_response('M', $key));
+
+}
+sub jacket_large {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_cover_response('L', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub toc_html {
+ my( $self, $key ) = @_;
+ my $xml = $self->fetch_content('TocDetail', $key);
+ my $doc = XML::LibXML->new->parse_string($xml);
+ $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
+ my $html = '';
+ my @nodes = $doc->findnodes('//cc:Toc');
+ return 0 if (scalar(@nodes) < 1);
+ foreach my $node ( @nodes ) {
+ $html .= $node->textContent . '</P></P>';
+ }
+ return $self->send_html($html);
+}
+
+sub toc_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('TocDetail', $key));
+}
+
+sub toc_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('TocDetail', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub anotes_html {
+ my( $self, $key ) = @_;
+ my $xml = $self->fetch_content('BiographyDetail', $key);
+ my $doc = XML::LibXML->new->parse_string($xml);
+ $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
+ my $html = '';
+ my @nodes = $doc->findnodes('//cc:Biography');
+ return 0 if (scalar(@nodes) < 1);
+ foreach my $node ( @nodes ) {
+ $html .= '<P class="biography">' . $node->textContent . '</P>';
+ }
+ return $self->send_html($html);
+}
+
+sub anotes_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('BiographyDetail', $key));
+}
+
+sub anotes_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('BiographyDetail', $key));
+}
+
+
+# --------------------------------------------------------------------------
+
+sub excerpt_html {
+ my( $self, $key ) = @_;
+ my $xml = $self->fetch_content('ExcerptDetail', $key);
+ my $doc = XML::LibXML->new->parse_string($xml);
+ $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
+ my $html = '';
+ my @nodes = $doc->findnodes('//cc:Excerpt');
+ return 0 if (scalar(@nodes) < 1);
+ foreach my $node ( @nodes ) {
+ $html .= $node->textContent;
+ }
+ return $self->send_html($html);
+}
+
+sub excerpt_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('ExcerptDetail', $key));
+}
+
+sub excerpt_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('ExcerptDetail', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub reviews_html {
+ my( $self, $key ) = @_;
+ my $xml = $self->fetch_content('ReviewDetail', $key);
+ my $doc = XML::LibXML->new->parse_string($xml);
+ $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
+ my $html = '<ul>';
+ my @nodes = $doc->findnodes('//cc:ReviewItem');
+ return 0 if (scalar(@nodes) < 1);
+ foreach my $node ( @nodes ) {
+ my @s_nodes = $node->findnodes('./cc:Supplier');
+ my @p_nodes = $node->findnodes('./cc:Publication');
+ my @i_nodes = $node->findnodes('./cc:Issue');
+ my @r_nodes = $node->findnodes('./cc:Review');
+ $html .= '<li><b>' . (scalar(@p_nodes) ? $p_nodes[0]->textContent : '') . '</b>';
+ if (scalar(@i_nodes) && scalar(@p_nodes)) { $html .= ' : '; }
+ $html .= (scalar(@i_nodes) ? $i_nodes[0]->textContent : '') . '<br/>';
+ $html .= (scalar(@r_nodes) ? $r_nodes[0]->textContent : '') . '</li>';
+ }
+ $html .= '</ul>';
+ return $self->send_html($html);
+}
+
+sub reviews_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('ReviewDetail', $key));
+}
+
+sub reviews_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('ReviewDetail', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub summary_html {
+ my( $self, $key ) = @_;
+ my $xml = $self->fetch_content('AnnotationDetail', $key);
+ my $doc = XML::LibXML->new->parse_string($xml);
+ $doc->documentElement->setNamespace('http://ContentCafe2.btol.com', 'cc');
+ my $html = '<ul>';
+ my @nodes = $doc->findnodes('//cc:AnnotationItem');
+ return 0 if (scalar(@nodes) < 1);
+ foreach my $node ( @nodes ) {
+ my @s_nodes = $node->findnodes('./cc:Supplier');
+ my @a_nodes = $node->findnodes('./cc:Annotation');
+ $html .= '<li><b>' . (scalar(@s_nodes) ? $s_nodes[0]->textContent : '') . '</b><br/>';
+ $html .= (scalar(@a_nodes) ? $a_nodes[0]->textContent : '') . '</li>';
+ }
+ $html .= '</ul>';
+ return $self->send_html($html);
+}
+
+sub summary_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('AnnotationDetail', $key));
+}
+
+sub summary_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('AnnotationDetail', $key));
+}
+
+
+# --------------------------------------------------------------------------
+
+
+sub data_exists {
+ my( $self, $data ) = @_;
+ return 0 if $data =~ m/<title>error<\/title>/iog;
+ return 1;
+}
+
+
+sub send_json {
+ my( $self, $xml ) = @_;
+ return 0 unless $self->data_exists($xml);
+ my $doc;
+
+ try {
+ $doc = XML::LibXML->new->parse_string($xml);
+ } catch Error with {
+ my $err = shift;
+ $logger->error("added content XML parser error: $err\n\n$xml");
+ $doc = undef;
+ };
+
+ return 0 unless $doc;
+ my $perl = OpenSRF::Utils::SettingsParser::XML2perl($doc->documentElement);
+ my $json = OpenSRF::Utils::JSON->perl2JSON($perl);
+ return { content_type => 'text/plain', content => $json };
+}
+
+sub send_xml {
+ my( $self, $xml ) = @_;
+ return 0 unless $self->data_exists($xml);
+ return { content_type => 'application/xml', content => $xml };
+}
+
+sub send_html {
+ my( $self, $content ) = @_;
+ return 0 unless $self->data_exists($content);
+
+ # Hide anything that might contain a link since it will be broken
+ my $HTML = <<" HTML";
+ <div>
+ <style type='text/css'>
+ div.ac input, div.ac a[href],div.ac img, div.ac button { display: none; visibility: hidden }
+ </style>
+ <div class='ac'>
+ $content
+ </div>
+ </div>
+ HTML
+
+ return { content_type => 'text/html', content => $HTML };
+}
+
+sub send_img {
+ my($self, $response) = @_;
+ return {
+ content_type => $response->header('Content-type'),
+ content => $response->content,
+ binary => 1
+ };
+}
+
+# returns the raw content returned from the URL fetch
+sub fetch_content {
+ my( $self, $contentType, $key ) = @_;
+ return $self->fetch_response($contentType, $key)->content;
+}
+
+# returns the HTTP response object from the URL fetch
+sub fetch_response {
+ my( $self, $contentType, $key ) = @_;
+ my $userid = $self->userid;
+ my $password = $self->password;
+ my $url = $base_url . "?UserID=$userid&Password=$password&Key=$key&Content=$contentType";
+ return $AC->get_url($url);
+}
+
+# returns the HTTP response object from the URL fetch
+sub fetch_cover_response {
+ my( $self, $size, $key ) = @_;
+ my $userid = $self->userid;
+ my $password = $self->password;
+ my $return = $self->return_behavior_on_no_jacket_image;
+ my $url = $cover_base_url . "?UserID=$userid&Password=$password&Return=$return&Type=$size&Value=$key";
+ return $AC->get_url($url);
+}
+
+
+1;
--- /dev/null
+# ---------------------------------------------------------------
+# Copyright (C) 2009 David Christensen <david.a.christensen@gmail.com>
+# Copyright (C) 2009 Dan Scott <dscott@laurentian.ca>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+# ---------------------------------------------------------------
+
+package OpenILS::WWW::AddedContent::OpenLibrary;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils::SettingsParser;
+use OpenILS::WWW::AddedContent;
+use OpenSRF::Utils::JSON;
+use OpenSRF::EX qw/:try/;
+use Data::Dumper;
+
+# Edit the <added_content> section of /openils/conf/opensrf.xml
+# Change <module> to:
+# <module>OpenILS::WWW::AddedContent::OpenLibrary</module>
+
+my $AC = 'OpenILS::WWW::AddedContent';
+
+# These URLs are always the same for OpenLibrary, so there's no advantage to
+# pulling from opensrf.xml; we hardcode them here
+my $base_url = 'http://openlibrary.org/api/books?details=true&bibkeys=ISBN:';
+my $cover_base_url = 'http://covers.openlibrary.org/b/isbn/';
+
+sub new {
+ my( $class, $args ) = @_;
+ $class = ref $class || $class;
+ return bless($args, $class);
+}
+
+# --------------------------------------------------------------------------
+sub jacket_small {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_cover_response('-S.jpg', $key));
+}
+
+sub jacket_medium {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_cover_response('-M.jpg', $key));
+
+}
+sub jacket_large {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_cover_response('-L.jpg', $key));
+}
+
+# --------------------------------------------------------------------------
+
+=head1
+
+OpenLibrary returns a JSON hash of zero or more book responses matching our
+request. Each response may contain a table of contents within the details
+section of the response.
+
+For now, we check only the first response in the hash for a table of
+contents, and if we find a table of contents, we transform it to a simple
+HTML table.
+
+=cut
+
+sub toc_html {
+ my( $self, $key ) = @_;
+ my $book_details_json = $self->fetch_response($key)->content();
+
+
+ # Trim the "var _OlBookInfo = " declaration that makes this
+ # invalid JSON
+ $book_details_json =~ s/^.+?({.*?});$/$1/s;
+
+ $logger->debug("$key: " . $book_details_json);
+
+ my $toc_html;
+
+ my $book_details = OpenSRF::Utils::JSON->JSON2perl($book_details_json);
+ my $book_key = (keys %$book_details)[0];
+
+ # We didn't find a matching book; short-circuit our response
+ if (!$book_key) {
+ $logger->debug("$key: no found book");
+ return 0;
+ }
+
+ my $toc_json = $book_details->{$book_key}->{details}->{table_of_contents};
+
+ # No table of contents is available for this book; short-circuit
+ if (!$toc_json or !scalar(@$toc_json)) {
+ $logger->debug("$key: no TOC");
+ return 0;
+ }
+
+ # Build a basic HTML table containing the section number, section title,
+ # and page number. Some rows may not contain section numbers, we should
+ # protect against empty page numbers too.
+ foreach my $chapter (@$toc_json) {
+ my $label = $chapter->{label};
+ if ($label) {
+ $label .= '. ';
+ }
+ my $title = $chapter->{title} || '';
+ my $page_number = $chapter->{pagenum} || '';
+
+ $toc_html .= '<tr>' .
+ "<td style='text-align: right;'>$label</td>" .
+ "<td style='text-align: left; padding-right: 2em;'>$title</td>" .
+ "<td style='text-align: right;'>$page_number</td>" .
+ "</tr>\n";
+ }
+
+ $logger->debug("$key: $toc_html");
+ $self->send_html("<table>$toc_html</table>");
+}
+
+sub toc_json {
+ my( $self, $key ) = @_;
+ my $toc = $self->send_json(
+ $self->fetch_response($key)
+ );
+}
+
+sub send_img {
+ my($self, $response) = @_;
+ return {
+ content_type => $response->header('Content-type'),
+ content => $response->content,
+ binary => 1
+ };
+}
+
+sub send_json {
+ my( $self, $content ) = @_;
+ return 0 unless $content;
+
+ return { content_type => 'text/plain', content => $content };
+}
+
+sub send_html {
+ my( $self, $content ) = @_;
+ return 0 unless $content;
+
+ # Hide anything that might contain a link since it will be broken
+ my $HTML = <<" HTML";
+ <div>
+ <style type='text/css'>
+ div.ac input, div.ac a[href],div.ac img, div.ac button { display: none; visibility: hidden }
+ </style>
+ <div class='ac'>
+ $content
+ </div>
+ </div>
+ HTML
+
+ return { content_type => 'text/html', content => $HTML };
+}
+
+# returns the HTTP response object from the URL fetch
+sub fetch_response {
+ my( $self, $key ) = @_;
+ my $url = $base_url . "$key";
+ my $response = $AC->get_url($url);
+ return $response;
+}
+
+# returns the HTTP response object from the URL fetch
+sub fetch_cover_response {
+ my( $self, $size, $key ) = @_;
+ my $url = $cover_base_url . "$key$size";
+ return $AC->get_url($url);
+}
+
+
+1;
--- /dev/null
+package OpenILS::WWW::AddedContent::Syndetic;
+use strict; use warnings;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils::SettingsParser;
+use OpenSRF::Utils::JSON;
+use OpenSRF::EX qw/:try/;
+use OpenILS::WWW::AddedContent;
+use XML::LibXML;
+use MIME::Base64;
+
+my $AC = 'OpenILS::WWW::AddedContent';
+
+
+sub new {
+ my( $class, $args ) = @_;
+ $class = ref $class || $class;
+ return bless($args, $class);
+}
+
+sub base_url {
+ my $self = shift;
+ return $self->{base_url};
+}
+
+sub userid {
+ my $self = shift;
+ return $self->{userid};
+}
+
+
+# --------------------------------------------------------------------------
+sub jacket_small {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_response('sc.gif', $key, 1));
+}
+
+sub jacket_medium {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_response('mc.gif', $key, 1));
+
+}
+sub jacket_large {
+ my( $self, $key ) = @_;
+ return $self->send_img(
+ $self->fetch_response('lc.gif', $key, 1));
+}
+
+# --------------------------------------------------------------------------
+
+sub toc_html {
+ my( $self, $key ) = @_;
+ return $self->send_html(
+ $self->fetch_content('toc.html', $key));
+}
+
+sub toc_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('toc.xml', $key));
+}
+
+sub toc_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('toc.xml', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub anotes_html {
+ my( $self, $key ) = @_;
+ return $self->send_html(
+ $self->fetch_content('anotes.html', $key));
+}
+
+sub anotes_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('anotes.xml', $key));
+}
+
+sub anotes_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('anotes.xml', $key));
+}
+
+
+# --------------------------------------------------------------------------
+
+sub excerpt_html {
+ my( $self, $key ) = @_;
+ return $self->send_html(
+ $self->fetch_content('dbchapter.html', $key));
+}
+
+sub excerpt_xml {
+ my( $self, $key ) = @_;
+ return $self->send_xml(
+ $self->fetch_content('dbchapter.xml', $key));
+}
+
+sub excerpt_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('dbchapter.xml', $key));
+}
+
+# --------------------------------------------------------------------------
+
+sub reviews_html {
+ my( $self, $key ) = @_;
+
+ my %reviews;
+
+ $reviews{ljreview} = $self->fetch_content('ljreview.html', $key);
+ $reviews{pwreview} = $self->fetch_content('pwreview.html', $key);
+ $reviews{slreview} = $self->fetch_content('slreview.html', $key);
+ $reviews{chreview} = $self->fetch_content('chreview.html', $key);
+ $reviews{blreview} = $self->fetch_content('blreview.html', $key);
+ $reviews{hbreview} = $self->fetch_content('hbreview.html', $key);
+ $reviews{kirkreview} = $self->fetch_content('kirkreview.html', $key);
+
+ for(keys %reviews) {
+ if( ! $self->data_exists($reviews{$_}) ) {
+ delete $reviews{$_};
+ next;
+ }
+ $reviews{$_} =~ s/<!.*?>//og; # Strip any doctype declarations
+ }
+
+ return 0 if scalar(keys %reviews) == 0;
+
+ #my $html = "<div>";
+ my $html;
+ $html .= $reviews{$_} for keys %reviews;
+ #$html .= "</div>";
+
+ return $self->send_html($html);
+}
+
+# we have to aggregate the reviews
+sub reviews_xml {
+ my( $self, $key ) = @_;
+ my %reviews;
+
+ $reviews{ljreview} = $self->fetch_content('ljreview.xml', $key);
+ $reviews{pwreview} = $self->fetch_content('pwreview.xml', $key);
+ $reviews{slreview} = $self->fetch_content('slreview.xml', $key);
+ $reviews{chreview} = $self->fetch_content('chreview.xml', $key);
+ $reviews{blreview} = $self->fetch_content('blreview.xml', $key);
+ $reviews{hbreview} = $self->fetch_content('hbreview.xml', $key);
+ $reviews{kirkreview} = $self->fetch_content('kirkreview.xml', $key);
+
+ for(keys %reviews) {
+ if( ! $self->data_exists($reviews{$_}) ) {
+ delete $reviews{$_};
+ next;
+ }
+ # Strip the xml and doctype declarations
+ $reviews{$_} =~ s/<\?xml.*?>//og;
+ $reviews{$_} =~ s/<!.*?>//og;
+ }
+
+ return 0 if scalar(keys %reviews) == 0;
+
+ my $xml = "<reviews>";
+ $xml .= $reviews{$_} for keys %reviews;
+ $xml .= "</reviews>";
+
+ return $self->send_xml($xml);
+}
+
+
+sub reviews_json {
+ my( $self, $key ) = @_;
+ return $self->send_json(
+ $self->fetch_content('dbchapter.xml', $key));
+}
+
+# --------------------------------------------------------------------------
+
+
+sub data_exists {
+ my( $self, $data ) = @_;
+ return 0 if $data =~ m/<title>error<\/title>/iog;
+ return 1;
+}
+
+
+sub send_json {
+ my( $self, $xml ) = @_;
+ return 0 unless $self->data_exists($xml);
+ my $doc;
+
+ try {
+ $doc = XML::LibXML->new->parse_string($xml);
+ } catch Error with {
+ my $err = shift;
+ $logger->error("added content XML parser error: $err\n\n$xml");
+ $doc = undef;
+ };
+
+ return 0 unless $doc;
+ my $perl = OpenSRF::Utils::SettingsParser::XML2perl($doc->documentElement);
+ my $json = OpenSRF::Utils::JSON->perl2JSON($perl);
+ return { content_type => 'text/plain', content => $json };
+}
+
+sub send_xml {
+ my( $self, $xml ) = @_;
+ return 0 unless $self->data_exists($xml);
+ return { content_type => 'application/xml', content => $xml };
+}
+
+sub send_html {
+ my( $self, $content ) = @_;
+ return 0 unless $self->data_exists($content);
+
+ # Hide anything that might contain a link since it will be broken
+ my $HTML = <<" HTML";
+ <div>
+ <style type='text/css'>
+ div.ac input, div.ac a[href],div.ac img, div.ac button { display: none; visibility: hidden }
+ </style>
+ <div class='ac'>
+ $content
+ </div>
+ </div>
+ HTML
+
+ return { content_type => 'text/html', content => $HTML };
+}
+
+sub send_img {
+ my($self, $response) = @_;
+ return {
+ content_type => $response->header('Content-type'),
+ content => $response->content,
+ binary => 1
+ };
+}
+
+# returns the raw content returned from the URL fetch
+sub fetch_content {
+ my( $self, $page, $key ) = @_;
+ return $self->fetch_response($page, $key)->content;
+}
+
+# returns the HTTP response object from the URL fetch
+sub fetch_response {
+ my( $self, $page, $key, $notype ) = @_;
+ my $uname = $self->userid;
+ my $url = $self->base_url . "?isbn=$key/$page&client=$uname" . (($notype) ? '' : "&type=rw12");
+ return $AC->get_url($url);
+}
+
+
+
+1;
--- /dev/null
+package OpenILS::WWW::BadDebt;
+use strict;
+use warnings;
+use bytes;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use APR::Table;
+
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use XML::LibXML;
+use XML::LibXSLT;
+
+use Encode;
+use Unicode::Normalize;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use UNIVERSAL::require;
+
+# set the bootstrap config when this module is loaded
+my $bootstrap;
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+}
+
+sub handler {
+ my $r = shift;
+ my $cgi = new CGI;
+ my $auth_ses = $cgi->cookie('ses') || $cgi->param('ses');
+
+ # find some IDs ...
+ my @xacts;
+
+ my $user = verify_login($auth_ses);
+ return 403 unless $user;
+
+ my $mark_bad = $cgi->param('action') eq 'unmark' ? 'f' : 't';
+ my $format = $cgi->param('format') || 'csv';
+
+ my $file = $cgi->param('idfile');
+ if ($file) {
+ my $col = $cgi->param('idcolumn') || 0;
+ my $csv = new Text::CSV;
+
+ while (<$file>) {
+ $csv->parse($_);
+ my @data = $csv->fields;
+ my $id = $data[$col];
+ $id =~ s/\D+//o;
+ next unless ($id);
+ push @xacts, $id;
+ }
+ }
+
+ if (!@xacts) { # try pathinfo
+ my $path_rec = $cgi->path_info();
+ if ($path_rec) {
+ @xacts = map { $_ ? ($_) : () } split '/', $path_rec;
+ }
+ }
+
+ return 404 unless @xacts;
+
+ my @lines;
+
+ my ($yr,$mon,$day) = (localtime())[5,4,3]; $yr += 1900;
+ my $date = sprintf('%d-%02d-%02d',$yr,$mon,$day);
+
+ my @header = ( '"Transaction ID"', '"Message"', '"Amount Owed"', '"Transaction Start Date"', '"User Barcode"' );
+
+ my $cstore = OpenSRF::AppSession->create('open-ils.cstore');
+ my $actor = OpenSRF::AppSession->create('open-ils.actor');
+
+ $cstore->connect();
+ $cstore->request('open-ils.cstore.transaction.begin')->gather(1);
+
+ for my $xact ( @xacts ) {
+ try {
+
+ my $x = $cstore->request('open-ils.cstore.direct.money.billable_xact.retrieve' => $xact)->gather(1);
+ my $s = $cstore->request('open-ils.cstore.direct.money.billable_xact_summary.retrieve' => $xact)->gather(1);
+ my $u = $cstore->request('open-ils.cstore.direct.actor.usr.retrieve' => $s->usr)->gather(1);
+ my $c = $cstore->request('open-ils.cstore.direct.actor.card.retrieve' => $u->card)->gather(1);
+ my $w;
+
+ if ($s->xact_type eq 'circulation') {
+ $w = $cstore->request('open-ils.cstore.direct.action.circulation.retrieve' => $xact)->gather(1)->circ_lib :
+ } elsif ($s->xact_type eq 'grocery') {
+ $w = $cstore->request('open-ils.cstore.direct.money.grocery.retrieve' => $xact)->gather(1)->billing_location;
+ } elsif ($s->xact_type eq 'reservation') {
+ $w = $cstore->request('open-ils.cstore.direct.booking.reservation.retrieve' => $xact)->gather(1)->pickup_lib;
+ } else {
+ die;
+ }
+
+ my $failures = $actor->request('open-ils.actor.user.perm.check', $auth_ses, $user->id, $w, ['MARK_BAD_DEBT'])->gather(1);
+
+ if (@$failures) {
+ push @lines, [ $xact, '"Permission Failure"', '""', '""', '""' ];
+ } else {
+ $x->unrecovered($mark_bad);
+ my $result = $cstore->request('open-ils.cstore.direct.money.billable_xact.update' => $x)->gather(1);
+ if ($result != $x->id) {
+ push @lines, [ $xact, '"Update Failure"', '""', '""', '""' ];
+ } else {
+ my $amount = $s->balance_owed;
+ my $start = $s->xact_start;
+ my $barcode = $c->barcode;
+
+ if ( $mark_bad eq 't' ) {
+ push @lines, [ $xact, '"Marked Bad Debt"', $amount, "\"$start\"", "\"$barcode\"" ];
+ } else {
+ push @lines, [ $xact, '"Unmarked Bad Debt"', $amount, "\"$start\"", "\"$barcode\"" ];
+ }
+ }
+ }
+ } otherwise {
+ push @lines, [ $xact, '"Update Failure"', '""', '""', '""' ];
+ };
+ }
+
+ $cstore->request('open-ils.cstore.transaction.commit')->gather(1);
+ $cstore->disconnect();
+
+ if ($format eq 'csv') {
+ $r->headers_out->set("Content-Disposition" => "inline; filename=bad_debt_$date.csv");
+ $r->content_type('application/octet-stream');
+
+ $r->print( join(',', @header) . "\n" );
+ $r->print( join(',', @$_ ) . "\n" ) for (@lines);
+
+ } elsif ($format eq 'json') {
+
+ $r->content_type('application/json');
+
+ $r->print( '[' );
+
+ my $first = 1;
+ for my $line ( @lines ) {
+ $r->print( ',' ) if $first;
+ $first = 0;
+
+ $r->print( '{' );
+ for my $field ( 0 .. 4 ) {
+ $r->print( "$header[$field] : $$line[$field]" );
+ $r->print( ',' ) if ($field < 4);
+ }
+ $r->print( '}' );
+ }
+
+ $r->print( ']' );
+ }
+
+ return Apache2::Const::OK;
+
+}
+
+sub verify_login {
+ my $auth_token = shift;
+ return undef unless $auth_token;
+
+ my $user = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( "open-ils.auth.session.retrieve", $auth_token )
+ ->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return undef;
+ }
+
+ return $user if ref($user);
+ return undef;
+}
+
+sub show_template {
+ my $r = shift;
+
+ $r->content_type('text/html');
+ $r->print(<<HTML);
+
+<html>
+ <head>
+ <title>Record Export</title>
+ </head>
+ <body>
+ <form method="POST" enctype="multipart/form-data">
+ Use field number <input type="text" size="2" maxlength="2" name="idcolumn" value="0"/> (starting from 0)
+ from CSV file <input type="file" name="idfile"/>
+ <input type="submit" value="Mark Transactions Unrecoverable"/>
+ </form>
+ </body>
+</html>
+
+HTML
+
+ return Apache2::Const::OK;
+}
+
+1;
--- /dev/null
+package OpenILS::WWW::EGWeb;
+use strict; use warnings;
+use Template;
+use XML::Simple;
+use XML::LibXML;
+use File::stat;
+use Apache2::Const -compile => qw(OK DECLINED HTTP_INTERNAL_SERVER_ERROR);
+use Apache2::Log;
+use OpenSRF::EX qw(:try);
+
+use constant OILS_HTTP_COOKIE_SKIN => 'oils:skin';
+use constant OILS_HTTP_COOKIE_THEME => 'oils:theme';
+use constant OILS_HTTP_COOKIE_LOCALE => 'oils:locale';
+
+my $web_config;
+my $web_config_file;
+my $web_config_edit_time;
+
+sub import {
+ my $self = shift;
+ $web_config_file = shift;
+ unless(-r $web_config_file) {
+ warn "Invalid web config $web_config_file";
+ return;
+ }
+ check_web_config();
+}
+
+
+sub handler {
+ my $r = shift;
+ check_web_config($r); # option to disable this
+ my $ctx = load_context($r);
+ my $base = $ctx->{base_path};
+ my($template, $page_args, $as_xml) = find_template($r, $base, $ctx);
+ return Apache2::Const::DECLINED unless $template;
+
+ $template = $ctx->{skin} . "/$template";
+ $ctx->{page_args} = $page_args;
+ $r->content_type('text/html; encoding=utf8');
+
+ my $tt = Template->new({
+ OUTPUT => ($as_xml) ? sub { parse_as_xml($r, $ctx, @_); } : $r,
+ INCLUDE_PATH => $ctx->{template_paths},
+ });
+
+ unless($tt->process($template, {ctx => $ctx})) {
+ $r->log->warn('Template error: ' . $tt->error);
+ return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
+ }
+
+ return Apache2::Const::OK;
+}
+
+sub parse_as_xml {
+ my $r = shift;
+ my $ctx = shift;
+ my $data = shift;
+
+ my $success = 0;
+
+ try {
+ my $doc = XML::LibXML->new->parse_string($data);
+ $data = $doc->documentElement->toStringC14N;
+ $data = $ctx->{final_dtd} . "\n" . $data;
+ $success = 1;
+ } otherwise {
+ my $e = shift;
+ my $err = "Invalid XML: $e";
+ $r->log->error($err);
+ $r->content_type('text/plain; encoding=utf8');
+ $r->print("\n$err\n\n$data");
+ };
+
+ $r->print($data) if ($success);
+}
+
+
+sub load_context {
+ my $r = shift;
+ my $cgi = CGI->new;
+ my $ctx = $web_config->{ctx};
+ $ctx->{hostname} = $r->hostname;
+ $ctx->{base_url} = $cgi->url(-base => 1);
+ $ctx->{skin} = $cgi->cookie(OILS_HTTP_COOKIE_SKIN) || 'default';
+ $ctx->{theme} = $cgi->cookie(OILS_HTTP_COOKIE_THEME) || 'default';
+ $ctx->{locale} =
+ $cgi->cookie(OILS_HTTP_COOKIE_LOCALE) ||
+ parse_accept_lang($r->headers_in->get('Accept-Language')) || 'en-US';
+ $r->log->debug('skin = ' . $ctx->{skin} . ' : theme = ' .
+ $ctx->{theme} . ' : locale = ' . $ctx->{locale});
+ return $ctx;
+}
+
+# turn Accept-Language into sometihng EG can understand
+sub parse_accept_lang {
+ my $al = shift;
+ return undef unless $al;
+ my ($locale) = split(/,/, $al);
+ ($locale) = split(/;/, $locale);
+ return undef unless $locale;
+ $locale =~ s/-(.*)/eval '-'.uc("$1")/e;
+ return $locale;
+}
+
+# Given a URI, finds the configured template and any extra page
+# arguments (trailing path info). Any extra data is returned
+# as page arguments, in the form of an array, one item per
+# /-separated URI component
+sub find_template {
+ my $r = shift;
+ my $base = shift;
+ my $ctx = shift;
+ my $skin = $ctx->{skin};
+ my $path = $r->uri;
+ $path =~ s/$base//og;
+ my @parts = split('/', $path);
+ my $template = '';
+ my $page_args = [];
+ my $as_xml = $ctx->{force_valid_xml};
+ my $handler = $web_config->{handlers};
+
+ while(@parts) {
+ my $part = shift @parts;
+ next unless $part;
+ my $t = $handler->{$part};
+ if(ref($t) eq 'PathConfig') {
+ $template = $t->{template};
+ $as_xml = ($t->{as_xml} and $t->{as_xml} =~ /true/io) || $as_xml;
+ $page_args = [@parts];
+ last;
+ } else {
+ $handler = $t;
+ }
+ }
+
+ unless($template) { # no template configured
+
+ # see if we can magically find the template based on the path and default extension
+ my $ext = $ctx->{default_template_extension};
+
+ my @parts = split('/', $path);
+ my $localpath = $path;
+ my @args;
+ while(@parts) {
+ last unless $localpath;
+ for my $tpath (@{$ctx->{template_paths}}) {
+ my $fpath = "$tpath/$skin/$localpath.$ext";
+ $r->log->debug("looking at possible template $fpath");
+ if(-r $fpath) {
+ $template = "$localpath.$ext";
+ last;
+ }
+ }
+ last if $template;
+ push(@args, pop @parts);
+ $localpath = '/'.join('/', @parts);
+ }
+
+ $page_args = [@args];
+
+ # no template configured or found
+ unless($template) {
+ $r->log->warn("No template configured for path $path");
+ return ();
+ }
+ }
+
+ $r->log->debug("template = $template : page args = @$page_args");
+ return ($template, $page_args, $as_xml);
+}
+
+# if the web configuration file has never been loaded or has
+# changed since the last load, reload it
+sub check_web_config {
+ my $r = shift;
+ my $epoch = stat($web_config_file)->mtime;
+ unless($web_config_edit_time and $web_config_edit_time == $epoch) {
+ $r->log->debug("Reloading web config after edit...") if $r;
+ $web_config_edit_time = $epoch;
+ $web_config = parse_config($web_config_file);
+ }
+}
+
+sub parse_config {
+ my $cfg_file = shift;
+ my $data = XML::Simple->new->XMLin($cfg_file);
+ my $ctx = {};
+ my $handlers = {};
+
+ $ctx->{media_prefix} = (ref $data->{media_prefix}) ? '' : $data->{media_prefix};
+ $ctx->{base_path} = (ref $data->{base_path}) ? '' : $data->{base_path};
+ $ctx->{template_paths} = [];
+ $ctx->{force_valid_xml} = ($data->{force_valid_xml} =~ /true/io) ? 1 : 0;
+ $ctx->{default_template_extension} = $data->{default_template_extension} || 'tt2';
+ $ctx->{web_dir} = $data->{web_dir};
+
+ my $tpaths = $data->{template_paths}->{path};
+ $tpaths = [$tpaths] unless ref $tpaths;
+ push(@{$ctx->{template_paths}}, $_) for @$tpaths;
+
+ for my $handler (@{$data->{handlers}->{handler}}) {
+ my @parts = split('/', $handler->{path});
+ my $h = $handlers;
+ my $pcount = scalar(@parts);
+ for(my $i = 0; $i < $pcount; $i++) {
+ my $p = $parts[$i];
+ unless(defined $h->{$p}) {
+ if($i == $pcount - 1) {
+ $h->{$p} = PathConfig->new(%$handler);
+ last;
+ } else {
+ $h->{$p} = {};
+ }
+ }
+ $h = $h->{$p};
+ }
+ }
+
+ return {ctx => $ctx, handlers => $handlers};
+}
+
+package PathConfig;
+sub new {
+ my($class, %args) = @_;
+ return bless(\%args, $class);
+}
+
+
+1;
--- /dev/null
+package OpenILS::WWW::Exporter;
+use strict;
+use warnings;
+use bytes;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use APR::Table;
+
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+use Data::Dumper;
+use Text::CSV;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Cache;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use XML::LibXML;
+use XML::LibXSLT;
+
+use Encode;
+use Unicode::Normalize;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use MARC::Record;
+use MARC::File::XML;
+
+use UNIVERSAL::require;
+
+our @formats = qw/USMARC UNIMARC XML BRE/;
+
+# set the bootstrap config and template include directory when
+# this module is loaded
+my $bootstrap;
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+}
+
+sub handler {
+ my $r = shift;
+ my $cgi = new CGI;
+
+ # find some IDs ...
+ my @records;
+
+ @records = map { $_ ? ($_) : () } $cgi->param('id');
+
+ if (!@records) { # try for a file
+ my $file = $cgi->param('idfile');
+ if ($file) {
+ my $col = $cgi->param('idcolumn') || 0;
+ my $csv = new Text::CSV;
+
+ while (<$file>) {
+ $csv->parse($_);
+ my @data = $csv->fields;
+ my $id = $data[$col];
+ $id =~ s/\D+//o;
+ next unless ($id);
+ push @records, $id;
+ }
+ }
+ }
+
+ if (!@records) { # try pathinfo
+ my $path_rec = $cgi->path_info();
+ if ($path_rec) {
+ @records = map { $_ ? ($_) : () } split '/', $path_rec;
+ }
+ }
+
+ my $ses = OpenSRF::AppSession->create('open-ils.cstore');
+
+ # still no records ...
+ my $container = $cgi->param('containerid');
+ if ($container) {
+ my $bucket = $ses->request( 'open-ils.cstore.direct.container.biblio_record_entry_bucket.retrieve', $container )->gather(1);
+ unless($bucket) {
+ $r->log->error("No such bucket $container");
+ $logger->error("No such bucket $container");
+ return Apache2::Const::NOT_FOUND;
+ }
+ if ($bucket->pub !~ /t|1/oi) {
+ my $authid = $cgi->cookie('ses') || $cgi->param('ses');
+ my $auth = verify_login($authid);
+ if (!$auth) {
+ return 403;
+ }
+ }
+ my $recs = $ses->request( 'open-ils.cstore.direct.container.biblio_record_entry_bucket_item.search.atomic', { bucket => $container } )->gather(1);
+ @records = map { ($_->target_biblio_record_entry) } @$recs;
+ }
+
+ return show_template($r) unless (@records);
+
+ my $type = $cgi->param('rectype') || 'biblio';
+ if ($type ne 'biblio' && $type ne 'authority') {
+ return 400;
+ }
+
+ my $tcn_v = 'tcn_value';
+ my $tcn_s = 'tcn_source';
+
+ my $holdings = $cgi->param('holdings') if ($type eq 'biblio');
+ my $location = $cgi->param('location') || 'gaaagpl'; # just because...
+
+ my $format = $cgi->param('format') || 'USMARC';
+ $format = uc($format);
+
+ my $encoding = $cgi->param('encoding') || 'UTF-8';
+ $encoding = uc($encoding);
+
+ my $filename = $cgi->param('filename') || "export.$type.$encoding.$format";
+
+ binmode(STDOUT, ':raw') if ($encoding ne 'UTF-8');
+ binmode(STDOUT, ':utf8') if ($encoding eq 'UTF-8');
+
+ if (!grep { uc($format) eq $_ } @formats) {
+ return 400;
+ }
+
+ if ($format ne 'XML') {
+ my $ftype = 'MARC::File::' . $format;
+ $ftype->require;
+ }
+
+
+ $r->headers_out->set("Content-Disposition" => "inline; filename=$filename");
+
+ if (uc($format) eq 'XML') {
+ $r->content_type('application/xml');
+ } else {
+ $r->content_type('application/octet-stream');
+ }
+
+ $r->print( <<" HEADER" ) if (uc($format) eq 'XML');
+<?xml version="1.0" encoding="$encoding"?>
+<collection xmlns='http://www.loc.gov/MARC21/slim'>
+ HEADER
+
+ my %orgs;
+ my %shelves;
+ my %statuses;
+
+ my $flesh = {};
+ if ($holdings) {
+
+ my $req = $ses->request( 'open-ils.cstore.direct.actor.org_unit.search', { id => { '!=' => undef } } );
+
+ while (my $o = $req->recv) {
+ next if ($req->failed);
+ $o = $o->content;
+ last unless ($o);
+ $orgs{$o->id} = $o;
+ }
+ $req->finish;
+
+ $req = $ses->request( 'open-ils.cstore.direct.asset.copy_location.search', { id => { '!=' => undef } } );
+
+ while (my $s = $req->recv) {
+ next if ($req->failed);
+ $s = $s->content;
+ last unless ($s);
+ $shelves{$s->id} = $s;
+ }
+ $req->finish;
+
+ $req = $ses->request( 'open-ils.cstore.direct.config.copy_status.search', { id => { '!=' => undef } } );
+
+ while (my $s = $req->recv) {
+ next if ($req->failed);
+ $s = $s->content;
+ last unless ($s);
+ $statuses{$s->id} = $s;
+ }
+ $req->finish;
+
+ $flesh = { flesh => 2, flesh_fields => { bre => [ 'call_numbers' ], acn => [ 'copies' ] } };
+ }
+
+ for my $i ( @records ) {
+ my $bib;
+ try {
+ local $SIG{ALRM} = sub { die "TIMEOUT\n" };
+ alarm(1);
+ $bib = $ses->request( "open-ils.cstore.direct.$type.record_entry.retrieve", $i, $flesh )->gather(1);
+ alarm(0);
+ } otherwise {
+ warn "\n!!!!!! Timed out trying to read record $i\n";
+ };
+ alarm(0);
+
+ next unless $bib;
+
+ if (uc($format) eq 'BRE') {
+ $r->print( OpenSRF::Utils::JSON->perl2JSON($bib) . "\n" );
+ next;
+ }
+
+ try {
+
+ my $req = MARC::Record->new_from_xml( $bib->marc, $encoding, $format );
+ $req->encoding($encoding) if ($encoding eq 'UTF-8');
+
+ if ($holdings) {
+ $req->delete_field( $_ ) for ($req->field('852')); # remove any legacy 852s
+ my $cn_list = $bib->call_numbers;
+ if ($cn_list && @$cn_list) {
+
+ my $cp_list = [ map { @{ $_->copies } } @$cn_list ];
+ if ($cp_list && @$cp_list) {
+
+ my %cn_map;
+ push @{$cn_map{$_->call_number}}, $_ for (@$cp_list);
+
+ for my $cn ( @$cn_list ) {
+ my $cn_map_list = $cn_map{$cn->id};
+
+ for my $cp ( @$cn_map_list ) {
+
+ $req->append_fields(
+ MARC::Field->new(
+ 852, '4', '',
+ a => $location,
+ b => $orgs{$cn->owning_lib}->shortname,
+ b => $orgs{$cp->circ_lib}->shortname,
+ c => $shelves{$cp->location}->name,
+ j => $cn->label,
+ ($cp->circ_modifier ? ( g => $cp->circ_modifier ) : ()),
+ p => $cp->barcode,
+ ($cp->price ? ( y => $cp->price ) : ()),
+ ($cp->copy_number ? ( t => $cp->copy_number ) : ()),
+ ($cp->ref eq 't' ? ( x => 'reference' ) : ( x => 'nonreference' )),
+ ($cp->holdable eq 'f' ? ( x => 'unholdable' ) : ( x => 'holdable' )),
+ ($cp->circulate eq 'f' ? ( x => 'noncirculating' ) : ( x => 'circulating' )),
+ ($cp->opac_visible eq 'f' ? ( x => 'hidden' ) : ( x => 'visible' )),
+ z => $statuses{$cp->status}->name,
+ )
+ );
+
+ }
+ }
+ }
+ }
+ }
+
+ if (uc($format) eq 'XML') {
+ my $x = $req->as_xml_record;
+ $x =~ s/^<\?xml version="1.0" encoding="UTF-8"\?>//o;
+ $r->print($x);
+ } elsif (uc($format) eq 'UNIMARC') {
+ $r->print($req->as_usmarc);
+ } elsif (uc($format) eq 'USMARC') {
+ $r->print($req->as_usmarc);
+ }
+
+ $r->rflush();
+
+ } otherwise {
+ my $e = shift;
+ warn "\n$e\n";
+ };
+
+ }
+
+ $r->print("</collection>\n") if ($format eq 'XML');
+
+ return Apache2::Const::OK;
+
+}
+
+sub verify_login {
+ my $auth_token = shift;
+ return undef unless $auth_token;
+
+ my $user = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( "open-ils.auth.session.retrieve", $auth_token )
+ ->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return undef;
+ }
+
+ return $user if ref($user);
+ return undef;
+}
+
+sub show_template {
+ my $r = shift;
+
+ $r->content_type('text/html');
+ $r->print(<<HTML);
+
+<html>
+ <head>
+ <title>Record Export</title>
+ </head>
+ <body>
+ <form method="POST" enctype="multipart/form-data">
+ Use field number <input type="text" size="2" maxlength="2" name="idcolumn" value="0"/> (starting from 0)
+ from CSV file <input type="file" name="idfile"/>
+ <br/><br/> <b>or</b> <br/><br/>
+ Record ID <input type="text" size="12" maxlength="12" name="id"/>
+ <br/><br/> Record Type:
+ <select name="rectype">
+ <option value="biblio">Bibliographic Records</option>
+ <option value="authority">Authority Records</option>
+ </select>
+ <br/> Record Format:
+ <select name="format">
+ <option value="USMARC">MARC21</option>
+ <option value="UNIMARC">UNIMARC</option>
+ <option value="XML">MARC XML</option>
+ <option value="BRE">Evergreen BRE</option>
+ </select>
+ <br/> Record Encoding:
+ <select name="encoding">
+ <option value="UTF-8">UTF-8</option>
+ <option value="MARC8">MARC8</option>
+ </select>
+ <br/> Include holdings in Bibliographic Records:
+ <input type="checkbox" name="holdings" value="1">
+ <br/><br/><input type="submit" value="Retrieve Records"/>
+ </form>
+ </body>
+</html>
+
+HTML
+
+ return Apache2::Const::OK;
+}
+
+1;
--- /dev/null
+package OpenILS::WWW::IDL2js;
+use strict; use warnings;
+use XML::LibXML;
+use XML::LibXSLT;
+use Apache2::Const -compile => qw(OK DECLINED HTTP_INTERNAL_SERVER_ERROR);
+use Error qw/:try/;
+use OpenSRF::System;
+use OpenSRF::Utils::SettingsClient;
+
+my $bs_config;
+my $stylesheet;
+my $idl_doc;
+
+
+# load and parse the stylesheet
+sub import {
+ my $self = shift;
+ $bs_config = shift;
+}
+
+# parse the IDL, loaded from the network
+my $__initted = 0;
+sub child_init {
+ $__initted = 1;
+
+ OpenSRF::System->bootstrap_client(config_file => $bs_config);
+ my $sclient = OpenSRF::Utils::SettingsClient->new();
+
+ my $xsl_file = $sclient->config_value('IDL2js');
+
+ unless($xsl_file) {
+ warn "XSL2js XSL file required for IDL2js Apache module\n";
+ return;
+ }
+
+ $xsl_file = $sclient->config_value(dirs => 'xsl')."/$xsl_file";
+ my $idl_file = $sclient->config_value("IDL");
+
+ my $xslt = XML::LibXSLT->new();
+
+ try {
+
+ my $style_doc = XML::LibXML->load_xml(location => $xsl_file, no_cdata=>1);
+ $stylesheet = $xslt->parse_stylesheet($style_doc);
+
+ } catch Error with {
+ my $e = shift;
+ warn "Invalid XSL File: $xsl_file: $e\n";
+ };
+
+ $idl_doc = XML::LibXML->load_xml(location => $idl_file);
+}
+
+
+sub handler {
+ my $r = shift;
+ my $args = $r->args || '';
+ child_init() unless $__initted;
+
+ return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR unless $stylesheet and $idl_doc;
+ return Apache2::Const::DECLINED if $args and $args !~ /^[a-zA-Z,]*$/;
+
+ my $output;
+ try {
+ my $results = $stylesheet->transform($idl_doc, class_list => "'$args'");
+ $output = $stylesheet->output_as_bytes($results);
+ } catch Error with {
+ my $e = shift;
+ $r->log->error("IDL XSL Error: $e");
+ };
+
+ return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR unless $output;
+
+ $r->content_type('application/x-javascript; encoding=utf8');
+ $r->print($output);
+ return Apache2::Const::OK;
+}
+
+1;
--- /dev/null
+package OpenILS::WWW::Method;
+use strict; use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+
+use OpenSRF::Utils::JSON;
+
+use CGI ();
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+
+my %session_hash;
+
+use constant MAX_SESSION_REQUESTS => 20;
+
+sub handler {
+
+ use Data::Dumper;
+
+
+ my $apache = shift;
+ my $cgi = CGI->new( $apache );
+
+ print "Content-type: text/plain; charset=utf-8\n\n";
+ #print $cgi->header;
+
+ my @p = $cgi->param();
+ warn "Params: " . Dumper(\@p);
+
+ my $method = $cgi->param("method");
+ my $service = $cgi->param("service");
+
+ my $err = undef;
+
+ if( ! $service || ! $method ) {
+ $err = {
+ is_err => 1,
+ err_msg => "Service name and method name required to fulfill request",
+ };
+ }
+
+ if($err) {
+ print OpenSRF::Utils::JSON->perl2JSON($err);
+ return Apache2::Const::OK;
+ }
+
+ my @param_array;
+ my %param_hash;
+
+ warn "here\n";
+
+ if(defined($cgi->param("param"))) {
+ for my $param ( $cgi->param("param")) {
+ push( @param_array, OpenSRF::Utils::JSON->JSON2perl( $param ));
+ }
+ } else {
+ for my $param ($cgi->param()) {
+ $param_hash{$param} = OpenSRF::Utils::JSON->JSON2perl($cgi->param($param))
+ unless( $param eq "method" or $param eq "service" );
+ }
+ }
+
+
+ if( @param_array ) {
+ perform_method($service, $method, @param_array);
+ } else {
+ perform_method($service, $method, %param_hash);
+ }
+
+ return Apache2::Const::OK;
+}
+
+sub child_init_handler {
+ OpenSRF::System->bootstrap_client(
+ config_file => "@sysconfdir@/opensrf_core.xml" );
+}
+
+
+sub perform_method {
+
+ my ($service, $method, @params) = @_;
+
+ warn "performing method $method for service $service with params @params\n";
+
+ my $session;
+
+ if($session_hash{$service} ) {
+
+ $session = $session_hash{$service};
+ $session->{web_count} += 1;
+
+ if( $session->{web_count} > MAX_SESSION_REQUESTS) {
+ $session->disconnect();
+ $session->{web_count} = 1;
+ }
+
+ } else {
+
+ $session = OpenSRF::AppSession->create($service);
+ $session_hash{$service} = $session;
+ $session->{web_count} = 1;
+
+ }
+
+ my $request = $session->request( $method, @params );
+
+ my @results;
+ while( my $response = $request->recv(20) ) {
+
+ if( UNIVERSAL::isa( $response, "Error" )) {
+ warn "Received exception: " . $response->stringify . "\n";
+ my $err = {
+ is_err => 1,
+ err_msg => "Error Completing Request:\n " .
+ "Service: $service \nMethod: $method \nParams: @params \n" .
+ $response->stringify() . "\n",
+ };
+ print OpenSRF::Utils::JSON->perl2JSON($err);
+ $request->finish();
+ return 0;
+ }
+
+ my $content = $response->content;
+ push @results, $content;
+ }
+
+
+ if(!$request->complete) {
+ warn "ERROR Completing Request";
+ my $err = {
+ is_err => 1,
+ err_msg => "Error Completing Request:\n ".
+ "Service: $service \nMethod: $method \nParams: @params \n" .
+ "request->complete test failed in OpenILS::Web::Method\n"
+ };
+ print OpenSRF::Utils::JSON->perl2JSON($err);
+ $request->finish();
+ return 0;
+ }
+
+ $request->finish();
+ $session->finish();
+
+ warn "Results: \n";
+ warn Dumper \@results;
+
+ print OpenSRF::Utils::JSON->perl2JSON( \@results );
+
+ return 1;
+}
+
+# This module appears unfinshed and/or obsolete with many unconditional warns/dumps.
+# File is not referenced elsewhere in the codebase. Candidate for deletion.
+
+1;
--- /dev/null
+package OpenILS::WWW::PasswordReset;
+
+# Copyright (C) 2010 Laurentian University
+# Dan Scott <dscott@laurentian.ca>
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+use strict; use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+use Template;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Cache;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+
+my $log = 'OpenSRF::Utils::Logger';
+my $U = 'OpenILS::Application::AppUtils';
+
+my ($bootstrap, $actor, $templates);
+my $i18n = {};
+my $init_done = 0; # has child_init been called?
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+
+ my $conf = OpenSRF::Utils::SettingsClient->new();
+ my $idl = $conf->config_value("IDL");
+ Fieldmapper->import(IDL => $idl);
+ $templates = $conf->config_value("dirs", "templates");
+ $actor = OpenSRF::AppSession->create('open-ils.actor');
+ load_i18n();
+ $init_done = 1;
+}
+
+sub password_reset {
+ my $apache = shift;
+
+ child_init() unless $init_done;
+
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ $apache->content_type('text/html');
+
+ my $cgi = new CGI;
+ my $ctx = {};
+
+ $ctx->{'uri'} = $apache->uri;
+
+ # Get our locale from the URL
+ (my $locale = $apache->path_info) =~ s{^.*?/([a-z]{2}-[A-Z]{2})/.*?$}{$1};
+ if (!$locale) {
+ $locale = 'en-US';
+ }
+
+ # If locale exists, use it; otherwise fall back to en-US
+ if (exists $i18n->{$locale}) {
+ $ctx->{'i18n'} = $i18n->{$locale};
+ } else {
+ $ctx->{'i18n'} = $i18n->{'en-US'};
+ }
+
+ my $tt = Template->new({
+ INCLUDE_PATH => $templates
+ }) || die "$Template::ERROR\n";
+
+ # Get our UUID: if no UUID, then display barcode / username / email prompt
+ (my $uuid = $apache->path_info) =~ s{^/$locale/([^/]*?)$}{$1};
+ $logger->info("Password reset: UUID = $uuid");
+
+ if (!$uuid) {
+ request_password_reset($apache, $cgi, $tt, $ctx);
+ } else {
+ reset_password($apache, $cgi, $tt, $ctx, $uuid);
+ }
+}
+
+sub reset_password {
+ my ($apache, $cgi, $tt, $ctx, $uuid) = @_;
+
+ my $password_1 = $cgi->param('pwd1');
+ my $password_2 = $cgi->param('pwd2');
+
+ $ctx->{'title'} = $ctx->{'i18n'}{'TITLE'};
+ $ctx->{'password_prompt'} = $ctx->{'i18n'}{'PASSWORD_PROMPT'};
+ $ctx->{'password_prompt2'} = $ctx->{'i18n'}{'PASSWORD_PROMPT2'};
+
+ # In case non-matching passwords slip through our funky Web interface
+ if ($password_1 and $password_2 and ($password_1 ne $password_2)) {
+ $ctx->{'status'} = {
+ style => 'error',
+ msg => $ctx->{'i18n'}{'NO_MATCH'}
+ };
+ $tt->process('password-reset/reset-form.tt2', $ctx)
+ || die $tt->error();
+ return Apache2::Const::OK;
+ }
+
+ if ($password_1 and $password_2 and ($password_1 eq $password_2)) {
+ my $response = $actor->request('open-ils.actor.patron.password_reset.commit', $uuid, $password_1)->gather();
+ if (ref($response) && $response->{'textcode'}) {
+
+ if ($response->{'textcode'} eq 'PATRON_NOT_AN_ACTIVE_PASSWORD_RESET_REQUEST') {
+ $ctx->{'status'} = {
+ style => 'error',
+ msg => $ctx->{'i18n'}{'NOT_ACTIVE'}
+
+ };
+ }
+ if ($response->{'textcode'} eq 'PATRON_PASSWORD_WAS_NOT_STRONG') {
+ $ctx->{'status'} = {
+ style => 'error',
+ msg => $ctx->{'i18n'}{'NOT_STRONG'}
+
+ };
+ }
+ $tt->process('password-reset/reset-form.tt2', $ctx)
+ || die $tt->error();
+ return Apache2::Const::OK;
+ }
+ $ctx->{'status'} = {
+ style => 'success',
+ msg => $ctx->{'i18n'}{'SUCCESS'}
+ };
+ }
+
+ # Either the password change was successful, or this is their first time through
+ $tt->process('password-reset/reset-form.tt2', $ctx)
+ || die $tt->error();
+
+ return Apache2::Const::OK;
+}
+
+# Load our localized strings - lame, need to convert to Locale::Maketext
+sub load_i18n {
+ foreach my $string_bundle (glob("$templates/password-reset/strings.*")) {
+ open(I18NFH, '<', $string_bundle);
+ (my $locale = $string_bundle) =~ s/^.*\.([a-z]{2}-[A-Z]{2})$/$1/;
+ $logger->debug("Loaded locale [$locale] from file: [$string_bundle]");
+ while(<I18NFH>) {
+ my ($string_id, $string) = ($_ =~ m/^(.+?)=(.*?)$/);
+ $i18n->{$locale}{$string_id} = $string;
+ }
+ close(I18NFH);
+ }
+}
+
+sub request_password_reset {
+ my ($apache, $cgi, $tt, $ctx) = @_;
+
+ my $barcode = $cgi->param('barcode');
+ my $username = $cgi->param('username');
+ my $email = $cgi->param('email');
+
+ if (!($barcode or $username or $email)) {
+ $ctx->{'status'} = {
+ style => 'plain',
+ msg => $ctx->{'i18n'}{'IDENTIFY_YOURSELF'}
+ };
+ $tt->process('password-reset/request-form.tt2', $ctx)
+ || die $tt->error();
+ return Apache2::Const::OK;
+ } elsif ($barcode) {
+ my $response = $actor->request('open-ils.actor.patron.password_reset.request', 'barcode', $barcode)->gather();
+ $ctx->{'status'} = {
+ style => 'plain',
+ msg => $ctx->{'i18n'}{'REQUEST_SUCCESS'}
+ };
+ # Hide form
+ $tt->process('password-reset/request-form.tt2', $ctx)
+ || die $tt->error();
+ return Apache2::Const::OK;
+ } elsif ($username) {
+ my $response = $actor->request('open-ils.actor.patron.password_reset.request', 'username', $username)->gather();
+ $ctx->{'status'} = {
+ style => 'plain',
+ msg => $ctx->{'i18n'}{'REQUEST_SUCCESS'}
+ };
+ # Hide form
+ $tt->process('password-reset/request-form.tt2', $ctx)
+ || die $tt->error();
+ return Apache2::Const::OK;
+ }
+}
+
+1;
+
+# vim: et:ts=4:sw=4
--- /dev/null
+package OpenILS::WWW::Proxy;
+use strict; use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(REDIRECT FORBIDDEN OK NOT_FOUND DECLINED :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use CGI;
+use Data::Dumper;
+use Digest::MD5 qw/md5_hex/;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+
+
+# set the bootstrap config and template include directory when
+# this module is loaded
+my $bootstrap;
+my $ssl_off;
+
+my $default_template = <<HTML;
+<html>
+ <head>
+ <title>TITLE</title>
+ </head>
+ <body>
+ <br/><br/><br/>
+ <center>
+ <form method='POST'>
+ <table style='border-collapse: collapse; border: 1px solid black;'>
+ <tr>
+ <th colspan='2' align='center'><u>DESCRIPTION</u></th>
+ </tr>
+ <tr>
+ <th align="right">Username or barcode:</th>
+ <td><input type="text" name="user"/></td>
+ </tr>
+ <tr>
+ <th align="right">Password:</th>
+ <td><input type="password" name="passwd"/></td>
+ </tr>
+ </table>
+ <input type="submit" value="Log in"/>
+ </form>
+ </center>
+ </body>
+</html>
+HTML
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+ $ssl_off = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+}
+
+sub handler {
+ my $apache = shift;
+
+ my $proxyhtml = $apache->dir_config('OILSProxyHTML');
+ my $title = $apache->dir_config('OILSProxyTitle');
+ my $desc = $apache->dir_config('OILSProxyDescription');
+ my $ltype = $apache->dir_config('OILSProxyLoginType');
+ my $perms = [ split ' ', $apache->dir_config('OILSProxyPermissions') ];
+
+ return Apache2::Const::NOT_FOUND unless ($title || $proxyhtml);
+ return Apache2::Const::NOT_FOUND unless (@$perms);
+
+ my $cgi = new CGI;
+ my $auth_ses = $cgi->cookie('ses') || $cgi->param('ses');
+ my $ws_ou = $apache->dir_config('OILSProxyLoginOU') || $cgi->cookie('ws_ou') || $cgi->param('ws_ou');
+
+ my $url = $cgi->url;
+
+ # push everyone to the secure site
+ if (!$ssl_off && $url =~ /^http:/o) {
+ my $base = $cgi->url(-base=>1);
+ $base =~ s/^http:/https:/o;
+ print "Location: $base".$apache->unparsed_uri."\n\n";
+ return Apache2::Const::REDIRECT;
+ }
+
+ if (!$auth_ses) {
+ my $u = $cgi->param('user');
+ my $p = $cgi->param('passwd');
+
+ if (!$u) {
+
+ print $cgi->header(-type=>'text/html', -expires=>'-1d');
+ if (!$proxyhtml) {
+ $proxyhtml = $default_template;
+ $proxyhtml =~ s/TITLE/$title/gso;
+ $proxyhtml =~ s/DESCRIPTION/$desc/gso;
+ } else {
+ # XXX template toolkit??
+ }
+
+ print $proxyhtml;
+ return Apache2::Const::OK;
+ }
+
+ $auth_ses = oils_login($u, $p, $ltype);
+ if ($auth_ses) {
+ print $cgi->redirect(
+ -uri=> $apache->unparsed_uri,
+ -cookie=>$cgi->cookie(
+ -name=>'ses',
+ -value=>$auth_ses,
+ -path=>'/'
+ )
+ );
+ return Apache2::Const::REDIRECT;
+ } else {
+ return back_to_login($apache, $cgi);
+ }
+ }
+
+ my $user = verify_login($auth_ses);
+ return back_to_login($apache, $cgi) unless $user;
+
+ $ws_ou ||= $user->home_ou;
+
+ warn "Checking perms " . join(',', @$perms) . " for user " . $user->id . " at location $ws_ou\n";
+
+ my $failures = OpenSRF::AppSession
+ ->create('open-ils.actor')
+ ->request('open-ils.actor.user.perm.check', $auth_ses, $user->id, $ws_ou, $perms)
+ ->gather(1);
+
+ return back_to_login($apache, $cgi) if (@$failures > 0);
+
+ # they're good, let 'em through
+ return Apache2::Const::DECLINED;
+}
+
+sub back_to_login {
+ my $apache = shift;
+ my $cgi = shift;
+ print $cgi->redirect(
+ -uri=>$apache->unparsed_uri,
+ -cookie=>$cgi->cookie(
+ -name=>'ses',
+ -value=>'',
+ -path=>'/',-expires=>'-1h'
+ )
+ );
+ return Apache2::Const::REDIRECT;
+}
+
+# returns the user object if the session is valid, 0 otherwise
+sub verify_login {
+ my $auth_token = shift;
+ return undef unless $auth_token;
+
+ my $user = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( "open-ils.auth.session.retrieve", $auth_token )
+ ->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return undef;
+ }
+
+ return $user if ref($user);
+ return undef;
+}
+
+sub oils_login {
+ my( $username, $password, $type ) = @_;
+
+ $type |= "staff";
+ my $nametype = 'username';
+ $nametype = 'barcode' if ($username =~ /^\d+$/o);
+
+ my $seed = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( 'open-ils.auth.authenticate.init', $username )
+ ->gather(1);
+
+ return undef unless $seed;
+
+ my $response = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( 'open-ils.auth.authenticate.complete',
+ { $nametype => $username,
+ password => md5_hex($seed . md5_hex($password)),
+ type => $type })
+ ->gather(1);
+
+ return undef unless $response;
+
+ return $response->{payload}->{authtoken};
+}
+
+1;
+
--- /dev/null
+package OpenILS::WWW::Redirect;
+use strict; use warnings;
+
+use Socket;
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use CGI ();
+
+use OpenSRF::AppSession;
+use OpenSRF::System;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use vars '$lib_ips_hash';
+my $lib_ips_hash;
+
+my $bootstrap_config_file;
+sub import {
+ my( $self, $config ) = @_;
+ $bootstrap_config_file = $config;
+}
+
+sub init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap_config_file );
+}
+
+sub parse_ips_file {
+ my $class = shift;
+ my $ips_file = shift;
+
+ if( open(F, $ips_file) ) {
+
+ while( my $data = <F> ) {
+ chomp($data);
+
+ my( $shortname, $ip1, $ip2 ) = split(/\s+/, $data);
+ next unless ($shortname and $ip1 and $ip2);
+
+ $lib_ips_hash->{$shortname} = [] unless $lib_ips_hash->{$shortname};
+ push( @{$lib_ips_hash->{$shortname}}, [ $ip1, $ip2 ] );
+ }
+
+ close(F);
+
+ } else {
+ $logger->error("Unable to open lib IP redirector file $ips_file");
+ }
+}
+
+
+sub handler {
+
+ my $user_ip = $ENV{REMOTE_ADDR};
+ my $apache_obj = shift;
+ my $cgi = CGI->new( $apache_obj );
+
+
+ my $skin = $apache_obj->dir_config('OILSRedirectSkin') || 'default';
+ my $depth = $apache_obj->dir_config('OILSRedirectDepth');
+ my $locale = $apache_obj->dir_config('OILSRedirectLocale') || 'en-US';
+
+ my $hostname = $cgi->server_name();
+ my $port = $cgi->server_port();
+
+ my $proto = "http";
+ if($cgi->https) { $proto = "https"; }
+
+ my $url = "$proto://$hostname:$port/opac/$locale/skin/$skin/xml/index.xml";
+
+ my $path = $apache_obj->path_info();
+
+ $logger->debug("Apache client connecting from $user_ip");
+
+ if(my $shortname = redirect_libs($user_ip)) {
+
+ $logger->info("Apache redirecting $user_ip to $shortname");
+ my $session = OpenSRF::AppSession->create("open-ils.actor");
+
+ my $org = $session->request(
+ 'open-ils.actor.org_unit.retrieve_by_shortname',
+ $shortname)->gather(1);
+
+ if($org) {
+ $url .= "?ol=" . $org->id;
+ $url .= "&d=$depth" if defined $depth;
+ }
+ }
+
+ print "Location: $url\n\n";
+ return Apache2::Const::REDIRECT;
+
+ return print_page($url);
+}
+
+sub redirect_libs {
+ my $source_ip = shift;
+ my $aton_binary = inet_aton( $source_ip );
+
+ return 0 unless $aton_binary;
+
+ # do this the linear way for now...
+ for my $shortname (keys %$lib_ips_hash) {
+
+ for my $block (@{$lib_ips_hash->{$shortname}}) {
+
+ if(defined($block->[0]) && defined($block->[1]) ) {
+ my $start_binary = inet_aton( $block->[0] );
+ my $end_binary = inet_aton( $block->[1] );
+ next unless( $start_binary and $end_binary );
+ if( $start_binary le $aton_binary and
+ $end_binary ge $aton_binary ) {
+ return $shortname;
+ }
+ }
+ }
+ }
+ return 0;
+}
+
+
+sub print_page {
+
+ my $url = shift;
+
+ print "Content-type: text/html; charset=utf-8\n\n";
+ print <<" HTML";
+ <html>
+ <head>
+ <meta HTTP-EQUIV='Refresh' CONTENT="0; URL=$url"/>
+ <style TYPE="text/css">
+ .loading_div {
+ text-align:center;
+ margin-top:30px;
+ font-weight:bold;
+ background: lightgrey;
+ color:black;
+ width:100%;
+ }
+ </style>
+ </head>
+ <body>
+ <br/><br/>
+ <div class="loading_div">
+ <h4>Loading...</h4>
+ </div>
+ <br/><br/>
+ <center><img src='/opac/images/main_logo.jpg'/></center>
+ </body>
+ </html>
+ HTML
+
+ return Apache2::Const::OK;
+}
+
+
+1;
--- /dev/null
+package OpenILS::WWW::Reporter;
+use strict; use warnings;
+
+use vars qw/$dtype_xform_map $dtype_xform/;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+use Data::Dumper;
+
+use Template;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+use XML::LibXML;
+
+use OpenSRF::Utils::SettingsParser;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::WWW::Reporter::transforms;
+
+
+# set the bootstrap config and template include directory when
+# this module is loaded
+my $bootstrap;
+my $includes = [];
+my $base_xml;
+#my $base_xml_doc;
+
+sub import {
+ my( $self, $bs_config, $core_xml, @incs ) = @_;
+ $bootstrap = $bs_config;
+ $base_xml = $core_xml;
+ $includes = [ @incs ];
+}
+
+
+# our templates plugins are here
+my $plugin_base = 'OpenILS::Template::Plugin';
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+
+ #parse the base xml file
+ #my $parser = XML::LibXML->new;
+ #$parser->expand_xinclude(1);
+
+ #$base_xml_doc = $parser->parse_file($base_xml);
+
+}
+
+sub handler {
+
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = CGI->new;
+
+ my $path = $apache->path_info;
+ (my $ttk = $path) =~ s{^/?([a-zA-Z0-9_]+).*?$}{$1}o;
+
+ $ttk = $apache->filename unless $ttk;
+ $ttk = "dashboard" unless $ttk;
+
+ $ttk = (split '/', $ttk)[-1];
+
+ my $user;
+
+ # if the user is not logged in via cookie, route them to the login page
+ if(! ($user = verify_login($cgi->cookie("ses"))) ) {
+ $ttk = "login";
+ }
+
+
+ print "Content-type: text/html; charset=utf-8\n\n";
+ #print "Content-type: text/html\n\n";
+
+ _process_template(
+ apache => $apache,
+ template => "$ttk.ttk",
+ params => {
+ user => $user,
+ stage_dir => $ttk,
+ config_xml => $base_xml,
+ },
+ );
+
+ return Apache2::Const::OK;
+}
+
+
+sub _process_template {
+
+ my %params = @_;
+ my $ttk = $params{template} || return undef;
+ my $apache = $params{apache} || undef;
+ my $param_hash = $params{params} || {};
+ $$param_hash{dtype_xform_map} = $OpenILS::WWW::Reporter::dtype_xform_map;
+ $$param_hash{dtype_xforms} = $OpenILS::WWW::Reporter::dtype_xforms;
+
+ my $template;
+
+ $template = Template->new( {
+ OUTPUT => $apache,
+ ABSOLUTE => 1,
+ RELATIVE => 1,
+ PLUGIN_BASE => $plugin_base,
+ INCLUDE_PATH => $includes,
+ PRE_CHOMP => 1,
+ POST_CHOMP => 1,
+ #LOAD_PERL => 1,
+ }
+ );
+
+ try {
+
+ if( ! $template->process( $ttk, $param_hash ) ) {
+ warn "Error Processing Template: " . $template->error();
+ my $err = $template->error();
+ $err =~ s/\n/\<br\/\>/g;
+ warn "Error processing template $ttk\n";
+ my $string = "<br><b>Unable to process template:<br/><br/> " . $err . "</b>";
+ print "ERROR: $string";
+ #$template->process( $error_ttk , { error => $string } );
+ }
+
+ } catch Error with {
+ my $e = shift;
+ warn "Error processing template $ttk: $e - $@ \n";
+ print "<center><br/><br/><b>Error<br/><br/> $e <br/><br/> $@ </b><br/></center>";
+ return;
+ };
+
+}
+
+# returns the user object if the session is valid, 0 otherwise
+sub verify_login {
+ my $auth_token = shift;
+ return 0 unless $auth_token;
+
+ my $session = OpenSRF::AppSession->create("open-ils.auth");
+ my $req = $session->request(
+ "open-ils.auth.session.retrieve", $auth_token );
+ my $user = $req->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return 0;
+ }
+
+ return $user if ref($user);
+ return 0;
+}
+
+
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+package OpenILS::WWW::Reporter;
+
+our $dtype_xform_map = {
+ 'int' => [ 'avg','stddev','sum','count','count_dist','numformat'],
+ 'numeric' => [ 'avg','stddev','sum','count','count_dist','numformat'],
+ 'float' => [ 'avg','stddev','sum','count','count_dist','numformat'],
+ 'time' => [ 'count', 'dateformat'],
+ 'date' => [ 'count', 'age','dateformat'],
+ 'timestamp' => [ 'count', 'age','dateformat'],
+ 'timestamptz' => [ 'count', 'age','dateformat'],
+ 'text' => [ 'count','count_dist','lower','upper','substr'],
+ 'call_number' => [ 'count','count_dist','dewy','dewy_prefix','count_dist_dewey','count_dist_dewey_prefix','lower','upper','substr'],
+};
+
+
+
+our $dtype_xforms = {
+ 'avg' => {
+ 'name' => 'Average per group',
+ 'select' => 'AVG(?COLNAME?)',
+ 'group' => 0 },
+ 'stddev' => {
+ 'label' => 'Standard Deviation per group',
+ 'select' => 'STDDEV(?COLNAME?)',
+ 'group' => 0 },
+ 'sum' => {
+ 'label' => 'Sum per group',
+ 'select' => 'SUM(?COLNAME?)',
+ 'group' => 0 },
+ 'count' => {
+ 'label' => 'Count per group',
+ 'select' => 'COUNT(?COLNAME?)',
+ 'group' => 0 },
+ 'count_dist' => {
+ 'label' => 'Distinct Count per group',
+ 'select' => 'COUNT(DISTINCT ?COLNAME?)',
+ 'group' => 0 },
+ 'count_dist_dewey' => {
+ 'label' => 'Distinct Count of Dewey numbers per group',
+ 'select' => 'COUNT(DISTINCT call_number_dewey(?COLNAME?))',
+ 'group' => 1 },
+ 'count_dist_dewey_prefix'=> {
+ 'label' => 'Distinct Count of Dewey Number Prefixes per group',
+ 'select' => 'COUNT(DISTINCT call_number_dewey(?COLNAME?,?PARAM?))',
+ 'param' => 1,
+ 'group' => 1 },
+ 'dewy_prefix' => {
+ 'label' => 'Extract Dewey number prefix from call number',
+ 'select' => 'call_number_dewey(?COLNAME?,?PARAM?)',
+ 'param' => 1,
+ 'group' => 1 },
+ 'dewy' => {
+ 'label' => 'Extract Dewey number from call number',
+ 'select' => 'call_number_dewey(?COLNAME?)',
+ 'group' => 1 },
+ 'lower' => {
+ 'label' => 'Transform string to lower case',
+ 'select' => 'LOWER(?COLNAME?)',
+ 'group' => 1 },
+ 'upper' => {
+ 'label' => 'Transform string to upper case',
+ 'select' => 'UPPER(?COLNAME?)',
+ 'group' => 1 },
+ 'substr' => {
+ 'label' => 'Trim string length',
+ 'select' => 'substr(?COLNAME?,1,?PARAM?)',
+ 'param' => 1,
+ 'group' => 1 },
+ 'age' => {
+ 'label' => 'Age as of runtime -- day granularity',
+ 'select' => 'AGE(?COLNAME?::DATE)',
+ 'group' => 1 },
+ 'dateformat' => { # see http://www.postgresql.org/docs/8.0/interactive/functions-formatting.html
+ 'label' => 'Format date and time',
+ 'select' => "TO_CHAR(?COLNAME?,'?PARAM?')",
+ 'param' => 1,
+ 'group' => 1 },
+ 'numformat' => { # see http://www.postgresql.org/docs/8.0/interactive/functions-formatting.html
+ 'label' => 'Format Numeric data',
+ 'select' => "TO_CHAR(?COLNAME?,'?PARAM?')",
+ 'param' => 1,
+ 'group' => 1 },
+};
+
+;
--- /dev/null
+package OpenILS::WWW::SuperCat;
+use strict; use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+use Data::Dumper;
+use SRU::Request;
+use SRU::Response;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Cache;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use XML::LibXML;
+use XML::LibXSLT;
+
+use Encode;
+use Unicode::Normalize;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::WWW::SuperCat::Feed;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenILS::Application::AppUtils;
+
+use MARC::Record;
+use MARC::File::XML;
+
+my $log = 'OpenSRF::Utils::Logger';
+my $U = 'OpenILS::Application::AppUtils';
+
+# set the bootstrap config when this module is loaded
+my ($bootstrap, $supercat, $actor, $parser, $search, $xslt, $cn_browse_xslt, %browse_types);
+
+$browse_types{call_number}{xml} = sub {
+ my $tree = shift;
+
+ my $year = (gmtime())[5] + 1900;
+ my $content = '';
+
+ $content .= "<volumes xmlns='http://open-ils.org/spec/holdings/v1'>\n";
+
+ for my $cn (@$tree) {
+ (my $cn_class = $cn->class_name) =~ s/::/-/gso;
+ $cn_class =~ s/Fieldmapper-//gso;
+
+ my $cn_tag = "tag:open-ils.org,$year:$cn_class/".$cn->id;
+ my $cn_lib = $cn->owning_lib->shortname;
+ my $cn_label = $cn->label;
+
+ $cn_label =~ s/\n//gos;
+ $cn_label =~ s/&/&/go;
+ $cn_label =~ s/'/'/go;
+ $cn_label =~ s/</</go;
+ $cn_label =~ s/>/>/go;
+
+ (my $ou_class = $cn->owning_lib->class_name) =~ s/::/-/gso;
+ $ou_class =~ s/Fieldmapper-//gso;
+
+ my $ou_tag = "tag:open-ils.org,$year:$ou_class/".$cn->owning_lib->id;
+ my $ou_name = $cn->owning_lib->name;
+
+ $ou_name =~ s/\n//gos;
+ $ou_name =~ s/'/'/go;
+
+ (my $rec_class = $cn->record->class_name) =~ s/::/-/gso;
+ $rec_class =~ s/Fieldmapper-//gso;
+
+ my $rec_tag = "tag:open-ils.org,$year:$rec_class/".$cn->record->id.'/'.$cn->owning_lib->shortname;
+
+ $content .= "<volume id='$cn_tag' lib='$cn_lib' label='$cn_label'>\n";
+ $content .= "<owning_lib xmlns='http://open-ils.org/spec/actors/v1' id='$ou_tag' name='$ou_name'/>\n";
+
+ my $r_doc = $parser->parse_string($cn->record->marc);
+ $r_doc->documentElement->setAttribute( id => $rec_tag );
+ $content .= $U->entityize($r_doc->documentElement->toString);
+
+ $content .= "</volume>\n";
+ }
+
+ $content .= "</volumes>\n";
+ return ("Content-type: application/xml\n\n",$content);
+};
+
+
+$browse_types{call_number}{html} = sub {
+ my $tree = shift;
+ my $p = shift;
+ my $n = shift;
+
+ if (!$cn_browse_xslt) {
+ $cn_browse_xslt = $parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/CNBrowse2HTML.xsl"
+ );
+ $cn_browse_xslt = $xslt->parse_stylesheet( $cn_browse_xslt );
+ }
+
+ my (undef,$xml) = $browse_types{call_number}{xml}->($tree);
+
+ return (
+ "Content-type: text/html\n\n",
+ $U->entityize(
+ $cn_browse_xslt->transform(
+ $parser->parse_string( $xml ),
+ 'prev' => "'$p'",
+ 'next' => "'$n'"
+ )->toString(1)
+ )
+ );
+};
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+
+ my $idl = OpenSRF::Utils::SettingsClient->new->config_value("IDL");
+ Fieldmapper->import(IDL => $idl);
+
+ $supercat = OpenSRF::AppSession->create('open-ils.supercat');
+ $actor = OpenSRF::AppSession->create('open-ils.actor');
+ $search = OpenSRF::AppSession->create('open-ils.search');
+ $parser = new XML::LibXML;
+ $xslt = new XML::LibXSLT;
+
+ $cn_browse_xslt = $parser->parse_file(
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/CNBrowse2HTML.xsl"
+ );
+
+ $cn_browse_xslt = $xslt->parse_stylesheet( $cn_browse_xslt );
+
+ my $list = $supercat
+ ->request("open-ils.supercat.record.formats")
+ ->gather(1);
+
+ $list = [ map { (keys %$_)[0] } @$list ];
+ push @$list, 'htmlholdings','html', 'marctxt', 'ris';
+
+ for my $browse_axis ( qw/title author subject topic series item-age/ ) {
+ for my $record_browse_format ( @$list ) {
+ {
+ my $__f = $record_browse_format;
+ my $__a = $browse_axis;
+
+ $browse_types{$__a}{$__f} = sub {
+ my $record_list = shift;
+ my $prev = shift;
+ my $next = shift;
+ my $real_format = shift || $__f;
+ my $unapi = shift;
+ my $base = shift;
+ my $site = shift;
+
+ $log->info("Creating record feed with params [$real_format, $record_list, $unapi, $site]");
+ my $feed = create_record_feed( 'record', $real_format, $record_list, $unapi, $site, undef, $real_format =~ /(-full|-uris)$/o ? 1 : 0 );
+ $feed->root( "$base/../" );
+ $feed->lib( $site );
+ $feed->link( next => $next => $feed->type );
+ $feed->link( previous => $prev => $feed->type );
+
+ return (
+ "Content-type: ". $feed->type ."; charset=utf-8\n\n",
+ $feed->toString
+ );
+ };
+ }
+ }
+ }
+
+ for my $basic_axis ( qw/authority.title authority.author authority.subject authority.topic/ ) {
+ for my $browse_axis ( ($basic_axis, $basic_axis . ".refs") ) {
+ {
+ my $__f = 'marcxml';
+ my $__a = $browse_axis;
+
+ $browse_types{$__a}{$__f} = sub {
+ my $record_list = shift;
+ my $prev = shift;
+ my $next = shift;
+ my $real_format = shift || $__f;
+ my $unapi = shift;
+ my $base = shift;
+ my $site = shift;
+
+ $log->info("Creating record feed with params [$real_format, $record_list, $unapi, $site]");
+ my $feed = create_record_feed( 'authority', $real_format, $record_list, $unapi, $site, undef, $real_format =~ /-full$/o ? -1 : 0 );
+ $feed->root( "$base/../" );
+ $feed->link( next => $next => $feed->type );
+ $feed->link( previous => $prev => $feed->type );
+
+ return (
+ "Content-type: ". $feed->type ."; charset=utf-8\n\n",
+ $feed->toString
+ );
+ };
+ }
+ }
+ }
+}
+
+=head2 parse_feed_type($type)
+
+Determines whether and how a given feed type needs to be "fleshed out"
+with holdings information.
+
+The feed type could end with the string "-full", in which case we want
+to return call numbers, copies, and URIS.
+
+Or the feed type could be "-uris", in which case we want to return
+call numbers and URIS.
+
+Otherwise, we won't return any holdings.
+
+=cut
+
+sub parse_feed_type {
+ my $type = shift;
+
+ if ($type =~ /-full$/o) {
+ return 1;
+ }
+
+ if ($type =~ /-uris$/o) {
+ return "uris";
+ }
+
+ # Otherwise, we'll return just the facts, ma'am
+ return 0;
+}
+
+=head2 supercat_format($format_hashref, $format_type)
+
+Given a reference to a hash containing the namespace_uri,
+docs, and schema location attributes for a set of formats,
+generate the XML description required by the supercat service.
+
+We derive the base type from the format type so that we do not
+have to populate the hash with redundant information.
+
+=cut
+
+sub supercat_format {
+ my $h = shift;
+ my $type = shift;
+
+ (my $base_type = $type) =~ s/(-full|-uris)$//o;
+
+ my $format = "<format><name>$type</name><type>application/xml</type>";
+
+ for my $part ( qw/namespace_uri docs schema_location/ ) {
+ $format .= "<$part>$$h{$base_type}{$part}</$part>"
+ if ($$h{$base_type}{$part});
+ }
+
+ $format .= '</format>';
+
+ return $format;
+}
+
+=head2 unapi_format($format_hashref, $format_type)
+
+Given a reference to a hash containing the namespace_uri,
+docs, and schema location attributes for a set of formats,
+generate the XML description required by the supercat service.
+
+We derive the base type from the format type so that we do not
+have to populate the hash with redundant information.
+
+=cut
+
+sub unapi_format {
+ my $h = shift;
+ my $type = shift;
+
+ (my $base_type = $type) =~ s/(-full|-uris)$//o;
+
+ my $format = "<format name='$type' type='application/xml'";
+
+ for my $part ( qw/namespace_uri docs schema_location/ ) {
+ $format .= " $part='$$h{$base_type}{$part}'"
+ if ($$h{$base_type}{$part});
+ }
+
+ $format .= "/>\n";
+
+ return $format;
+}
+
+
+sub oisbn {
+
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ (my $isbn = $apache->path_info) =~ s{^.*?([^/]+)$}{$1}o;
+
+ my $list = $supercat
+ ->request("open-ils.supercat.oisbn", $isbn)
+ ->gather(1);
+
+ print "Content-type: application/xml; charset=utf-8\n\n";
+ print "<?xml version='1.0' encoding='UTF-8' ?>\n";
+
+ unless (exists $$list{metarecord}) {
+ print '<idlist/>';
+ return Apache2::Const::OK;
+ }
+
+ print "<idlist metarecord='$$list{metarecord}'>\n";
+
+ for ( keys %{ $$list{record_list} } ) {
+ (my $o = $$list{record_list}{$_}) =~s/^(\S+).*?$/$1/o;
+ print " <isbn record='$_'>$o</isbn>\n"
+ }
+
+ print "</idlist>\n";
+
+ return Apache2::Const::OK;
+}
+
+sub unapi {
+
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'unapi', $url)[0];
+ my $base = (split 'unapi', $url)[0] . 'unapi';
+
+
+ my $uri = $cgi->param('id') || '';
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $skin = $cgi->param('skin') || 'default';
+ my $locale = $cgi->param('locale') || 'en-US';
+
+ # Enable localized results of copy status, etc
+ $supercat->session_locale($locale);
+
+ my $format = $cgi->param('format');
+ my $flesh_feed = parse_feed_type($format);
+ (my $base_format = $format) =~ s/(-full|-uris)$//o;
+ my ($id,$type,$command,$lib,$depth,$paging) = ('','','');
+
+ if (!$format) {
+ my $body = "Content-type: application/xml; charset=utf-8\n\n";
+
+ if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
+ $id = $2;
+ $paging = $3;
+ ($lib,$depth) = split('/', $4);
+ $type = 'record';
+ $type = 'metarecord' if ($1 =~ /^m/o);
+ $type = 'authority' if ($1 =~ /^authority/o);
+
+ my $list = $supercat
+ ->request("open-ils.supercat.$type.formats")
+ ->gather(1);
+
+ if ($type eq 'record' or $type eq 'isbn') {
+ $body .= <<" FORMATS";
+<formats id='$uri'>
+ <format name='opac' type='text/html'/>
+ <format name='html' type='text/html'/>
+ <format name='htmlholdings' type='text/html'/>
+ <format name='holdings_xml' type='application/xml'/>
+ <format name='holdings_xml-full' type='application/xml'/>
+ <format name='html-full' type='text/html'/>
+ <format name='htmlholdings-full' type='text/html'/>
+ <format name='marctxt' type='text/plain'/>
+ <format name='ris' type='text/plain'/>
+ FORMATS
+ } elsif ($type eq 'metarecord') {
+ $body .= <<" FORMATS";
+ <formats id='$uri'>
+ <format name='opac' type='text/html'/>
+ FORMATS
+ } else {
+ $body .= <<" FORMATS";
+ <formats id='$uri'>
+ FORMATS
+ }
+
+ for my $h (@$list) {
+ my ($type) = keys %$h;
+ $body .= unapi_format($h, $type);
+
+ if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
+ $body .= unapi_format($h, "$type-full");
+ $body .= unapi_format($h, "$type-uris");
+ }
+ }
+
+ $body .= "</formats>\n";
+
+ } else {
+ my $list = $supercat
+ ->request("open-ils.supercat.$type.formats")
+ ->gather(1);
+
+ push @$list,
+ @{ $supercat
+ ->request("open-ils.supercat.metarecord.formats")
+ ->gather(1);
+ };
+
+ my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
+ $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
+
+ $body .= <<" FORMATS";
+<formats>
+ <format name='opac' type='text/html'/>
+ <format name='html' type='text/html'/>
+ <format name='htmlholdings' type='text/html'/>
+ <format name='holdings_xml' type='application/xml'/>
+ <format name='holdings_xml-full' type='application/xml'/>
+ <format name='html-full' type='text/html'/>
+ <format name='htmlholdings-full' type='text/html'/>
+ <format name='marctxt' type='text/plain'/>
+ <format name='ris' type='text/plain'/>
+ FORMATS
+
+
+ for my $h (@$list) {
+ my ($type) = keys %$h;
+ $body .= "\t" . unapi_format($h, $type);
+
+ if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
+ $body .= "\t" . unapi_format($h, "$type-full");
+ $body .= "\t" . unapi_format($h, "$type-uris");
+ }
+ }
+
+ $body .= "</formats>\n";
+
+ }
+ print $body;
+ return Apache2::Const::OK;
+ }
+
+ my $scheme;
+ if ($uri =~ m{^tag:[^:]+:([^\/]+)/([^\/[]+)(?:\[([0-9,]+)\])?(?:/(.+))?}o) {
+ $scheme = $1;
+ $id = $2;
+ $paging = $3;
+ ($lib,$depth) = split('/', $4);
+ $type = 'record';
+ $type = 'metarecord' if ($scheme =~ /^metabib/o);
+ $type = 'isbn' if ($scheme =~ /^isbn/o);
+ $type = 'acp' if ($scheme =~ /^asset-copy/o);
+ $type = 'acn' if ($scheme =~ /^asset-call_number/o);
+ $type = 'auri' if ($scheme =~ /^asset-uri/o);
+ $type = 'authority' if ($scheme =~ /^authority/o);
+ $command = 'retrieve';
+ $command = 'browse' if (grep { $scheme eq $_ } qw/call_number title author subject topic authority.title authority.author authority.subject authority.topic series item-age/);
+ }
+
+ if ($paging) {
+ $paging = [split ',', $paging];
+ } else {
+ $paging = [];
+ }
+
+ if (!$lib || $lib eq '-') {
+ $lib = $actor->request(
+ 'open-ils.actor.org_unit_list.search' => parent_ou => undef
+ )->gather(1)->[0]->shortname;
+ }
+
+ my ($lib_object,$lib_id,$ou_types,$lib_depth);
+ if ($type ne 'acn' && $type ne 'acp' && $type ne 'auri') {
+ $lib_object = $actor->request(
+ 'open-ils.actor.org_unit_list.search' => shortname => $lib
+ )->gather(1)->[0];
+ $lib_id = $lib_object->id;
+
+ $ou_types = $actor->request( 'open-ils.actor.org_types.retrieve' )->gather(1);
+ $lib_depth = $depth || (grep { $_->id == $lib_object->ou_type } @$ou_types)[0]->depth;
+ }
+
+ if ($command eq 'browse') {
+ print "Location: $root/browse/$base_format/$scheme/$lib/$id\n\n";
+ return 302;
+ }
+
+ if ($type eq 'isbn') {
+ my $rec = $supercat->request('open-ils.supercat.isbn.object.retrieve',$id)->gather(1);
+ if (!@$rec) {
+ print "Content-type: text/html; charset=utf-8\n\n";
+ $apache->custom_response( 404, <<" HTML");
+ <html>
+ <head>
+ <title>Type [$type] with id [$id] not found!</title>
+ </head>
+ <body>
+ <br/>
+ <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
+ </body>
+ </html>
+ HTML
+ return 404;
+ }
+ $id = $rec->[0]->id;
+ $type = 'record';
+ }
+
+ if ( !grep
+ { (keys(%$_))[0] eq $base_format }
+ @{ $supercat->request("open-ils.supercat.$type.formats")->gather(1) }
+ and !grep
+ { $_ eq $base_format }
+ qw/opac html htmlholdings marctxt ris holdings_xml/
+ ) {
+ print "Content-type: text/html; charset=utf-8\n\n";
+ $apache->custom_response( 406, <<" HTML");
+ <html>
+ <head>
+ <title>Invalid format [$format] for type [$type]!</title>
+ </head>
+ <body>
+ <br/>
+ <center>Sorry, format $format is not valid for type $type.</center>
+ </body>
+ </html>
+ HTML
+ return 406;
+ }
+
+ if ($format eq 'opac') {
+ print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?m=$id&l=$lib_id&d=$lib_depth\n\n"
+ if ($type eq 'metarecord');
+ print "Location: $root/../../$locale/skin/$skin/xml/rdetail.xml?r=$id&l=$lib_id&d=$lib_depth\n\n"
+ if ($type eq 'record');
+ return 302;
+ } elsif (OpenILS::WWW::SuperCat::Feed->exists($base_format) && ($type ne 'acn' && $type ne 'acp' && $type ne 'auri')) {
+ my $feed = create_record_feed(
+ $type,
+ $format => [ $id ],
+ $base,
+ $lib,
+ $depth,
+ $flesh_feed,
+ $paging
+ );
+
+ if (!$feed->count) {
+ print "Content-type: text/html; charset=utf-8\n\n";
+ $apache->custom_response( 404, <<" HTML");
+ <html>
+ <head>
+ <title>Type [$type] with id [$id] not found!</title>
+ </head>
+ <body>
+ <br/>
+ <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
+ </body>
+ </html>
+ HTML
+ return 404;
+ }
+
+ $feed->root($root);
+ $feed->creator($host);
+ $feed->update_ts();
+ $feed->link( unapi => $base) if ($flesh_feed);
+
+ print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
+ print $U->entityize($feed->toString) . "\n";
+
+ return Apache2::Const::OK;
+ }
+
+ my $method = "open-ils.supercat.$type.$base_format.$command";
+ my @params = ($id);
+ push @params, $lib, $lib_depth, $flesh_feed, $paging if ($base_format eq 'holdings_xml');
+
+ # for acn, acp, etc, the "lib" pathinfo position isn't useful.
+ # however, we can have it carry extra options like no_record! (comma separated)
+ push @params, { map { ( $_ => 1 ) } split(',', $lib) } if ( grep { $type eq $_} qw/acn acp auri/);
+
+ my $req = $supercat->request($method,@params);
+ my $data = $req->gather();
+
+ if ($req->failed || !$data) {
+ print "Content-type: text/html; charset=utf-8\n\n";
+ $apache->custom_response( 404, <<" HTML");
+ <html>
+ <head>
+ <title>$type $id not found!</title>
+ </head>
+ <body>
+ <br/>
+ <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
+ </body>
+ </html>
+ HTML
+ return 404;
+ }
+
+ print "Content-type: application/xml; charset=utf-8\n\n$data";
+
+ if ($base_format eq 'holdings_xml') {
+ while (my $c = $req->recv) {
+ print $c->content;
+ }
+ }
+
+ return Apache2::Const::OK;
+}
+
+sub supercat {
+
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'supercat', $url)[0];
+ my $base = (split 'supercat', $url)[0] . 'supercat';
+ my $unapi = (split 'supercat', $url)[0] . 'unapi';
+
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $path = $cgi->path_info;
+ my ($id,$type,$format,$command) = reverse split '/', $path;
+ my $flesh_feed = parse_feed_type($format);
+ (my $base_format = $format) =~ s/(-full|-uris)$//o;
+
+ my $skin = $cgi->param('skin') || 'default';
+ my $locale = $cgi->param('locale') || 'en-US';
+
+ # Enable localized results of copy status, etc
+ $supercat->session_locale($locale);
+
+ if ( $path =~ m{^/formats(?:/([^\/]+))?$}o ) {
+ print "Content-type: application/xml; charset=utf-8\n";
+ if ($1) {
+ my $list = $supercat
+ ->request("open-ils.supercat.$1.formats")
+ ->gather(1);
+
+ print "\n";
+
+ print "<formats>
+ <format>
+ <name>opac</name>
+ <type>text/html</type>
+ </format>";
+
+ if ($1 eq 'record' or $1 eq 'isbn') {
+ print "<format>
+ <name>htmlholdings</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>html</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>htmlholdings-full</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>html-full</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>marctxt</name>
+ <type>text/plain</type>
+ </format>
+ <format>
+ <name>ris</name>
+ <type>text/plain</type>
+ </format>";
+ }
+
+ for my $h (@$list) {
+ my ($type) = keys %$h;
+ print supercat_format($h, $type);
+
+ if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
+ print supercat_format($h, "$type-full");
+ print supercat_format($h, "$type-uris");
+ }
+
+ }
+
+ print "</formats>\n";
+
+ return Apache2::Const::OK;
+ }
+
+ my $list = $supercat
+ ->request("open-ils.supercat.record.formats")
+ ->gather(1);
+
+ push @$list,
+ @{ $supercat
+ ->request("open-ils.supercat.metarecord.formats")
+ ->gather(1);
+ };
+
+ my %hash = map { ( (keys %$_)[0] => (values %$_)[0] ) } @$list;
+ $list = [ map { { $_ => $hash{$_} } } sort keys %hash ];
+
+ print "\n<formats>
+ <format>
+ <name>opac</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>htmlholdings</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>html</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>htmlholdings-full</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>html-full</name>
+ <type>text/html</type>
+ </format>
+ <format>
+ <name>marctxt</name>
+ <type>text/plain</type>
+ </format>
+ <format>
+ <name>ris</name>
+ <type>text/plain</type>
+ </format>";
+
+ for my $h (@$list) {
+ my ($type) = keys %$h;
+ print supercat_format($h, $type);
+
+ if (OpenILS::WWW::SuperCat::Feed->exists($type)) {
+ print supercat_format($h, "$type-full");
+ print supercat_format($h, "$type-uris");
+ }
+
+ }
+
+ print "</formats>\n";
+
+
+ return Apache2::Const::OK;
+ }
+
+ if ($format eq 'opac') {
+ print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?m=$id\n\n"
+ if ($type eq 'metarecord');
+ print "Location: $root/../../$locale/skin/$skin/xml/rdetail.xml?r=$id\n\n"
+ if ($type eq 'record');
+ return 302;
+
+ } elsif ($base_format eq 'marc21') {
+
+ my $ret = 200;
+ try {
+ my $bib = $supercat->request( "open-ils.supercat.record.object.retrieve", $id )->gather(1)->[0];
+
+ print "Content-type: application/octet-stream\n\n" . MARC::Record->new_from_xml( $bib->marc, 'UTF-8', 'USMARC' )->as_usmarc;
+
+ } otherwise {
+ warn shift();
+
+ print "Content-type: text/html; charset=utf-8\n\n";
+ $apache->custom_response( 404, <<" HTML");
+ <html>
+ <head>
+ <title>ERROR</title>
+ </head>
+ <body>
+ <br/>
+ <center>Couldn't fetch $id as MARC21.</center>
+ </body>
+ </html>
+ HTML
+ $ret = 404;
+ };
+
+ return Apache2::Const::OK;
+
+ } elsif (OpenILS::WWW::SuperCat::Feed->exists($base_format)) {
+ my $feed = create_record_feed(
+ $type,
+ $format => [ $id ],
+ undef, undef, undef,
+ $flesh_feed
+ );
+
+ $feed->root($root);
+ $feed->creator($host);
+
+ $feed->update_ts();
+
+ $feed->link( unapi => $base) if ($flesh_feed);
+
+ print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
+ print $U->entityize($feed->toString) . "\n";
+
+ return Apache2::Const::OK;
+ }
+
+ my $req = $supercat->request("open-ils.supercat.$type.$format.$command",$id);
+ $req->wait_complete;
+
+ if ($req->failed) {
+ print "Content-type: text/html; charset=utf-8\n\n";
+ $apache->custom_response( 404, <<" HTML");
+ <html>
+ <head>
+ <title>$type $id not found!</title>
+ </head>
+ <body>
+ <br/>
+ <center>Sorry, we couldn't $command a $type with the id of $id in format $format.</center>
+ </body>
+ </html>
+ HTML
+ return 404;
+ }
+
+ print "Content-type: application/xml; charset=utf-8\n\n";
+ print $U->entityize( $parser->parse_string( $req->gather(1) )->documentElement->toString );
+
+ return Apache2::Const::OK;
+}
+
+
+sub bookbag_feed {
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+
+ my $year = (gmtime())[5] + 1900;
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'feed', $url)[0] . '/';
+ my $base = (split 'bookbag', $url)[0] . '/bookbag';
+ my $unapi = (split 'feed', $url)[0] . '/unapi';
+
+ my $skin = $cgi->param('skin') || 'default';
+ my $locale = $cgi->param('locale') || 'en-US';
+ my $org = $cgi->param('searchOrg');
+
+ # Enable localized results of copy status, etc
+ $supercat->session_locale($locale);
+
+ my $org_unit = get_ou($org);
+ my $scope = "l=" . $org_unit->[0]->id . "&";
+
+ $root =~ s{(?<!http:)//}{/}go;
+ $base =~ s{(?<!http:)//}{/}go;
+ $unapi =~ s{(?<!http:)//}{/}go;
+
+ my $path = $cgi->path_info;
+ #warn "URL breakdown: $url -> $root -> $base -> $path -> $unapi";
+
+ my ($id,$type) = reverse split '/', $path;
+ my $flesh_feed = parse_feed_type($type);
+
+ my $bucket = $actor->request("open-ils.actor.container.public.flesh", 'biblio', $id)->gather(1);
+ return Apache2::Const::NOT_FOUND unless($bucket);
+
+ my $bucket_tag = "tag:$host,$year:record_bucket/$id";
+ if ($type eq 'opac') {
+ print "Location: $root/../../$locale/skin/$skin/xml/rresult.xml?$scope" . "rt=list&" .
+ join('&', map { "rl=" . $_->target_biblio_record_entry } @{ $bucket->items }) .
+ "\n\n";
+ return 302;
+ }
+
+ my $feed = create_record_feed(
+ 'record',
+ $type,
+ [ map { $_->target_biblio_record_entry } @{ $bucket->items } ],
+ $unapi,
+ $org_unit->[0]->shortname,
+ undef,
+ $flesh_feed
+ );
+ $feed->root($root);
+ $feed->id($bucket_tag);
+
+ $feed->title("Items in Book Bag [".$bucket->name."]");
+ $feed->creator($host);
+ $feed->update_ts();
+
+ $feed->link(alternate => $base . "/rss2-full/$id" => 'application/rss+xml');
+ $feed->link(atom => $base . "/atom-full/$id" => 'application/atom+xml');
+ $feed->link(html => $base . "/html-full/$id" => 'text/html');
+ $feed->link(unapi => $unapi);
+
+ $feed->link(
+ OPAC =>
+ "http://$host/opac/$locale/skin/$skin/xml/rresult.xml?$scope" . "rt=list&" .
+ join('&', map { 'rl=' . $_->target_biblio_record_entry } @{$bucket->items} ),
+ 'text/html'
+ );
+
+
+ print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
+ print $U->entityize($feed->toString) . "\n";
+
+ return Apache2::Const::OK;
+}
+
+sub changes_feed {
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+
+ my $year = (gmtime())[5] + 1900;
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'feed', $url)[0];
+ my $base = (split 'freshmeat', $url)[0] . '/freshmeat';
+ my $unapi = (split 'feed', $url)[0] . 'unapi';
+
+ my $skin = $cgi->param('skin') || 'default';
+ my $locale = $cgi->param('locale') || 'en-US';
+ my $org = $cgi->param('searchOrg');
+
+ # Enable localized results of copy status, etc
+ $supercat->session_locale($locale);
+
+ my $org_unit = get_ou($org);
+ my $scope = "l=" . $org_unit->[0]->id . "&";
+
+ my $path = $cgi->path_info;
+ #warn "URL breakdown: $url ($rel_name) -> $root -> $base -> $path -> $unapi";
+
+ $path =~ s/^\/(?:feed\/)?freshmeat\///og;
+
+ my ($type,$rtype,$axis,$limit,$date) = split '/', $path;
+ my $flesh_feed = parse_feed_type($type);
+
+ $limit ||= 10;
+ $limit = 10 if $limit !~ /^\d+$/;
+
+ my $list = $supercat->request("open-ils.supercat.$rtype.record.$axis.recent", $date, $limit)->gather(1);
+
+ #if ($type eq 'opac') {
+ # print "Location: $root/../../en-US/skin/default/xml/rresult.xml?rt=list&" .
+ # join('&', map { "rl=" . $_ } @$list) .
+ # "\n\n";
+ # return 302;
+ #}
+
+ my $search = 'record';
+ if ($rtype eq 'authority') {
+ $search = 'authority';
+ }
+ my $feed = create_record_feed( $search, $type, $list, $unapi, $org_unit->[0]->shortname, undef, $flesh_feed);
+ $feed->root($root);
+
+ if ($date) {
+ $feed->title("Up to $limit recent $rtype ${axis}s from $date forward");
+ } else {
+ $feed->title("$limit most recent $rtype ${axis}s");
+ }
+
+ $feed->creator($host);
+ $feed->update_ts();
+
+ $feed->link(alternate => $base . "/rss2-full/$rtype/$axis/$limit/$date" => 'application/rss+xml');
+ $feed->link(atom => $base . "/atom-full/$rtype/$axis/$limit/$date" => 'application/atom+xml');
+ $feed->link(html => $base . "/html-full/$rtype/$axis/$limit/$date" => 'text/html');
+ $feed->link(unapi => $unapi);
+
+ $feed->link(
+ OPAC =>
+ "http://$host/opac/$locale/skin/$skin/xml/rresult.xml?$scope" . "rt=list&" .
+ join('&', map { 'rl=' . $_} @$list ),
+ 'text/html'
+ );
+
+
+ print "Content-type: ". $feed->type ."; charset=utf-8\n\n";
+ print $U->entityize($feed->toString) . "\n";
+
+ return Apache2::Const::OK;
+}
+
+sub opensearch_osd {
+ my $version = shift;
+ my $lib = shift;
+ my $class = shift;
+ my $base = shift;
+
+ if ($version eq '1.0') {
+ print <<OSD;
+Content-type: application/opensearchdescription+xml; charset=utf-8
+
+<?xml version="1.0" encoding="UTF-8"?>
+<OpenSearchDescription xmlns="http://a9.com/-/spec/opensearchdescription/1.0/">
+ <Url>$base/1.0/$lib/-/$class/?searchTerms={searchTerms}&startPage={startPage}&startIndex={startIndex}&count={count}</Url>
+ <Format>http://a9.com/-/spec/opensearchrss/1.0/</Format>
+ <ShortName>$lib</ShortName>
+ <LongName>Search $lib</LongName>
+ <Description>Search the $lib OPAC by $class.</Description>
+ <Tags>$lib book library</Tags>
+ <SampleSearch>harry+potter</SampleSearch>
+ <Developer>Mike Rylander for GPLS/PINES</Developer>
+ <Contact>feedback\@open-ils.org</Contact>
+ <SyndicationRight>open</SyndicationRight>
+ <AdultContent>false</AdultContent>
+</OpenSearchDescription>
+OSD
+ } else {
+ print <<OSD;
+Content-type: application/opensearchdescription+xml; charset=utf-8
+
+<?xml version="1.0" encoding="UTF-8"?>
+<OpenSearchDescription xmlns="http://a9.com/-/spec/opensearch/1.1/">
+ <ShortName>$lib</ShortName>
+ <Description>Search the $lib OPAC by $class.</Description>
+ <Tags>$lib book library</Tags>
+ <Url type="application/rss+xml"
+ template="$base/1.1/$lib/rss2-full/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
+ <Url type="application/atom+xml"
+ template="$base/1.1/$lib/atom-full/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
+ <Url type="application/x-mods3+xml"
+ template="$base/1.1/$lib/mods3/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
+ <Url type="application/x-mods+xml"
+ template="$base/1.1/$lib/mods/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
+ <Url type="application/x-marcxml+xml"
+ template="$base/1.1/$lib/marcxml/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
+ <Url type="text/html"
+ template="$base/1.1/$lib/html-full/$class/?searchTerms={searchTerms}&startPage={startPage?}&startIndex={startIndex?}&count={count?}&searchLang={language?}"/>
+ <LongName>Search $lib</LongName>
+ <Query role="example" searchTerms="harry+potter" />
+ <Developer>Mike Rylander for GPLS/PINES</Developer>
+ <Contact>feedback\@open-ils.org</Contact>
+ <SyndicationRight>open</SyndicationRight>
+ <AdultContent>false</AdultContent>
+ <Language>en-US</Language>
+ <OutputEncoding>UTF-8</OutputEncoding>
+ <InputEncoding>UTF-8</InputEncoding>
+</OpenSearchDescription>
+OSD
+ }
+
+ return Apache2::Const::OK;
+}
+
+sub opensearch_feed {
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+ my $year = (gmtime())[5] + 1900;
+
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'opensearch', $url)[0];
+ my $base = (split 'opensearch', $url)[0] . 'opensearch';
+ my $unapi = (split 'opensearch', $url)[0] . 'unapi';
+
+ my $path = $cgi->path_info;
+ #warn "URL breakdown: $url ($rel_name) -> $root -> $base -> $path -> $unapi";
+
+ if ($path =~ m{^/?(1\.\d{1})/(?:([^/]+)/)?([^/]+)/osd.xml}o) {
+
+ my $version = $1;
+ my $lib = uc($2);
+ my $class = $3;
+
+ if (!$lib || $lib eq '-') {
+ $lib = $actor->request(
+ 'open-ils.actor.org_unit_list.search' => parent_ou => undef
+ )->gather(1)->[0]->shortname;
+ }
+
+ if ($class eq '-') {
+ $class = 'keyword';
+ }
+
+ return opensearch_osd($version, $lib, $class, $base);
+ }
+
+
+ my $page = $cgi->param('startPage') || 1;
+ my $offset = $cgi->param('startIndex') || 1;
+ my $limit = $cgi->param('count') || 10;
+
+ $page = 1 if ($page !~ /^\d+$/);
+ $offset = 1 if ($offset !~ /^\d+$/);
+ $limit = 10 if ($limit !~ /^\d+$/); $limit = 25 if ($limit > 25);
+
+ if ($page > 1) {
+ $offset = ($page - 1) * $limit;
+ } else {
+ $offset -= 1;
+ }
+
+ my ($version,$org,$type,$class,$terms,$sort,$sortdir,$lang) = ('','','','','','','','');
+ (undef,$version,$org,$type,$class,$terms,$sort,$sortdir,$lang) = split '/', $path;
+
+ $lang = $cgi->param('searchLang') if $cgi->param('searchLang');
+ $lang = '' if ($lang eq '*');
+
+ $sort = $cgi->param('searchSort') if $cgi->param('searchSort');
+ $sort ||= '';
+ $sortdir = $cgi->param('searchSortDir') if $cgi->param('searchSortDir');
+ $sortdir ||= '';
+
+ $terms .= " " if ($terms && $cgi->param('searchTerms'));
+ $terms .= $cgi->param('searchTerms') if $cgi->param('searchTerms');
+
+ $class = $cgi->param('searchClass') if $cgi->param('searchClass');
+ $class ||= '-';
+
+ $type = $cgi->param('responseType') if $cgi->param('responseType');
+ $type ||= '-';
+
+ $org = $cgi->param('searchOrg') if $cgi->param('searchOrg');
+ $org ||= '-';
+
+
+ my $kwt = $cgi->param('kw');
+ my $tit = $cgi->param('ti');
+ my $aut = $cgi->param('au');
+ my $sut = $cgi->param('su');
+ my $set = $cgi->param('se');
+
+ $terms .= " " if ($terms && $kwt);
+ $terms .= "keyword: $kwt" if ($kwt);
+ $terms .= " " if ($terms && $tit);
+ $terms .= "title: $tit" if ($tit);
+ $terms .= " " if ($terms && $aut);
+ $terms .= "author: $aut" if ($aut);
+ $terms .= " " if ($terms && $sut);
+ $terms .= "subject: $sut" if ($sut);
+ $terms .= " " if ($terms && $set);
+ $terms .= "series: $set" if ($set);
+
+ if ($version eq '1.0') {
+ $type = 'rss2';
+ } elsif ($type eq '-') {
+ $type = 'atom';
+ }
+ my $flesh_feed = parse_feed_type($type);
+
+ $terms = decode_utf8($terms);
+ $lang = 'eng' if ($lang eq 'en-US');
+
+ $log->debug("OpenSearch terms: $terms");
+
+ my $org_unit = get_ou($org);
+
+ # Apostrophes break search and get indexed as spaces anyway
+ my $safe_terms = $terms;
+ $safe_terms =~ s{'}{ }go;
+
+ my $recs = $search->request(
+ 'open-ils.search.biblio.multiclass.query' => {
+ org_unit => $org_unit->[0]->id,
+ offset => $offset,
+ limit => $limit,
+ sort => $sort,
+ sort_dir => $sortdir,
+ default_class => $class,
+ ($lang ? ( 'language' => $lang ) : ()),
+ } => $safe_terms => 1
+ )->gather(1);
+
+ $log->debug("Hits for [$terms]: $recs->{count}");
+
+ my $feed = create_record_feed(
+ 'record',
+ $type,
+ [ map { $_->[0] } @{$recs->{ids}} ],
+ $unapi,
+ $org,
+ undef,
+ $flesh_feed
+ );
+
+ $log->debug("Feed created...");
+
+ $feed->root($root);
+ $feed->lib($org);
+ $feed->search($safe_terms);
+ $feed->class($class);
+
+ $feed->title("Search results for [$terms] at ".$org_unit->[0]->name);
+
+ $feed->creator($host);
+ $feed->update_ts();
+
+ $feed->_create_node(
+ $feed->{item_xpath},
+ 'http://a9.com/-/spec/opensearch/1.1/',
+ 'totalResults',
+ $recs->{count},
+ );
+
+ $feed->_create_node(
+ $feed->{item_xpath},
+ 'http://a9.com/-/spec/opensearch/1.1/',
+ 'startIndex',
+ $offset + 1,
+ );
+
+ $feed->_create_node(
+ $feed->{item_xpath},
+ 'http://a9.com/-/spec/opensearch/1.1/',
+ 'itemsPerPage',
+ $limit,
+ );
+
+ $log->debug("...basic feed data added...");
+
+ $feed->link(
+ next =>
+ $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang&startIndex=" . int($offset + $limit + 1) . "&count=" . $limit =>
+ 'application/opensearch+xml'
+ ) if ($offset + $limit < $recs->{count});
+
+ $feed->link(
+ previous =>
+ $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang&startIndex=" . int(($offset - $limit) + 1) . "&count=" . $limit =>
+ 'application/opensearch+xml'
+ ) if ($offset);
+
+ $feed->link(
+ self =>
+ $base . "/$version/$org/$type/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
+ 'application/opensearch+xml'
+ );
+
+ $feed->link(
+ alternate =>
+ $base . "/$version/$org/rss2-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
+ 'application/rss+xml'
+ );
+
+ $feed->link(
+ atom =>
+ $base . "/$version/$org/atom-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
+ 'application/atom+xml'
+ );
+
+ $feed->link(
+ 'html' =>
+ $base . "/$version/$org/html/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
+ 'text/html'
+ );
+
+ $feed->link(
+ 'html-full' =>
+ $base . "/$version/$org/html-full/$class?searchTerms=$terms&searchSort=$sort&searchSortDir=$sortdir&searchLang=$lang" =>
+ 'text/html'
+ );
+
+ $feed->link( 'unapi-server' => $unapi);
+
+ $log->debug("...feed links added...");
+
+# $feed->link(
+# opac =>
+# $root . "../$lang/skin/default/xml/rresult.xml?rt=list&" .
+# join('&', map { 'rl=' . $_->[0] } grep { ref $_ && defined $_->[0] } @{$recs->{ids}} ),
+# 'text/html'
+# );
+
+ #print $cgi->header( -type => $feed->type, -charset => 'UTF-8') . entityize($feed->toString) . "\n";
+ print $cgi->header( -type => $feed->type, -charset => 'UTF-8') . $feed->toString . "\n";
+
+ $log->debug("...and feed returned.");
+
+ return Apache2::Const::OK;
+}
+
+sub create_record_feed {
+ my $search = shift;
+ my $type = shift;
+ my $records = shift;
+ my $unapi = shift;
+
+ my $lib = uc(shift()) || '-';
+ my $depth = shift;
+ my $flesh = shift;
+
+ my $paging = shift;
+
+ my $cgi = new CGI;
+ my $base = $cgi->url;
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my ($year,$month,$day) = reverse( (localtime)[3,4,5] );
+ $year += 1900;
+ $month += 1;
+
+ my $tag_prefix = sprintf("tag:open-ils.org,$year-\%0.2d-\%0.2d", $month, $day);
+
+ my $flesh_feed = defined($flesh) ? $flesh : parse_feed_type($type);
+
+ $type =~ s/(-full|-uris)$//o;
+
+ my $feed = new OpenILS::WWW::SuperCat::Feed ($type);
+ $feed->base($base) if ($flesh);
+ $feed->unapi($unapi) if ($flesh);
+
+ $type = 'atom' if ($type eq 'html');
+ $type = 'marcxml' if (($type eq 'htmlholdings') || ($type eq 'marctxt') || ($type eq 'ris'));
+
+ #$records = $supercat->request( "open-ils.supercat.record.object.retrieve", $records )->gather(1);
+
+ my $count = 0;
+ for my $record (@$records) {
+ next unless($record);
+
+ #my $rec = $record->id;
+ my $rec = $record;
+
+ my $item_tag = "$tag_prefix:biblio-record_entry/$rec/$lib";
+ $item_tag = "$tag_prefix:metabib-metarecord/$rec/$lib" if ($search eq 'metarecord');
+ $item_tag = "$tag_prefix:isbn/$rec/$lib" if ($search eq 'isbn');
+ $item_tag .= "/$depth" if (defined($depth));
+
+ $item_tag = "$tag_prefix:authority-record_entry/$rec" if ($search eq 'authority');
+
+ my $xml = $supercat->request(
+ "open-ils.supercat.$search.$type.retrieve",
+ $rec
+ )->gather(1);
+ next unless $xml;
+
+ my $node = $feed->add_item($xml);
+ next unless $node;
+
+ $xml = '';
+ if ($lib && ($type eq 'marcxml' || $type eq 'atom') && $flesh > 0) {
+ my $r = $supercat->request( "open-ils.supercat.$search.holdings_xml.retrieve", $rec, $lib, $depth, $flesh_feed, $paging );
+ while ( !$r->complete ) {
+ $xml .= join('', map {$_->content} $r->recv);
+ }
+ $xml .= join('', map {$_->content} $r->recv);
+ $node->add_holdings($xml);
+ }
+
+ $node->id($item_tag);
+ #$node->update_ts(cleanse_ISO8601($record->edit_date));
+ $node->link(alternate => $feed->unapi . "?id=$item_tag&format=htmlholdings-full" => 'text/html') if ($flesh > 0);
+ $node->link(opac => $feed->unapi . "?id=$item_tag&format=opac") if ($flesh > 0);
+ $node->link(unapi => $feed->unapi . "?id=$item_tag") if ($flesh);
+ $node->link('unapi-id' => $item_tag) if ($flesh);
+ }
+
+ return $feed;
+}
+
+sub string_browse {
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+ my $year = (gmtime())[5] + 1900;
+
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'browse', $url)[0];
+ my $base = (split 'browse', $url)[0] . 'browse';
+ my $unapi = (split 'browse', $url)[0] . 'unapi';
+
+ my $path = $cgi->path_info;
+ $path =~ s/^\///og;
+
+ my ($format,$axis,$site,$string,$page,$page_size) = split '/', $path;
+ #warn " >>> $format -> $axis -> $site -> $string -> $page -> $page_size ";
+
+ return item_age_browse($apache) if ($axis eq 'item-age'); # short-circut to the item-age sub
+
+ my $status = [$cgi->param('status')];
+ my $cpLoc = [$cgi->param('copyLocation')];
+ $site ||= $cgi->param('searchOrg');
+ $page ||= $cgi->param('startPage') || 0;
+ $page_size ||= $cgi->param('count') || 9;
+
+ $page = 0 if ($page !~ /^-?\d+$/);
+ $page_size = 9 if $page_size !~ /^\d+$/;
+
+ my $prev = join('/', $base,$format,$axis,$site,$string,$page - 1,$page_size);
+ my $next = join('/', $base,$format,$axis,$site,$string,$page + 1,$page_size);
+
+ unless ($string and $axis and grep { $axis eq $_ } keys %browse_types) {
+ warn "something's wrong...";
+ warn " >>> format: $format -> axis: $axis -> site: $site -> string: $string -> page: $page -> page_size: $page_size ";
+ return undef;
+ }
+
+ $string = decode_utf8($string);
+ $string =~ s/\+/ /go;
+ $string =~ s/'//go;
+
+ my $tree = $supercat->request(
+ "open-ils.supercat.$axis.browse",
+ $string,
+ (($axis =~ /^authority/) ? () : ($site)),
+ $page_size,
+ $page,
+ $status,
+ $cpLoc
+ )->gather(1);
+
+ (my $norm_format = $format) =~ s/(-full|-uris)$//o;
+
+ my ($header,$content) = $browse_types{$axis}{$norm_format}->($tree,$prev,$next,$format,$unapi,$base,$site);
+ print $header.$content;
+ return Apache2::Const::OK;
+}
+
+sub string_startwith {
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+ my $year = (gmtime())[5] + 1900;
+
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'startwith', $url)[0];
+ my $base = (split 'startwith', $url)[0] . 'startwith';
+ my $unapi = (split 'startwith', $url)[0] . 'unapi';
+
+ my $path = $cgi->path_info;
+ $path =~ s/^\///og;
+
+ my ($format,$axis,$site,$string,$page,$page_size) = split '/', $path;
+ #warn " >>> $format -> $axis -> $site -> $string -> $page -> $page_size ";
+
+ my $status = [$cgi->param('status')];
+ my $cpLoc = [$cgi->param('copyLocation')];
+ $site ||= $cgi->param('searchOrg');
+ $page ||= $cgi->param('startPage') || 0;
+ $page_size ||= $cgi->param('count') || 9;
+
+ $page = 0 if ($page !~ /^-?\d+$/);
+ $page_size = 9 if $page_size !~ /^\d+$/;
+
+ my $prev = join('/', $base,$format,$axis,$site,$string,$page - 1,$page_size);
+ my $next = join('/', $base,$format,$axis,$site,$string,$page + 1,$page_size);
+
+ unless ($string and $axis and grep { $axis eq $_ } keys %browse_types) {
+ warn "something's wrong...";
+ warn " >>> format: $format -> axis: $axis -> site: $site -> string: $string -> page: $page -> page_size: $page_size ";
+ return undef;
+ }
+
+ $string = decode_utf8($string);
+ $string =~ s/\+/ /go;
+ $string =~ s/'//go;
+
+ my $tree = $supercat->request(
+ "open-ils.supercat.$axis.startwith",
+ $string,
+ (($axis =~ /^authority/) ? () : ($site)),
+ $page_size,
+ $page,
+ $status,
+ $cpLoc
+ )->gather(1);
+
+ (my $norm_format = $format) =~ s/(-full|-uris)$//o;
+
+ my ($header,$content) = $browse_types{$axis}{$norm_format}->($tree,$prev,$next,$format,$unapi,$base,$site);
+ print $header.$content;
+ return Apache2::Const::OK;
+}
+
+sub item_age_browse {
+ my $apache = shift;
+ return Apache2::Const::DECLINED if (-e $apache->filename);
+
+ my $cgi = new CGI;
+ my $year = (gmtime())[5] + 1900;
+
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+
+ my $url = $cgi->url(-path_info=>$add_path);
+ my $root = (split 'browse', $url)[0];
+ my $base = (split 'browse', $url)[0] . 'browse';
+ my $unapi = (split 'browse', $url)[0] . 'unapi';
+
+ my $path = $cgi->path_info;
+ $path =~ s/^\///og;
+
+ my ($format,$axis,$site,$page,$page_size) = split '/', $path;
+ #warn " >>> $format -> $axis -> $site -> $page -> $page_size ";
+
+ unless ($axis eq 'item-age') {
+ warn "something's wrong...";
+ warn " >>> $format -> $axis -> $site -> $page -> $page_size ";
+ return undef;
+ }
+
+ my $status = [$cgi->param('status')];
+ my $cpLoc = [$cgi->param('copyLocation')];
+ $site ||= $cgi->param('searchOrg') || '-';
+ $page ||= $cgi->param('startPage') || 1;
+ $page_size ||= $cgi->param('count') || 10;
+
+ $page = 1 if ($page !~ /^-?\d+$/ || $page < 1);
+ $page_size = 10 if $page_size !~ /^\d+$/;
+
+ my $prev = join('/', $base,$format,$axis,$site,$page - 1,$page_size);
+ my $next = join('/', $base,$format,$axis,$site,$page + 1,$page_size);
+
+ my $recs = $supercat->request(
+ "open-ils.supercat.new_book_list",
+ $site,
+ $page_size,
+ $page,
+ $status,
+ $cpLoc
+ )->gather(1);
+
+ (my $norm_format = $format) =~ s/(-full|-uris)$//o;
+
+ my ($header,$content) = $browse_types{$axis}{$norm_format}->($recs,$prev,$next,$format,$unapi,$base,$site);
+ print $header.$content;
+ return Apache2::Const::OK;
+}
+
+our %qualifier_map = (
+
+ # Some EG qualifiers
+ 'eg.site' => 'site',
+ 'eg.sort' => 'sort',
+ 'eg.direction' => 'dir',
+ 'eg.available' => 'available',
+
+ # Title class:
+ 'eg.title' => 'title',
+ 'dc.title' => 'title',
+ 'bib.titleabbreviated' => 'title|abbreviated',
+ 'bib.titleuniform' => 'title|uniform',
+ 'bib.titletranslated' => 'title|translated',
+ 'bib.titlealternative' => 'title',
+ 'bib.titleseries' => 'series',
+ 'eg.series' => 'title',
+
+ # Author/Name class:
+ 'eg.author' => 'author',
+ 'eg.name' => 'author',
+ 'creator' => 'author',
+ 'dc.creator' => 'author',
+ 'dc.contributer' => 'author',
+ 'dc.publisher' => 'keyword',
+ 'bib.name' => 'author',
+ 'bib.namepersonal' => 'author|personal',
+ 'bib.namepersonalfamily'=> 'author|personal',
+ 'bib.namepersonalgiven' => 'author|personal',
+ 'bib.namecorporate' => 'author|corporate',
+ 'bib.nameconference' => 'author|conference',
+
+ # Subject class:
+ 'eg.subject' => 'subject',
+ 'dc.subject' => 'subject',
+ 'bib.subjectplace' => 'subject|geographic',
+ 'bib.subjecttitle' => 'keyword',
+ 'bib.subjectname' => 'subject|name',
+ 'bib.subjectoccupation' => 'keyword',
+
+ # Keyword class:
+ 'eg.keyword' => 'keyword',
+ 'srw.serverchoice' => 'keyword',
+
+ # Identifiers:
+ 'dc.identifier' => 'keyword',
+
+ # Dates:
+ 'bib.dateissued' => undef,
+ 'bib.datecreated' => undef,
+ 'bib.datevalid' => undef,
+ 'bib.datemodified' => undef,
+ 'bib.datecopyright' => undef,
+
+ # Resource Type:
+ 'dc.type' => undef,
+
+ # Format:
+ 'dc.format' => undef,
+
+ # Genre:
+ 'bib.genre' => 'keyword',
+
+ # Target Audience:
+ 'bib.audience' => undef,
+
+ # Place of Origin:
+ 'bib.originplace' => undef,
+
+ # Language
+ 'dc.language' => 'lang',
+
+ # Edition
+ 'bib.edition' => 'keyword',
+
+ # Part:
+ 'bib.volume' => 'keyword',
+ 'bib.issue' => 'keyword',
+ 'bib.startpage' => 'keyword',
+ 'bib.endpage' => 'keyword',
+
+ # Issuance:
+ 'bib.issuance' => 'keyword',
+);
+
+our %qualifier_ids = (
+ eg => 'http://open-ils.org/spec/SRU/context-set/evergreen/v1',
+ dc => 'info:srw/cql-context-set/1/dc-v1.1',
+ bib => 'info:srw/cql-context-set/1/bib-v1.0',
+ srw => ''
+);
+
+our %nested_qualifier_map = (
+ eg => {
+ site => ['site','Evergreen Site Code (shortname)'],
+ sort => ['sort','Sort on relevance, title, author, pubdate, create_date or edit_date'],
+ direction => ['dir','Sort direction (asc|desc)'],
+ available => ['available','Filter to available (true|false)'],
+ title => ['title'],
+ author => ['author'],
+ name => ['author'],
+ subject => ['subject'],
+ keyword => ['keyword'],
+ series => ['series'],
+ },
+ dc => {
+ title => ['title'],
+ creator => ['author'],
+ contributor => ['author'],
+ publisher => ['keyword'],
+ subject => ['subject'],
+ identifier => ['keyword'],
+ type => [undef],
+ format => [undef],
+ language => ['lang'],
+ },
+ bib => {
+ # Title class:
+ titleAbbreviated => ['title'],
+ titleUniform => ['title'],
+ titleTranslated => ['title'],
+ titleAlternative => ['title'],
+ titleSeries => ['series'],
+
+ # Author/Name class:
+ name => ['author'],
+ namePersonal => ['author'],
+ namePersonalFamily => ['author'],
+ namePersonalGiven => ['author'],
+ nameCorporate => ['author'],
+ nameConference => ['author'],
+
+ # Subject class:
+ subjectPlace => ['subject'],
+ subjectTitle => ['keyword'],
+ subjectName => ['subject|name'],
+ subjectOccupation => ['keyword'],
+
+ # Keyword class:
+
+ # Dates:
+ dateIssued => [undef],
+ dateCreated => [undef],
+ dateValid => [undef],
+ dateModified => [undef],
+ dateCopyright => [undef],
+
+ # Genre:
+ genre => ['keyword'],
+
+ # Target Audience:
+ audience => [undef],
+
+ # Place of Origin:
+ originPlace => [undef],
+
+ # Edition
+ edition => ['keyword'],
+
+ # Part:
+ volume => ['keyword'],
+ issue => ['keyword'],
+ startPage => ['keyword'],
+ endPage => ['keyword'],
+
+ # Issuance:
+ issuance => ['keyword'],
+ },
+ srw => {
+ serverChoice => ['keyword'],
+ },
+);
+
+
+my $base_explain = <<XML;
+<explain
+ id="evergreen-sru-explain-full"
+ authoritative="true"
+ xmlns:z="http://explain.z3950.org/dtd/2.0/"
+ xmlns="http://explain.z3950.org/dtd/2.0/">
+ <serverInfo transport="http" protocol="SRU" version="1.1">
+ <host/>
+ <port/>
+ <database/>
+ </serverInfo>
+
+ <databaseInfo>
+ <title primary="true"/>
+ <description primary="true"/>
+ </databaseInfo>
+
+ <indexInfo>
+ <set identifier="info:srw/cql-context-set/1/cql-v1.2" name="cql"/>
+ </indexInfo>
+
+ <schemaInfo>
+ <schema
+ identifier="info:srw/schema/1/marcxml-v1.1"
+ location="http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
+ sort="true"
+ retrieve="true"
+ name="marcxml">
+ <title>MARC21Slim (marcxml)</title>
+ </schema>
+ </schemaInfo>
+
+ <configInfo>
+ <default type="numberOfRecords">50</default>
+ <default type="contextSet">eg</default>
+ <default type="index">keyword</default>
+ <default type="relation">all</default>
+ <default type="sortSchema">marcxml</default>
+ <default type="retrieveSchema">marcxml</default>
+ <setting type="maximumRecords">50</setting>
+ <supports type="relationModifier">relevant</supports>
+ <supports type="relationModifier">stem</supports>
+ <supports type="relationModifier">fuzzy</supports>
+ <supports type="relationModifier">word</supports>
+ </configInfo>
+
+</explain>
+XML
+
+
+my $ex_doc;
+sub sru_search {
+ my $cgi = new CGI;
+
+ my $req = SRU::Request->newFromCGI( $cgi );
+ my $resp = SRU::Response->newFromRequest( $req );
+
+ # Find the org_unit shortname, if passed as part of the URL
+ # http://example.com/opac/extras/sru/SHORTNAME
+ my $url = $cgi->path_info;
+ my ($shortname, $holdings) = $url =~ m#/?([^/]*)(/holdings)?#;
+
+ if ( $resp->type eq 'searchRetrieve' ) {
+
+ # Older versions of Debian packages returned terms to us double-encoded,
+ # so we had to forcefully double-decode them a second time with
+ # an outer decode('utf8', $string) call; this seems to be resolved with
+ # Debian Lenny packages sometime between 2009-07-27 and 2010-02-15
+ my $cql_query = decode_utf8($req->query);
+ my $search_string = decode_utf8($req->cql->toEvergreen);
+
+ # Ensure the search string overrides the default site
+ if ($shortname and $search_string !~ m#site:#) {
+ $search_string .= " site:$shortname";
+ }
+
+ my $offset = $req->startRecord;
+ $offset-- if ($offset);
+ $offset ||= 0;
+
+ my $limit = $req->maximumRecords;
+ $limit ||= 10;
+
+ $log->info("SRU search string [$cql_query] converted to [$search_string]\n");
+
+ my $recs = $search->request(
+ 'open-ils.search.biblio.multiclass.query' => {offset => $offset, limit => $limit} => $search_string => 1
+ )->gather(1);
+
+ my $bre = $supercat->request( 'open-ils.supercat.record.object.retrieve' => [ map { $_->[0] } @{$recs->{ids}} ] )->gather(1);
+
+ foreach my $record (@$bre) {
+ my $marcxml = $record->marc;
+ # Make the beast conform to a VDX-supported format
+ # See http://vdxipedia.oclc.org/index.php/Holdings_Parsing
+ # Trying to implement LIBSOL_852_A format; so much for standards
+ if ($holdings) {
+ my $bib_holdings = $supercat->request('open-ils.supercat.record.basic_holdings.retrieve', $record->id, $shortname || '-')->gather(1);
+ my $marc = MARC::Record->new_from_xml($marcxml, 'UTF8', 'XML');
+
+ # Force record leader to 'a' as our data is always UTF8
+ # Avoids marc8_to_utf8 from being invoked with horrible results
+ # on the off-chance the record leader isn't correct
+ my $ldr = $marc->leader;
+ substr($ldr, 9, 1, 'a');
+ $marc->leader($ldr);
+
+ # Expects the record ID in the 001
+ $marc->delete_field($_) for ($marc->field('001'));
+ if (!$marc->field('001')) {
+ $marc->insert_fields_ordered(
+ MARC::Field->new( '001', $record->id )
+ );
+ }
+ $marc->delete_field($_) for ($marc->field('852')); # remove any legacy 852s
+ foreach my $cn (keys %$bib_holdings) {
+ foreach my $cp (@{$bib_holdings->{$cn}->{'copies'}}) {
+ $marc->insert_fields_ordered(
+ MARC::Field->new(
+ '852', '4', '',
+ a => $cp->{'location'},
+ b => $bib_holdings->{$cn}->{'owning_lib'},
+ c => $cn,
+ d => $cp->{'circlib'},
+ g => $cp->{'barcode'},
+ n => $cp->{'status'},
+ )
+ );
+ }
+ }
+
+ # Ensure the data is encoded as UTF8 before we hand it off
+ $marcxml = encode_utf8($marc->as_xml_record());
+ $marcxml =~ s/^<\?xml version="1.0" encoding="UTF-8"\?>//o;
+
+ }
+ $resp->addRecord(
+ SRU::Response::Record->new(
+ recordSchema => 'info:srw/schema/1/marcxml-v1.1',
+ recordData => $marcxml,
+ recordPosition => ++$offset
+ )
+ );
+ }
+
+ $resp->numberOfRecords($recs->{count});
+
+ } elsif ( $resp->type eq 'explain' ) {
+ if (!$ex_doc) {
+ my $host = $cgi->virtual_host || $cgi->server_name;
+
+ my $add_path = 0;
+ if ( $cgi->server_software !~ m|^Apache/2.2| ) {
+ my $rel_name = $cgi->url(-relative=>1);
+ $add_path = 1 if ($cgi->url(-path_info=>1) !~ /$rel_name$/);
+ }
+ my $base = $cgi->url(-base=>1);
+ my $url = $cgi->url(-path_info=>$add_path);
+ $url =~ s/^$base\///o;
+
+ my $doc = $parser->parse_string($base_explain);
+ my $e = $doc->documentElement;
+ $e->findnodes('/z:explain/z:serverInfo/z:host')->shift->appendText( $host );
+ $e->findnodes('/z:explain/z:serverInfo/z:port')->shift->appendText( $cgi->server_port );
+ $e->findnodes('/z:explain/z:serverInfo/z:database')->shift->appendText( $url );
+
+ for my $name ( keys %OpenILS::WWW::SuperCat::nested_qualifier_map ) {
+
+ my $identifier = $OpenILS::WWW::SuperCat::qualifier_ids{ $name };
+
+ next unless $identifier;
+
+ my $set_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'set' );
+ $set_node->setAttribute( identifier => $identifier );
+ $set_node->setAttribute( name => $name );
+
+ $e->findnodes('/z:explain/z:indexInfo')->shift->appendChild( $set_node );
+
+ for my $index ( keys %{ $OpenILS::WWW::SuperCat::nested_qualifier_map{$name} } ) {
+ my $desc = $OpenILS::WWW::SuperCat::nested_qualifier_map{$name}{$index}[1] || $index;
+
+ my $name_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'name' );
+
+ my $map_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'map' );
+ $map_node->appendChild( $name_node );
+
+ my $title_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'title' );
+
+ my $index_node = $doc->createElementNS( 'http://explain.z3950.org/dtd/2.0/', 'index' );
+ $index_node->appendChild( $title_node );
+ $index_node->appendChild( $map_node );
+
+ $index_node->setAttribute( id => $name . '.' . $index );
+ $title_node->appendText( $desc );
+ $name_node->setAttribute( set => $name );
+ $name_node->appendText($index );
+
+ $e->findnodes('/z:explain/z:indexInfo')->shift->appendChild( $index_node );
+ }
+ }
+
+ $ex_doc = $e->toString;
+ }
+
+ $resp->record(
+ SRU::Response::Record->new(
+ recordSchema => 'info:srw/cql-context-set/2/zeerex-1.1',
+ recordData => $ex_doc
+ )
+ );
+ }
+
+ print $cgi->header( -type => 'application/xml' );
+ print $U->entityize($resp->asXML) . "\n";
+ return Apache2::Const::OK;
+}
+
+
+{
+ package CQL::BooleanNode;
+
+ sub toEvergreen {
+ my $self = shift;
+ my $left = $self->left();
+ my $right = $self->right();
+ my $leftStr = $left->toEvergreen;
+ my $rightStr = $right->toEvergreen();
+
+ my $op = '||' if uc $self->op() eq 'OR';
+ $op ||= '&&';
+
+ return "$leftStr $rightStr";
+ }
+
+ package CQL::TermNode;
+
+ sub toEvergreen {
+ my $self = shift;
+ my $qualifier = $self->getQualifier();
+ my $term = $self->getTerm();
+ my $relation = $self->getRelation();
+
+ my $query;
+ if ( $qualifier ) {
+ my ($qset, $qname) = split(/\./, $qualifier);
+
+ $log->debug("SRU toEvergreen: $qset, $qname $OpenILS::WWW::SuperCat::nested_qualifier_map{$qset}{$qname}[0]\n");
+
+ if ( exists($OpenILS::WWW::SuperCat::nested_qualifier_map{$qset}{$qname}) ) {
+ $qualifier = $OpenILS::WWW::SuperCat::nested_qualifier_map{$qset}{$qname}[0] || 'kw';
+ }
+
+ my @modifiers = $relation->getModifiers();
+
+ my $base = $relation->getBase();
+ if ( grep { $base eq $_ } qw/= scr exact all/ ) {
+
+ my $quote_it = 1;
+ foreach my $m ( @modifiers ) {
+ if( grep { $m->[ 1 ] eq $_ } qw/cql.fuzzy cql.stem cql.relevant cql.word/ ) {
+ $quote_it = 0;
+ last;
+ }
+ }
+
+ $quote_it = 0 if ( $base eq 'all' );
+ $term = maybeQuote($term) if $quote_it;
+
+ } else {
+ croak( "Evergreen doesn't support the $base relations" );
+ }
+
+
+ } else {
+ $qualifier = "kw";
+ }
+
+ return "$qualifier:$term";
+ }
+}
+
+=head2 get_ou($org_unit)
+
+Returns an aou object for a given actor.org_unit shortname or ID.
+
+=cut
+
+sub get_ou {
+ my $org = shift || '-';
+ my $org_unit;
+
+ if ($org eq '-') {
+ $org_unit = $actor->request(
+ 'open-ils.actor.org_unit_list.search' => parent_ou => undef
+ )->gather(1);
+ } elsif ($org !~ /^\d+$/o) {
+ $org_unit = $actor->request(
+ 'open-ils.actor.org_unit_list.search' => shortname => uc($org)
+ )->gather(1);
+ } else {
+ $org_unit = $actor->request(
+ 'open-ils.actor.org_unit_list.search' => id => $org
+ )->gather(1);
+ }
+
+ return $org_unit;
+}
+
+1;
+
+# vim: noet:ts=4:sw=4
--- /dev/null
+package OpenILS::WWW::SuperCat::Feed;
+use strict; use warnings;
+use vars qw/$parser/;
+use OpenSRF::EX qw(:try);
+use XML::LibXML;
+use XML::LibXSLT;
+use OpenSRF::Utils::SettingsClient;
+use CGI;
+use DateTime;
+use DateTime::Format::Mail;
+
+
+sub exists {
+ my $class = shift;
+ my $type = shift;
+
+ return 1 if UNIVERSAL::can("OpenILS::WWW::SuperCat::Feed::$type" => 'new');
+ return 0;
+}
+
+sub new {
+ my $class = shift;
+ my $type = shift;
+ if ($type) {
+ $class .= '::'.$type;
+ return $class->new;
+ }
+ throw OpenSRF::EX::ERROR ("I need a feed type!") ;
+}
+
+sub build {
+ my $class = shift;
+ my $xml = shift;
+ return undef unless $xml;
+
+ $parser = new XML::LibXML if (!$parser);
+
+ my $self = { doc => $parser->parse_string($xml), items => [] };
+
+ $self = bless $self => $class;
+ $self->{count} = 0;
+ return $self;
+}
+
+sub type {
+ my $self = shift;
+ my $type = shift;
+ $self->{type} = $type if ($type);
+ return $self->{type};
+}
+
+sub count {
+ my $self = shift;
+ return $self->{count};
+}
+
+sub search {
+ my $self = shift;
+ my $search = shift;
+ $self->{search} = $search if ($search);
+ return $self->{search};
+}
+
+sub class {
+ my $self = shift;
+ my $search = shift;
+ $self->{class} = $search if ($search);
+ return $self->{class};
+}
+
+sub Sort {
+ my $self = shift;
+ my $search = shift;
+ $self->{sort} = $search if ($search);
+ return $self->{sort};
+}
+
+sub SortDir {
+ my $self = shift;
+ my $search = shift;
+ $self->{sort_dir} = $search if ($search);
+ return $self->{sort_dir};
+}
+
+sub lang {
+ my $self = shift;
+ my $search = shift;
+ $self->{lang} = $search if ($search);
+ return $self->{lang};
+}
+
+sub lib {
+ my $self = shift;
+ my $lib = shift;
+ $self->{lib} = $lib if ($lib);
+ return $self->{lib};
+}
+
+sub base {
+ my $self = shift;
+ my $base = shift;
+ $self->{base} = $base if ($base);
+ return $self->{base};
+}
+
+sub root {
+ my $self = shift;
+ my $root = shift;
+ $self->{root} = $root if ($root);
+ return $self->{root};
+}
+
+sub unapi {
+ my $self = shift;
+ my $unapi = shift;
+ $self->{unapi} = $unapi if ($unapi);
+ return $self->{unapi};
+}
+
+sub push_item {
+ my $self = shift;
+ $self->{count} += scalar(@_);
+ push @{ $self->{items} }, @_;
+}
+
+sub items {
+ my $self = shift;
+ return @{ $self->{items} } if (wantarray);
+ return $self->{items};
+}
+
+sub _add_node {
+ my $self = shift;
+
+ my $xpath = shift;
+ my $new = shift;
+
+ for my $node ($self->{doc}->findnodes($xpath)) {
+ $node->appendChild($new);
+ last;
+ }
+}
+
+sub _create_node {
+ my $self = shift;
+
+ my $xpath = shift;
+ my $ns = shift;
+ my $name = shift;
+ my $text = shift;
+ my $attrs = shift;
+
+ for my $node ($self->{doc}->findnodes($xpath)) {
+ my $new = $self->{doc}->createElement($name) if (!$ns);
+ $new = $self->{doc}->createElementNS($ns,$name) if ($ns);
+
+ $new->appendChild( $self->{doc}->createTextNode( $text ) )
+ if (defined $text);
+
+ if (ref($attrs)) {
+ for my $key (keys %$attrs) {
+ next unless $$attrs{$key};
+ $new->setAttribute( $key => $$attrs{$key} );
+ }
+ }
+
+ $node->appendChild( $new );
+
+ return $new;
+ }
+}
+
+sub add_item {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ $class .= '::item';
+
+ my $item_xml = shift;
+ my $entry = $class->new($item_xml);
+ return undef unless $entry;
+
+ $entry->base($self->base);
+ $entry->unapi($self->unapi);
+
+ $self->push_item($entry);
+ return $entry;
+}
+
+sub add_holdings {
+ my $self = shift;
+ my $holdings_xml = shift;
+
+ return $self unless ($holdings_xml);
+
+ $parser = new XML::LibXML if (!$parser);
+ my $new_doc = $parser->parse_string($holdings_xml);
+
+ for my $root ( $self->{doc}->findnodes($self->{holdings_xpath}) ) {
+ $root->appendChild($new_doc->documentElement);
+ last;
+ }
+ return $self;
+}
+
+sub composeDoc {
+ my $self = shift;
+ for my $root ( $self->{doc}->findnodes($self->{item_xpath}) ) {
+ for my $item ( $self->items ) {
+ $root->appendChild( $item->{doc}->documentElement );
+ }
+ last;
+ }
+}
+
+sub toString {
+ my $self = shift;
+ $self->composeDoc;
+ return $self->{doc}->toString(1);
+}
+
+sub id {};
+sub link {};
+sub title {};
+sub update_ts {};
+sub creator {};
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::atom;
+use base 'OpenILS::WWW::SuperCat::Feed';
+use OpenSRF::Utils qw/:datetime/;
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<feed xmlns:atom="http://www.w3.org/2005/Atom"/>');
+ $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', undef);
+ $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', 'atom');
+ $self->{type} = 'application/atom+xml';
+ $self->{item_xpath} = '/atom:feed';
+ return $self;
+}
+
+sub title {
+ my $self = shift;
+ my $text = shift;
+ $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','title', $text);
+}
+
+sub update_ts {
+ my $self = shift;
+ # ATOM demands RFC-3339 compliant datetime formats
+ my $text = shift || gmtime_ISO8601();
+ $self->_create_node($self->{item_xpath},'http://www.w3.org/2005/Atom','updated', $text);
+}
+
+sub creator {
+ my $self = shift;
+ my $text = shift;
+ $self->_create_node('/atom:feed','http://www.w3.org/2005/Atom','author');
+ $self->_create_node('/atom:feed/atom:author', 'http://www.w3.org/2005/Atom','name', $text);
+}
+
+sub link {
+ my $self = shift;
+ my $type = shift;
+ my $id = shift;
+ my $mime = shift || "application/x-$type+xml";
+ my $title = shift;
+
+ $type = 'self' if ($type eq 'atom');
+
+ $self->_create_node(
+ $self->{item_xpath},
+ 'http://www.w3.org/2005/Atom',
+ 'link',
+ undef,
+ { rel => $type,
+ href => $id,
+ title => $title,
+ type => $mime,
+ }
+ );
+}
+
+sub id {
+ my $self = shift;
+ my $id = shift;
+
+ $self->_create_node( $self->{item_xpath}, 'http://www.w3.org/2005/Atom', 'id', $id );
+}
+
+package OpenILS::WWW::SuperCat::Feed::atom::item;
+use base 'OpenILS::WWW::SuperCat::Feed::atom';
+
+sub new {
+ my $class = shift;
+ my $xml = shift;
+ my $self = $class->SUPER::build($xml);
+ $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', undef);
+ $self->{doc}->documentElement->setNamespace('http://www.w3.org/2005/Atom', 'atom');
+ $self->{item_xpath} = '/atom:entry';
+ $self->{holdings_xpath} = '/atom:entry';
+ $self->{type} = 'application/atom+xml';
+ return $self;
+}
+
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::rss2;
+use base 'OpenILS::WWW::SuperCat::Feed';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<rss version="2.0"><channel/></rss>');
+ $self->{type} = 'application/rss+xml';
+ $self->{item_xpath} = '/rss/channel';
+ return $self;
+}
+
+sub title {
+ my $self = shift;
+ my $text = shift;
+ $self->_create_node('/rss/channel',undef,'title', $text);
+ # RSS2 demands a /channel/description element; just dupe title until we give
+ # users the ability to provide a description for their bookbags
+ $self->_create_node('/rss/channel',undef,'description', $text);
+}
+
+sub update_ts {
+ my $self = shift;
+ # RSS2 demands RFC-822 compliant datetime formats
+ my $text = shift || DateTime::Format::Mail->format_datetime(DateTime->now());
+ $self->_create_node($self->{item_xpath},undef,'lastBuildDate', $text);
+}
+
+sub creator {
+ my $self = shift;
+ my $text = shift;
+ $self->_create_node('/rss/channel', undef,'generator', $text);
+}
+
+sub link {
+ my $self = shift;
+ my $type = shift;
+ my $id = shift;
+ my $mime = shift || "application/x-$type+xml";
+
+ if ($type eq 'rss2' or $type eq 'alternate') {
+ # Just link to ourself using standard RSS2 link element
+ $self->_create_node(
+ $self->{item_xpath},
+ undef,
+ 'link',
+ $id,
+ undef
+ );
+ } else {
+ # Alternate link: use XHTML link element
+ $self->_create_node(
+ $self->{item_xpath},
+ 'http://www.w3.org/1999/xhtml',
+ 'xhtml:link',
+ $id,
+ { rel => $type,
+ type => $mime,
+ }
+ );
+ }
+}
+
+sub id {
+ my $self = shift;
+ my $id = shift;
+
+ $self->_create_node($self->{item_xpath}, undef,'guid', $id);
+}
+
+package OpenILS::WWW::SuperCat::Feed::rss2::item;
+use base 'OpenILS::WWW::SuperCat::Feed::rss2';
+
+sub new {
+ my $class = shift;
+ my $xml = shift;
+ my $self = $class->SUPER::build($xml);
+ $self->{type} = 'application/rss+xml';
+ $self->{item_xpath} = '/item';
+ $self->{holdings_xpath} = '/item';
+ return $self;
+}
+
+sub update_ts {
+ my $self = shift;
+ # RSS2 demands RFC-822 compliant datetime formats
+ my $text = shift;
+ if (!$text) {
+ # No date passed in, default to now
+ $text = DateTime::Format::Mail->format_datetime(DateTime->now());
+ } elsif ($text =~ m/^\s*(\d{4})\.?\s*$/o) {
+ # Publication date is just a year, convert accordingly
+ my $year = DateTime->new(year=>$1);
+ $text = DateTime::Format::Mail->format_datetime($year);
+ }
+ $self->_create_node($self->{item_xpath},undef,'pubDate', $text);
+}
+
+sub id {
+ my $self = shift;
+ my $id = shift;
+
+ $self->_create_node(
+ $self->{item_xpath},
+ undef,
+ 'guid',
+ $id,
+ {
+ isPermaLink=>"false"
+ }
+ );
+}
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::mods;
+use base 'OpenILS::WWW::SuperCat::Feed';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<modsCollection version="3.0" xmlns="http://www.loc.gov/mods/" xmlns:mods="http://www.loc.gov/mods/"/>');
+ $self->{type} = 'application/xml';
+ $self->{item_xpath} = '/mods:modsCollection';
+ return $self;
+}
+
+package OpenILS::WWW::SuperCat::Feed::mods::item;
+use base 'OpenILS::WWW::SuperCat::Feed::mods';
+
+sub new {
+ my $class = shift;
+ my $xml = shift;
+ my $self = $class->SUPER::build($xml);
+ $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/', 'mods');
+ $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/', undef, 1);
+ $self->{type} = 'application/xml';
+ $self->{holdings_xpath} = '/mods:mods';
+ return $self;
+}
+
+my $linkid = 1;
+
+sub link {
+ my $self = shift;
+ my $type = shift;
+ my $id = shift;
+
+ if ($type eq 'unapi' || $type eq 'opac') {
+ $self->_create_node(
+ 'mods:mods',
+ undef,
+ 'relatedItem',
+ undef,
+ { type => 'otherFormat', id => 'link-'.$linkid }
+ );
+ $self->_create_node(
+ "mods:mods/relatedItem[\@id='link-$linkid']",
+ undef,
+ 'recordIdentifier',
+ $id
+ );
+ $linkid++;
+ }
+}
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::mods3;
+use base 'OpenILS::WWW::SuperCat::Feed::mods';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<modsCollection version="3.0" xmlns="http://www.loc.gov/mods/v3" xmlns:mods="http://www.loc.gov/mods/v3"/>');
+ $self->{type} = 'application/xml';
+ $self->{item_xpath} = '/mods:modsCollection';
+ return $self;
+}
+
+package OpenILS::WWW::SuperCat::Feed::mods3::item;
+use base 'OpenILS::WWW::SuperCat::Feed::mods::item';
+
+sub new {
+ my $class = shift;
+ my $xml = shift;
+ my $self = $class->SUPER::build($xml);
+ $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/v3', 'mods');
+ $self->{doc}->documentElement->setNamespace('http://www.loc.gov/mods/v3', undef, 1);
+ $self->{type} = 'application/xml';
+ $self->{holdings_xpath} = '/mods:mods';
+ return $self;
+}
+
+sub link {
+ my $self = shift;
+ my $type = shift;
+ my $id = shift;
+
+ if ($type eq 'unapi' || $type eq 'opac') {
+ $self->_create_node(
+ 'mods:mods',
+ undef,
+ 'relatedItem',
+ undef,
+ { type => 'otherFormat', id => 'link-'.$linkid }
+ );
+ $self->_create_node(
+ "mods:mods/relatedItem[\@id='link-$linkid']",
+ undef,
+ 'recordIdentifier',
+ $id
+ );
+ $linkid++;
+ }
+}
+
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::mods32;
+use base 'OpenILS::WWW::SuperCat::Feed::mods3';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<modsCollection version="3.2" xmlns="http://www.loc.gov/mods/v3" xmlns:mods="http://www.loc.gov/mods/v3"/>');
+ $self->{type} = 'application/xml';
+ $self->{item_xpath} = '/mods:modsCollection';
+ return $self;
+}
+
+package OpenILS::WWW::SuperCat::Feed::mods32::item;
+use base 'OpenILS::WWW::SuperCat::Feed::mods3::item';
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::mods33;
+use base 'OpenILS::WWW::SuperCat::Feed::mods3';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<modsCollection version="3.3" xmlns="http://www.loc.gov/mods/v3" xmlns:mods="http://www.loc.gov/mods/v3"/>');
+ $self->{type} = 'application/xml';
+ $self->{item_xpath} = '/mods:modsCollection';
+ return $self;
+}
+
+package OpenILS::WWW::SuperCat::Feed::mods33::item;
+use base 'OpenILS::WWW::SuperCat::Feed::mods3::item';
+
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::marcxml;
+use base 'OpenILS::WWW::SuperCat::Feed';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::build('<collection xmlns="http://www.loc.gov/MARC21/slim" xmlns:marc="http://www.loc.gov/MARC21/slim"/>');
+ $self->{type} = 'application/xml';
+ $self->{item_xpath} = '/marc:collection';
+ return $self;
+}
+sub link {
+ my $self = shift;
+ my $type = shift;
+ my $id = shift;
+
+ if ($type eq 'unapi') {
+ $self->_create_node(
+ 'marc:collection',
+ 'http://www.w3.org/1999/xhtml',
+ 'xhtml:link',
+ undef,
+ { rel => 'unapi-server', href => $id, title => "unapi" }
+ );
+ $linkid++;
+ }
+}
+
+
+package OpenILS::WWW::SuperCat::Feed::marcxml::item;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
+
+sub new {
+ my $class = shift;
+ my $xml = shift;
+ my $self = $class->SUPER::build($xml);
+ return undef unless $self;
+ $self->{doc}->documentElement->setNamespace('http://www.loc.gov/MARC21/slim', undef);
+ $self->{type} = 'application/xml';
+ $self->{holdings_xpath} = '/*[local-name()="record"]';
+ return $self;
+}
+
+sub link {
+ my $self = shift;
+ my $type = shift;
+ my $id = shift;
+
+ if ($type eq 'opac') {
+ $self->_create_node(
+ '*[local-name()="record"]',
+ 'http://www.w3.org/1999/xhtml',
+ 'xhtml:link',
+ undef,
+ { rel => 'otherFormat', href => $id, title => "Dynamic Details" }
+ );
+ $linkid++;
+ } elsif ($type eq 'unapi-id') {
+ $self->_create_node(
+ '*[local-name()="record"]',
+ 'http://www.w3.org/1999/xhtml',
+ 'xhtml:abbr',
+ undef,
+ { title => $id, class => "unapi-id" }
+ );
+ $linkid++;
+ }
+}
+
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::html;
+use base 'OpenILS::WWW::SuperCat::Feed::atom';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+ $self->type('text/html');
+ return $self;
+}
+
+our ($_parser, $_xslt, $xslt_file);
+
+sub toString {
+ my $self = shift;
+ my $base = $self->base || '';
+ my $root = $self->root || '';
+ my $search = $self->search || '';
+ my $class = $self->class || '';
+ my $lib = $self->lib || '-';
+
+ $self->composeDoc;
+
+ $_parser ||= new XML::LibXML;
+ $_xslt ||= new XML::LibXSLT;
+
+ $xslt_file ||=
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ "/ATOM2XHTML.xsl";
+
+ # parse the MODS xslt ...
+ my $atom2html_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
+
+ my $new_doc = $atom2html_xslt->transform(
+ $self->{doc},
+ base_dir => "'$root'",
+ lib => "'$lib'",
+ searchTerms => "'$search'",
+ searchClass => "'$class'",
+ );
+
+ return $new_doc->toString(1);
+}
+
+
+package OpenILS::WWW::SuperCat::Feed::html::item;
+use base 'OpenILS::WWW::SuperCat::Feed::atom::item';
+
+#----------------------------------------------------------
+
+package OpenILS::WWW::SuperCat::Feed::htmlcard;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+ $self->type('text/html');
+ $self->{xsl} = "/MARC21slim2HTMLCard.xsl";
+ return $self;
+}
+
+our ($_parser, $_xslt, $xslt_file);
+
+sub toString {
+ my $self = shift;
+ my $base = $self->base || '';
+ my $root = $self->root || '';
+ my $search = $self->search || '';
+ my $sort = $self->Sort || '';
+ my $sort_dir = $self->SortDir || '';
+ my $lang = $self->lang || '';
+ my $lib = $self->lib || '-';
+
+ $self->composeDoc;
+
+ $_parser ||= new XML::LibXML;
+ $_xslt ||= new XML::LibXSLT;
+
+ $xslt_file =
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).$self->{xsl};
+
+ # parse the MODS xslt ...
+ my $atom2html_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
+
+ my $new_doc = $atom2html_xslt->transform(
+ $self->{doc},
+ base_dir => "'$root'",
+ lib => "'$lib'",
+ searchTerms => "'$search'",
+ searchSort => "'$sort'",
+ searchSortDir => "'$sort_dir'",
+ searchLang => "'$lang'",
+ );
+
+ return $new_doc->toString(1);
+}
+
+package OpenILS::WWW::SuperCat::Feed::htmlcard::item;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml::item';
+
+package OpenILS::WWW::SuperCat::Feed::htmlholdings;
+use base 'OpenILS::WWW::SuperCat::Feed::htmlcard';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+ $self->{xsl} = "/MARC21slim2HTMLCard-holdings.xsl";
+ return $self;
+}
+
+package OpenILS::WWW::SuperCat::Feed::htmlholdings::item;
+use base 'OpenILS::WWW::SuperCat::Feed::htmlcard::item';
+
+
+package OpenILS::WWW::SuperCat::Feed::marctxt;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+ $self->{type} = 'text/plain';
+ $self->{xsl} = "/MARC21slim2MARCtxt.xsl";
+ return $self;
+}
+
+
+our ($_parser, $_xslt, $xslt_file);
+
+sub toString {
+ my $self = shift;
+ my $base = $self->base || '';
+ my $root = $self->root || '';
+ my $search = $self->search || '';
+ my $class = $self->class || '';
+ my $lib = $self->lib || '-';
+
+ $self->composeDoc;
+
+ $_parser ||= new XML::LibXML;
+ $_xslt ||= new XML::LibXSLT;
+
+ $xslt_file ||=
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ $self->{xsl};
+
+ # parse the MARC text xslt ...
+ my $marctxt_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
+
+ my $new_doc = $marctxt_xslt->transform(
+ $self->{doc},
+ base_dir => "'$root'",
+ lib => "'$lib'",
+ searchTerms => "'$search'",
+ searchClass => "'$class'",
+ );
+
+ return $marctxt_xslt->output_string($new_doc);
+}
+
+
+package OpenILS::WWW::SuperCat::Feed::marctxt::item;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml::item';
+
+
+package OpenILS::WWW::SuperCat::Feed::ris;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml';
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new;
+ $self->{type} = 'text/plain';
+ $self->{xsl} = "/MARC21slim2RIS.xsl";
+ return $self;
+}
+
+
+our ($_parser, $_xslt, $xslt_file);
+
+sub toString {
+ my $self = shift;
+ my $base = $self->base || '';
+ my $root = $self->root || '';
+ my $search = $self->search || '';
+ my $class = $self->class || '';
+ my $lib = $self->lib || '-';
+
+ $self->composeDoc;
+
+ $_parser ||= new XML::LibXML;
+ $_xslt ||= new XML::LibXSLT;
+
+ $xslt_file ||=
+ OpenSRF::Utils::SettingsClient
+ ->new
+ ->config_value( dirs => 'xsl' ).
+ $self->{xsl};
+
+ # parse the MARC text xslt ...
+ my $ris_xslt = $_xslt->parse_stylesheet( $_parser->parse_file($xslt_file) );
+
+ my $new_doc = $ris_xslt->transform(
+ $self->{doc},
+ base_dir => "'$root'",
+ lib => "'$lib'",
+ searchTerms => "'$search'",
+ searchClass => "'$class'",
+ );
+
+ return $ris_xslt->output_string($new_doc);
+}
+
+
+package OpenILS::WWW::SuperCat::Feed::ris::item;
+use base 'OpenILS::WWW::SuperCat::Feed::marcxml::item';
+
+
+1;
--- /dev/null
+package OpenILS::WWW::TemplateBatchBibUpdate;
+use strict;
+use warnings;
+use bytes;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use APR::Table;
+
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+use Data::Dumper;
+use Text::CSV;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils qw/:datetime/;
+use OpenSRF::Utils::Cache;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use XML::LibXML;
+use XML::LibXSLT;
+
+use Encode;
+use Unicode::Normalize;
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use MARC::Record;
+use MARC::File::XML;
+
+use UNIVERSAL::require;
+
+our @formats = qw/USMARC UNIMARC XML BRE/;
+
+# set the bootstrap config and template include directory when
+# this module is loaded
+my $bootstrap;
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+ Fieldmapper->import(IDL => OpenSRF::Utils::SettingsClient->new->config_value("IDL"));
+}
+
+sub handler {
+ my $r = shift;
+ my $cgi = new CGI;
+
+ my $authid = $cgi->cookie('ses') || $cgi->param('ses');
+ my $usr = verify_login($authid);
+ return show_template($r) unless ($usr);
+
+ my $template = $cgi->param('template');
+ return show_template($r) unless ($template);
+
+
+ my $rsource = $cgi->param('recordSource');
+ # find some IDs ...
+ my @records;
+
+ if ($rsource eq 'r') {
+ @records = map { $_ ? ($_) : () } $cgi->param('recid');
+ }
+
+ if ($rsource eq 'c') { # try for a file
+ my $file = $cgi->param('idfile');
+ if ($file) {
+ my $col = $cgi->param('idcolumn') || 0;
+ my $csv = new Text::CSV;
+
+ while (<$file>) {
+ $csv->parse($_);
+ my @data = $csv->fields;
+ my $id = $data[$col];
+ $id =~ s/\D+//o;
+ next unless ($id);
+ push @records, $id;
+ }
+ }
+ }
+
+ my $e = OpenSRF::AppSession->connect('open-ils.cstore');
+ $e->request('open-ils.cstore.transaction.begin')->gather(1);
+
+ # still no records ...
+ my $container = $cgi->param('containerid');
+ if ($rsource eq 'b') {
+ if ($container) {
+ my $bucket = $e->request(
+ 'open-ils.cstore.direct.container.biblio_record_entry_bucket.retrieve',
+ $container
+ )->gather(1);
+ unless($bucket) {
+ $e->request('open-ils.cstore.transaction.rollback')->gather(1);
+ $e->disconnect;
+ $r->log->error("No such bucket $container");
+ $logger->error("No such bucket $container");
+ return Apache2::Const::NOT_FOUND;
+ }
+ my $recs = $e->request(
+ 'open-ils.cstore.direct.container.biblio_record_entry_bucket_item.search.atomic',
+ { bucket => $container }
+ )->gather(1);
+ @records = map { ($_->target_biblio_record_entry) } @$recs;
+ }
+ }
+
+ unless (@records) {
+ $e->request('open-ils.cstore.transaction.rollback')->gather(1);
+ $e->disconnect;
+ return show_template($r);
+ }
+
+ # we have a template and some record ids, so...
+
+ # insert the template record
+ my $min_id = $e->request(
+ 'open-ils.cstore.json_query',
+ { select => { bre => [{ column => 'id', transform => 'min', aggregate => 1}] }, from => 'bre' }
+ )->gather(1)->{id} - 1;
+
+ warn "new template bib id = $min_id\n";
+
+ my $tmpl_rec = Fieldmapper::biblio::record_entry->new;
+ $tmpl_rec->id($min_id);
+ $tmpl_rec->deleted('t');
+ $tmpl_rec->active('f');
+ $tmpl_rec->marc($template);
+ $tmpl_rec->creator($usr->id);
+ $tmpl_rec->editor($usr->id);
+
+ warn "about to create bib $min_id\n";
+ $e->request('open-ils.cstore.direct.biblio.record_entry.create', $tmpl_rec )->gather(1);
+
+ # create the new container for the records and the template
+ my $bucket = Fieldmapper::container::biblio_record_entry_bucket->new;
+ $bucket->owner($usr->id);
+ $bucket->btype('template_merge');
+
+ my $bname = $cgi->param('bname') || 'Temporary Merge Bucket '. localtime() . ' ' . $usr->id;
+ $bucket->name($bname);
+
+ $bucket = $e->request('open-ils.cstore.direct.container.biblio_record_entry_bucket.create', $bucket )->gather(1);
+
+ # create items in the bucket
+ my $item = Fieldmapper::container::biblio_record_entry_bucket_item->new;
+ $item->bucket($bucket->id);
+ $item->target_biblio_record_entry($min_id);
+
+ $e->request('open-ils.cstore.direct.container.biblio_record_entry_bucket_item.create', $item )->gather(1);
+
+ my %seen;
+ for my $r (@records) {
+ next if ($seen{$r});
+ $item->target_biblio_record_entry($r);
+ $e->request('open-ils.cstore.direct.container.biblio_record_entry_bucket_item.create', $item )->gather(1);
+ $seen{$r}++;
+ }
+
+ $e->request('open-ils.cstore.transaction.commit')->gather(1);
+ $e->disconnect;
+
+ # fire the background bucket processor
+ my $cache_key = OpenSRF::AppSession
+ ->create('open-ils.cat')
+ ->request('open-ils.cat.container.template_overlay.background', $authid, $bucket->id)
+ ->gather(1);
+
+ return show_processing_template($r, $bucket->id, \@records, $cache_key);
+}
+
+sub verify_login {
+ my $auth_token = shift;
+ return undef unless $auth_token;
+
+ my $user = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( "open-ils.auth.session.retrieve", $auth_token )
+ ->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return undef;
+ }
+
+ return $user if ref($user);
+ return undef;
+}
+
+sub show_processing_template {
+ my $r = shift;
+ my $bid = shift;
+ my $recs = shift;
+ my $cache_key = shift;
+
+ my $rec_string = @$recs;
+
+ $r->content_type('text/html');
+ $r->print(<<HTML);
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <head>
+ <title>Merging records...</title>
+ <style type="text/css">
+ \@import '/js/dojo/dojo/resources/dojo.css';
+ \@import '/js/dojo/dijit/themes/tundra/tundra.css';
+ .hide_me { display: none; visibility: hidden; }
+ th { font-weight: bold; }
+ </style>
+
+ <script type="text/javascript">
+ var djConfig= {
+ isDebug: false,
+ parseOnLoad: true,
+ AutoIDL: ['aou','aout','pgt','au','cbreb']
+ }
+ </script>
+
+ <script src='/js/dojo/dojo/dojo.js'></script>
+ <!-- <script src="/js/dojo/dojo/openils_dojo.js"></script> -->
+
+ <script type="text/javascript">
+
+ dojo.require('fieldmapper.AutoIDL');
+ dojo.require('fieldmapper.dojoData');
+ dojo.require('openils.User');
+ dojo.require('openils.CGI');
+ dojo.require('openils.widget.ProgressDialog');
+
+ var cgi = new openils.CGI();
+ var u = new openils.User({ authcookie : 'ses' });
+
+ dojo.addOnLoad(function () {
+ progress_dialog.show(true);
+ progress_dialog.update({maximum:$rec_string});
+
+ var interval;
+ interval = setInterval( function() {
+ fieldmapper.standardRequest(
+ ['open-ils.actor','open-ils.actor.anon_cache.get_value'],
+ { async : false,
+ params: [ u.authtoken, 'res_list' ],
+ onerror : function (r) { progress_dialog.hide(); },
+ onresponse : function (r) {
+ var counter = { success : 0, fail : 0, total : 0 };
+ dojo.forEach( openils.Util.readResponse(r), function(x) {
+ if (x.complete) {
+ clearInterval(interval);
+ progress_dialog.hide();
+ if (x.success == 't') dojo.byId('complete_msg').innerHTML = 'Overlay completed successfully';
+ else dojo.byId('complete_msg').innerHTML = 'Overlay did not complet successfully';
+ } else {
+ counter.total++;
+ switch (x.success) {
+ case 't':
+ counter.success++;
+ break;
+ default:
+ counter.fail++;
+ break;
+ }
+ }
+ });
+
+ // update the progress dialog
+ progress_dialog.update({progress:counter.total});
+ dojo.byId('success_count').innerHTML = counter.success;
+ dojo.byId('fail_count').innerHTML = counter.fail;
+ dojo.byId('total_count').innerHTML = counter.total;
+ }
+ }
+ );
+ }, 1000);
+
+ });
+ </script>
+ </head>
+
+ <body style="margin:10px;" class='tundra'>
+ <div class="hide_me"><div dojoType="openils.widget.ProgressDialog" jsId="progress_dialog"></div></div>
+
+ <table style="width:100%; margin-top:100px;">
+ <th>
+ <td>Status</td>
+ <td>Record Count</td>
+ </th>
+ <tr>
+ <td>Success</td>
+ <td id='success_count'></td>
+ </tr>
+ <tr>
+ <td>Failure</td>
+ <td id='fail_count'></td>
+ </tr>
+ <tr>
+ <td></td>
+ <td id='total_count'></td>
+ </tr>
+ </table>
+
+ <div id='complete_msg'></div>
+
+ </body>
+</html>
+HTML
+
+ return Apache2::Const::OK;
+}
+
+
+sub show_template {
+ my $r = shift;
+
+ $r->content_type('text/html');
+ $r->print(<<'HTML');
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <head>
+ <title>Merge Template Builder</title>
+ <style type="text/css">
+ @import '/js/dojo/dojo/resources/dojo.css';
+ @import '/js/dojo/dijit/themes/tundra/tundra.css';
+ .hide_me { display: none; visibility: hidden; }
+ table.ruleTable th { padding: 5px; border-collapse: collapse; border-bottom: solid 1px gray; font-weight: bold; }
+ table.ruleTable td { padding: 5px; border-collapse: collapse; border-bottom: solid 1px gray; }
+ </style>
+
+ <script type="text/javascript">
+ var djConfig= {
+ isDebug: false,
+ parseOnLoad: true,
+ AutoIDL: ['aou','aout','pgt','au','cbreb']
+ }
+ </script>
+
+ <script src='/js/dojo/dojo/dojo.js'></script>
+ <!-- <script src="/js/dojo/dojo/openils_dojo.js"></script> -->
+
+ <script type="text/javascript">
+
+ dojo.require('dojo.data.ItemFileReadStore');
+ dojo.require('dijit.form.Form');
+ dojo.require('dijit.form.NumberSpinner');
+ dojo.require('dijit.form.FilteringSelect');
+ dojo.require('dijit.form.TextBox');
+ dojo.require('dijit.form.Textarea');
+ dojo.require('dijit.form.Button');
+ dojo.require('MARC.Batch');
+ dojo.require('fieldmapper.AutoIDL');
+ dojo.require('fieldmapper.dojoData');
+ dojo.require('openils.User');
+ dojo.require('openils.CGI');
+
+ var cgi = new openils.CGI();
+ var u = new openils.User({ authcookie : 'ses' });
+
+ var bucketStore = new dojo.data.ItemFileReadStore(
+ { data : cbreb.toStoreData(
+ fieldmapper.standardRequest(
+ ['open-ils.actor','open-ils.actor.container.retrieve_by_class'],
+ [u.authtoken, u.user.id(), 'biblio', 'staff_client']
+ )
+ )
+ }
+ );
+
+ function render_preview () {
+ var rec = ruleset_to_record();
+ dojo.byId('marcPreview').innerHTML = rec.toBreaker();
+ }
+
+ function render_from_template () {
+ var kid_number = dojo.byId('ruleList').childNodes.length;
+ var clone = dojo.query('*[name=ruleTable]', dojo.byId('ruleTemplate'))[0].cloneNode(true);
+
+ var typeSelect = dojo.query('*[name=typeSelect]',clone).instantiate(dijit.form.FilteringSelect, {
+ onChange : function (val) {
+ switch (val) {
+ case 'a':
+ case 'r':
+ dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]).attr('disabled',false);
+ break;
+ default :
+ dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]).attr('disabled',true);
+ };
+ render_preview();
+ }
+ })[0];
+
+ var marcData = dojo.query('*[name=marcData]',clone).instantiate(dijit.form.TextBox, {
+ onChange : render_preview
+ })[0];
+
+
+ var tag = dojo.query('*[name=tag]',clone).instantiate(dijit.form.TextBox, {
+ onChange : function (newtag) {
+ var md = dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]);
+ var current_marc = md.attr('value');
+
+ if (newtag.length == 3) {
+ if (current_marc.length == 0) newtag += ' \\\\';
+ if (current_marc.substr(0,3) != newtag) current_marc = newtag + current_marc.substr(3);
+ }
+ md.attr('value', current_marc);
+ render_preview();
+ }
+ })[0];
+
+ var sf = dojo.query('*[name=sf]',clone).instantiate(dijit.form.TextBox, {
+ onChange : function (newsf) {
+ var md = dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',clone)[0]);
+ var current_marc = md.attr('value');
+ var sf_list = newsf.split('');
+
+ for (var i in sf_list) {
+ var re = '\\$' + sf_list[i];
+ if (current_marc.match(re)) continue;
+ current_marc += '$' + sf_list[i];
+ }
+
+ md.attr('value', current_marc);
+ render_preview();
+ }
+ })[0];
+
+ var matchSF = dojo.query('*[name=matchSF]',clone).instantiate(dijit.form.TextBox, {
+ onChange : render_preview
+ })[0];
+
+ var matchRE = dojo.query('*[name=matchRE]',clone).instantiate(dijit.form.TextBox, {
+ onChange : render_preview
+ })[0];
+
+ var removeButton = dojo.query('*[name=removeButton]',clone).instantiate(dijit.form.Button, {
+ onClick : function() {
+ dojo.addClass(
+ dojo.byId('ruleList').childNodes[kid_number],
+ 'hide_me'
+ );
+ render_preview();
+ }
+ })[0];
+
+ dojo.place(clone,'ruleList');
+ }
+
+ function ruleset_to_record () {
+ var rec = new MARC.Record ({ delimiter : '$' });
+
+ dojo.forEach(
+ dojo.query('#ruleList *[name=ruleTable]').filter( function (node) {
+ if (node.className.match(/hide_me/)) return false;
+ return true;
+ }),
+ function (tbl) {
+ var rule_tag = new MARC.Field ({
+ tag : '905',
+ ind1 : ' ',
+ ind2 : ' '
+ });
+ var rule_txt = dijit.byNode(dojo.query('*[name=tagContainer] .dijit',tbl)[0]).attr('value');
+ rule_txt += dijit.byNode(dojo.query('*[name=sfContainer] .dijit',tbl)[0]).attr('value');
+
+ var reSF = dijit.byNode(dojo.query('*[name=matchSFContainer] .dijit',tbl)[0]).attr('value');
+ if (reSF) {
+ var reRE = dijit.byNode(dojo.query('*[name=matchREContainer] .dijit',tbl)[0]).attr('value');
+ rule_txt += '[' + reSF + '~' + reRE + ']';
+ }
+
+ var rtype = dijit.byNode(dojo.query('*[name=typeSelectContainer] .dijit',tbl)[0]).attr('value');
+ rule_tag.addSubfields( rtype, rule_txt )
+ rec.appendFields( rule_tag );
+
+ if (rtype == 'a' || rtype == 'r') {
+ rec.appendFields(
+ new MARC.Record ({
+ delimiter : '$',
+ marcbreaker : dijit.byNode(dojo.query('*[name=marcDataContainer] .dijit',tbl)[0]).attr('value')
+ }).fields[0]
+ );
+ }
+ }
+ );
+
+ return rec;
+ }
+ </script>
+ </head>
+
+ <body style="margin:10px;" class='tundra'>
+
+ <div dojoType="dijit.form.Form" id="myForm" jsId="myForm" encType="multipart/form-data" action="" method="POST">
+ <script type='dojo/method' event='onSubmit'>
+ var rec = ruleset_to_record();
+
+ if (rec.subfield('905','r') == '') { // no-op to force replace mode
+ rec.appendFields(
+ new MARC.Field ({
+ tag : '905',
+ ind1 : ' ',
+ ind2 : ' ',
+ subfields : [['r','901c']]
+ })
+ );
+ }
+
+ dojo.byId('template_value').value = rec.toXmlString();
+ return true;
+ </script>
+
+ <input type='hidden' id='template_value' name='template'/>
+
+ <label for='inputTypeSelect'>Record source:</label>
+ <select name='recordSource' dojoType='dijit.form.FilteringSelect'>
+ <script type='dojo/method' event='onChange' args="val">
+ switch (val) {
+ case 'b':
+ dojo.removeClass('bucketListContainer','hide_me');
+ dojo.addClass('csvContainer','hide_me');
+ dojo.addClass('recordContainer','hide_me');
+ break;
+ case 'c':
+ dojo.addClass('bucketListContainer','hide_me');
+ dojo.removeClass('csvContainer','hide_me');
+ dojo.addClass('recordContainer','hide_me');
+ break;
+ case 'r':
+ dojo.addClass('bucketListContainer','hide_me');
+ dojo.addClass('csvContainer','hide_me');
+ dojo.removeClass('recordContainer','hide_me');
+ break;
+ };
+ </script>
+ <script type='dojo/method' event='postCreate'>
+ if (cgi.param('recordSource')) {
+ this.attr('value',cgi.param('recordSource'));
+ this.onChange(cgi.param('recordSource'));
+ }
+ </script>
+ <option value='b'>a Bucket</option>
+ <option value='c'>a CSV File</option>
+ <option value='r'>a specific record ID</option>
+ </select>
+
+ <table style='margin:10px; margin-bottom:20px;'>
+<!--
+ <tr>
+ <th>Merge template name (optional):</th>
+ <td><input id='bucketName' jsId='bucketName' type='text' dojoType='dijit.form.TextBox' name='bname' value=''/></td>
+ </tr>
+-->
+ <tr class='' id='bucketListContainer'>
+ <td>Bucket named:
+ <div name='containerid' jsId='bucketList' dojoType='dijit.form.FilteringSelect' store='bucketStore' searchAttr='name' id='bucketList'>
+ <script type='dojo/method' event='postCreate'>
+ if (cgi.param('containerid')) this.attr('value',cgi.param('containerid'));
+ </script>
+ </div>
+ </td>
+ </tr>
+ <tr class='hide_me' id='csvContainer'>
+ <td>
+ Column <input style='width:75px;' type='text' dojoType='dijit.form.NumberSpinner' name='idcolumn' value='0' constraints='{min:0,max:100,places:0}' /> of:
+ <input id='idfile' type="file" name="idfile"/>
+ <br/>
+ <br/>
+ Columns are numbered starting at 0. For instance, when looking at a CSV file in Excel, the column labeled A is the same as column 0, and the column labeled B is the same as column 1.
+ </td>
+ </tr>
+ <tr class='hide_me' id='recordContainer'>
+ <td>Record ID: <input dojoType='dijit.form.TextBox' name='recid' style='width:75px;' type='text' value=''/></td>
+ </tr>
+ </table>
+
+ <button type="submit" dojoType='dijit.form.Button'>GO!</button> (After setting up your template below.)
+
+ <br/>
+ <br/>
+
+ </div> <!-- end of the form -->
+
+ <hr/>
+ <table style='width: 100%'>
+ <tr>
+ <td style='width: 50%'><div id='ruleList'></div></td>
+ <td valign='top'>Update Template Preview:<br/><pre id='marcPreview'></pre></td>
+ </tr>
+ </table>
+
+ <button dojoType='dijit.form.Button'>Add Merge Rule
+ <script type='dojo/connect' event='onClick'>render_from_template()</script>
+ <script type='dojo/method' event='postCreate'>render_from_template()</script>
+ </button>
+
+ <div class='hide_me' id='ruleTemplate'>
+ <div name='ruleTable'>
+ <table class='ruleTable'>
+ <tbody>
+ <tr>
+ <th style="text-align:center;">Rule Setup</th>
+ <th style="text-align:center;">Data</th>
+ <th style="text-align:center;">Help</th>
+ </tr>
+ <tr>
+ <th>Action (Rule Type)</th>
+ <td name='typeSelectContainer'>
+ <select name='typeSelect'>
+ <option value='r'>Replace</option>
+ <option value='a'>Add</option>
+ <option value='d'>Delete</option>
+ </select>
+ </td>
+ <td>How to change the existing records</td>
+ </tr>
+ <tr>
+ <th>MARC Tag</th>
+ <td name='tagContainer'><input style='with: 2em;' name='tag' type='text'></input</td>
+ <td>Three characters, no spaces, no indicators, etc. eg: 245</td>
+ </td>
+ <tr>
+ <th>Subfields (optional)</th>
+ <td name='sfContainer'><input name='sf' type='text'/></td>
+ <td>No spaces, no delimiters, eg: abcnp</td>
+ </tr>
+ <tr>
+ <th>MARC Data</th>
+ <td name='marcDataContainer'><input name='marcData' type='text'/></td>
+ <td>MARC-Breaker formatted data with indicators and subfield delimiters, eg:<br/>245 04$aThe End</td>
+ </tr>
+ <tr>
+ <th colspan='3' style='padding-top: 20px; text-align: center;'>Advanced Matching Restriction (Optional)</th>
+ </tr>
+ <tr>
+ <th>Subfield</th>
+ <td name='matchSFContainer'><input style='with: 2em;' name='matchSF' type='text'></input</td>
+ <td>A single subfield code, no delimiters, eg: a</td>
+ <tr>
+ <th>Regular Expression</th>
+ <td name='matchREContainer'><input name='matchRE' type='text'/></td>
+ <td>See <a href="http://perldoc.perl.org/perlre.html#Regular-Expressions" target="_blank">the Perl documentation</a>
+ for an explanation of Regular Expressions.
+ </td>
+ </tr>
+ <tr>
+ <td colspan='3' style='padding-top: 20px; text-align: center;'>
+ <button name='removeButton'>Remove this Template Rule</button>
+ </td>
+ </tr>
+ </tbody>
+ </table>
+ <hr/>
+ </div>
+ </div>
+
+ </body>
+</html>
+HTML
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+
--- /dev/null
+package OpenILS::WWW::Vandelay;
+use strict;
+use warnings;
+use bytes;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND FORBIDDEN :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use APR::Table;
+
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use CGI;
+use Data::Dumper;
+use Text::CSV;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::Utils::Cache;
+use OpenSRF::System;
+use OpenSRF::AppSession;
+use XML::LibXML;
+
+use OpenILS::Utils::Fieldmapper;
+use OpenSRF::Utils::Logger qw/$logger/;
+
+use MARC::Record;
+use MARC::File::XML;
+
+use MIME::Base64;
+use Digest::MD5 qw/md5_hex/;
+use OpenSRF::Utils::SettingsClient;
+
+use UNIVERSAL::require;
+
+our @formats = qw/USMARC UNIMARC XML BRE/;
+my $MAX_FILE_SIZE = 10737418240; #10G
+my $FILE_READ_SIZE = 4096;
+
+# set the bootstrap config and template include directory when
+# this module is loaded
+my $bootstrap;
+
+sub import {
+ my $self = shift;
+ $bootstrap = shift;
+}
+
+
+sub child_init {
+ OpenSRF::System->bootstrap_client( config_file => $bootstrap );
+}
+
+sub spool_marc {
+ my $r = shift;
+ my $cgi = new CGI;
+
+ my $auth = $cgi->param('ses') || $cgi->cookie('ses');
+
+ unless(verify_login($auth)) {
+ $logger->error("authentication failed on vandelay record import: $auth");
+ return Apache2::Const::FORBIDDEN;
+ }
+
+ my $data_fingerprint = '';
+ my $purpose = $cgi->param('purpose') || '';
+ my $infile = $cgi->param('marc_upload') || '';
+ my $bib_source = $cgi->param('bib_source') || '';
+ my $provider = $cgi->param('provider') || '';
+ my $picklist = $cgi->param('picklist') || '';
+ my $create_po = $cgi->param('create_po') || '';
+ my $activate_po = $cgi->param('activate_po') || '';
+ my $ordering_agency = $cgi->param('ordering_agency') || '';
+ my $create_assets = $cgi->param('create_assets') || '';
+
+ $logger->debug("purpose = $purpose, infile = $infile, bib_source = $bib_source ".
+ "provider = $provider, picklist = $picklist, create_po = $create_po, ordering_agency = $ordering_agency");
+
+ my $conf = OpenSRF::Utils::SettingsClient->new;
+ my $dir = $conf->config_value(
+ apps => 'open-ils.vandelay' => app_settings => databases => 'importer');
+
+ unless(-w $dir) {
+ $logger->error("We need some place to store our MARC files");
+ return Apache2::Const::FORBIDDEN;
+ }
+
+ if($infile and -e $infile) {
+ my ($total_bytes, $buf, $bytes) = (0);
+ $data_fingerprint = md5_hex(time."$$".rand());
+ my $outfile = "$dir/$data_fingerprint.mrc";
+
+ unless(open(OUTFILE, ">$outfile")) {
+ $logger->error("unable to open MARC file [$outfile] for writing: $@");
+ return Apache2::Const::FORBIDDEN;
+ }
+
+ while($bytes = sysread($infile, $buf, $FILE_READ_SIZE)) {
+ $total_bytes += $bytes;
+ if($total_bytes >= $MAX_FILE_SIZE) {
+ close(OUTFILE);
+ unlink $outfile;
+ $logger->error("import exceeded upload size: $MAX_FILE_SIZE");
+ return Apache2::Const::FORBIDDEN;
+ }
+ print OUTFILE $buf;
+ }
+
+ close(OUTFILE);
+
+ OpenSRF::Utils::Cache->new->put_cache(
+ 'vandelay_import_spool_' . $data_fingerprint,
+ { purpose => $purpose,
+ path => $outfile,
+ bib_source => $bib_source,
+ provider => $provider,
+ picklist => $picklist,
+ create_po => $create_po,
+ create_assets => $create_assets,
+ ordering_agency => $ordering_agency
+ }
+ );
+ }
+
+ $logger->info("uploaded MARC batch with key $data_fingerprint");
+ $r->content_type('text/plain; charset=utf-8');
+ print "$data_fingerprint";
+ return Apache2::Const::OK;
+}
+
+sub verify_login {
+ my $auth_token = shift;
+ return undef unless $auth_token;
+
+ my $user = OpenSRF::AppSession
+ ->create("open-ils.auth")
+ ->request( "open-ils.auth.session.retrieve", $auth_token )
+ ->gather(1);
+
+ if (ref($user) eq 'HASH' && $user->{ilsevent} == 1001) {
+ return undef;
+ }
+
+ return $user if ref($user);
+ return undef;
+}
+
+1;
--- /dev/null
+package OpenILS::WWW::Web;
+use strict;
+use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+
+#use CGI ();
+use Template;
+
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+
+my $main_ttk = "opac/logic/page_router.ttk";
+my $error_ttk = "opac/pages/error.ttk";
+my $init_ttk = "opac/logic/page_init.ttk";
+my $bootstrap = "@sysconfdir@/opensrf_core.xml";
+my $child_init_ttk = "opac/logic/child_init.ttk";
+
+my $includes = []; # [ '/pines/cvs/ILS/Open-ILS/src/templates' ];
+
+sub import {
+ my ( $self, $tdir ) = @_;
+ $includes = [$tdir];
+}
+
+my $plugin_base = 'OpenILS::Template::Plugin';
+
+sub handler {
+
+ my $apache = shift;
+ print "Content-type: text/html; charset=utf-8\n\n";
+
+ _process_template(
+ apache => $apache,
+ template => $main_ttk,
+ pre_process => $init_ttk
+ );
+
+ return Apache2::Const::OK;
+}
+
+sub child_init_handler {
+ _process_template( template => $child_init_ttk );
+}
+
+sub _process_template {
+
+ my %params = @_;
+ my $ttk = $params{template} || return undef;
+ my $apache = $params{apache} || undef;
+ my $pre_process = $params{pre_process} || undef;
+ my $param_hash = $params{params} || {};
+
+ my $template;
+
+ $template = Template->new(
+ {
+ OUTPUT => $apache,
+ ABSOLUTE => 1,
+ RELATIVE => 1,
+ PLUGIN_BASE => $plugin_base,
+ PRE_PROCESS => $pre_process,
+ INCLUDE_PATH => $includes,
+ PRE_CHOMP => 1,
+ POST_CHOMP => 1,
+ }
+ );
+
+ try {
+
+ if ( !$template->process( $ttk, $param_hash ) ) {
+ warn "Error Occured: " . $template->error();
+ my $err = $template->error();
+ $err =~ s/\n/\<br\/\>/g;
+ warn "Error processing template $ttk\n";
+ my $string =
+ "<br><b>Unable to process template:<br/><br/> "
+ . $err
+ . "!!!</b>";
+ $template->process( $error_ttk, { error => $string } );
+ }
+
+ }
+ catch Error with {
+ my $e = shift;
+ warn "Error processing template $ttk: $e - $@ \n";
+ print "<center><br/><br/><b>Error<br/><br/> $e <br/><br/> $@ </b><br/></center>";
+ return;
+ };
+
+}
+
+# This module appears obsolete (probably superceded by EGWeb.pm
+# The template files it references do not exist in the codebase.
+# File is not referenced elsewhere in the codebase. Candidate for deletion.
+
+1;
--- /dev/null
+package OpenILS::WWW::XMLRPCGateway;
+use strict; use warnings;
+
+use CGI;
+use Apache2::Log;
+use Apache2::Const -compile => qw(OK REDIRECT DECLINED NOT_FOUND :log);
+use APR::Const -compile => qw(:error SUCCESS);
+use Apache2::RequestRec ();
+use Apache2::RequestIO ();
+use Apache2::RequestUtil;
+use Data::Dumper;
+use UNIVERSAL::require;
+
+use XML::LibXML;
+use OpenSRF::EX qw(:try);
+use OpenSRF::System;
+use OpenSRF::Utils::Cache;
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils::SettingsClient;
+
+use RPC::XML qw/smart_encode/;
+use RPC::XML::Parser;
+use RPC::XML::Function;
+use RPC::XML::Method;
+use RPC::XML::Procedure;
+
+$RPC::XML::ENCODING = 'utf-8';
+
+my $services; # allowed services
+my $CLASS_KEY = '__class__'; # object wrapper class key
+my $PAYLOAD_KEY = '__data__'; # object wrapper payload key
+my $bs_config; # bootstrap config
+my $__inited = 0; # has child_init run?
+
+
+# set the bootstrap config when this module is loaded
+sub import { $bs_config = $_[1]; }
+
+
+# Bootstrap and load config settings
+sub child_init {
+ $__inited = 1;
+ OpenSRF::System->bootstrap_client( config_file => $bs_config );
+ my $sclient = OpenSRF::Utils::SettingsClient->new();
+ my $idl = $sclient->config_value("IDL");
+ $services = $sclient->config_value("xml-rpc", "allowed_services", "service");
+ $services = ref $services ? $services : [ $services ];
+ $logger->debug("XML-RPC: allowed services @$services");
+ OpenILS::Utils::Fieldmapper->require;
+ Fieldmapper->import(IDL => $idl);
+}
+
+
+sub handler {
+
+ my $r = shift;
+ my $cgi = CGI->new;
+ my $service = $r->path_info;
+ $service =~ s#^/##;
+
+ child_init() unless $__inited; # ?
+
+ return Apache2::Const::NOT_FOUND unless grep { $_ eq $service } @$services;
+
+ my $request = RPC::XML::Parser->new->parse($cgi->param('POSTDATA'));
+
+ my @args;
+ push( @args, unwrap_perl($_->value) ) for @{$request->args};
+ my $method = $request->name;
+
+ warn "XML-RPC: service=$service, method=$method, args=@args\n";
+ $logger->debug("XML-RPC: service=$service, method=$method, args=@args");
+
+ my $perl = run_request( $service, $method, @args );
+ my $resp = RPC::XML::response->new(smart_encode($perl));
+
+ print "Content-type: application/xml; charset=utf-8\n\n";
+ print $resp->as_string;
+ return Apache2::Const::OK;
+}
+
+
+sub run_request {
+ my( $service, $method, @args ) = @_;
+ my $ses = OpenSRF::AppSession->create( $service );
+ #my $data = $ses->request($method, @args)->gather(1);
+
+ my $data = [];
+ my $req = $ses->request($method, @args);
+ while( my $resp = $req->recv( timeout => 600 ) ) {
+ if( $req->failed ) {
+ push( @$data, $req->failed );
+ last;
+ }
+ push( @$data, $resp->content );
+ }
+
+ return [] if scalar(@$data) == 0;
+ return wrap_perl($$data[0])
+ if scalar(@$data) == 1 and $method !~ /.atomic$/og;
+ return wrap_perl($data);
+}
+
+# These should probably be moved out to a library somewhere
+
+sub wrap_perl {
+ my $obj = shift;
+ my $ref = ref($obj);
+
+ if ($ref =~ /^Fieldmapper/o) {
+ $ref = $obj->json_hint;
+ $obj = $obj->to_bare_hash;
+ }
+
+ if( $ref eq 'HASH' ) {
+ $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
+ } elsif( $ref eq 'ARRAY' ) {
+ $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1 );
+ } elsif( $ref ) {
+ if(UNIVERSAL::isa($obj, 'HASH')) {
+ $obj->{$_} = wrap_perl( $obj->{$_} ) for (keys %$obj);
+ bless($obj, 'HASH'); # so our parser won't add the hints
+ } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
+ $obj->[$_] = wrap_perl( $obj->[$_] ) for(0..scalar(@$obj) - 1);
+ bless($obj, 'ARRAY'); # so our parser won't add the hints
+ }
+ $obj = { $CLASS_KEY => $ref, $PAYLOAD_KEY => $obj };
+ }
+ return $obj;
+}
+
+
+
+sub unwrap_perl {
+ my $obj = shift;
+ my $ref = ref($obj);
+ if( $ref eq 'HASH' ) {
+ if( defined($obj->{$CLASS_KEY})) {
+ my $class = $obj->{$CLASS_KEY};
+ if( $obj = unwrap_perl($obj->{$PAYLOAD_KEY}) ) {
+ return bless(\$obj, $class) unless ref($obj);
+ return bless( $obj, $class );
+ }
+ return undef;
+ }
+ $obj->{$_} = unwrap_perl( $obj->{$_} ) for (keys %$obj);
+ } elsif( $ref eq 'ARRAY' ) {
+ $obj->[$_] = unwrap_perl($obj->[$_]) for(0..scalar(@$obj) - 1);
+ }
+ return $obj;
+}
+
+
+
+
+1;
#/usr/bin/perl
use strict; use warnings;
-use lib q|../../../perlmods/|;
+use lib q|../../../perlmods/lib/|;
use Time::HiRes qw/time/;
use OpenILS::Application::Circ::ScriptBuilder;
require '../oils_header.pl';
-#!/usr/bin/perl -IOpen-ILS/src/perlmods
+#!/usr/bin/perl -IOpen-ILS/src/perlmods/lib/
use strict; use warnings;
-#!/usr/bin/perl -IOpen-ILS/src/perlmods
+#!/usr/bin/perl -IOpen-ILS/src/perlmods/lib
use strict; use warnings;
-#!/usr/bin/perl -IOpen-ILS/src/perlmods
+#!/usr/bin/perl -IOpen-ILS/src/perlmods/lib
use strict; use warnings;
Open-ILS/xul/staff_client/Makefile
Open-ILS/src/extras/eg_config
Open-ILS/src/extras/fast-extract
- Open-ILS/src/perlmods/OpenILS/Utils/Cronscript.pm],
+ Open-ILS/src/perlmods/Makefile
+ Open-ILS/src/perlmods/lib/OpenILS/WWW/Method.pm
+ Open-ILS/src/perlmods/lib/OpenILS/WWW/Web.pm
+ Open-ILS/src/perlmods/lib/OpenILS/Utils/Cronscript.pm],
[
if test -e "./Open-ILS/src/extras/eg_config"; then chmod 755 Open-ILS/src/extras/eg_config; fi;
if test -e "./Open-ILS/src/extras/fast-extract"; then chmod 755 Open-ILS/src/extras/fast-extract; fi;
projects / evergreen / masslnc.git / commitdiff