Build.PL100664001761001761 45513167535265 15435 0ustar00srdjansrdjan000000000000WebService-ILS-0.17# ========================================================================= # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. # DO NOT EDIT DIRECTLY. # ========================================================================= use 5.008_001; use strict; use Module::Build::Tiny 0.035; Build_PL(); Changes100664001761001761 304313167535265 15450 0ustar00srdjansrdjan000000000000WebService-ILS-0.17Revision history for Perl extension WebService-ILS 0.17 2017-10-12T00:43:30Z - Overdrive bugfix: no more _item_metadata(), we switched to item_metadata() 0.16 2017-08-14T04:12:46Z - Bugfix: Moved Params::Check::check() to BUILDARGS in 0.15 broke new(%params) 0.15 2017-08-14T02:19:05Z - Moved Params::Check::check() to BUILDARGS - OneClickDigital -> RecordedBooks 0.14 2017-06-07T01:19:26Z - OneClickDigital bugfix: item_metadata() and item description 0.13 2017-05-31T00:40:58Z - OneClickDigital: removed country param, domain is oneclickdigital.com subdomain 0.12 2017-05-12T03:43:00Z - OneClickDigital: Moved products search url from PartnerBase to top module 0.11 2017-03-27T07:10:22Z - item_metadata() - OneClickDigital: better handling of place_hold(), remove_hold() and return() 0.10 2017-03-07T03:53:48Z - OneClickDigital: Fix patron() call for PartnerPatron 0.09 2017-03-06T02:22:43Z - OneClickDigital: no default for country, reworked domain logic, default domain .com 0.08 2016-09-27T01:23:46Z - OneClickDigital clean-up 0.07 2016-05-04T08:32:09Z - OneClickDigital 0.06 2016-02-25T03:00:45Z - Added item metadata to OverDrive::Patron->holds() 0.05 2016-02-02T04:09:59Z - Changed OverDrive checkout formats - now a hashref with immediate availability 0.04 2015-12-09T05:26:55Z - Prerequisites 0.03 2015-12-08T05:43:07Z - Improved OverDrive checkout format handling 0.02 2015-12-02T03:22:48Z - Better access_token handling 0.01 2015-11-12T02:48:08Z - original version LICENSE100664001761001761 4377313167535265 15220 0ustar00srdjansrdjan000000000000WebService-ILS-0.17This software is copyright (c) 2015 by Catalyst IT NZ Ltd and Bywater Solutions This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2015 by Catalyst IT NZ Ltd and Bywater Solutions This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy 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 1, 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 Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2015 by Catalyst IT NZ Ltd and Bywater Solutions This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End META.json100664001761001761 625013167535265 15601 0ustar00srdjansrdjan000000000000WebService-ILS-0.17{ "abstract" : "Standardised library discovery/circulation services", "author" : [ "Srdjan Janković " ], "dynamic_config" : 0, "generated_by" : "Minilla/v3.0.0", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "WebService-ILS", "no_index" : { "directory" : [ "t", "xt", "inc", "share", "eg", "examples", "author", "builder" ] }, "prereqs" : { "configure" : { "requires" : { "Module::Build::Tiny" : "0.035" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::MinimumVersion::Fast" : "0.04", "Test::PAUSE::Permissions" : "0.04", "Test::Pod" : "1.41", "Test::Spellunker" : "v0.2.7" } }, "runtime" : { "recommends" : { "XML::LibXML" : "0" }, "requires" : { "Class::Tiny" : "0", "HTTP::Request::Common" : "0", "HTTP::Status" : "0", "Hash::Merge" : "0", "JSON" : "0", "LWP::UserAgent" : "0", "Modern::Perl" : "0", "Params::Check" : "0", "URI" : "0", "perl" : "5.008001" } }, "test" : { "recommends" : { "HTTP::Daemon" : "0", "HTTP::Response" : "0", "URI::QueryParam" : "0" }, "requires" : { "FindBin" : "0", "Test::More" : "0.98" } } }, "provides" : { "WebService::ILS" : { "file" : "lib/WebService/ILS.pm", "version" : "0.17" }, "WebService::ILS::JSON" : { "file" : "lib/WebService/ILS/JSON.pm" }, "WebService::ILS::OverDrive" : { "file" : "lib/WebService/ILS/OverDrive.pm" }, "WebService::ILS::OverDrive::Library" : { "file" : "lib/WebService/ILS/OverDrive/Library.pm" }, "WebService::ILS::OverDrive::Patron" : { "file" : "lib/WebService/ILS/OverDrive/Patron.pm" }, "WebService::ILS::RecordedBooks" : { "file" : "lib/WebService/ILS/RecordedBooks.pm" }, "WebService::ILS::RecordedBooks::Partner" : { "file" : "lib/WebService/ILS/RecordedBooks/Partner.pm" }, "WebService::ILS::RecordedBooks::PartnerBase" : { "file" : "lib/WebService/ILS/RecordedBooks/PartnerBase.pm" }, "WebService::ILS::RecordedBooks::PartnerPatron" : { "file" : "lib/WebService/ILS/RecordedBooks/PartnerPatron.pm" }, "WebService::ILS::RecordedBooks::Patron" : { "file" : "lib/WebService/ILS/RecordedBooks/Patron.pm" }, "WebService::ILS::XML" : { "file" : "lib/WebService/ILS/XML.pm" } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "git+ssh://git.catalyst.net.nz/git/private/webservice-ils.git" } }, "version" : "0.17", "x_serialization_backend" : "JSON::PP version 2.27203" } README.md100664001761001761 1036113167535265 15455 0ustar00srdjansrdjan000000000000WebService-ILS-0.17# NAME WebService::ILS - Standardised library discovery/circulation services # SYNOPSIS use WebService::ILS::; my $ils = WebService::ILS::->new({ client_id => $client_id, client_secret => $client_secret }); my %search_params = ( query => "Some keyword", sort => "rating", ); my $result = $ils->search(\%search_params); foreach (@{ $result->{items} }) { ... } foreach (2..$result->{pages}) { $search_params{page} = $_; my $next_results = $ils->search(\%search_params); ... } or my $native_result = $ils->native_search(\%native_search_params); # DESCRIPTION WebService::ILS is an attempt to create a standardised interface for online library services providers. In addition, native API interface is provided. Here we will describe constructor parameters and methods common to all service providers. Diversions and native interfaces are documented in corresponding modules. ## Supported service providers - **WebService::ILS::OverDrive::Library** OverDrive Library API [https://developer.overdrive.com/discovery-apis](https://developer.overdrive.com/discovery-apis) - **WebService::ILS::OverDrive::Patron** OverDrive Circulation API [https://developer.overdrive.com/circulation-apis](https://developer.overdrive.com/circulation-apis) # TESTING ENVIRONMENT Testing `WebService::ILS` modules is extremely difficult. It requires test accounts with vendors, sometimes special setup for handling redirect URLs. In that respect for building purposes, all tests are skipped by default. If you want to run tests for vendor specific modules during the build, you need to set the corresponding WEBSERVICE\_ILS\_TEST\_\* env vars to true, and supply values in vendor specific env vars. Those vendor specific vars correspond to [CONSTRUCTOR](https://metacpan.org/pod/CONSTRUCTOR) params. # TESTING OverDrive API - **WEBSERVICE\_ILS\_TEST\_OVERDRIVE\_LIBRARY** When set to true turns on tests from t/overdrve\_library.t, which test `WebService::ILS::OverDrive::Library` module - **WEBSERVICE\_ILS\_TEST\_OVERDRIVE\_PATRON** When set to true turns on tests from t/overdrve\_patron.t, which test `WebService::ILS::OverDrive::Patron` module - **WEBSERVICE\_ILS\_TEST\_OVERDRIVE\_AUTH** When set to true turns on tests from t/overdrve\_auth.t, which test OverDrive Granted (3-legged) authentication mechanism. It is separated because of the challenges it presents ## OverDrive account vars - **OVERDRIVE\_TEST\_CLIENT\_ID** - **OVERDRIVE\_TEST\_CLIENT\_SECRET** - **OVERDRIVE\_TEST\_LIBRARY\_ID** library and auth - **OVERDRIVE\_TEST\_WEBSITE\_ID** patron only - **OVERDRIVE\_TEST\_AUTHORIZATION\_NAME** patron only - **OVERDRIVE\_TEST\_USER\_ID** patron only - **OVERDRIVE\_TEST\_USER\_PASSWORD** patron only - **OVERDRIVE\_TEST\_AUTH\_REDIRECT\_URL** auth only # TESTING OneClickDigital API - **WEBSERVICE\_ILS\_TEST\_ONECLICKDIGITAL\_PARTNER** When set to true turns on tests from t/oneclickdigital.t, which test `WebService::ILS::OneClickDigital::Partner` and `WebService::ILS::OneClickDigital::PartnerPatron` modules - **WEBSERVICE\_ILS\_TEST\_ONECLICKDIGITAL\_PATRON** When set to true turns on tests from t/oneclickdigital.t, which test `WebService::ILS::OneClickDigital::Patron` module - **WEBSERVICE\_ILS\_TEST\_ONECLICKDIGITAL** When set to true turns on all tests from t/overdrve\_auth.t. Same as `WEBSERVICE_ILS_TEST_ONECLICKDIGITAL_PARTNER` and `WEBSERVICE_ILS_TEST_ONECLICKDIGITAL_PATRON` both set to true. ## OneClickDigital account vars - **ONECLICKDIGITAL\_TEST\_CLIENT\_SECRET** - **ONECLICKDIGITAL\_TEST\_LIBRARY\_ID** - **ONECLICKDIGITAL\_TEST\_USER\_ID** patron only - **ONECLICKDIGITAL\_TEST\_USER\_PASSWORD** patron only - **ONECLICKDIGITAL\_TEST\_USER\_EMAIL** partner only - **ONECLICKDIGITAL\_TEST\_USER\_BARCODE** partner only Only one of `ONECLICKDIGITAL_TEST_USER_EMAIL` (preferred) and `ONECLICKDIGITAL_TEST_USER_BARCODE` needs to be supplied. # POD ERRORS Hey! **The above document had some coding errors, which are explained below:** - Around line 109: You forgot a '=back' before '=head1' Readme.pod100664001761001761 1001513167535265 16073 0ustar00srdjansrdjan000000000000WebService-ILS-0.17=head1 NAME WebService::ILS - Standardised library discovery/circulation services =head1 SYNOPSIS use WebService::ILS::; my $ils = WebService::ILS::->new({ client_id => $client_id, client_secret => $client_secret }); my %search_params = ( query => "Some keyword", sort => "rating", ); my $result = $ils->search(\%search_params); foreach (@{ $result->{items} }) { ... } foreach (2..$result->{pages}) { $search_params{page} = $_; my $next_results = $ils->search(\%search_params); ... } or my $native_result = $ils->native_search(\%native_search_params); =head1 DESCRIPTION WebService::ILS is an attempt to create a standardised interface for online library services providers. In addition, native API interface is provided. Here we will describe constructor parameters and methods common to all service providers. Diversions and native interfaces are documented in corresponding modules. =head2 Supported service providers =over 4 =item B OverDrive Library API L =item B OverDrive Circulation API L =back =head1 TESTING ENVIRONMENT Testing C modules is extremely difficult. It requires test accounts with vendors, sometimes special setup for handling redirect URLs. In that respect for building purposes, all tests are skipped by default. If you want to run tests for vendor specific modules during the build, you need to set the corresponding WEBSERVICE_ILS_TEST_* env vars to true, and supply values in vendor specific env vars. Those vendor specific vars correspond to L params. =head1 TESTING OverDrive API =over 4 =item B When set to true turns on tests from t/overdrve_library.t, which test C module =item B When set to true turns on tests from t/overdrve_patron.t, which test C module =item B When set to true turns on tests from t/overdrve_auth.t, which test OverDrive Granted (3-legged) authentication mechanism. It is separated because of the challenges it presents =back =head2 OverDrive account vars =over 4 =item B =item B =item B library and auth =item B patron only =item B patron only =item B patron only =item B patron only =item B auth only =head1 TESTING OneClickDigital API =over 4 =item B When set to true turns on tests from t/oneclickdigital.t, which test C and C modules =item B When set to true turns on tests from t/oneclickdigital.t, which test C module =item B When set to true turns on all tests from t/overdrve_auth.t. Same as C and C both set to true. =back =head2 OneClickDigital account vars =over 4 =item B =item B =item B patron only =item B patron only =item B partner only =item B partner only =back Only one of C (preferred) and C needs to be supplied. license.pl100775001761001761 56313167535265 17551 0ustar00srdjansrdjan000000000000WebService-ILS-0.17/builder#!/usr/bin/perl -w -pi BEGIN { undef $/; } my $LICENSE = <srdjan\@catalyst.net.nzE =cut EOS s/(.*__END__).*/$1$LICENSE/s; readme.sh100775001761001761 20413167535265 17353 0ustar00srdjansrdjan000000000000WebService-ILS-0.17/builder#!/bin/sh podselect -s "NAME" -s "SYNOPSIS" -s "DESCRIPTION" lib/WebService/ILS.pm > Readme.pod cat t/lib/T/Test.pod >> Readme.pod cpanfile100664001761001761 101513167535265 15656 0ustar00srdjansrdjan000000000000WebService-ILS-0.17requires 'perl', '5.008001'; requires 'Class::Tiny', '0'; requires 'HTTP::Request::Common', '0'; requires 'HTTP::Status', '0'; requires 'Hash::Merge', '0'; requires 'JSON', '0'; requires 'LWP::UserAgent', '0'; requires 'Modern::Perl', '0'; requires 'Params::Check', '0'; requires 'URI', '0'; recommends 'XML::LibXML', '0'; on 'test' => sub { requires 'Test::More', '0.98'; requires 'FindBin', '0'; recommends 'HTTP::Daemon', '0'; recommends 'HTTP::Response', '0'; recommends 'URI::QueryParam', '0'; }; ILS.pm100664001761001761 4627613167535265 20005 0ustar00srdjansrdjan000000000000WebService-ILS-0.17/lib/WebServicepackage WebService::ILS; use Modern::Perl; our $VERSION = "0.17"; =encoding utf-8 =head1 NAME WebService::ILS - Standardised library discovery/circulation services =head1 SYNOPSIS use WebService::ILS::; my $ils = WebService::ILS::->new({ client_id => $client_id, client_secret => $client_secret }); my %search_params = ( query => "Some keyword", sort => "rating", ); my $result = $ils->search(\%search_params); foreach (@{ $result->{items} }) { ... } foreach (2..$result->{pages}) { $search_params{page} = $_; my $next_results = $ils->search(\%search_params); ... } or my $native_result = $ils->native_search(\%native_search_params); =head1 DESCRIPTION WebService::ILS is an attempt to create a standardised interface for online library services providers. In addition, native API interface is provided. Here we will describe constructor parameters and methods common to all service providers. Diversions and native interfaces are documented in corresponding modules. =head2 Supported service providers =over 4 =item B OverDrive Library API L =item B OverDrive Circulation API L =back =head1 INTERFACE =head2 Error handling Method calls will die on error. $@ will contain a multi-line string. See C below. =head2 Item record Item record is returned by many methods, so we specify it here. =over 12 =item C =item C =item C =item C<subtitle> =item C<description> =item C<author> =item C<publisher> =item C<publication_date> =item C<language> =item C<rating> => user ratings metrics =item C<popularity> => checkout metrics =item C<subjects> => subject categories (tags) =item C<facets> => a hashref of facet => [values] =item C<media> => book, e-book, video, audio etc =item C<formats> => an arrayref of available formats =item C<images> => a hashref of size => url =item C<encryption_key> => for decryption purposes =item C<drm> => subject to drm =back Not all fields are available for all service providers. Field values are not standardised. =cut use Carp; use Hash::Merge; use Params::Check; use LWP::UserAgent; use HTTP::Status qw(:constants); use MIME::Base64 qw(); use JSON qw(from_json); our $DEBUG; my %CONSTRUCTOR_PARAMS_SPEC; sub _set_param_spec { my $class = shift; my $param_spec = shift; $CONSTRUCTOR_PARAMS_SPEC{$class} = $param_spec; } sub _get_param_spec { my $class = shift; if (my $ref = ref($class)) { $class = $ref; } my $p_s = $CONSTRUCTOR_PARAMS_SPEC{$class}; return $p_s if $class eq __PACKAGE__; (my $superclass = $class) =~ s/::\w+$//o; return Hash::Merge::merge($p_s || {}, $superclass->_get_param_spec); } =head1 CONSTRUCTOR =head2 new (%params_hash or $params_hashref) =head3 Client (vendor) related constructor params, given by service provider: =over 12 =item C<client_id> => client (vendor) identifier =item C<client_secret> => secret key (password) =item C<library_id> => sometimes service providers provide access to differnt "libraries" =back =head3 General constructor params: =over 12 =item C<user_agent> => LWP::UserAgent or a derivative; usually not needed, one is created for you. =item C<user_agent_params> => LWP::UserAgent constructor params so you don't need to create user agent yourself =item C<access_token> => as returned from the provider authentication system =item C<access_token_type> => as returned from the provider authentication system =back These are also read-only attributes Not all of client/library params are required for all service providers. =cut use Class::Tiny qw( user_agent client_id client_secret library_id access_token access_token_type ); __PACKAGE__->_set_param_spec({ client_id => { required => 1, defined => 1 }, client_secret => { required => 1, defined => 1 }, library_id => { required => 0, defined => 1 }, access_token => { required => 0 }, access_token_type => { required => 0 }, user_agent => { required => 0 }, user_agent_params => { required => 0 }, }); sub BUILDARGS { my $self = shift; my $params = shift || {}; if (!ref( $params )) { $params = {$params, @_}; } local $Params::Check::WARNINGS_FATAL = 1; $params = Params::Check::check($self->_get_param_spec, $params) or croak "Invalid parameters: ".Params::Check::last_error(); return $params; } sub BUILD { my $self = shift; my $params = shift; my $ua_params = delete $params->{user_agent_params} || {}; $self->user_agent( LWP::UserAgent->new(%$ua_params) ) unless $self->user_agent; delete $self->{user_agent_params}; } =head1 ATTRIBUTES =head2 user_agent As provided to constructor, or auto created. Useful if one wants to change user agent attributes on the fly, eg $ils->user_agent->timeout(120); =head1 DISCOVERY METHODS =head2 search ($params_hashref) =head3 Input params: =over 12 =item C<query> => query (search) string =item C<page_size> => number of items per results page =item C<page> => wanted page number =item C<sort> => resultset sort option (see below) =back Sort options are either an array or a comma separated string of options: =over 12 =item C<publication_date> => date title was published =item C<available_date> => date title became available for users =item C<rating> => number of items per results page =back Sort order can be added after option with ":", eg "publication_date:desc,rating:desc" =head3 Returns search results record: =over 12 =item C<items> => an array of item records =item C<page_size> => number of items per results page =item C<page> => results page number =item C<pages> => total number of pages =item C<total> => total number of items found by the search =back =head2 item_metadata ($item_id) =head3 Returns item record =head2 item_availability ($item_id) =head3 Returns item availability record: =over 12 =item C<id> =item C<available> => boolean =item C<copies_available> => number of copies available =item C<copies_owned> => number of copies owned =item C<type> => availability type, provider dependant =back Not all fields are available for all service providers. For example, some will provide "copies_available", making "available" redundant, whereas others will just provide "available". =head2 is_item_available ($item_id) =head3 Returns boolean Simplified version of L<item_availability()> =cut sub search { die "search() not implemented"; } # relevancy availability available_date title author popularity rating price publisher publication_date sub _parse_sort_string { my $self = shift; my $sort = shift or croak "No sort options"; my $xlate_table = shift || {}; my $camelise = shift; $sort = [split /\s*,\s*/, $sort] unless ref $sort; foreach (@$sort) { my ($s,$d) = split ':'; if (exists $xlate_table->{$s}) { next unless $xlate_table->{$s}; $_ = $xlate_table->{$s}; } else { $_ = $s; } # join('', map{ ucfirst $_ } split(/(?<=[A-Za-z])_(?=[A-Za-z])|\b/, $s)); $_ = join '', map ucfirst, split /(?<=[A-Za-z])_(?=[A-Za-z])|\b/ if $camelise; $_ = "$_:$d" if $d; } return $sort; } sub item_metadata { die "item_metadata() not implemented"; } sub item_availability { die "item_availability() not implemented"; } =head1 INDIVIDUAL USER AUTHENTICATION AND METHODS =head2 user_id / password Provider authentication API is used to get an authorized session. =head3 auth_by_user_id($user_id, $password) An example: my $ils = WebService::ILS::Provider({ client_id => $client_id, client_secret => $client_secret, }); eval { $ils->auth_by_user_id( $user_id, $password ) }; if ($@) { some_error_handling(); return; } $session{ils_access_token} = $ils->access_token; $session{ils_access_token_type} = $ils->access_token_type; ... Somewhere else in your app: my $ils = WebService::ILS::Provider({ client_id => $client_id, client_secret => $client_secret, access_token => $session{ils_access_token}, access_token_type => $session{ils_access_token_type}, }); my $checkouts = $ils->checkouts; =head2 Authentication at the provider User is redirected to the provider authentication url, and after authenticating at the provider redirected back with some kind of auth token. Requires url to handle return redirect from the provider. It can be used as an alternative to FB and Google auth. This is just to give an idea, specifics heavily depend on the provider =head3 auth_url ($redirect_back_uri) Returns provider authentication url to redirect to =head3 auth_token_param_name () Returns auth code url param name =head3 auth_by_token ($provider_token) An example: my $ils = WebService::ILS::Provider({ client_id => $client_id, client_secret => $client_secret, }); my $redirect_url = $ils->auth_url("http://myapp.com/ils-auth"); $response->redirect($redirect_url); ... After successful authentication at the provider, provider redirects back to specified app url (http://myapp.com/ils-auth) /ils-auth handler: my $auth_token = $req->param( $ils->auth_token_param_name ) or some_error_handling(), return; local $@; eval { $ils->auth_by_token( $auth_token ) }; if ($@) { some_error_handling(); return; } $session{ils_access_token} = $ils->access_token; $session{ils_access_token_type} = $ils->access_token_type; ... Somewhere else in your app: passing access token to the constructor as above =cut =head1 CIRCULATION METHODS =head2 patron () =head3 Returns patron record: =over 12 =item C<id> =item C<active> => boolean =item C<copies_available> => number of copies available =item C<checkout_limit> => number of checkouts allowed =item C<hold_limit> => number of holds allowed =back =head2 holds () =head3 Returns holds record: =over 12 =item C<total> => number of items on hold =item C<items> => list of individual items =back In addition to Item record fields described above, item records will have: =over 12 =item C<placed_datetime> => hold timestamp, with or without timezone =item C<queue_position> => user's position in the waiting queue, if available =back =head2 place_hold ($item_id) =head3 Returns holds item record (as described above) In addition, C<total> field will be incorported as well. =head2 remove_hold ($item_id) =head3 Returns true to indicate success Returns true in case user does not have a hold on the item. Throws exception in case of any other failure. =head2 checkouts () =head3 Returns checkout record: =over 12 =item C<total> => number of items on hold =item C<items> => list of individual items =back In addition to Item record fields described above, item records will have: =over 12 =item C<checkout_datetime> => checkout timestamp, with or without timezone =item C<expires> => date (time) checkout expires =item C<url> => download/stream url =item C<files> => an arrayref of downloadable file details title, url, size =back =head2 checkout ($item_id) =head3 Returns checkout item record (as described above) In addition, C<total> field will be incorported as well. =head2 return ($item_id) =head3 Returns true to indicate success Returns true in case user does not have the item checked out. Throws exception in case of any other failure. =cut =head1 NATIVE METHODS All Discovery and Circulation methods (with exception of remove_hold() and return(), where it does not make sense) have native_*() counterparts, eg native_search(), native_item_availability(), native_checkout() etc. In case of single item methods, native_item_availability(), native_checkout() etc, they take item_id as parameter. Otherwise, it's a hashref of HTTP request params (GET or POST). Return value is a record as returned by API. Individual provider subclasses provide additional provider specific native methods. =head1 UTILITY METHODS =head2 Error constants =over 4 =item C<ERROR_ACCESS_TOKEN> =item C<ERROR_NOT_AUTHENTICATED> =back =cut use constant ERROR_ACCESS_TOKEN => "Error: Authorization Failed"; use constant ERROR_NOT_AUTHENTICATED => "Error: User Not Authenticated"; sub invalid_response_exception_string { my $self = shift; my $response = shift; return join "\n", $response->message, "Request:" => $response->request->as_string, "Response:" => $response->as_string ; } sub check_response { my $self = shift; my $response = shift; die $self->invalid_response_exception_string($response) unless $response->is_success; } =head2 error_message ($exception_string) =head3 Returns error message probably suitable for displaying to the user Example: my $res = eval { $ils->checkout($id) }; if ($@) { my $msg = $ils->error_message($@); display($msg); log_error($@); } =head2 is_access_token_error ($exception_string) =head3 Returns true if the error is access token related =head2 is_not_authenticated_error ($exception_string) =head3 Returns true if the error is "Not authenticated" =cut sub error_message { my $self = shift; my $die_string = shift or return; $die_string =~ m/(.*?)\n/o; (my $msg = $1 || $die_string) =~ s! at /.* line \d+\.$!!; return $msg; } sub is_access_token_error { my $self = shift; my $die_string = shift or croak "No error message"; return $self->error_message($die_string) eq ERROR_ACCESS_TOKEN; } sub is_not_authenticated_error { my $self = shift; my $die_string = shift or croak "No error message"; return $self->error_message($die_string) eq ERROR_NOT_AUTHENTICATED; } # Client access authorization # sub _request_with_auth { my $self = shift; my $request = shift or croak "No request"; my $has_token = $self->access_token; my $response = $self->_request_with_token($request); # token expired? $response = $self->_request_with_token($request, "FRESH TOKEN") if $response->code == HTTP_UNAUTHORIZED && $has_token; return $response; } sub make_access_token_request { die "make_access_token_request() not implemented"; } sub _request_access_token { my $self = shift; my $request = shift or croak "No request"; $request->header( Authorization => "Basic " . $self->_access_auth_string ); my $response = $self->user_agent->request( $request ); # XXX check content type return $self->process_json_response( $response, sub { my ($data) = @_; my ($token, $token_type) = $self->_extract_token_from_response($data); $token or die "No access token\n"; $self->access_token($token); $self->access_token_type($token_type || 'Bearer'); return $data; }, sub { my ($data) = @_; die join "\n", ERROR_ACCESS_TOKEN, $self->_error_from_json($data) || $response->decoded_content; } ); } sub _access_auth_string { my $self = shift; return MIME::Base64::encode( join(":", $self->client_id, $self->client_secret) ); } sub _extract_token_from_response { my $self = shift; my $data = shift; return ($data->{access_token}, $data->{token_type}); } sub _request_with_token { my $self = shift; my $request = shift or croak "No request"; my $force_fresh = shift; my $token = $force_fresh ? undef : $self->access_token; unless ($token) { my $request = $self->make_access_token_request; $self->_request_access_token($request); $token = $self->access_token; } die "No access token" unless $token; my $token_type = $self->access_token_type; $request->header( Authorization => "$token_type $token" ); return $self->user_agent->request( $request ); } # Strictly speaking process_json_response() and process_json_error_response() # should go to ::JSON. However, JSON is used for authentication services even for # APIs that are XML, so need to be available sub process_json_response { my $self = shift; my $response = shift or croak "No response"; my $success_callback = shift; my $error_callback = shift; unless ($response->is_success) { return $self->process_json_error_response($response, $error_callback); } my $content_type = $response->header('Content-Type'); die "Invalid Content-Type\n".$response->as_string unless $content_type && $content_type =~ m!application/json!; my $content = $response->decoded_content or die $self->invalid_response_exception_string($response); local $@; my $data = $content ? eval { from_json( $content ) } : {}; die "$@\nResponse:\n".$response->as_string if $@; return $data unless $success_callback; my $res = eval { $success_callback->($data); }; die "$@\nResponse:\n$content" if $@; return $res; } sub process_json_error_response { my $self = shift; my $response = shift or croak "No response"; my $error_callback = shift; my $content_type = $response->header('Content-Type'); if ($content_type && $content_type =~ m!application/json!) { my $content = $response->decoded_content or die $self->invalid_response_exception_string($response); my $data = eval { from_json( $content ) }; die $content || $self->invalid_response_exception_string($response) if $@; if ($error_callback) { return $error_callback->($data); } die $self->_error_from_json($data) || "Invalid response:\n$content"; } die $self->invalid_response_exception_string($response); } sub _error_from_json {}; # wrapper around error response handlers to include some debugging if the debug flag is set sub _error_result { my $self = shift; my $process_sub = shift or croak "No process sub"; my $request = shift or croak "No HTTP request"; my $response = shift or croak "No HTTP response"; return $process_sub->() unless $DEBUG; local $@; my $ret = eval { $process_sub->() }; die join "\n", $@, "Request:", $request->as_string, "Response:", $response->as_string if $@; return $ret; } sub _result_xlate { my $self = shift; my $res = shift; my $xlate_table = shift; return { map { my $val = $res->{$_}; defined($val) ? ($xlate_table->{$_} => $val) : () } keys %$xlate_table }; } =head1 TODO Federated search =cut 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������JSON.pm���������������������������������������������������������������������������������������������100664��001761��001761�� 7430�13167535265� 20523� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS���������������������������������������������������������������������������������������������������������������������������������package WebService::ILS::JSON; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::JSON - WebService::ILS module for services with JSON API =head1 DESCRIPTION To be subclassed See L<WebService::ILS> =cut use Carp; use HTTP::Request::Common; use JSON qw(encode_json); use URI; use parent qw(WebService::ILS); sub with_get_request { my $self = shift; my $callback = shift or croak "No callback"; my $url = shift or croak "No url"; my $get_params = shift; # hash ref my $uri = URI->new($url); $uri->query_form($get_params) if $get_params; my $request = HTTP::Request::Common::GET( $uri ); my $response = $self->_request_with_auth($request); return $self->process_json_response($response, $callback); } sub with_delete_request { my $self = shift; my $callback = shift or croak "No callback"; my $error_callback = shift; my $url = shift or croak "No url"; my $request = HTTP::Request::Common::DELETE( $url ); my $response = $self->_request_with_auth($request); return $response->content ? $self->process_json_response($response, $callback) : 1 if $response->is_success; return $self->_error_result( sub { $self->process_json_error_response($response, $error_callback); }, $request, $response ); } sub with_post_request { my $self = shift; my $callback = shift or croak "No callback"; my $url = shift or croak "No url"; my $post_params = shift || {}; # hash ref my $request = HTTP::Request::Common::POST( $url, $post_params ); my $response = $self->_request_with_auth($request); return $self->process_json_response($response, $callback); } # This will probably not suit everyone sub with_put_request { my $self = shift; my $callback = shift or croak "No callback"; my $url = shift or croak "No url"; my $put_params = shift; my $request = HTTP::Request::Common::PUT( $url ); my $content; if ($put_params) { my $url = URI->new('http:'); $url->query_form(ref($put_params) eq "HASH" ? %$put_params : @$put_params); $content = $url->query; } if( $content ) { # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A') $content =~ s/(?<!%0D)%0A/%0D%0A/go; $request->content_type("application/x-www-form-urlencoded"); $request->content_length(length $content); $request->content($content); } else { $request->content_length(0); } my $response = $self->_request_with_auth($request); return $self->process_json_response($response, $callback); } sub with_json_request { my $self = shift; my $callback = shift or croak "No callback"; my $error_callback = shift; my $url = shift or croak "No url"; my $post_params = shift || {}; # hashref my $method = shift || 'post'; my $req_builder = "HTTP::Request::Common::".uc( $method ); no strict 'refs'; my $request = $req_builder->( $url ); $self->_json_request_content($request, $post_params); my $response = $self->_request_with_auth($request); return $self->process_json_response($response, $callback, $error_callback); } sub _json_request_content { my $self = shift; my $request = shift or croak "No request"; my $data = shift or croak "No data"; # hashref $request->header( 'Content-Type' => 'application/json; charset=utf-8' ); $request->content( encode_json($data) ); $request->header( 'Content-Length' => bytes::length($request->content)); return $request; } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������OverDrive.pm����������������������������������������������������������������������������������������100664��001761��001761�� 22651�13167535265� 21701� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS���������������������������������������������������������������������������������������������������������������������������������package WebService::ILS::OverDrive; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::OverDrive - WebService::ILS module for OverDrive services =head1 SYNOPSIS use WebService::ILS::OverDrive::Library; or use WebService::ILS::OverDrive::Patron; =head1 DESCRIPTION L<WebService::ILS::OverDrive::Library> - anonymous discovery services - no individual user credentials required L<WebService::ILS::OverDrive::Patron> - discovery and circulation services that require individual user credentials See L<WebService::ILS> =cut use Carp; use HTTP::Request::Common; use URI::Escape; use parent qw(WebService::ILS::JSON); use constant API_VERSION => "v1"; use constant DISCOVERY_API_URL => "http://api.overdrive.com/"; use constant TEST_DISCOVERY_API_URL => "http://integration.api.overdrive.com/"; =head1 CONSTRUCTOR =head2 new (%params_hash or $params_hashref) =head3 Additional constructor params: =over 10 =item C<test> => if set to true use OverDrive test API urls =back =cut use Class::Tiny qw( collection_token test ), { _discovery_api_url => sub { $_[0]->test ? TEST_DISCOVERY_API_URL : DISCOVERY_API_URL }, }; __PACKAGE__->_set_param_spec({ test => { required => 0 }, }); =head1 DISCOVERY METHODS =head2 search ($params_hashref) =head3 Additional input params: =over 16 =item C<no_details> => if true, no metadata calls will be made for result items; only id, title, rating and media will be available =back =cut my %SORT_XLATE = ( available_date => "dateadded", rating => "starrating", publication_date => undef, # not available ); sub search { my $self = shift; my $params = shift || {}; my $short_response = delete $params->{no_details}; my $url = $self->products_url; if (my $query = delete $params->{query}) { $query = join " ", @$query if ref $query; $params->{q} = $query; } my $page_size = delete $params->{page_size}; $params->{limit} = $page_size if $page_size; if (my $page_number = delete $params->{page}) { croak "page_size must be specified for paging" unless $params->{limit}; $params->{offset} = ($page_number - 1)*$page_size; } if (my $sort = delete $params->{sort}) { $params->{sort} = join ",", @{ $self->_parse_sort_string($sort, \%SORT_XLATE) }; } $params->{formats} = join ",", @{$params->{formats}} if ref $params->{formats}; my $res = $self->get_response($url, $params); my @items; foreach (@{$res->{products} || []}) { my $item; if ($short_response) { $item = $self->_item_xlate($_); } else { my $native_metadata = $self->native_item_metadata($_) or next; $item = $self->_item_metadata_xlate($native_metadata); } next unless $item; push @items, $item; } my $tot = $res->{totalItems}; my %ret = ( total => $tot, items => \@items, ); if (my $page_size = $res->{limit}) { my $pages = int($tot/$page_size); $pages++ if $tot > $page_size*$pages; $ret{pages} = $pages; $ret{page_size} = $page_size; $ret{page} = $res->{offset}/$page_size + 1; } return \%ret; } my %SEARCH_RESULT_ITEM_XLATE = ( id => "id", title => "title", subtitle => "subtitle", starRating => "rating", mediaType => "media", ); sub _item_xlate { my $self = shift; my $item = shift; my $std_item = $self->_result_xlate($item, \%SEARCH_RESULT_ITEM_XLATE); if (my $formats = $item->{formats}) { $std_item->{formats} = [map $_->{id}, @$formats]; } if (my $images = $item->{images}) { $std_item->{images} = {map { $_ => $images->{$_}{href} } keys %$images}; } # XXX #if (my $details = $item->{contentDetails}) { # $std_item->{details_url} = $details->{href}; #} return $std_item; } my %METADATA_XLATE = ( id => "id", mediaType => "media", title => "title", publisher => "publisher", shortDescription => "subtitle", starRating => "rating", popularity => "popularity", ); sub item_metadata { my $self = shift; my $id = shift or croak "No item id"; my $native_metadata = $self->get_response($self->products_url."/$id/metadata"); return $self->_item_metadata_xlate($native_metadata); } sub _item_metadata_xlate { my $self = shift; my $metadata = shift or croak "No native metadata"; my $item = $self->_result_xlate($metadata, \%METADATA_XLATE); my @authors; foreach (@{ $metadata->{creators} }) { push @authors, $_->{name} if $_->{role} eq "Author"; } $item->{author} = join ", ", @authors; if (my $images = $metadata->{images}) { $item->{images} = {map { $_ => $images->{$_}{href} } keys %$images}; } if (my $languages = $metadata->{languages}) { $item->{languages} = [map $_->{name}, @$languages]; } if (my $subjects = $metadata->{subjects}) { $item->{subjects} = [map $_->{value}, @$subjects]; } if (my $formats = $metadata->{formats}) { $item->{formats} = [map $_->{id}, @$formats]; } return $item; } my %AVAILABILITY_RESULT_XLATE = ( id => "id", available => "available", copiesAvailable => "copies_available", copiesOwned => "copies_owned", availabilityType => "type", ); sub item_availability { my $self = shift; my $id = shift or croak "No item id"; return $self->_result_xlate( $self->get_response($self->products_url."/$id/availability"), \%AVAILABILITY_RESULT_XLATE ); } sub is_item_available { my $self = shift; my $id = shift or croak "No item id"; my $type = shift; my $availability = $self->item_availability($id) or return; return unless $availability->{available}; return !$type || $type eq $availability->{type}; } =head1 NATIVE METHODS =head2 native_search ($params_hashref) See L<https://developer.overdrive.com/apis/search> =head2 native_search_[next|prev|first|last] ($data_as returned_by_native_search*) For iterating through search result pages. Each native_search_*() method accepts record returned by any native_search*() method as input. Example: my $res = $od->native_search({q => "Dogs"}); while ($res) { do_something($res); $res = $od->native_search_next($res); } or my $res = $od->native_search({q => "Dogs"}); my $last = $od->native_search_last($res); my $next_to_last = $od->native_search_prev($last); my $first = $od->native_search_first($next_to_last) # Same as $od->native_search_first($last) # Same as $res =cut # params: q, limit, offset, formats, sort ? availability sub native_search { my $self = shift; my $search_params = shift; return $self->get_response($self->products_url, $search_params); } foreach my $f (qw(next prev first last)) { no strict 'refs'; my $method = "native_search_$f"; *$method = sub { my $self = shift; my $search_data = shift or croak "No search result data"; my $url = _extract_link($search_data, $f) or return; return $self->get_response($url); } } # Item API =head2 native_item_metadata ($item_data as returned by native_search*) =head2 native_item_availability ($item_data as returned by native_search*) Example: my $res = $od->native_search({q => "Dogs"}); foreach (@{ $res->{products} }) { my $meta = $od->native_item_metadata($_); my $availability = $od->native_item_availability($_); ... } =cut sub native_item_metadata { my $self = shift; my $item = shift or croak "No item record"; my $url = _extract_link($item, 'metadata') or die "No metadata link\n"; return $self->get_response($url); } sub native_item_availability { my $self = shift; my $item = shift or croak "No item record"; return $self->get_response(_extract_link($item, 'availability')); } # Discovery helpers sub discovery_action_url { my $self = shift; my $action = shift; return $self->_discovery_api_url.$self->API_VERSION.$action; } sub products_url { my $self = shift; my $collection_token = $self->collection_token or die "No collection token"; if ($collection_token) { return $self->_discovery_api_url.$self->API_VERSION."/collections/$collection_token/products"; } } # API helpers sub _extract_link { my ($data, $link) = @_; my $href = $data->{links}{$link}{href} or croak "No '$link' url in data"; } # Utility methods sub _basic_callback { return $_[0]; } # This is not exatly how we meant to use with_get_request() # ie processing should be placed within the callback. # However, if all goes well, it is faster (from the development perspective) # this way. sub get_response { my $self = shift; my $url = shift or croak "No url"; my $get_params = shift; # hash ref return $self->with_get_request(\&_basic_callback, $url, $get_params); } sub _error_from_json { my $self = shift; my $data = shift or croak "No json data"; my $error = join " ", grep defined($_), $data->{errorCode}, $data->{error_description} || $data->{error} || $data->{message} || $data->{Message}; $error = "$error\n" if $error; # strip code line when dying return $error; } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ���������������������������������������������������������������������������������������Library.pm������������������������������������������������������������������������������������������100664��001761��001761�� 3423�13167535265� 23261� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS/OverDrive�����������������������������������������������������������������������������������������������������������������������package WebService::ILS::OverDrive::Library; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::OverDrive::Library - WebService::ILS module for OverDrive discovery only services =head1 SYNOPSIS use WebService::ILS::OverDrive::Library; =head1 DESCRIPTION See L<WebService::ILS::OverDrive> =cut use Carp; use HTTP::Request::Common; use parent qw(WebService::ILS::OverDrive); __PACKAGE__->_set_param_spec({ library_id => { required => 1, defined => 1 }, }); sub make_access_token_request { my $self = shift; return HTTP::Request::Common::POST( 'https://oauth.overdrive.com/token', { grant_type => 'client_credentials' } ); } sub collection_token { my $self = shift; if (my $collection_token = $self->SUPER::collection_token) { return $collection_token; } $self->native_library_account; my $collection_token = $self->SUPER::collection_token or die "Library has no collections\n"; return $collection_token; } =head1 NATIVE METHODS =head2 native_library_account () See L<https://developer.overdrive.com/apis/library-account> =cut sub native_library_account { my $self = shift; my $library = $self->get_response($self->library_url); if (my $collection_token = $library->{collectionToken}) { $self->SUPER::collection_token( $collection_token); } return $library; } # Discovery helpers sub library_url { my $self = shift; return $self->discovery_action_url("/libraries/".$self->library_id); } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Patron.pm�������������������������������������������������������������������������������������������100664��001761��001761�� 52533�13167535265� 23146� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS/OverDrive�����������������������������������������������������������������������������������������������������������������������# Copyright 2015 Catalyst package WebService::ILS::OverDrive::Patron; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::OverDrive::Patron - WebService::ILS module for OverDrive circulation services =head1 SYNOPSIS use WebService::ILS::OverDrive::Patron; =head1 DESCRIPTION These services require individual user credentials. See L<WebService::ILS INDIVIDUAL USER AUTHENTICATION AND METHODS> See L<WebService::ILS::OverDrive> =cut use Carp; use HTTP::Request::Common; use URI::Escape; use Data::Dumper; use parent qw(WebService::ILS::OverDrive); use constant CIRCULATION_API_URL => "http://patron.api.overdrive.com/"; use constant TEST_CIRCULATION_API_URL => "http://integration-patron.api.overdrive.com/"; use constant OAUTH_BASE_URL => "https://oauth.overdrive.com/"; use constant TOKEN_URL => OAUTH_BASE_URL . 'token'; use constant AUTH_URL => OAUTH_BASE_URL . 'auth'; =head1 CONSTRUCTOR =head2 new (%params_hash or $params_hashref) =head3 Additional constructor params: =over 16 =item C<auth_token> => auth token as previously obtained =back =cut use Class::Tiny qw( user_id password website_id authorization_name auth_token ), { _circulation_api_url => sub { $_[0]->test ? TEST_CIRCULATION_API_URL : CIRCULATION_API_URL }, }; __PACKAGE__->_set_param_spec({ auth_token => { required => 0 }, }); =head1 INDIVIDUAL USER AUTHENTICATION METHODS =head2 auth_by_user_id ($user_id, $password, $website_id, $authorization_name) C<website_id> and C<authorization_name> (domain) are provided by OverDrive =head3 Returns (access_token, access_token_type) or access_token =cut sub auth_by_user_id { my $self = shift; my $user_id = shift or croak "No user id"; my $password = shift; # can be blank my $website_id = shift or croak "No website id"; my $authorization_name = shift or croak "No authorization name"; my $request = $self->_make_access_token_by_user_id_request($user_id, $password, $website_id, $authorization_name); $self->_request_access_token($request); $self->user_id($user_id); $self->password($password); $self->website_id($website_id); $self->authorization_name($authorization_name); return wantarray ? ($self->access_token, $self->access_token_type) : $self->access_token; } sub _make_access_token_by_user_id_request { my $self = shift; my $user_id = shift or croak "No user id"; my $password = shift; # can be blank my $website_id = shift or croak "No website id"; my $authorization_name = shift or croak "No authorization name"; my %params = ( grant_type => 'password', username => $user_id, scope => "websiteid:".$website_id." authorizationname:".$authorization_name, ); if ($password) { $params{password} = $password; } else { $params{password} = "[ignore]"; $params{password_required} = "false"; } return HTTP::Request::Common::POST( 'https://oauth-patron.overdrive.com/patrontoken', \%params ); } =head2 Authentication at OverDrive - Granted or "3-Legged" Authorization With OverDrive there's an extra step - an auth code is returned to the redirect back handler that needs to make an API call to convert it into a auth token. An example: my $overdrive = WebService::ILS::OverDrive::Patron({ client_id => $client_id, client_secret => $client_secret, library_id => $library_id, }); my $redirect_url = $overdrive->auth_url("http://myapp.com/overdrive-auth"); $response->redirect($redirect_url); ... /overdrive-auth handler: my $auth_code = $req->param( $overdrive->auth_code_param_name ) or some_error_handling(), return; # my $state = $req->param( $overdrive->state_token_param_name )... local $@; eval { $overdrive->auth_by_code( $auth_code ) }; if ($@) { some_error_handling(); return; } $session{overdrive_access_token} = $access_token; $session{overdrive_access_token_type} = $access_token_type; $session{overdrive_auth_token} = $auth_token; ... Somewhere else in your app: my $ils = WebService::ILS::Provider({ client_id => $client_id, client_secret => $client_secret, access_token => $session{overdrive_access_token}, access_token_type => $session{overdrive_access_token_type}, auth_token = $session{overdrive_auth_token} }); my $checkouts = $overdrive->checkouts; =head2 auth_url ($redirect_uri, $state_token) =head3 Input params: =over 18 =item C<redirect_uri> => return url which will handle redirect back after auth =item C<state_token> => a token that is returned back unchanged; for additional security; not required =back =cut sub auth_url { my $self = shift; my $redirect_uri = shift or croak "Redirect URI not specified"; my $state_token = shift; my $library_id = $self->library_id or croak "No Library Id"; return sprintf AUTH_URL . "?client_id=%s" . "&redirect_uri=%s" . "&scope=%s" . "&response_type=code" . "&state=%s", map uri_escape($_), $self->client_id, $redirect_uri, "accountid:$library_id", defined ($state_token) ? $state_token : "" ; } =head2 auth_code_param_name () =head2 state_token_param_name () =cut use constant auth_code_param_name => "code"; use constant state_token_param_name => "code"; =head2 auth_by_code ($provider_code, $redirect_uri) =head3 Returns (access_token, access_token_type, auth_token) or access_token =cut sub auth_by_code { my $self = shift; my $code = shift or croak "No authorization code"; my $redirect_uri = shift or croak "Redirect URI not specified"; my $auth_type = 'authorization_code'; my $request = HTTP::Request::Common::POST( TOKEN_URL, { grant_type => 'authorization_code', code => $code, redirect_uri => $redirect_uri, } ); $self->_request_access_token($request); return wantarray ? ($self->access_token, $self->access_token_type, $self->auth_token) : $self->access_token; } =head2 auth_by_token ($provider_token) =head3 Returns (access_token, access_token_type, auth_token) or access_token =cut sub auth_by_token { my $self = shift; my $auth_token = shift or croak "No authorization token"; $self->auth_token($auth_token); my $request = $self->_make_access_token_by_auth_token_request($auth_token); $self->_request_access_token($request); return wantarray ? ($self->access_token, $self->access_token_type, $self->auth_token) : $self->access_token; } sub _make_access_token_by_auth_token_request { my $self = shift; my $auth_token = shift or croak "No authorization token"; return HTTP::Request::Common::POST( TOKEN_URL, { grant_type => 'refresh_token', refresh_token => $auth_token, } ); } sub make_access_token_request { my $self = shift; if (my $auth_token = $self->auth_token) { return $self->_make_access_token_by_auth_token_request($auth_token); } elsif (my $user_id = $self->user_id) { return $self->_make_access_token_by_user_id_request( $user_id, $self->password, $self->website_id, $self->authorization_name ); } die $self->ERROR_NOT_AUTHENTICATED."\n"; } sub _request_access_token { my $self = shift; my $request = shift or croak "No request"; my $data = $self->SUPER::_request_access_token($request) or die "Unsuccessful access token request"; if (my $auth_token = $data->{refresh_token}) { $self->auth_token($auth_token); } return $data; } sub collection_token { my $self = shift; if (my $collection_token = $self->SUPER::collection_token) { return $collection_token; } $self->native_patron; # sets collection_token as a side-effect my $collection_token = $self->SUPER::collection_token or die "Patron has no collections\n"; return $collection_token; } =head1 CIRCULATION METHOD SPECIFICS Differences to general L<WebService::ILS> interface =cut my %PATRON_XLATE = ( checkoutLimit => "checkout_limit", existingPatron => 'active', patronId => 'id', holdLimit => 'hold_limit', ); sub patron { my $self = shift; return $self->_result_xlate($self->native_patron, \%PATRON_XLATE); } my %HOLDS_XLATE = ( totalItems => 'total', ); my %HOLDS_ITEM_XLATE = ( reserveId => 'id', holdPlacedDate => 'placed_datetime', holdListPosition => 'queue_position', ); sub holds { my $self = shift; my $holds = $self->native_holds; my $items = delete ($holds->{holds}) || []; my $res = $self->_result_xlate($holds, \%HOLDS_XLATE); $res->{items} = [ map { my $item = $self->_result_xlate($_, \%HOLDS_ITEM_XLATE); my $item_id = $item->{id}; my $metadata = $self->item_metadata($item_id); my $i = {%$item, %$metadata}; # we need my $i, don't ask me why... } @$items ]; return $res; } =head2 place_hold ($item_id, $notification_email_address, $auto_checkout) C<$notification_email_address> and C<$auto_checkout> are optional. C<$auto_checkout> defaults to false. =head3 Returns holds item record It is prefered that the C<$notification_email_address> is specified. If C<$auto_checkout> is set to true, the item will be checked out as soon as it becomes available. =cut sub place_hold { my $self = shift; my $hold = $self->native_place_hold(@_) or return; my $res = $self->_result_xlate($hold, \%HOLDS_ITEM_XLATE); $res->{total} = $hold->{numberOfHolds}; return $res; } # sub suspend_hold { - not really useful sub remove_hold { my $self = shift; my $item_id = shift or croak "No item id"; my $url = $self->circulation_action_url("/holds/$item_id"); return $self->with_delete_request( \&_basic_callback, sub { my ($data) = @_; return 1 if $data->{errorCode} eq "PatronDoesntHaveTitleOnHold"; die ($data->{message} || $data->{errorCode})."\n"; }, $url ); } =head2 checkouts () For formats see C<checkout_formats()> below =cut my %CHECKOUTS_XLATE = ( totalItems => 'total', totalCheckouts => 'total_format', ); sub checkouts { my $self = shift; my $checkouts = $self->native_checkouts; my $items = delete ($checkouts->{checkouts}) || []; my $res = $self->_result_xlate($checkouts, \%CHECKOUTS_XLATE); $res->{items} = [ map { my $item = $self->_checkout_item_xlate($_); my $item_id = $item->{id}; my $formats = delete ($_->{formats}); my $actions = delete ($_->{actions}); my $metadata = $self->item_metadata($item_id); if ($formats) { $formats = $self->_formats_xlate($item_id, $formats); } else { $formats = {}; } if ($actions) { if (my $format_action = $actions->{format}) { foreach (@{$format_action->{fields}}) { next unless $_->{name} eq "formatType"; foreach my $format (@{$_->{options}}) { $formats->{$format} = undef unless exists $formats->{$format}; } last; } } } my $i = {%$item, %$metadata, formats => $formats}; # we need my $i, don't ask me why... } @$items ]; return $res; } my %CHECKOUT_ITEM_XLATE = ( reserveId => 'id', checkoutDate => 'checkout_datetime', expires => 'expires', ); sub _checkout_item_xlate { my $self = shift; my $item = shift; my $i = $self->_result_xlate($item, \%CHECKOUT_ITEM_XLATE); if ($item->{isFormatLockedIn}) { my $formats = $item->{formats} or die "Item $item->{reserveId}: Format locked in, but no formats returned\n"; $i->{format} = $formats->[0]{formatType}; } return $i; } =head2 checkout ($item_id, $format, $allow_multiple_format_checkouts) C<$format> and C<$allow_multiple_format_checkouts> are optional. C<$allow_multiple_format_checkouts> defaults to false. =head3 Returns checkout item record An item can be available in multiple formats. Checkout is complete only when the format is specified. Checkout can be actioned without format being specified. In that case an early return can be actioned. To complete checkout format must be locked later (see L<lock_format()> below). That would be the case with L<place_hold()> with C<$auto_checkout> set to true. Once format is locked, an early return is not possible. If C<$allow_multiple_format_checkouts> flag is set to true, mutiple formats of the same item can be acioned. If it is false (default) and the item was already checked out, the checked out item record will be returned regardless of the format. Checkout record will have an extra field C<format> if format is locked in. =cut sub checkout { my $self = shift; my $checkout = $self->native_checkout(@_) or return; return $self->_checkout_item_xlate($checkout); } =head2 checkout_formats ($item_id) =head3 Returns a hashref of available title formats and immediate availability { format => available, ... } If format is not immediately available it must be locked first =cut sub checkout_formats { my $self = shift; my $id = shift or croak "No item id"; my $formats = $self->native_checkout_formats($id) or return; $formats = $formats->{'formats'} or return; return $self->_formats_xlate($id, $formats); } sub _formats_xlate { my $self = shift; my $id = shift or croak "No item id"; my $formats = shift or croak "No formats"; my %ret; my $id_uc = uc $id; foreach (@$formats) { die "Non-matching item id\nExpected $id\nGot $_->{reserveId}" unless uc($_->{reserveId}) eq $id_uc; my $format = $_->{formatType}; my $available; if (my $lt = $_->{linkTemplates}) { $available = grep /^downloadLink/, keys %$lt; } $ret{$format} = $available; } return \%ret; } sub is_lockable { my $self = shift; my $checkout_formats = shift or croak "No checkout formats"; while (my ($format, $available) = each %$checkout_formats) { return 1 unless $available; } return 0; } =head2 lock_format ($item_id, $format) =head3 Returns locked format (should be the same as the input value) =cut sub lock_format { my $self = shift; my $item_id = shift or croak "No item id"; my $format = shift or croak "No format"; my $lock = $self->native_lock_format($item_id, $format) or return; die "Non-matching item id\nExpected $item_id\nGot $lock->{reserveId}" unless uc($lock->{reserveId}) eq uc($item_id); return $lock->{formatType}; } =head2 checkout_download_url ($item_id, $format, $error_url, $success_url) =head3 Returns OverDrive download url Checked out items must be downloaded by users on the OverDrive site. This method returns the url where the user should be sent to (redirected). Once the download is complete, user will be redirected back to C<$error_url> in case of an error, otherwise to optional C<$success_url> if specified. See L<https://developer.overdrive.com/apis/download> =cut sub checkout_download_url { my $self = shift; my $item_id = shift or croak "No item id"; my $format = shift or croak "No format"; my $error_url = shift or die "No error url"; my $success_url = shift; $error_url = uri_escape($error_url); $success_url = $success_url ? uri_escape($success_url) : ''; my $url = $self->circulation_action_url("/checkouts/$item_id/formats/$format/downloadlink?errorurl=$error_url&successurl=$success_url"); my $response_data = $self->get_response($url); my $download_url = _extract_link($response_data, 'contentLink') || _extract_link($response_data, 'contentlink') or die "Cannot get download url\n".Dumper($response_data); return $download_url; } sub return { my $self = shift; my $item_id = shift or croak "No item id"; my $url = $self->circulation_action_url("/checkouts/$item_id"); return $self->with_delete_request( \&_basic_callback, sub { my ($data) = @_; return 1 if $data->{errorCode} eq "PatronDoesntHaveTitleCheckedOut"; die ($data->{message} || $data->{errorCode})."\n"; }, $url ); } =head1 NATIVE METHODS =head2 native_patron () See L<https://developer.overdrive.com/apis/patron-information> =cut sub native_patron { my $self = shift; my $url = $self->circulation_action_url(""); my $patron = $self->get_response($url) or return; if (my $collection_token = $patron->{collectionToken}) { $self->SUPER::collection_token( $collection_token); } return $patron; } =head2 native_holds () =head2 native_place_hold ($item_id, $notification_email_address, $auto_checkout) See L<https://developer.overdrive.com/apis/holds> =cut sub native_holds { my $self = shift; my $url = $self->circulation_action_url("/holds"); return $self->get_response($url); } sub native_place_hold { my $self = shift; my $item_id = shift or croak "No item id"; my $email = shift; my $auto_checkout = shift; my @fields = ( {name => "reserveId", value => $item_id } ); push @fields, {name => "autoCheckout", value => "true"} if $auto_checkout; if ($email) { push @fields, {name => "emailAddress", value => $email}; } else { push @fields, {name => "ignoreHoldEmail", value => "true"}; } my $url = $self->circulation_action_url("/holds"); return $self->with_json_request( \&_basic_callback, sub { my ($data) = @_; if ($data->{errorCode} eq "AlreadyOnWaitList") { if (my $holds = $self->native_holds) { my $item_id_uc = uc $item_id; foreach (@{ $holds->{holds} || [] }) { if ( uc($_->{reserveId}) eq $item_id_uc ) { $_->{numberOfHolds} = $holds->{totalItems}; return $_; } } } } die ($data->{message} || $data->{errorCode})."\n"; }, $url, {fields => \@fields} ); } =head2 native_checkouts () =head2 native_checkout_info ($item_id) =head2 native_checkout ($item_id, $format, $allow_multiple_format_checkouts) =head2 native_checkout_formats ($item_id) =head2 native_lock_format ($item_id, $format) See L<https://developer.overdrive.com/apis/checkouts> =cut sub native_checkouts { my $self = shift; my $url = $self->circulation_action_url("/checkouts"); return $self->get_response($url); } sub native_checkout_info { my $self = shift; my $id = shift or croak "No item id"; my $url = $self->circulation_action_url("/checkouts/$id"); return $self->get_response($url); } sub native_checkout_formats { my $self = shift; my $id = shift or croak "No item id"; my $url = $self->circulation_action_url("/checkouts/$id/formats"); return $self->get_response($url); } sub native_checkout { my $self = shift; my $item_id = shift or croak "No item id"; my $format = shift; my $allow_multi = shift; if (my $checkouts = $self->native_checkouts) { my $item_id_uc = uc $item_id; foreach (@{ $checkouts->{checkouts} || [] }) { if ( uc($_->{reserveId}) eq $item_id_uc ) { if ($format) { if ($_->{isFormatLockedIn}) { return $_ if lc($_->{formats}[0]{formatType}) eq lc($format); die "Item $item_id has already been locked for different format '$_->{formats}[0]{formatType}'\n" unless $allow_multi; } # else { $self->native_lock_format()? } } # else { die if !$allow_multi ? } return $_; } } } my $url = $self->circulation_action_url("/checkouts"); return $self->with_json_request( \&_basic_callback, undef, $url, {fields => _build_checkout_fields($item_id, $format)} ); } sub native_lock_format { my $self = shift; my $item_id = shift or croak "No item id"; my $format = shift or croak "No format"; my $url = $self->circulation_action_url("/checkouts/$item_id/formats"); return $self->with_json_request( \&_basic_callback, sub { my ($data) = @_; die "$format ".($data->{message} || $data->{errorCode})."\n"; }, $url, {fields => _build_checkout_fields($item_id, $format)} ); } sub _build_checkout_fields { my ($id, $format) = @_; my @fields = ( {name => "reserveId", value => $id } ); push @fields, {name => "formatType", value => $format} if $format; return \@fields; } # Circulation helpers sub circulation_action_url { my $self = shift; my $action = shift; return $self->_circulation_api_url.$self->API_VERSION."/patrons/me$action"; } # API helpers sub _extract_link { my ($data, $link) = @_; return $data->{links}{$link}->{href}; } sub _basic_callback { return $_[0]; } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ���������������������������������������������������������������������������������������������������������������������������������������������������������������������RecordedBooks.pm������������������������������������������������������������������������������������100664��001761��001761�� 41134�13167535265� 22516� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS���������������������������������������������������������������������������������������������������������������������������������package WebService::ILS::RecordedBooks; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::RecordedBooks - WebService::ILS module for RecordedBooks services =head1 SYNOPSIS use WebService::ILS::RecordedBooks::Partner; or use WebService::ILS::RecordedBooks::Patron; =head1 DESCRIPTION L<WebService::ILS::RecordedBooks::Partner> - services that use partner credentials, for any patron L<WebService::ILS::RecordedBooks::PartnerPatron> - same as above, except it operates on a single patron account L<WebService::ILS::RecordedBooks::Patron> - services that use individual patron credentials, in addition to partner credentials L<WebService::ILS::RecordedBooks::PartnerPatron> is preferred over L<WebService::ILS::RecordedBooks::Patron> because the later requires patron credentials - username and password. However, if you do not know patron's email or RecordedBooks id (barcode) you are stuck with Patron interface. See L<WebService::ILS> =cut use Carp; use HTTP::Request::Common; use URI::Escape; use JSON qw(to_json); use parent qw(WebService::ILS::JSON); use constant API_VERSION => "v1"; use constant BASE_DOMAIN => "rbdigital.com"; =head1 CONSTRUCTOR =head2 new (%params_hash or $params_hashref) =head3 Additional constructor params: =over 12 =item C<ssl> => if set to true use https =item C<domain> => RecordedBooks domain for title url =back C<client_id> is either RecordedBooks id (barcode) or email C<domain> if set is either "whatever.rbdigital.com" or "whatever", in which case rbdigital.com is appended. =cut use Class::Tiny qw( ssl domain _api_base_url ); __PACKAGE__->_set_param_spec({ client_id => { required => 0 }, library_id => { required => 1 }, domain => { required => 0 }, ssl => { required => 0, default => 1 }, }); sub BUILD { my $self = shift; my $params = shift; if (my $domain = $self->domain) { $self->domain("$domain.".BASE_DOMAIN) unless $domain =~ m/\./; } my $ssl = $self->ssl; my $ua = $self->user_agent; $ua->ssl_opts( verify_hostname => 0 ) if $ssl; my $api_url = sprintf "%s://api.%s", $ssl ? "https" : "http", BASE_DOMAIN; $self->_api_base_url($api_url); } sub api_url { my $self = shift; my $action = shift or croak "No action"; return sprintf "%s/%s%s", $self->_api_base_url, API_VERSION, $action; } sub library_action_base_url { my $self = shift; return $self->api_url("/libraries/".$self->library_id); } sub products_url { my $self = shift; return $self->library_action_base_url."/search"; } sub circulation_action_url { my $self = shift; my $action = shift or croak "No action"; return $self->circulation_action_base_url(@_).$action; } sub _access_auth_string { my $self = shift; return $self->client_secret; } sub native_countries { my $self = shift; my $url = $self->api_url("/countries"); return $self->get_without_auth($url); } sub native_facets { my $self = shift; my $url = $self->api_url("/facets"); return $self->get_response($url); } sub native_facet_values { my $self = shift; my $facet = shift or croak "No facet"; my $url = $self->api_url("/facets/$facet"); return $self->get_without_auth($url); } sub native_libraries_search { my $self = shift; my $query = shift or croak "No query"; my $region = shift; my %search_params = ( term => $query ); $search_params{ar} = $region if $region; my $url = $self->api_url("/suggestive/libraries"); return $self->get_without_auth($url, \%search_params); } sub get_without_auth { my $self = shift; my $url = shift or croak "No url"; my $get_params = shift; # hash ref my $uri = URI->new($url); $uri->query_form($get_params) if $get_params; my $request = HTTP::Request::Common::GET( $uri ); my $response = $self->user_agent->request( $request ); $self->check_response($response); return $self->process_json_response($response, sub { my ($data) = @_; die "No data\n" unless $data; return $data; }); } =head1 DISCOVERY METHODS =head2 facets () =head3 Returns a hashref of facet => [values] =cut sub facets { my $self = shift; my $facets = $self->native_facets; my %facet_values; foreach (@$facets) { my $f = $_->{facetToken}; $facet_values{$f} = [map $_->{valueToken}, @{ $self->native_facet_values($f) }]; } return \%facet_values; } =head2 search ($params_hashref) =head3 Additional input params: =over 12 =item C<facets> => a hashref of facet values =back =cut my %SORT_XLATE = ( rating => undef, publication_date => undef, # not available ); sub search { my $self = shift; my $params = shift || {}; my $url = $self->products_url; if (my $query = delete $params->{query}) { $query = join " ", @$query if ref $query; $params->{all} = $query; } if (my $page_size = delete $params->{page_size}) { $params->{'page-size'} = $page_size; } if (my $page_number = delete $params->{page}) { die "page_size must be specified for paging" unless $params->{'page-size'}; $params->{'page-index'} = $page_number - 1; } if (my $sort = delete $params->{sort}) { my $sa = $self->_parse_sort_string($sort, \%SORT_XLATE); if (@$sa) { my @params = %$params; foreach (@$sa) { my ($s, $d) = split ':'; push @params, "sort-by", $s; push @params, "sort-order", $d if $d; } return $self->_search_result_xlate( $self->get_response($url, \@params) ); } } return $self->_search_result_xlate( $self->get_response($url, $params) ); } sub _search_result_xlate { my $self = shift; my $res = shift or return; my $domain = $self->domain; return { items => [ map { my $i = $self->_item_xlate($_->{item}); $i->{url} ||= "https://$domain/#titles/$i->{isbn}" if $domain; $i; } @{$res->{items} || []} ], page_size => $res->{pageSize}, page => $res->{pageIndex} + 1, pages => $res->{pageCount}, }; } my %SEARCH_RESULT_ITEM_XLATE = ( id => "id", title => "title", subtitle => "subtitle", shortDescription => "description", mediaType => "media", downloadUrl => "url", encryptionKey => "encryption_key", isbn => "isbn", hasDrm => "drm", releasedDate => "publication_date", size => "size", language => "language", expiration => "expires", ); my %ITEM_FILES_XLATE = ( id => "id", filename => "filename", display => "title", downloadUrl => "url", size => "size", ); sub _item_xlate { my $self = shift; my $item = shift; my $std_item = $self->_result_xlate($item, \%SEARCH_RESULT_ITEM_XLATE); if (my $images = delete $item->{images}) { # XXX let's say that caller wouldn't mind $std_item->{images} = {map { $_->{name} => $_->{url} } @$images}; } if (my $files = delete $item->{files}) { $std_item->{files} = [ map $self->_result_xlate($_, \%ITEM_FILES_XLATE), @$files ]; } my %facets; if (my $publisher = delete $item->{publisher}) { if (ref $publisher) { if (my $f = $publisher->{facet}) { $facets{$f} = [$publisher->{token}]; } $publisher = $publisher->{text}; } $std_item->{publisher} = $publisher; } if (my $authors = delete $item->{authors}) { my @a; if (ref $authors) { foreach (@$authors) { push @a, $_->{text} if $_->{text}; if (my $f = $_->{facet}) { my $f_a = $facets{$f} ||= []; push @$f_a, $_->{token}; } } } else { push @a, $authors; } $std_item->{author} = join ", ", @a; } foreach my $v (values %$item) { my $ref = ref $v or next; $v = [$v] if $ref eq "HASH"; next unless ref($v) eq "ARRAY"; foreach (@$v) { if (my $f = $_->{facet}) { my $f_a = $facets{$f} ||= []; push @$f_a, $_->{token}; } } } $std_item->{facets} = \%facets if keys %facets; return $std_item; } =head2 named_query_search ($query, $media) See C<native_named_query_search()> below for $query, $media =cut sub named_query_search { my $self = shift; return $self->_search_result_xlate( $self->native_named_query_search(@_) ); } =head2 facet_search ($facets) See C<native_facet_search()> below for $facets =cut sub facet_search { my $self = shift; return $self->_search_result_xlate( $self->native_facet_search(@_) ); } sub item_metadata { my $self = shift; my $ni = $self->native_item(@_) or return; return $self->_item_xlate( $ni->{item} ); } =head1 CIRCULATION METHOD SPECIFICS Differences to general L<WebService::ILS> interface =cut =head2 holds () =head2 place_hold ($isbn) =head2 remove_hold ($isbn) =cut sub holds { my $self = shift; my $items = $self->native_holds(@_); return { total => scalar @$items, items => [ map { my $i = $self->_item_xlate($_); $i->{hold_id} = $_->{transactionId}; $i; } @$items ], }; } sub place_hold { my $self = shift; my $isbn = shift or croak "No isbn"; my $url = $self->circulation_action_url("/holds/$isbn", @_); my $request = HTTP::Request::Common::POST( $url ); my $response = $self->_request_with_auth($request); unless ($response->is_success) { $self->process_json_error_response($response, sub { my ($data) = @_; if (my $message = $data->{message}) { return 1 if $message =~ m/already exists/i; die $message; } die $self->_error_from_json($data) || "Cannot place hold: ".to_json($data); }); } if (my $holds = $self->holds(@_)) { foreach my $i (@{ $holds->{items} }) { if ($i->{isbn} eq $isbn) { $i->{total} = $holds->{total}; return $i; } } } my $content = $response->decoded_content; my $content_type = $response->header('Content-Type'); my $error; if ($content_type && $content_type =~ m!application/json!) { if (my $data = eval { from_json( $content ) }) { $error = $self->_error_from_json($data); } } die $error || "Cannot place hold:\n$content"; } sub remove_hold { my $self = shift; my $isbn = shift or croak "No isbn"; my $url = $self->circulation_action_url("/holds/$isbn", @_); my $request = HTTP::Request::Common::DELETE( $url ); my $response = $self->_request_with_auth($request); unless ($response->is_success) { return $self->process_json_error_response($response, sub { my ($data) = @_; if (my $message = $data->{message}) { return 1 if $message =~ m/not exists|expired/i; die $message; } die $self->_error_from_json($data) || "Cannot remove hold: ".to_json($data); }); } return 1; } =head2 checkouts () =head2 checkout ($isbn, $days) =head2 renew ($isbn) =head2 return ($isbn) =cut sub checkouts { my $self = shift; my $items = $self->native_checkouts(@_); return { total => scalar @$items, items => [ map { my $i = $self->_item_xlate($_); $i->{checkout_id} = $_->{transactionId}; $i; } @$items ], }; } sub checkout { my $self = shift; my $isbn = shift or croak "No isbn"; my $days = shift; if (my $checkouts = $self->checkouts(@_)) { foreach my $i (@{ $checkouts->{items} }) { if ( $i->{isbn} eq $isbn ) { $i->{total} = scalar @{ $checkouts->{items} }; return $i; } } } my $url = $self->circulation_action_url("/checkouts/$isbn", @_); $url .= "?days=$days" if $days; my $res = $self->with_post_request( \&_basic_callback, $url ); my $checkouts = $self->checkouts(@_) or die "Cannot checkout, unknown error"; foreach my $i (@{ $checkouts->{items} }) { if ($i->{isbn} eq $isbn) { $i->{total} = scalar @{ $checkouts->{items} }; return $i; } } die $res->{message} || "Cannot checkout, unknown error"; } sub renew { my $self = shift; my $isbn = shift or croak "No isbn"; my $url = $self->circulation_action_url("/checkouts/$isbn", @_); my $res = $self->with_put_request( \&_basic_callback, $url ); my $checkouts = $self->checkouts(@_) or die "Cannot renew, unkmown error"; foreach my $i (@{ $checkouts->{items} }) { if ($i->{isbn} eq $isbn) { $i->{total} = scalar @{ $checkouts->{items} }; return $i; } } die $res->{output} || "Cannot renew, unknown error"; } sub return { my $self = shift; my $isbn = shift or croak "No isbn"; my $url = $self->circulation_action_url("/checkouts/$isbn", @_); my $request = HTTP::Request::Common::DELETE( $url ); my $response = $self->_request_with_auth($request); unless ($response->is_success) { return $self->process_json_error_response($response, sub { my ($data) = @_; if (my $message = $data->{message}) { return 1 if $message =~ m/not exists|expired/i; die $message; } die "Cannot return: ".to_json($data); }); } return 1; } =head1 NATIVE METHODS =head2 native_search ($params_hashref) See L<https://developer.overdrive.com/apis/search> =cut sub native_search { my $self = shift; my $search_params = shift; return $self->get_response($self->products_url, $search_params); } =head2 native_named_query_search ($query, $media) $query can be one of 'bestsellers', 'most-popular', 'newly-added' $media can be 'eaudio' or 'ebook' =cut my @MEDIA = qw( eaudio ebook ); my @NAMED_QUERY = ( 'bestsellers', 'most-popular', 'newly-added' ); sub native_named_query_search { my $self = shift; my $query = shift or croak "No query"; my $media = shift or croak "No media"; croak "Invalid media $media - should be one of ".join(", ", @MEDIA) unless grep { $_ eq $media } @MEDIA; croak "Invalid named query $query - should be one of ".join(", ", @NAMED_QUERY) unless grep { $_ eq $query } @NAMED_QUERY; my $url = $self->products_url."/$media/$query"; return $self->get_response($url); } =head2 native_facet_search ($facets) $facets can be either: * a hashref of facet => [values], * an arrayref of values * a single value =cut sub native_facet_search { my $self = shift; my $facets = shift or croak "No facets"; $facets = [$facets] unless ref $facets; my $url = $self->products_url; if (ref ($facets) eq "ARRAY") { $url = join "/", $url, @$facets; undef $facets; } return $self->get_response($url, $facets); } # Item API =head2 native_item ($isbn) =head2 native_item_summary ($isbn) =head3 Returns subset of item fields, with addition of summary field =cut sub native_item { my $self = shift; my $isbn = shift or croak "No isbn"; my $url = $self->title_url($isbn); return $self->get_response($url); } sub native_item_summary { my $self = shift; my $isbn = shift or croak "No isbn"; my $url = $self->title_url("$isbn/summary"); return $self->get_response($url); } =head2 native_holds () See L<http://developer.rbdigital.com/endpoints/title-holds> =cut sub native_holds { my $self = shift; my $url = $self->circulation_action_url("/holds/all", @_); return $self->get_response($url); } =head2 native_checkouts () =cut sub native_checkouts { my $self = shift; my $url = $self->circulation_action_url("/checkouts/all", @_); return $self->get_response($url); } # Utility methods sub _basic_callback { return $_[0]; } sub get_response { my $self = shift; my $url = shift or croak "No url"; my $get_params = shift; # hash ref return $self->with_get_request(\&_basic_callback, $url, $get_params); } sub _error_from_json { my $self = shift; my $data = shift or croak "No json data"; return join " ", grep defined, $data->{errorCode}, $data->{message}; } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Partner.pm������������������������������������������������������������������������������������������100664��001761��001761�� 4740�13167535265� 24113� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS/RecordedBooks�������������������������������������������������������������������������������������������������������������������package WebService::ILS::RecordedBooks::Partner; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::RecordedBooks::Partner - RecordedBooks partner API =head1 SYNOPSIS use WebService::ILS::RecordedBooks::Partner; =head1 DESCRIPTION L<WebService::ILS::RecordedBooks::Partner> - services that use trusted partner credentials See L<WebService::ILS::RecordedBooks> =cut use Carp; use parent qw(WebService::ILS::RecordedBooks::PartnerBase); sub circulation_action_base_url { my $self = shift; my $patron_id = shift or croak "No patron id"; return $self->library_action_base_url."/patrons/${patron_id}"; } =head1 DISCOVERY METHODS =head2 facet_search ($facets) See C<native_facet_search()> below for $facets =head2 named_query_search ($query, $media) See C<native_named_query_search()> below for $query, $media =head1 CIRCULATION METHOD SPECIFICS Differences to general L<WebService::ILS> interface =head2 patron_id ($email_or_id) =head2 holds ($patron_id) =head2 place_hold ($patron_id, $isbn) =head2 checkouts ($patron_id) =head2 checkout ($patron_id, $isbn) =head2 renew ($patron_id, $isbn) =head2 return ($patron_id, $isbn) =cut foreach my $sub (qw(place_hold remove_hold renew return)) { no strict "refs"; *$sub = sub { my $self = shift; my $patron_id = shift or croak "No patron id"; my $isbn = shift or croak "No isbn"; my $supersub = "SUPER::$sub"; return $self->$supersub($isbn, $patron_id); }; } sub checkout { my $self = shift; my $patron_id = shift or croak "No patron id"; my $isbn = shift or croak "No isbn"; my $days = shift; return $self->SUPER::checkout($isbn, $days, $patron_id); } =head1 NATIVE METHODS =head2 native_quick_search ($query, $category) $category can be one of 'all', 'title', 'author', or 'narrator'; optional, defaults to 'all' =cut =head2 native_facet_search ($facets) $facets can be either: * a hashref of facet => [values], * an arrayref of values * a single value =head2 native_named_query_search ($query, $media) $query can be one of 'bestsellers', 'most-popular', 'newly-added' $media can be 'eaudio' or 'ebook' =head2 native_patron ($email_or_id) =cut 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ��������������������������������PartnerBase.pm��������������������������������������������������������������������������������������100664��001761��001761�� 3375�13167535265� 24711� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS/RecordedBooks�������������������������������������������������������������������������������������������������������������������package WebService::ILS::RecordedBooks::PartnerBase; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::RecordedBooks::PartnerBase - RecordedBooks partner API =head1 SYNOPSIS See L<WebService::ILS::RecordedBooks::Partner> and L<WebService::ILS::RecordedBooks::PartnerPatron>; =cut use Carp; use URI::Escape; use parent qw(WebService::ILS::RecordedBooks); sub title_url { my $self = shift; my $isbn = shift or croak "No isbn"; return $self->library_action_base_url."/titles/$isbn"; } sub _request_with_token { my $self = shift; my $request = shift or croak "No request"; $request->header( Authorization => "Basic ".$self->client_secret ); return $self->user_agent->request( $request ); } =head1 CIRCULATION METHOD SPECIFICS =cut use constant NATIVE_PATRON_ID_KEY => "patronId"; my %PATRON_XLATE = ( NATIVE_PATRON_ID_KEY() => 'id', ); sub patron { my $self = shift; return $self->_result_xlate($self->native_patron(@_), \%PATRON_XLATE); } =head2 patron_id ($email_or_id) =cut sub patron_id { my $self = shift; my $patron = $self->native_patron(@_) or return; return $patron->{NATIVE_PATRON_ID_KEY()}; } =head1 NATIVE METHODS =head2 native_patron ($email_or_id) =cut sub native_patron { my $self = shift; my $cardnum_or_email = shift or croak "No patron identification"; my $url = $self->api_url("/rpc/libraries/".$self->library_id."/patrons/".uri_escape($cardnum_or_email)); return $self->get_response($url); } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������PartnerPatron.pm������������������������������������������������������������������������������������100664��001761��001761�� 3414�13167535265� 25274� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS/RecordedBooks�������������������������������������������������������������������������������������������������������������������package WebService::ILS::RecordedBooks::PartnerPatron; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::RecordedBooks::PartnerPatron - RecordedBooks patner API for an individual patron =head1 SYNOPSIS use WebService::ILS::RecordedBooks::PartnerPatron; =head1 DESCRIPTION L<WebService::ILS::RecordedBooks::PartnerPatron> - services that use trusted partner credentials to operat on behalf of a specified patron See L<WebService::ILS::RecordedBooks::Partner> =cut use Carp; use parent qw(WebService::ILS::RecordedBooks::PartnerBase); =head1 CONSTRUCTOR =head2 new (%params_hash or $params_hashref) =head3 Additional constructor params: =over 12 =item C<user_id> => RecordedBooks user id (barcode), or email =back C<client_id> is either RecordedBooks id (barcode) or email =cut use Class::Tiny qw( user_id ); __PACKAGE__->_set_param_spec({ user_id => { required => 1 }, }); sub BUILD { my $self = shift; my $params = shift; local $@; my $patron_id = eval { $self->SUPER::patron_id($self->user_id) } or croak "Invalid user_id ".$self->user_id.($@ ? "\n$@" : ""); $self->user_id($patron_id); } sub circulation_action_base_url { my $self = shift; return $self->library_action_base_url."/patrons/".$self->user_id; } sub patron_id { my $self = shift; return $self->user_id; } sub patron { my $self = shift; return {id => $self->user_id}; } =head1 NATIVE METHODS =head2 native_patron () This method cannot be called =cut 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Patron.pm�������������������������������������������������������������������������������������������100664��001761��001761�� 3451�13167535265� 23741� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS/RecordedBooks�������������������������������������������������������������������������������������������������������������������package WebService::ILS::RecordedBooks::Patron; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::RecordedBooks::Patron - RecordedBooks patron API =head1 SYNOPSIS use WebService::ILS::RecordedBooks::Patron; =cut =head1 DESCRIPTION L<WebService::ILS::RecordedBooks::Patron> - services that require patron credentials See L<WebService::ILS::RecordedBooks> =cut use Carp; use parent qw(WebService::ILS::RecordedBooks); =head1 CONSTRUCTOR =head2 new (%params_hash or $params_hashref) =head3 Additional constructor params: =over 16 =item C<user_id> =item C<password> =back =cut use Class::Tiny qw( user_id password ); __PACKAGE__->_set_param_spec({ user_id => { required => 1 }, password => { required => 1 }, }); sub _access_auth_string { my $self = shift; return $self->client_secret; } sub _extract_token_from_response { my $self = shift; my $data = shift; return ($data->{bearer}, "bearer"); } sub make_access_token_request { my $self = shift; my $url = $self->api_url("/tokens"); my %params = ( UserName => $self->user_id, Password => $self->password, LibraryId => $self->library_id, ); my $req = HTTP::Request::Common::POST( $url ); return $self->_json_request_content($req, \%params); } sub title_url { my $self = shift; my $isbn = shift or croak "No isbn"; return $self->api_url("/titles/$isbn"); } sub circulation_action_base_url { my $self = shift; return $self->api_url("/transactions"); } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������XML.pm����������������������������������������������������������������������������������������������100664��001761��001761�� 12051�13167535265� 20425� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/lib/WebService/ILS���������������������������������������������������������������������������������������������������������������������������������package WebService::ILS::XML; use Modern::Perl; =encoding utf-8 =head1 NAME WebService::ILS::JSON - WebService::ILS module for services with XML API =head1 DESCRIPTION To be subclassed See L<WebService::ILS> =cut use Carp; use HTTP::Request::Common; use URI; use XML::LibXML; use parent qw(WebService::ILS); sub with_get_request { my $self = shift; my $callback = shift or croak "No callback"; my $url = shift or croak "No url"; my $get_params = shift; # hash ref my $uri = URI->new($url); $uri->query_form($get_params) if $get_params; my $request = HTTP::Request::Common::GET( $uri ); my $response = $self->_request_with_auth($request); return $self->process_xml_response($response, $callback); } sub with_delete_request { my $self = shift; my $callback = shift or croak "No callback"; my $error_callback = shift; my $url = shift or croak "No url"; my $request = HTTP::Request::Common::DELETE( $url ); my $response = $self->_request_with_auth($request); return 1 if $response->is_success; return $self->_error_result( sub { $self->process_invalid_xml_response($response, $error_callback); }, $request, $response ); } sub with_post_request { my $self = shift; my $callback = shift or croak "No callback"; my $url = shift or croak "No url"; my $post_params = shift || {}; # hash ref my $request = HTTP::Request::Common::POST( $url, $post_params ); my $response = $self->_request_with_auth($request); return $self->process_xml_response($response, $callback); } sub with_xml_request { my $self = shift; my $callback = shift or croak "No callback"; my $error_callback = shift; my $url = shift or croak "No url"; my $dom = shift or croak "No XML document"; my $method = shift || 'post'; my $req_builder = "HTTP::Request::Common::".uc( $method ); no strict 'refs'; my $request = $req_builder->( $url ); $request->header( 'Content-Type' => 'application/xml; charset=utf-8' ); $request->content( $dom->toeString ); $request->header( 'Content-Length' => bytes::length($request->content)); my $response = $self->_request_with_auth($request); return $self->process_xml_response($response, $callback, $error_callback); } sub process_xml_response { my $self = shift; my $response = shift or croak "No response"; my $success_callback = shift; my $error_callback = shift; unless ($response->is_success) { return $self->process_xml_error_response($response, $error_callback); } my $content_type = $response->header('Content-Type'); die $response->as_string unless $content_type && $content_type =~ m!application/xml!; my $content = $response->decoded_content or die $self->invalid_response_exception_string($response); local $@; my $doc = eval { XML::LibXML->load_xml( string => $content )->documentElement() }; #XXX check XML::LibXML::Error die "$@\nResponse:\n".$response->as_string if $@; return $doc unless $success_callback; my $res = eval { $success_callback->($doc); }; die "$@\nResponse:\n$content" if $@; return $res; } sub process_xml_error_response { my $self = shift; my $response = shift or croak "No response"; my $error_callback = shift; my $content_type = $response->header('Content-Type'); if ($content_type && $content_type =~ m!application/xml!) { my $content = $response->decoded_content or die $self->invalid_response_exception_string($response); my $doc = eval { XML::LibXML->load_xml( string => $content )->documentElement() }; #XXX check XML::LibXML::Error die "$@\nResponse:\n$content" if $@; if ($error_callback) { return $error_callback->($doc); } die $self->_error_from_xml($doc) || "Invalid response:\n$content"; } die $self->invalid_response_exception_string($response); } sub _error_from_xml {}; sub _first_child_content { my $self = shift; my $parent_elt = shift or croak "No parent element"; my $tag = shift or croak "No child tag name"; my $child_elts = $parent_elt->getElementsByTagName($tag) or return; my $child_elt = $child_elts->shift or return; return $child_elt->textContent; } sub _children_content { my $self = shift; my $parent_elt = shift or croak "No parent element"; my $tag = shift or croak "No child tag name"; my $child_elts = $parent_elt->getElementsByTagName($tag) or return; return [ $child_elts->map( sub { $_[0]->textContent } ) ]; } sub _xml_to_hash { my $self = shift; my $parent_elt = shift or croak "No parent element"; my $tags = shift or croak "No children tag names"; return { map { $_ => $self->_first_child_content($parent_elt, $_) } @$tags }; } 1; __END__ =head1 LICENSE Copyright (C) Catalyst IT NZ Ltd Copyright (C) Bywater Solutions This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> =cut ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������minil.toml������������������������������������������������������������������������������������������100664��001761��001761�� 240�13167535265� 16136� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17����������������������������������������������������������������������������������������������������������������������������������������������������name = "WebService-ILS" # badges = ["travis"] module_maker="ModuleBuildTiny" readme_from="Readme.pod" [FileGatherer] exclude_match = ['^test.env', '^attic/'] ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������interface.t�����������������������������������������������������������������������������������������100664��001761��001761�� 463�13167535265� 16530� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t��������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use Modern::Perl; use Test::More tests => 3; use_ok('WebService::ILS'); my %params = ( client_id => "DUMMY", client_secret => "DUMMY", ); ok( WebService::ILS->new(%params), "WebService::ILS->new(name => val...)"); ok( WebService::ILS->new(\%params), "WebService::ILS->new({})"); �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Discovery.pm����������������������������������������������������������������������������������������100664��001761��001761�� 5040�13167535265� 17675� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t/lib/T��������������������������������������������������������������������������������������������������������������������������������������������package T::Discovery; use Modern::Perl; use Test::More; use Data::Dumper; #use Data::Random::WordList; #use constant WORDLIST => $ENV{ILS_TEST_WORDLIST} || '/usr/share/dict/words'; sub search_query { # my $wl = new Data::Random::WordList( # wordlist => WORDLIST # ); # while (1) { # my $w = ($wl->get_words)[0]; # next unless $w =~ m/^[a-z]+$/o; # return $w; # } return 'art'; } use constant DEFAULT_ITEM_FIELDS => [ qw(author media) ]; sub search { my ($ils, $item_fields) = @_; my $query = search_query(); my $resp = $ils->search({query => $query}); ok( exists $resp->{total}, "Search results ($query)") or diag(Dumper($resp)); my $items; SKIP: { skip "No search results", 1 unless $resp->{total}; $items = $resp->{items}; my $item = $items->[0]; my $id = $item->{id} or BAIL_OUT("No item id in search results \n".Dumper($resp)); ok( $item->{title}, "Search result item title ($query)") or diag(Dumper($item)); my $ok_fields = 1; $ok_fields &&= exists( $item->{$_} ) foreach @{ $item_fields || DEFAULT_ITEM_FIELDS }; ok( $ok_fields, "Search result item fields ($query)") or diag(Dumper($item)); my $availability = $ils->item_availability($id); ok( defined $availability->{available}, "Item availability") or diag(Dumper($availability)); my $pages = $resp->{pages}; SKIP: { skip "No multiple pages", 1 unless $pages > 1; $resp = $ils->search( {query => $query, page => 2, page_size => $resp->{page_size}} ); is( $resp->{page}, 2, "Search results page 2") or diag(Dumper($resp)); } } return $items; } sub search_all_random_page { my ($ils, $floor) = @_; $floor ||= 1; my $resp = $ils->search; my $page = 1; if (my $pages = $resp->{pages}) { if ($floor > $pages) { diag("Min page requested: $floor; resultset has only $pages pages\n".Dumper($resp)); return; } if ($floor < $pages) { $page = $floor + int(rand($pages - $floor)); # deliberately skew to lower page $resp = $ils->search( {page => $page, page_size => $resp->{page_size}} ) if $page > 1; } } else { diag("No 'pages' in Full collection search results\n".Dumper($resp)); return if $floor > 1; } my $items = $resp->{items}; return wantarray ? ($items, $page) : $items; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������OverDrive.pm����������������������������������������������������������������������������������������100664��001761��001761�� 6362�13167535265� 17643� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t/lib/T��������������������������������������������������������������������������������������������������������������������������������������������package T::OverDrive; use Modern::Perl; use Test::More; use Data::Dumper; use T::Discovery; my @ITEM_FIELDS = qw( author media subtitle publisher rating popularity ); sub search { my ($od) = @_; T::Discovery::search($od, \@ITEM_FIELDS); my $query = T::Discovery::search_query(); my $resp = $od->search({query => $query, no_details => 1}); ok( exists $resp->{total}, "Search results ($query)") or diag(Dumper($resp)); my $items; SKIP: { skip "No search results", 1 unless $resp->{total}; $items = $resp->{items}; my $item = $items->[0]; my $id = $item->{id} or BAIL_OUT("No item id in search results \n".Dumper($resp)); ok( $item->{title}, "Search result item title ($query)") or diag(Dumper($item)); my $ok_fields = 1; $ok_fields &&= exists( $item->{$_} ) foreach qw(subtitle media); ok( $ok_fields, "Search result item fields ($query)") or diag(Dumper($item)); my $metadata = $od->item_metadata($id); ok( defined $metadata->{title}, "Item metadata") or diag(Dumper($metadata)); } } sub native_search { my ($od) = @_; my $query = T::Discovery::search_query(); my $resp = $od->native_search({q => $query}); ok( exists $resp->{totalItems}, "Native search results ($query)") or diag("native_search: ".Dumper($resp)); my $items; SKIP: { skip "No native search results", 1 unless $resp->{totalItems}; $items = $resp->{products}; my $item = $resp->{products}[0]; my $id = $item->{id}; ok ($id, "Item id in native search results") or diag(Dumper($resp)); my $availability = $od->native_item_availability($item); ok( defined $availability->{available}, "Native item availability") or diag(Dumper($availability)); my $metadata = $od->native_item_metadata($item); ok( defined $metadata->{title}, "Native item metadata") or diag(Dumper($metadata)); my $multipage = $resp->{links}{next}; SKIP: { skip "No multiple pages", 1 unless $multipage; $resp = $od->native_search_next($resp); ok( $resp->{offset} > 0, "Native search results page 2") or diag(Dumper($resp)); $resp = $od->native_search_prev($resp); ok( $resp->{offset} == 0, "Native search results page 1") or diag(Dumper($resp)); } $resp = $od->native_search_last($resp); ok( $multipage ? $resp->{offset} > 0 : $resp->{offset} == 0 , "Native search results last page") or diag(Dumper($resp)); $resp = $od->native_search_first($resp); ok( $resp->{offset} == 0, "Native search results first page") or diag(Dumper($resp)); } return $items; } sub patron { my ($od) = @_; my $patron = $od->patron; my ($patron_id, $hold_limit, $checkout_limit, $active); if ($patron) { $patron_id = $patron->{id}; $hold_limit = $patron->{hold_limit}; $checkout_limit = $patron->{checkout_limit}; } ok($patron_id && defined($hold_limit) && defined($checkout_limit), "Patron") or diag(Dumper($patron)); return $patron; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Test.pod��������������������������������������������������������������������������������������������100664��001761��001761�� 5642�13167535265� 17023� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t/lib/T��������������������������������������������������������������������������������������������������������������������������������������������=head1 TESTING ENVIRONMENT Testing C<WebService::ILS> modules is extremely difficult. It requires test accounts with vendors, sometimes special setup for handling redirect URLs. In that respect for building purposes, all tests are skipped by default. If you want to run tests for vendor specific modules during the build, you need to set the corresponding WEBSERVICE_ILS_TEST_* env vars to true, and supply values in vendor specific env vars. Those vendor specific vars correspond to L<CONSTRUCTOR> params. =head1 TESTING OverDrive API =over 4 =item B<WEBSERVICE_ILS_TEST_OVERDRIVE_LIBRARY> When set to true turns on tests from t/overdrve_library.t, which test C<WebService::ILS::OverDrive::Library> module =item B<WEBSERVICE_ILS_TEST_OVERDRIVE_PATRON> When set to true turns on tests from t/overdrve_patron.t, which test C<WebService::ILS::OverDrive::Patron> module =item B<WEBSERVICE_ILS_TEST_OVERDRIVE_AUTH> When set to true turns on tests from t/overdrve_auth.t, which test OverDrive Granted (3-legged) authentication mechanism. It is separated because of the challenges it presents =back =head2 OverDrive account vars Those with default values can be omitted =over 4 =item B<OVERDRIVE_TEST_CLIENT_ID> =item B<OVERDRIVE_TEST_CLIENT_SECRET> =item B<OVERDRIVE_TEST_LIBRARY_ID> library and auth; always 4425? =item B<OVERDRIVE_TEST_WEBSITE_ID> patron only =item B<OVERDRIVE_TEST_AUTHORIZATION_NAME> patron only; default odapilibrary =item B<OVERDRIVE_TEST_USER_ID> patron only =item B<OVERDRIVE_TEST_USER_PASSWORD> patron only =item B<OVERDRIVE_TEST_AUTH_REDIRECT_URL> auth only; with a designated port =item B<OVERDRIVE_TEST_AUTH_WEB_BROWSER_EXE> auth only; not required, auth url will be printed. If set, system call to the exe is made with the auth url. On Debian "sensible-browser" is a good bet. =item B<OVERDRIVE_TEST_AUTH_LISTEN_PORT> auth only Port to listen on for the C<OVERDRIVE_TEST_AUTH_REDIRECT_URL> handling. If you have a port facing the internet it will be the designated port above and your redirect url will look like http://myhost.com:<port>/ Otherwise you'll need some port forwarding like ssh -R designated_port:localhost:listen_port host.facing.internet =back ����������������������������������������������������������������������������������������������overdrive-auth.t������������������������������������������������������������������������������������100664��001761��001761�� 11440�13167535265� 17571� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t��������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use Modern::Perl; use Test::More tests => 11; use HTTP::Daemon; use HTTP::Status qw(:constants); use HTTP::Response; use URI::QueryParam; use Data::Dumper; use FindBin; use lib "$FindBin::Bin/lib"; use T::OverDrive; my $DEFAULT_LISTEN_TIMEOUT = 600; # secs use_ok('WebService::ILS::OverDrive::Patron'); SKIP: { skip "Not testing OverDrive Granted (3-legged) auth API WEBSERVICE_ILS_TEST_OVERDRIVE_AUTH not set", 10 unless $ENV{WEBSERVICE_ILS_TEST_OVERDRIVE_AUTH}; my $od_id = $ENV{OVERDRIVE_TEST_CLIENT_ID} or BAIL_OUT("Env OVERDRIVE_TEST_CLIENT_ID not set"); my $od_secret = $ENV{OVERDRIVE_TEST_CLIENT_SECRET} or BAIL_OUT("Env OVERDRIVE_TEST_CLIENT_SECRET not set"); my $od_library_id = $ENV{OVERDRIVE_TEST_LIBRARY_ID} or BAIL_OUT("Env OVERDRIVE_TEST_LIBRARY_ID not set"); my $auth_url = $ENV{OVERDRIVE_TEST_AUTH_REDIRECT_URL} or BAIL_OUT("Env OVERDRIVE_TEST_AUTH_REDIRECT_URL not set"); my $port = $ENV{OVERDRIVE_TEST_AUTH_LISTEN_PORT} or BAIL_OUT("Env OVERDRIVE_TEST_AUTH_LISTEN_PORT not set"); my $listen_timeout = $ENV{OVERDRIVE_TEST_AUTH_LISTEN_TIMEOUT} || $DEFAULT_LISTEN_TIMEOUT; my $browser_command = $ENV{OVERDRIVE_TEST_AUTH_WEB_BROWSER_EXE}; my $od = WebService::ILS::OverDrive::Patron->new({ test => 1, client_id => $od_id, client_secret => $od_secret, library_id => $od_library_id, }); my $od_url = $od->auth_url($auth_url); ok( $od_url, "Auth URL"); diag("Will listen on port $port."); my $d = HTTP::Daemon->new(LocalPort => $port) or BAIL_OUT("Cannot listen on $port: $!"); $d->timeout($listen_timeout); system(qq{$browser_command "$od_url" &}) if $browser_command; diag("Authenticate in your browser $od_url"); diag('When authenticated, please push "Always allow" button'); diag("You have $listen_timeout secs to do that..."); my $code; my $c = $d->accept or BAIL_OUT("No redirect back request received: $!"); if (my $req = $c->get_request("HEADERS_ONLY")) { my $uri = $req->uri; if ($code = $uri->query_param("code")) { my $resp = HTTP::Response->new( HTTP_OK ); $resp->content_type("text/plain"); $resp->content("Received auth code\nYou can close the browser now"); $c->send_response($resp); } else { $c->send_error(HTTP_BAD_REQUEST); BAIl_OUT("Invalid redirect back request:\n".$req->as_string); } } else { BAIL_OUT("Redirect back request error: ".$c->reason); } $c->close; undef($c); my ($access_token, $access_token_type, $auth_token) = $od->auth_by_code($code, $auth_url); ok($access_token, "auth_by_code(): Authorized"); SKIP: { skip "Failed authorisation", 8 unless $access_token; my $patron = T::OverDrive::patron($od); $od = WebService::ILS::OverDrive::Patron->new({ test => 1, client_id => $od_id, client_secret => $od_secret, library_id => $od_library_id, access_token => $access_token, access_token_type => $access_token_type, }); $patron = T::OverDrive::patron($od); $od = WebService::ILS::OverDrive::Patron->new({ test => 1, client_id => $od_id, client_secret => $od_secret, library_id => $od_library_id, }); my $refreshed_auth_token; ($access_token, $access_token_type, $refreshed_auth_token) = $od->auth_by_token($auth_token); ok($access_token, "auth_by_token()"); $patron = T::OverDrive::patron($od); sleep 5; $od = WebService::ILS::OverDrive::Patron->new({ test => 1, client_id => $od_id, client_secret => $od_secret, library_id => $od_library_id, }); if ( ok($od->auth_by_token($refreshed_auth_token), "auth_by_token() refreshed") ) { diag("Refreshed token same as initial") if $auth_token eq $refreshed_auth_token; } else { diag("Initial token: $auth_token\nRefreshed token: $refreshed_auth_token"); } $patron = T::OverDrive::patron($od); my $bogus_access_token = "AA".$access_token."AA"; $od->access_token($bogus_access_token); # should pick up auth_token $patron = T::OverDrive::patron($od); my $bogus_auth_token = "AA".$auth_token."AA"; $od = WebService::ILS::OverDrive::Patron->new({ test => 1, client_id => $od_id, client_secret => $od_secret, library_id => $od_library_id, }); local $@; eval { $od->auth_by_token($bogus_auth_token) }; ok($@ && $od->is_access_token_error($@), "Bad auth_token") or diag($@); } } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������overdrive-library.t���������������������������������������������������������������������������������100664��001761��001761�� 2332�13167535265� 20254� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t��������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use Modern::Perl; use Test::More tests => 4; use Data::Dumper; use FindBin; use lib "$FindBin::Bin/lib"; use T::OverDrive; use_ok('WebService::ILS::OverDrive::Library'); SKIP: { skip "Not testing OverDrive::Library API, WEBSERVICE_ILS_TEST_OVERDRIVE_LIBRARY not set", 3 unless $ENV{WEBSERVICE_ILS_TEST_OVERDRIVE_LIBRARY}; my $od_id = $ENV{OVERDRIVE_TEST_CLIENT_ID} or BAIL_OUT("Env OVERDRIVE_TEST_CLIENT_ID not set"); my $od_secret = $ENV{OVERDRIVE_TEST_CLIENT_SECRET} or BAIL_OUT("Env OVERDRIVE_TEST_CLIENT_SECRET not set"); my $od_library_id = $ENV{OVERDRIVE_TEST_LIBRARY_ID} or BAIL_OUT("Env OVERDRIVE_TEST_LIBRARY_ID not set"); my $od = WebService::ILS::OverDrive::Library->new({ test => 1, client_id => $od_id, client_secret => $od_secret, library_id => $od_library_id, }); # Standard interface # subtest "Standard search" => sub { T::OverDrive::search( $od ) }; # Native interface # my $library = $od->native_library_account; ok( $library && $library->{name}, "Native library") or diag(Dumper($library)); subtest "Native search" => sub { T::OverDrive::native_search( $od ) }; } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������overdrive-patron.t����������������������������������������������������������������������������������100664��001761��001761�� 36626�13167535265� 20150� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t��������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use Modern::Perl; use Test::More tests => 11; use Data::Dumper; use FindBin; use lib "$FindBin::Bin/lib"; use T::Discovery; use T::OverDrive; my $EMAIL = 'nobody@nowhere.com'; my %NON_LOCKABLE_FORMAT = map { $_ => 1 } ( 'ebook-overdrive', 'audiobook-overdrive', 'ebook-mediado' ); #use WebService::ILS::OverDrive; #$WebService::ILS::OverDrive::DEBUG = 1; use_ok('WebService::ILS::OverDrive::Patron'); SKIP: { skip "Not testing OverDrive::Patron API, WEBSERVICE_ILS_TEST_OVERDRIVE_PATRON not set", 10 unless $ENV{WEBSERVICE_ILS_TEST_OVERDRIVE_PATRON}; my $od_id = $ENV{OVERDRIVE_TEST_CLIENT_ID} or BAIL_OUT("Env OVERDRIVE_TEST_CLIENT_ID not set"); my $od_secret = $ENV{OVERDRIVE_TEST_CLIENT_SECRET} or BAIL_OUT("Env OVERDRIVE_TEST_CLIENT_SECRET not set"); my $od_website_id = $ENV{OVERDRIVE_TEST_WEBSITE_ID} or BAIL_OUT("Env OVERDRIVE_TEST_WEBSITE_ID not set"); my $od_authorization_name = $ENV{OVERDRIVE_TEST_AUTHORIZATION_NAME} || 'odapilibrary'; my $od_user_id = $ENV{OVERDRIVE_TEST_USER_ID} or BAIL_OUT("Env OVERDRIVE_TEST_USER_ID not set"); my $od_password = $ENV{OVERDRIVE_TEST_USER_PASSWORD}; my $od = WebService::ILS::OverDrive::Patron->new({ test => 1, client_id => $od_id, client_secret => $od_secret, }); ok($od->auth_by_user_id($od_user_id, $od_password, $od_website_id, $od_authorization_name), "auth_by_user_id()"); my $patron = T::OverDrive::patron($od); my ($hold_limit, $checkout_limit, $active); if ($patron) { $hold_limit = $patron->{hold_limit}; $checkout_limit = $patron->{checkout_limit}; $active = $patron->{active}; } #BAIL_OUT("Patron not active") unless $active; clear($od) if $ENV{OVERDRIVE_TEST_CLEAR}; my $init_checkouts = $od->checkouts; my $init_holds = $od->holds; my ($total_init_holds); if ($init_holds) { $total_init_holds = $init_holds->{total}; } ok(defined $total_init_holds, "Holds") or diag(Dumper($init_holds)); my ($total_init_checkouts); if ($init_checkouts) { $total_init_checkouts = $init_checkouts->{total}; } ok(defined $total_init_checkouts, "Checkouts") or diag(Dumper($init_checkouts)); my ($items, $random_page) = T::Discovery::search_all_random_page( $od ); BAIL_OUT("No items in search results, cannot test circulation") unless $items && @$items; subtest "Place hold" => sub { if ($total_init_holds >= $hold_limit) { my $item = $init_holds->{items}[0]; test_remove_hold($od, $item->{id}); test_place_hold($od, $init_holds, $item); } else { my $item; while ($items) { $item = pick_unused_item($od, [@{ $init_checkouts->{items} }, @{ $init_holds->{items} }], $items); last if $item; diag( Dumper($init_checkouts, $init_holds, $items) ); ($items, $random_page) = T::Discovery::search_all_random_page( $od, $random_page + 1 ); } BAIL_OUT("Cannot find appropriate item to place hold") unless $item; my $item_id = test_place_hold($od, $init_holds, $item); SKIP: { skip "Could not place hold", 1 unless $item_id; test_remove_hold($od, $item_id); } } }; if ($total_init_checkouts >= $checkout_limit - 1) { foreach(@{ $init_checkouts->{items} }) { next if $_->{format}; $od->return($_->{id}) or BAIL_OUT("Checkouts at full capacity and cannot return"); $total_init_checkouts--; last if $total_init_checkouts < $checkout_limit - 1; } $init_checkouts = $od->checkouts; } BAIL_OUT("Checkouts at full capacity and no item can be returned") if $total_init_checkouts >= $checkout_limit; subtest "Checkout no format" => sub { my $item; while ($items) { $item = pick_unused_item($od, $init_checkouts->{items}, $items, 'AVAILABLE_ONLY'); last if $item; diag( Dumper($init_checkouts, $items) ); ($items, $random_page) = T::Discovery::search_all_random_page( $od, $random_page + 1 ); } BAIL_OUT("Cannot find appropriate item to checkout") unless $item; test_checkout($od, $init_checkouts, $item); $total_init_checkouts++; }; subtest "Checkout with format" => sub { SKIP: { skip "Not testing checkout with format locking, OVERDRIVE_TEST_LOCK_FORMAT not set", 1 unless $ENV{OVERDRIVE_TEST_LOCK_FORMAT}; SKIP: { skip "Checkouts at full capacity, cannot test checkout with locked format", 1 if $total_init_checkouts >= $checkout_limit; $init_checkouts = $od->checkouts; my $item; while ($items) { $item = pick_unused_item($od, $init_checkouts->{items}, $items, 'AVAILABLE_ONLY'); last if $item; ($items, $random_page) = T::Discovery::search_all_random_page( $od, $random_page + 1 ); } SKIP: { skip "Cannot find appropriate item to checkout with locked format", 1 unless $item; test_checkout_with_format($od, $init_checkouts, $item); } } } }; subtest "Standard search" => sub { T::OverDrive::search( $od ) }; $patron = $od->native_patron; ok($patron && $patron->{patronId}, "Native patron") or diag(Dumper($patron)); subtest "Native search" => sub { T::OverDrive::native_search( $od ) }; } sub test_place_hold { my ($od, $init_holds, $item) = @_; my $item_id = $item->{id}; my ($hold, $cannot_place_hold); { local $@; $hold = eval { $od->place_hold($item_id, $EMAIL, "AUTO_CHECKOUT") }; if ($@) { diag("$@\n".Dumper($item)); $cannot_place_hold = ($@ =~ m/not allowed to place a hold on this title/io); } } my ($hold_item_id, $hold_item_id_uc, $total_holds, $ok); SKIP: { skip "Cannot place hold", 1 if $cannot_place_hold; if ($hold) { $hold_item_id = uc $hold->{id}; $hold_item_id_uc = uc $hold_item_id; $total_holds = $hold->{total}; } # $ok = ok($hold_item_id_uc eq uc($item_id) && $total_holds == scalar(@$hold_items) + 1, "Place hold") $ok = ok($hold_item_id_uc && $hold_item_id_uc eq uc($item_id), "Place hold") or diag(Dumper($init_holds, $item, $hold)); } SKIP: { skip "Cannot place hold", 2 unless $ok; my $holds = $od->holds; my $found; foreach (@{ $holds->{items} }) { if (uc($_->{id}) eq $hold_item_id_uc) { $found = 1; last; } } ok ($found && $holds->{total} == $init_holds->{total} + 1, "Hold in the list") or diag(Dumper($hold, $holds, $init_holds)); my $same_hold = $od->place_hold($item_id, $EMAIL, "AUTO_CHECKOUT"); ok( $same_hold->{id} eq $hold->{id} && $same_hold->{placed_datetime} eq $hold->{placed_datetime}, "Place same hold") or diag(Dumper($same_hold, $hold)); } return $hold_item_id; } sub test_remove_hold { my ($od, $item_id) = @_; ok( $od->remove_hold($item_id), "Remove hold" ); ok( $od->remove_hold($item_id), "Remove hold again"); } sub test_checkout { my ($od, $init_checkouts, $item) = @_; my $item_id = $item->{id}; my $checkout; { local $@; $checkout = eval { $od->checkout($item_id) }; diag("$@\n".Dumper($item)) if $@; } my ($checkout_item_id, $checkout_item_id_uc); if ($checkout) { $checkout_item_id = $checkout->{id}; $checkout_item_id_uc = uc $checkout_item_id; } my $ok = ok($checkout_item_id_uc && $checkout_item_id_uc eq uc($item_id), "Checkout") or diag(Dumper($init_checkouts, $item, $checkout)); SKIP: { skip "Cannot checkout", 6 unless $ok; my $checkouts = $od->checkouts; my $found; foreach (@{ $checkouts->{items} }) { if (uc($_->{id}) eq $checkout_item_id_uc) { $found = $_; last; } } # ok ($found && $checkouts->{total} == $init_checkouts->{total} + 1, "Checkout in the list") # Sometimes API loses marbles when it comes to counting ok ($found, "Checkout in the list") or diag(Dumper($checkout, $checkouts, $init_checkouts)); SKIP: { skip "Checkout not found", 5 unless $found; my $formats = $od->checkout_formats($item_id); $ok = $formats && scalar(keys %$formats); ok ($ok, "Checkout formats") or diag(Dumper($formats, $item)); my $available_format; if ($ok) { while ( my($format, $available) = each %$formats ) { if ($available) { $available_format = $format; last; } } diag(Dumper($formats)) unless $available_format; } SKIP: { skip "Available format not found", 1 unless $available_format; test_download_url($od, $item_id, $available_format); } my $same_checkout = $od->checkout($item_id); ok( $same_checkout->{id} eq $checkout->{id} && $same_checkout->{checkout_datetime} eq $checkout->{checkout_datetime}, "Same checkout not locked") or diag(Dumper($same_checkout, $checkout)); ok( $od->return($item_id), "Return" ); # This is a bug in OverDrive API $ok = eval { $od->return($item_id) }; if ($@) { diag("Return again: $@\nPassing nevertheless"); $ok = 1; } ok( $ok, "Return again"); my $lockable_format; SKIP: { skip "Not testing format locking, OVERDRIVE_TEST_LOCK_FORMAT not set", 3 unless $ENV{OVERDRIVE_TEST_LOCK_FORMAT}; while ( my($format, $available) = each %$formats ) { unless ($available) { $lockable_format = $format; last; } } diag(Dumper($formats)) unless $lockable_format; SKIP: { skip "Checkout formats cannot be locked in", 3 unless $lockable_format; $checkout = $od->checkout($item_id); my $res = $od->lock_format($item_id, $lockable_format); ok($res eq $lockable_format, "Lock format $lockable_format") or diag("Format: $res"); my $same_checkout = $od->checkout($item_id); ok( $same_checkout->{id} eq $checkout->{id} && $same_checkout->{checkout_datetime} eq $checkout->{checkout_datetime} && $same_checkout->{format} eq $lockable_format, "Same checkout format locked") or diag(Dumper($same_checkout, $checkout, $lockable_format)); test_download_url($od, $item_id, $lockable_format); } } } } return $checkout_item_id; } sub test_checkout_with_format { my ($od, $init_checkouts, $item) = @_; my $item_id = $item->{id}; my ($checkout, $lockable_format); foreach my $format ( @{$item->{formats} || []} ) { local $@; $checkout = eval { $od->checkout($item_id, $format) }; diag("$@\n".Dumper($item)) if $@; if ($checkout) { $lockable_format = $format; last; } } diag(Dumper($item)) unless $checkout; SKIP: { skip "Checkout formats cannot be locked in", 4 unless $checkout; my $checkout_item_id = $checkout->{id}; my $checkout_item_id_uc = uc $checkout_item_id; my $checkout_item_format = $checkout->{format}; my $checkout_item_format_lc = $checkout_item_format ? lc ($checkout_item_format) : ""; my $ok = ok( $checkout_item_id_uc && $checkout_item_id_uc eq uc($item_id) && $checkout_item_format_lc eq lc($lockable_format), "Checkout with locked format $lockable_format" ) or diag(Dumper($init_checkouts, $item, $checkout)); SKIP: { skip "Mismatched checkout with locked format $lockable_format", 3 unless $ok; my $checkouts = $od->checkouts; my $found; foreach (@{ $checkouts->{items} }) { if (uc($_->{id}) eq $checkout_item_id_uc) { $found = $_; last; } } ok ( $found && $found->{format} && lc($found->{format}) eq $checkout_item_format_lc, "Checkout in the list" ) or diag(Dumper($checkout, $checkouts, $init_checkouts)); SKIP: { skip "Checkout not found", 2 unless $found; my $same_checkout = $od->checkout($item_id); ok( uc($same_checkout->{id}) eq $checkout_item_id_uc && $same_checkout->{checkout_datetime} eq $checkout->{checkout_datetime} && $same_checkout->{format} && lc($same_checkout->{format}) eq $checkout_item_format_lc, "Same checkout without specified format") or diag(Dumper($same_checkout, $checkout)); $same_checkout = $od->checkout($item_id, $lockable_format); ok( uc($same_checkout->{id}) eq $checkout_item_id_uc && $same_checkout->{checkout_datetime} eq $checkout->{checkout_datetime} && $same_checkout->{format} && lc($same_checkout->{format}) eq $checkout_item_format_lc, "Same checkout with specified format") or diag(Dumper($same_checkout, $checkout)); } } return $checkout_item_id; } return; } sub test_download_url { my ($od, $item_id, $format) = @_; my $download_url = $od->checkout_download_url( $item_id, $format, "http://wherever.com/failure", "http://wherever.com/success" ); ok($download_url, "Download url"); } sub pick_unused_item { my ($od, $used_items, $pool_items, $available_only) = @_; POOL_ITEMS_LOOP: foreach my $pi (@$pool_items) { if ($used_items) { my $id_uc = uc $pi->{id}; foreach (@$used_items) { next POOL_ITEMS_LOOP if uc($_->{id}) eq $id_uc; } } my $formats = $pi->{formats} or next; next if $available_only && !$od->is_item_available($pi->{id}); foreach my $format (@$formats) { next if $format eq 'periodicals-nook'; next if $format =~ m/-streaming$/o; next if $available_only && $NON_LOCKABLE_FORMAT{$format}; return $pi; } } return; } sub clear { my ($od) = @_; my $checkouts = $od->checkouts; eval { $od->return($_->{id}) } foreach @{$checkouts->{items}}; my $holds = $od->holds; $od->remove_hold($_->{id}) foreach @{$holds->{items}}; } ����������������������������������������������������������������������������������������������������������recordedbooks.t�������������������������������������������������������������������������������������100664��001761��001761�� 25056�13167535265� 17462� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17/t��������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use Modern::Perl; use Test::More tests => 15; use HTTP::Request::Common; use Data::Dumper; use FindBin; use lib "$FindBin::Bin/lib"; use T::Discovery; #se T::RecordedBooks; use_ok('WebService::ILS::RecordedBooks::Partner'); use_ok('WebService::ILS::RecordedBooks::PartnerPatron'); use_ok('WebService::ILS::RecordedBooks::Patron'); SKIP: { skip "Not testing RecordedBooks Patron API, WEBSERVICE_ILS_TEST_RECORDEDBOOKS or WEBSERVICE_ILS_TEST_RECORDEDBOOKS_PATRON not set", 4 unless $ENV{WEBSERVICE_ILS_TEST_RECORDEDBOOKS} || $ENV{WEBSERVICE_ILS_TEST_RECORDEDBOOKS_PATRON}; my $rb_domain = $ENV{RECORDEDBOOKS_TEST_DOMAIN} or BAIL_OUT("Env RECORDEDBOOKS_TEST_DOMAIN not set"); my $rb_secret = $ENV{RECORDEDBOOKS_TEST_CLIENT_SECRET} or BAIL_OUT("Env RECORDEDBOOKS_TEST_CLIENT_SECRET not set"); my $rb_library_id = $ENV{RECORDEDBOOKS_TEST_LIBRARY_ID} or BAIL_OUT("Env RECORDEDBOOKS_TEST_LIBRARY_ID not set"); my $rb_user_id = $ENV{RECORDEDBOOKS_TEST_USER_ID} || $ENV{RECORDEDBOOKS_TEST_USER_EMAIL} or BAIL_OUT("Env RECORDEDBOOKS_TEST_USER_ID or RECORDEDBOOKS_TEST_USER_EMAIL not set"); my $rb_password = $ENV{RECORDEDBOOKS_TEST_USER_PASSWORD} or BAIL_OUT("Env RECORDEDBOOKS_TEST_USER_PASSWORD not set"); my $rb = WebService::ILS::RecordedBooks::Patron->new({ client_secret => $rb_secret, library_id => $rb_library_id, user_id => $rb_user_id, password => $rb_password, domain => $rb_domain, }); # $rb->user_agent->add_handler( response_done => sub { # my($response, $ua, $h) = @_; # diag(join "\n", $response->request->as_string, $response->as_string); # } ); clear($rb) if $ENV{RECORDEDBOOKS_TEST_CLEAR}; test_search("Patron", $rb); test_circ("Patron", $rb); } SKIP: { skip "Not testing RecordedBooks Partner API, WEBSERVICE_ILS_TEST_RECORDEDBOOKS or WEBSERVICE_ILS_TEST_RECORDEDBOOKS_PARTNER not set", 8 unless $ENV{WEBSERVICE_ILS_TEST_RECORDEDBOOKS} || $ENV{WEBSERVICE_ILS_TEST_RECORDEDBOOKS_PARTNER}; my $rb_domain = $ENV{RECORDEDBOOKS_TEST_DOMAIN} or BAIL_OUT("Env RECORDEDBOOKS_TEST_DOMAIN not set"); my $rb_secret = $ENV{RECORDEDBOOKS_TEST_CLIENT_SECRET} or BAIL_OUT("Env RECORDEDBOOKS_TEST_CLIENT_SECRET not set"); my $rb_library_id = $ENV{RECORDEDBOOKS_TEST_LIBRARY_ID} or BAIL_OUT("Env RECORDEDBOOKS_TEST_LIBRARY_ID not set"); my $rb_user_id = $ENV{RECORDEDBOOKS_TEST_USER_BARCODE} || $ENV{RECORDEDBOOKS_TEST_USER_EMAIL} or BAIL_OUT("Env RECORDEDBOOKS_TEST_USER_BARCODE or RECORDEDBOOKS_TEST_USER_EMAIL not set"); my $rb = WebService::ILS::RecordedBooks::Partner->new({ client_secret => $rb_secret, library_id => $rb_library_id, domain => $rb_domain, }); # $rb->user_agent->add_handler( response_done => sub { # my($response, $ua, $h) = @_; # diag(join "\n", $response->request->as_string, $response->as_string); # } ); ok($rb->native_libraries_search('wood'), "Suggestive search"); test_search("Partner", $rb); my $patron_id = $rb->patron_id( $rb_user_id ); ok( $patron_id, "patron_id()"); BAIL_OUT("No patron $rb_user_id, cannot test circulation") unless $patron_id; clear($rb, $patron_id) if $ENV{RECORDEDBOOKS_TEST_CLEAR}; test_circ("Partner", $rb, $patron_id); $rb = WebService::ILS::RecordedBooks::PartnerPatron->new({ client_secret => $rb_secret, library_id => $rb_library_id, user_id => $rb_user_id, domain => $rb_domain, }); test_circ("PartnerPatron", $rb); } sub test_circ { my ($module, $rb, $patron_id) = @_; my $init_checkouts = $rb->checkouts($patron_id); my $init_holds = $rb->holds($patron_id); my ($items, $random_page) = T::Discovery::search_all_random_page( $rb ); BAIL_OUT("No items in search results, cannot test circulation") unless $items && @$items; subtest "Place hold $module" => sub { my $item; while ($items) { $item = pick_unused_item([@{ $init_checkouts->{items} }, @{ $init_holds->{items} }], $items); last if $item; diag( Dumper($init_checkouts, $init_holds, $items) ); ($items, $random_page) = T::Discovery::search_all_random_page( $rb, $random_page + 1 ); } BAIL_OUT("Cannot find appropriate item to place hold") unless $item; test_place_hold($rb, $patron_id, $init_holds, $item); }; subtest "Checkout $module" => sub { my $item; while ($items) { $item = pick_unused_item([@{ $init_checkouts->{items} }, @{ $init_holds->{items} }], $items); last if $item; diag( Dumper($init_checkouts, $init_holds, $items) ); ($items, $random_page) = T::Discovery::search_all_random_page( $rb, $random_page + 1 ); } BAIL_OUT("Cannot find appropriate item to checkout") unless $item; test_checkout($rb, $patron_id, $init_checkouts, $item); }; } sub test_place_hold { my ($rb, $patron_id, $init_holds, $item) = @_; my $isbn = $item->{isbn}; my $hold = $patron_id ? $rb->place_hold($patron_id, $isbn) : $rb->place_hold($isbn) ; my $hold_isbn = $hold ? $hold->{isbn} : undef; my $ok = ok($hold_isbn && $hold_isbn eq $isbn && $hold->{total} == $init_holds->{total} + 1, "Place hold") or diag(Dumper($patron_id, $init_holds, $item, $hold)); SKIP: { skip "Cannot place hold", 1 unless $ok; my $same_hold = $patron_id ? $rb->place_hold($patron_id, $isbn) : $rb->place_hold($isbn) ; ok( $same_hold->{isbn} eq $hold_isbn, "Place same hold") or diag(Dumper($patron_id, $same_hold, $hold)); $ok = $patron_id ? $rb->remove_hold($patron_id, $isbn) : $rb->remove_hold($isbn) ; ok( $ok, "Remove hold" ); $ok = $patron_id ? $rb->remove_hold($patron_id, $isbn) : $rb->remove_hold($isbn) ; ok( $ok, "Remove hold again"); } } sub test_checkout { my ($rb, $patron_id, $init_checkouts, $item) = @_; my $isbn = $item->{isbn}; my $checkout = $patron_id ? $rb->checkout($patron_id, $isbn) : $rb->checkout($isbn) ; my $checkout_isbn = $checkout ? $checkout->{isbn} : undef; my $ok = ok($checkout_isbn && $checkout_isbn eq $isbn && $checkout->{total} == $init_checkouts->{total} + 1, "Checkout") or diag(Dumper($patron_id, $init_checkouts, $item, $checkout)); SKIP: { skip "Cannot checkout", 1 unless $ok; my $same_checkout = $patron_id ? $rb->checkout($patron_id, $isbn) : $rb->checkout($isbn) ; ok( $same_checkout->{isbn} eq $checkout->{isbn} && $same_checkout->{expires} eq $checkout->{expires}, "Same checkout" ) or diag(Dumper($patron_id, $same_checkout, $checkout)); my $renewal = $patron_id ? $rb->renew($patron_id, $isbn) : $rb->renew($isbn) ; ok( $renewal->{isbn} eq $checkout->{isbn} && $renewal->{expires} ge $checkout->{expires}, "Renewal" ) or diag(Dumper($patron_id, $renewal, $checkout)); # Nothing to test really #test_download_url($rb, $renewal); $ok = $patron_id ? $rb->return($patron_id, $isbn) : $rb->return($isbn) ; ok( $ok, "Return" ); $ok = $patron_id ? $rb->return($patron_id, $isbn) : $rb->return($isbn) ; ok( $ok, "Return again" ); } } sub test_download_url { my ($rb, $item) = @_; #my $download_url = $item->{url}; foreach (@{ $item->{files} }) { my $download_url = $_->{url} or die "No url: ".Dumper($item); my $data = $rb->get_response($download_url); $download_url = $data->{url}; my $filename = $_->{filename} || "aa.whatever"; my $req = HTTP::Request::Common::GET($download_url); my $resp = $rb->user_agent->request($req, $filename); ok($resp->code == 200, "Download url") or diag("$download_url\n".$resp->as_string);; } } sub pick_unused_item { my ($used_items, $pool_items) = @_; POOL_ITEMS_LOOP: foreach my $pi (@$pool_items) { if ($used_items) { my $isbn = $pi->{isbn}; foreach (@$used_items) { next POOL_ITEMS_LOOP if $_->{isbn} eq $isbn; } } return $pi; } return; } sub clear { my ($rb, $patron_id) = @_; my $holds = $rb->holds($patron_id); my $items = $holds->{items}; $rb->remove_hold($patron_id, $_->{isbn}) foreach @$items; diag("Removed ".scalar(@$items)." holds"); } sub test_search { my ($module, $rb) = @_; subtest "Search $module" => sub { my $res = $rb->named_query_search("most-popular", "ebook"); my $item = $res && $res->{items} ? $res->{items}[0] : undef; ok($item, "named_query_search()"); SKIP: { skip "No search results", 3 unless $item; ok($item->{url}, "item url") or diag(Dumper($item)); SKIP: { skip "No item url", 1 unless $item->{url}; my $req = HTTP::Request::Common::GET($item->{url}); my $resp = $rb->user_agent->request($req); ok($resp->code == 200, "Item url") or diag("$item->{url}\n".$resp->as_string); } my $metadata = $rb->item_metadata($item->{isbn}); ok($metadata && $metadata->{title}, "item_metadata()") or diag(Dumper($metadata)); } }; SKIP: { skip "Facets stopped working", 1; } return; subtest "Facets $module" => sub { my $facets = $rb->facets; ok($facets && keys %$facets, "Facets"); my @genre_facets = @{ $facets->{genre} }[0..1]; my @audience_facets = @{ $facets->{audience} }[0..1]; my %facet_search; $facet_search{genre} = \@genre_facets if @genre_facets; $facet_search{audience} = \@audience_facets if @audience_facets; SKIP: { skip "No facets to search on", 1 unless keys %facet_search; my $results = $rb->facet_search(\%facet_search); ok($results, "facet_search(() hashref"); $results = $rb->facet_search([@genre_facets, @audience_facets]); ok($results, "facet_search(() arrayref"); $results = $rb->facet_search($genre_facets[0] || $audience_facets[0]); ok($results, "facet_search(() single facet"); } } } ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������META.yml��������������������������������������������������������������������������������������������100664��001761��001761�� 3535�13167535265� 15434� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17����������������������������������������������������������������������������������������������������������������������������������������������������--- abstract: 'Standardised library discovery/circulation services' author: - 'Srdjan Janković <srdjan@catalyst.net.nz>' build_requires: FindBin: '0' Test::More: '0.98' configure_requires: Module::Build::Tiny: '0.035' dynamic_config: 0 generated_by: 'Minilla/v3.0.0, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: WebService-ILS no_index: directory: - t - xt - inc - share - eg - examples - author - builder provides: WebService::ILS: file: lib/WebService/ILS.pm version: '0.17' WebService::ILS::JSON: file: lib/WebService/ILS/JSON.pm WebService::ILS::OverDrive: file: lib/WebService/ILS/OverDrive.pm WebService::ILS::OverDrive::Library: file: lib/WebService/ILS/OverDrive/Library.pm WebService::ILS::OverDrive::Patron: file: lib/WebService/ILS/OverDrive/Patron.pm WebService::ILS::RecordedBooks: file: lib/WebService/ILS/RecordedBooks.pm WebService::ILS::RecordedBooks::Partner: file: lib/WebService/ILS/RecordedBooks/Partner.pm WebService::ILS::RecordedBooks::PartnerBase: file: lib/WebService/ILS/RecordedBooks/PartnerBase.pm WebService::ILS::RecordedBooks::PartnerPatron: file: lib/WebService/ILS/RecordedBooks/PartnerPatron.pm WebService::ILS::RecordedBooks::Patron: file: lib/WebService/ILS/RecordedBooks/Patron.pm WebService::ILS::XML: file: lib/WebService/ILS/XML.pm recommends: XML::LibXML: '0' requires: Class::Tiny: '0' HTTP::Request::Common: '0' HTTP::Status: '0' Hash::Merge: '0' JSON: '0' LWP::UserAgent: '0' Modern::Perl: '0' Params::Check: '0' URI: '0' perl: '5.008001' resources: repository: git+ssh://git.catalyst.net.nz/git/private/webservice-ils.git version: '0.17' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' �������������������������������������������������������������������������������������������������������������������������������������������������������������������MANIFEST��������������������������������������������������������������������������������������������100664��001761��001761�� 1262�13167535265� 15307� 0����������������������������������������������������������������������������������������������������ustar�00srdjan��������������������������srdjan��������������������������000000��000000��WebService-ILS-0.17����������������������������������������������������������������������������������������������������������������������������������������������������Build.PL Changes LICENSE META.json README.md Readme.pod builder/license.pl builder/readme.sh cpanfile lib/WebService/ILS.pm lib/WebService/ILS/JSON.pm lib/WebService/ILS/OverDrive.pm lib/WebService/ILS/OverDrive/Library.pm lib/WebService/ILS/OverDrive/Patron.pm lib/WebService/ILS/RecordedBooks.pm lib/WebService/ILS/RecordedBooks/Partner.pm lib/WebService/ILS/RecordedBooks/PartnerBase.pm lib/WebService/ILS/RecordedBooks/PartnerPatron.pm lib/WebService/ILS/RecordedBooks/Patron.pm lib/WebService/ILS/XML.pm minil.toml t/interface.t t/lib/T/Discovery.pm t/lib/T/OverDrive.pm t/lib/T/Test.pod t/overdrive-auth.t t/overdrive-library.t t/overdrive-patron.t t/recordedbooks.t META.yml MANIFEST��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������