3 # Copyright 2000-2002 Katipo Communications
4 # Parts Copyright 2010 Nelsonville Public Library
5 # Parts copyright 2010 BibLibre
7 # This file is part of Koha.
9 # Koha is free software; you can redistribute it and/or modify it
10 # under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 3 of the License, or
12 # (at your option) any later version.
14 # Koha is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with Koha; if not, see <http://www.gnu.org/licenses>.
24 #use warnings; FIXME - Bug 2505
28 use Koha
::DateUtils
qw(dt_from_string);
29 use Koha
::AuthorisedValues
;
31 use Koha
::MarcSubfieldStructures
;
32 use DateTime
::Format
::MySQL
;
35 use autouse
'Data::cselectall_arrayref' => qw(Dumper);
36 use DBI
qw(:sql_types);
37 use vars
qw(@ISA @EXPORT @EXPORT_OK $DEBUG);
43 &GetPrinters &GetPrinter
44 &GetItemTypes &getitemtypeinfo
45 &GetItemTypesCategorized &GetItemTypesByCategory
46 &getframeworks &getframeworkinfo
52 &get_notforloan_label_of
55 &getitemtypeimagelocation
57 &GetAuthorisedValueCategories
61 &GetNormalizedOCLCNumber
74 @EXPORT_OK = qw( GetDailyQuote );
79 C4::Koha - Perl Module containing convenience functions for Koha scripts
87 Koha.pm provides many functions for Koha scripts.
95 $itemtypes = &GetItemTypes( style => $style );
97 Returns information about existing itemtypes.
100 style: either 'array' or 'hash', defaults to 'hash'.
101 'array' returns an arrayref,
102 'hash' return a hashref with the itemtype value as the key
104 build a HTML select with the following code :
106 =head3 in PERL SCRIPT
108 my $itemtypes = GetItemTypes;
110 foreach my $thisitemtype (sort keys %$itemtypes) {
111 my $selected = 1 if $thisitemtype eq $itemtype;
112 my %row =(value => $thisitemtype,
113 selected => $selected,
114 description => $itemtypes->{$thisitemtype}->{'description'},
116 push @itemtypesloop, \%row;
118 $template->param(itemtypeloop => \@itemtypesloop);
122 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
123 <select name="itemtype">
124 <option value="">Default</option>
125 <!-- TMPL_LOOP name="itemtypeloop" -->
126 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
129 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
130 <input type="submit" value="OK" class="button">
137 my $style = defined( $params{'style'} ) ?
$params{'style'} : 'hash';
139 require C4
::Languages
;
140 my $language = C4
::Languages
::getlanguage
();
141 # returns a reference to a hash of references to itemtypes...
142 my $dbh = C4
::Context
->dbh;
146 itemtypes
.description
,
147 itemtypes
.rentalcharge
,
148 itemtypes
.notforloan
,
151 itemtypes
.checkinmsg
,
152 itemtypes
.checkinmsgtype
,
153 itemtypes
.sip_media_type
,
154 itemtypes
.hideinopac
,
155 itemtypes
.searchcategory
,
156 COALESCE
( localization
.translation
, itemtypes
.description
) AS translated_description
158 LEFT JOIN localization ON itemtypes
.itemtype
= localization
.code
159 AND localization
.entity
= 'itemtypes'
160 AND localization
.lang
= ?
163 my $sth = $dbh->prepare($query);
164 $sth->execute( $language );
166 if ( $style eq 'hash' ) {
168 while ( my $IT = $sth->fetchrow_hashref ) {
169 $itemtypes{ $IT->{'itemtype'} } = $IT;
171 return ( \
%itemtypes );
173 return [ sort { lc $a->{translated_description
} cmp lc $b->{translated_description
} } @
{ $sth->fetchall_arrayref( {} ) } ];
177 =head2 GetItemTypesCategorized
179 $categories = GetItemTypesCategorized();
181 Returns a hashref containing search categories.
182 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
183 The categories must be part of Authorized Values (ITEMTYPECAT)
187 sub GetItemTypesCategorized
{
188 my $dbh = C4
::Context
->dbh;
189 # Order is important, so that partially hidden (some items are not visible in OPAC) search
190 # categories will be visible. hideinopac=0 must be last.
192 SELECT itemtype
, description
, imageurl
, hideinopac
, 0 as
'iscat' FROM itemtypes WHERE ISNULL
(searchcategory
) or length(searchcategory
) = 0
194 SELECT DISTINCT searchcategory AS
`itemtype`,
195 authorised_values
.lib_opac AS description
,
196 authorised_values
.imageurl AS imageurl
,
197 hideinopac
, 1 as
'iscat'
199 LEFT JOIN authorised_values ON searchcategory
= authorised_value
200 WHERE searchcategory
> '' and hideinopac
=1
202 SELECT DISTINCT searchcategory AS
`itemtype`,
203 authorised_values
.lib_opac AS description
,
204 authorised_values
.imageurl AS imageurl
,
205 hideinopac
, 1 as
'iscat'
207 LEFT JOIN authorised_values ON searchcategory
= authorised_value
208 WHERE searchcategory
> '' and hideinopac
=0
210 return ($dbh->selectall_hashref($query,'itemtype'));
213 =head2 GetItemTypesByCategory
215 @results = GetItemTypesByCategory( $searchcategory );
217 Returns the itemtype code of all itemtypes included in a searchcategory.
221 sub GetItemTypesByCategory
{
225 my $dbh = C4
::Context
->dbh;
226 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory
=?
|;
227 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
233 $frameworks = &getframework();
235 Returns information about existing frameworks
237 build a HTML select with the following code :
239 =head3 in PERL SCRIPT
241 my $frameworks = getframeworks();
243 foreach my $thisframework (keys %$frameworks) {
244 my $selected = 1 if $thisframework eq $frameworkcode;
246 value => $thisframework,
247 selected => $selected,
248 description => $frameworks->{$thisframework}->{'frameworktext'},
250 push @frameworksloop, \%row;
252 $template->param(frameworkloop => \@frameworksloop);
256 <form action="[% script_name %] method=post>
257 <select name="frameworkcode">
258 <option value="">Default</option>
259 [% FOREACH framework IN frameworkloop %]
260 [% IF ( framework.selected ) %]
261 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
263 <option value="[% framework.value %]">[% framework.description %]</option>
267 <input type=text name=searchfield value="[% searchfield %]">
268 <input type="submit" value="OK" class="button">
275 # returns a reference to a hash of references to branches...
277 my $dbh = C4
::Context
->dbh;
278 my $sth = $dbh->prepare("select * from biblio_framework");
280 while ( my $IT = $sth->fetchrow_hashref ) {
281 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
283 return ( \
%itemtypes );
286 =head2 GetFrameworksLoop
288 $frameworks = GetFrameworksLoop( $frameworkcode );
290 Returns the loop suggested on getframework(), but ordered by framework description.
292 build a HTML select with the following code :
294 =head3 in PERL SCRIPT
296 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
300 Same as getframework()
302 <form action="[% script_name %] method=post>
303 <select name="frameworkcode">
304 <option value="">Default</option>
305 [% FOREACH framework IN frameworkloop %]
306 [% IF ( framework.selected ) %]
307 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
309 <option value="[% framework.value %]">[% framework.description %]</option>
313 <input type=text name=searchfield value="[% searchfield %]">
314 <input type="submit" value="OK" class="button">
319 sub GetFrameworksLoop
{
320 my $frameworkcode = shift;
321 my $frameworks = getframeworks
();
323 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
324 my $selected = ( $thisframework eq $frameworkcode ) ?
1 : undef;
326 value
=> $thisframework,
327 selected
=> $selected,
328 description
=> $frameworks->{$thisframework}->{'frameworktext'},
330 push @frameworkloop, \
%row;
332 return \
@frameworkloop;
335 =head2 getframeworkinfo
337 $frameworkinfo = &getframeworkinfo($frameworkcode);
339 Returns information about an frameworkcode.
343 sub getframeworkinfo
{
344 my ($frameworkcode) = @_;
345 my $dbh = C4
::Context
->dbh;
347 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
348 $sth->execute($frameworkcode);
349 my $res = $sth->fetchrow_hashref;
353 =head2 getitemtypeinfo
355 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
357 Returns information about an itemtype. The optional $interface argument
358 sets which interface ('opac' or 'intranet') to return the imageurl for.
359 Defaults to intranet.
363 sub getitemtypeinfo
{
364 my ($itemtype, $interface) = @_;
365 my $dbh = C4
::Context
->dbh;
366 require C4
::Languages
;
367 my $language = C4
::Languages
::getlanguage
();
368 my $it = $dbh->selectrow_hashref(q
|
371 itemtypes
.description
,
372 itemtypes
.rentalcharge
,
373 itemtypes
.notforloan
,
376 itemtypes
.checkinmsg
,
377 itemtypes
.checkinmsgtype
,
378 itemtypes
.sip_media_type
,
379 COALESCE
( localization
.translation
, itemtypes
.description
) AS translated_description
381 LEFT JOIN localization ON itemtypes
.itemtype
= localization
.code
382 AND localization
.entity
= 'itemtypes'
383 AND localization
.lang
= ?
384 WHERE itemtypes
.itemtype
= ?
385 |, undef, $language, $itemtype );
387 $it->{imageurl
} = getitemtypeimagelocation
( ( ( defined $interface && $interface eq 'opac' ) ?
'opac' : 'intranet' ), $it->{imageurl
} );
392 =head2 getitemtypeimagedir
394 my $directory = getitemtypeimagedir( 'opac' );
396 pass in 'opac' or 'intranet'. Defaults to 'opac'.
398 returns the full path to the appropriate directory containing images.
402 sub getitemtypeimagedir
{
403 my $src = shift || 'opac';
404 if ($src eq 'intranet') {
405 return C4
::Context
->config('intrahtdocs') . '/' .C4
::Context
->preference('template') . '/img/itemtypeimg';
407 return C4
::Context
->config('opachtdocs') . '/' . C4
::Context
->preference('opacthemes') . '/itemtypeimg';
411 sub getitemtypeimagesrc
{
412 my $src = shift || 'opac';
413 if ($src eq 'intranet') {
414 return '/intranet-tmpl' . '/' . C4
::Context
->preference('template') . '/img/itemtypeimg';
416 return '/opac-tmpl' . '/' . C4
::Context
->preference('opacthemes') . '/itemtypeimg';
420 sub getitemtypeimagelocation
{
421 my ( $src, $image ) = @_;
423 return '' if ( !$image );
426 my $scheme = ( URI
::Split
::uri_split
( $image ) )[0];
428 return $image if ( $scheme );
430 return getitemtypeimagesrc
( $src ) . '/' . $image;
433 =head3 _getImagesFromDirectory
435 Find all of the image files in a directory in the filesystem
437 parameters: a directory name
439 returns: a list of images in that directory.
441 Notes: this does not traverse into subdirectories. See
442 _getSubdirectoryNames for help with that.
443 Images are assumed to be files with .gif or .png file extensions.
444 The image names returned do not have the directory name on them.
448 sub _getImagesFromDirectory
{
449 my $directoryname = shift;
450 return unless defined $directoryname;
451 return unless -d
$directoryname;
453 if ( opendir ( my $dh, $directoryname ) ) {
454 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
456 @images = sort(@images);
459 warn "unable to opendir $directoryname: $!";
464 =head3 _getSubdirectoryNames
466 Find all of the directories in a directory in the filesystem
468 parameters: a directory name
470 returns: a list of subdirectories in that directory.
472 Notes: this does not traverse into subdirectories. Only the first
473 level of subdirectories are returned.
474 The directory names returned don't have the parent directory name on them.
478 sub _getSubdirectoryNames
{
479 my $directoryname = shift;
480 return unless defined $directoryname;
481 return unless -d
$directoryname;
483 if ( opendir ( my $dh, $directoryname ) ) {
484 my @directories = grep { -d File
::Spec
->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
488 warn "unable to opendir $directoryname: $!";
495 returns: a listref of hashrefs. Each hash represents another collection of images.
497 { imagesetname => 'npl', # the name of the image set (npl is the original one)
498 images => listref of image hashrefs
501 each image is represented by a hashref like this:
503 { KohaImage => 'npl/image.gif',
504 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
505 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
506 checked => 0 or 1: was this the image passed to this method?
507 Note: I'd like to remove this somehow.
514 my $checked = $params{'checked'} || '';
516 my $paths = { staff
=> { filesystem
=> getitemtypeimagedir
('intranet'),
517 url
=> getitemtypeimagesrc
('intranet'),
519 opac
=> { filesystem
=> getitemtypeimagedir
('opac'),
520 url
=> getitemtypeimagesrc
('opac'),
524 my @imagesets = (); # list of hasrefs of image set data to pass to template
525 my @subdirectories = _getSubdirectoryNames
( $paths->{'staff'}{'filesystem'} );
526 foreach my $imagesubdir ( @subdirectories ) {
527 warn $imagesubdir if $DEBUG;
528 my @imagelist = (); # hashrefs of image info
529 my @imagenames = _getImagesFromDirectory
( File
::Spec
->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
530 my $imagesetactive = 0;
531 foreach my $thisimage ( @imagenames ) {
533 { KohaImage
=> "$imagesubdir/$thisimage",
534 StaffImageUrl
=> join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
535 OpacImageUrl
=> join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
536 checked
=> "$imagesubdir/$thisimage" eq $checked ?
1 : 0,
539 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
541 push @imagesets, { imagesetname
=> $imagesubdir,
542 imagesetactive
=> $imagesetactive,
543 images
=> \
@imagelist };
551 $printers = &GetPrinters();
552 @queues = keys %$printers;
554 Returns information about existing printer queues.
556 C<$printers> is a reference-to-hash whose keys are the print queues
557 defined in the printers table of the Koha database. The values are
558 references-to-hash, whose keys are the fields in the printers table.
564 my $dbh = C4
::Context
->dbh;
565 my $sth = $dbh->prepare("select * from printers");
567 while ( my $printer = $sth->fetchrow_hashref ) {
568 $printers{ $printer->{'printqueue'} } = $printer;
570 return ( \
%printers );
575 $printer = GetPrinter( $query, $printers );
580 my ( $query, $printers ) = @_; # get printer for this query from printers
581 my $printer = $query->param('printer');
582 my %cookie = $query->cookie('userenv');
583 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
584 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
590 Returns the number of pages to display in a pagination bar, given the number
591 of items and the number of items per page.
596 my ( $nb_items, $nb_items_per_page ) = @_;
598 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
603 (@themes) = &getallthemes('opac');
604 (@themes) = &getallthemes('intranet');
606 Returns an array of all available themes.
614 if ( $type eq 'intranet' ) {
615 $htdocs = C4
::Context
->config('intrahtdocs');
618 $htdocs = C4
::Context
->config('opachtdocs');
620 opendir D
, "$htdocs";
621 my @dirlist = readdir D
;
622 foreach my $directory (@dirlist) {
623 next if $directory eq 'lib';
624 -d
"$htdocs/$directory/en" and push @themes, $directory;
631 if ( C4
::Context
->preference("marcflavour") eq "UNIMARC" ) {
636 tags
=> [ qw
/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
642 tags
=> [ qw
/ 607a / ],
648 tags
=> [ qw
/ 500a 501a 503a / ],
654 tags
=> [ qw
/ 700ab 701ab 702ab / ],
655 sep
=> C4
::Context
->preference("UNIMARCAuthorsFacetsSeparator"),
660 tags
=> [ qw
/ 225a / ],
666 tags
=> [ qw
/ 995e / ],
670 unless ( Koha
::Libraries
->search->count == 1 )
672 my $DisplayLibraryFacets = C4
::Context
->preference('DisplayLibraryFacets');
673 if ( $DisplayLibraryFacets eq 'both'
674 || $DisplayLibraryFacets eq 'holding' )
679 idx
=> 'holdingbranch',
680 label
=> 'HoldingLibrary',
681 tags
=> [qw
/ 995c /],
686 if ( $DisplayLibraryFacets eq 'both'
687 || $DisplayLibraryFacets eq 'home' )
693 label
=> 'HomeLibrary',
694 tags
=> [qw
/ 995b /],
705 tags
=> [ qw
/ 650a / ],
710 # label => 'People and Organizations',
711 # tags => [ qw/ 600a 610a 611a / ],
717 tags
=> [ qw
/ 651a / ],
723 tags
=> [ qw
/ 630a / ],
729 tags
=> [ qw
/ 100a 110a 700a / ],
735 tags
=> [ qw
/ 440a 490a / ],
740 label
=> 'ItemTypes',
741 tags
=> [ qw
/ 952y 942c / ],
747 tags
=> [ qw
/ 952c / ],
751 unless ( Koha
::Libraries
->search->count == 1 )
753 my $DisplayLibraryFacets = C4
::Context
->preference('DisplayLibraryFacets');
754 if ( $DisplayLibraryFacets eq 'both'
755 || $DisplayLibraryFacets eq 'holding' )
760 idx
=> 'holdingbranch',
761 label
=> 'HoldingLibrary',
762 tags
=> [qw
/ 952b /],
767 if ( $DisplayLibraryFacets eq 'both'
768 || $DisplayLibraryFacets eq 'home' )
774 label
=> 'HomeLibrary',
775 tags
=> [qw
/ 952a /],
786 Return a href where a key is associated to a href. You give a query,
787 the name of the key among the fields returned by the query. If you
788 also give as third argument the name of the value, the function
789 returns a href of scalar. The optional 4th argument is an arrayref of
790 items passed to the C<execute()> call. It is designed to bind
791 parameters to any placeholders in your SQL.
800 # generic href of any information on the item, href of href.
801 my $iteminfos_of = get_infos_of($query, 'itemnumber');
802 print $iteminfos_of->{$itemnumber}{barcode};
804 # specific information, href of scalar
805 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
806 print $barcode_of_item->{$itemnumber};
811 my ( $query, $key_name, $value_name, $bind_params ) = @_;
813 my $dbh = C4
::Context
->dbh;
815 my $sth = $dbh->prepare($query);
816 $sth->execute( @
$bind_params );
819 while ( my $row = $sth->fetchrow_hashref ) {
820 if ( defined $value_name ) {
821 $infos_of{ $row->{$key_name} } = $row->{$value_name};
824 $infos_of{ $row->{$key_name} } = $row;
832 =head2 get_notforloan_label_of
834 my $notforloan_label_of = get_notforloan_label_of();
836 Each authorised value of notforloan (information available in items and
837 itemtypes) is link to a single label.
839 Returns a href where keys are authorised values and values are corresponding
842 foreach my $authorised_value (keys %{$notforloan_label_of}) {
844 "authorised_value: %s => %s\n",
846 $notforloan_label_of->{$authorised_value}
852 # FIXME - why not use GetAuthorisedValues ??
854 sub get_notforloan_label_of
{
855 my $dbh = C4
::Context
->dbh;
858 SELECT authorised_value
859 FROM marc_subfield_structure
860 WHERE kohafield = \'items.notforloan\'
863 my $sth = $dbh->prepare($query);
865 my ($statuscode) = $sth->fetchrow_array();
870 FROM authorised_values
873 $sth = $dbh->prepare($query);
874 $sth->execute($statuscode);
875 my %notforloan_label_of;
876 while ( my $row = $sth->fetchrow_hashref ) {
877 $notforloan_label_of{ $row->{authorised_value
} } = $row->{lib
};
881 return \
%notforloan_label_of;
884 =head2 GetAuthorisedValues
886 $authvalues = GetAuthorisedValues([$category]);
888 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
890 C<$category> returns authorised values for just one category (optional).
892 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
896 sub GetAuthorisedValues
{
897 my ( $category, $opac ) = @_;
899 # Is this cached already?
900 $opac = $opac ?
1 : 0; # normalise to be safe
902 C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : "";
904 "AuthorisedValues-$category-$opac-$branch_limit";
905 my $cache = Koha
::Caches
->get_instance();
906 my $result = $cache->get_from_cache($cache_key);
907 return $result if $result;
910 my $dbh = C4
::Context
->dbh;
913 FROM authorised_values av
916 LEFT JOIN authorised_values_branches ON
( id
= av_id
)
921 push @where_strings, "category = ?";
922 push @where_args, $category;
925 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
926 push @where_args, $branch_limit;
928 if(@where_strings > 0) {
929 $query .= " WHERE " . join(" AND ", @where_strings);
931 $query .= ' ORDER BY category, ' . (
932 $opac ?
'COALESCE(lib_opac, lib)'
936 my $sth = $dbh->prepare($query);
938 $sth->execute( @where_args );
939 while (my $data=$sth->fetchrow_hashref) {
940 if ($opac && $data->{lib_opac
}) {
941 $data->{lib
} = $data->{lib_opac
};
943 push @results, $data;
947 $cache->set_in_cache( $cache_key, \
@results, { expiry
=> 5 } );
951 =head2 GetAuthorisedValueCategories
953 $auth_categories = GetAuthorisedValueCategories();
955 Return an arrayref of all of the available authorised
960 sub GetAuthorisedValueCategories
{
961 my $dbh = C4
::Context
->dbh;
962 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
965 while (defined (my $category = $sth->fetchrow_array) ) {
966 push @results, $category;
973 my $escaped_string = C4::Koha::xml_escape($string);
975 Convert &, <, >, ', and " in a string to XML entities
981 return '' unless defined $str;
985 $str =~ s/'/'/g;
986 $str =~ s/"/"/g;
990 =head2 display_marc_indicators
992 my $display_form = C4::Koha::display_marc_indicators($field);
994 C<$field> is a MARC::Field object
996 Generate a display form of the indicators of a variable
997 MARC field, replacing any blanks with '#'.
1001 sub display_marc_indicators
{
1003 my $indicators = '';
1004 if ($field && $field->tag() >= 10) {
1005 $indicators = $field->indicator(1) . $field->indicator(2);
1006 $indicators =~ s/ /#/g;
1011 sub GetNormalizedUPC
{
1012 my ($marcrecord,$marcflavour) = @_;
1014 return unless $marcrecord;
1015 if ($marcflavour eq 'UNIMARC') {
1016 my @fields = $marcrecord->field('072');
1017 foreach my $field (@fields) {
1018 my $upc = _normalize_match_point
($field->subfield('a'));
1025 else { # assume marc21 if not unimarc
1026 my @fields = $marcrecord->field('024');
1027 foreach my $field (@fields) {
1028 my $indicator = $field->indicator(1);
1029 my $upc = _normalize_match_point
($field->subfield('a'));
1030 if ($upc && $indicator == 1 ) {
1037 # Normalizes and returns the first valid ISBN found in the record
1038 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1039 sub GetNormalizedISBN
{
1040 my ($isbn,$marcrecord,$marcflavour) = @_;
1042 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1043 # anything after " | " should be removed, along with the delimiter
1044 ($isbn) = split(/\|/, $isbn );
1045 return _isbn_cleanup
($isbn);
1048 return unless $marcrecord;
1050 if ($marcflavour eq 'UNIMARC') {
1051 my @fields = $marcrecord->field('010');
1052 foreach my $field (@fields) {
1053 my $isbn = $field->subfield('a');
1055 return _isbn_cleanup
($isbn);
1059 else { # assume marc21 if not unimarc
1060 my @fields = $marcrecord->field('020');
1061 foreach my $field (@fields) {
1062 $isbn = $field->subfield('a');
1064 return _isbn_cleanup
($isbn);
1070 sub GetNormalizedEAN
{
1071 my ($marcrecord,$marcflavour) = @_;
1073 return unless $marcrecord;
1075 if ($marcflavour eq 'UNIMARC') {
1076 my @fields = $marcrecord->field('073');
1077 foreach my $field (@fields) {
1078 my $ean = _normalize_match_point
($field->subfield('a'));
1084 else { # assume marc21 if not unimarc
1085 my @fields = $marcrecord->field('024');
1086 foreach my $field (@fields) {
1087 my $indicator = $field->indicator(1);
1088 my $ean = _normalize_match_point
($field->subfield('a'));
1089 if ( $ean && $indicator == 3 ) {
1096 sub GetNormalizedOCLCNumber
{
1097 my ($marcrecord,$marcflavour) = @_;
1098 return unless $marcrecord;
1100 if ($marcflavour ne 'UNIMARC' ) {
1101 my @fields = $marcrecord->field('035');
1102 foreach my $field (@fields) {
1103 my $oclc = $field->subfield('a');
1104 if ($oclc =~ /OCoLC/) {
1105 $oclc =~ s/\(OCoLC\)//;
1115 sub GetAuthvalueDropbox
{
1116 my ( $authcat, $default ) = @_;
1117 my $branch_limit = C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : "";
1118 my $dbh = C4
::Context
->dbh;
1122 FROM authorised_values
1125 LEFT JOIN authorised_values_branches ON
( id
= av_id
)
1130 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1131 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1132 my $sth = $dbh->prepare($query);
1133 $sth->execute( $authcat, $branch_limit ?
$branch_limit : () );
1136 my $option_list = [];
1137 my @authorised_values = ( q{} );
1138 while (my $av = $sth->fetchrow_hashref) {
1139 push @
{$option_list}, {
1140 value
=> $av->{authorised_value
},
1141 label
=> $av->{lib
},
1142 default => ($default eq $av->{authorised_value
}),
1146 if ( @
{$option_list} ) {
1147 return $option_list;
1153 =head2 GetDailyQuote($opts)
1155 Takes a hashref of options
1157 Currently supported options are:
1159 'id' An exact quote id
1160 'random' Select a random quote
1161 noop When no option is passed in, this sub will return the quote timestamped for the current day
1163 The function returns an anonymous hash following this format:
1166 'source' => 'source-of-quote',
1167 'timestamp' => 'timestamp-value',
1168 'text' => 'text-of-quote',
1174 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1175 # at least for default option
1179 my $dbh = C4
::Context
->dbh;
1184 $query = 'SELECT * FROM quotes WHERE id = ?';
1185 $sth = $dbh->prepare($query);
1186 $sth->execute($opts{'id'});
1187 $quote = $sth->fetchrow_hashref();
1189 elsif ($opts{'random'}) {
1190 # Fall through... we also return a random quote as a catch-all if all else fails
1193 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1194 $sth = $dbh->prepare($query);
1196 $quote = $sth->fetchrow_hashref();
1198 unless ($quote) { # if there are not matches, choose a random quote
1199 # get a list of all available quote ids
1200 $sth = C4
::Context
->dbh->prepare('SELECT count(*) FROM quotes;');
1202 my $range = ($sth->fetchrow_array)[0];
1203 # chose a random id within that range if there is more than one quote
1204 my $offset = int(rand($range));
1206 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1207 $sth = C4
::Context
->dbh->prepare($query);
1208 # see http://www.perlmonks.org/?node_id=837422 for why
1209 # we're being verbose and using bind_param
1210 $sth->bind_param(1, $offset, SQL_INTEGER
);
1212 $quote = $sth->fetchrow_hashref();
1213 # update the timestamp for that quote
1214 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1215 $sth = C4
::Context
->dbh->prepare($query);
1217 DateTime
::Format
::MySQL
->format_datetime( dt_from_string
() ),
1224 sub _normalize_match_point
{
1225 my $match_point = shift;
1226 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1227 $normalized_match_point =~ s/-//g;
1229 return $normalized_match_point;
1234 return NormalizeISBN
(
1237 format
=> 'ISBN-10',
1243 =head2 NormalizedISBN
1245 my $isbns = NormalizedISBN({
1247 strip_hyphens => [0,1],
1248 format => ['ISBN-10', 'ISBN-13']
1251 Returns an isbn validated by Business::ISBN.
1252 Optionally strips hyphens and/or forces the isbn
1253 to be of the specified format.
1255 If the string cannot be validated as an isbn,
1263 my $string = $params->{isbn
};
1264 my $strip_hyphens = $params->{strip_hyphens
};
1265 my $format = $params->{format
};
1267 return unless $string;
1269 my $isbn = Business
::ISBN
->new($string);
1271 if ( $isbn && $isbn->is_valid() ) {
1273 if ( $format eq 'ISBN-10' ) {
1274 $isbn = $isbn->as_isbn10();
1276 elsif ( $format eq 'ISBN-13' ) {
1277 $isbn = $isbn->as_isbn13();
1279 return unless $isbn;
1281 if ($strip_hyphens) {
1282 $string = $isbn->as_string( [] );
1284 $string = $isbn->as_string();
1291 =head2 GetVariationsOfISBN
1293 my @isbns = GetVariationsOfISBN( $isbn );
1295 Returns a list of variations of the given isbn in
1296 both ISBN-10 and ISBN-13 formats, with and without
1299 In a scalar context, the isbns are returned as a
1300 string delimited by ' | '.
1304 sub GetVariationsOfISBN
{
1307 return unless $isbn;
1311 push( @isbns, NormalizeISBN
({ isbn
=> $isbn }) );
1312 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-10' }) );
1313 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-13' }) );
1314 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-10', strip_hyphens
=> 1 }) );
1315 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-13', strip_hyphens
=> 1 }) );
1317 # Strip out any "empty" strings from the array
1318 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1320 return wantarray ?
@isbns : join( " | ", @isbns );
1323 =head2 GetVariationsOfISBNs
1325 my @isbns = GetVariationsOfISBNs( @isbns );
1327 Returns a list of variations of the given isbns in
1328 both ISBN-10 and ISBN-13 formats, with and without
1331 In a scalar context, the isbns are returned as a
1332 string delimited by ' | '.
1336 sub GetVariationsOfISBNs
{
1339 @isbns = map { GetVariationsOfISBN
( $_ ) } @isbns;
1341 return wantarray ?
@isbns : join( " | ", @isbns );
1344 =head2 NormalizedISSN
1346 my $issns = NormalizedISSN({
1348 strip_hyphen => [0,1]
1351 Returns an issn validated by Business::ISSN.
1352 Optionally strips hyphen.
1354 If the string cannot be validated as an issn,
1362 my $string = $params->{issn
};
1363 my $strip_hyphen = $params->{strip_hyphen
};
1365 my $issn = Business
::ISSN
->new($string);
1367 if ( $issn && $issn->is_valid ){
1369 if ($strip_hyphen) {
1370 $string = $issn->_issn;
1373 $string = $issn->as_string;
1380 =head2 GetVariationsOfISSN
1382 my @issns = GetVariationsOfISSN( $issn );
1384 Returns a list of variations of the given issn in
1385 with and without a hyphen.
1387 In a scalar context, the issns are returned as a
1388 string delimited by ' | '.
1392 sub GetVariationsOfISSN
{
1395 return unless $issn;
1398 my $str = NormalizeISSN
({ issn
=> $issn });
1401 push @issns, NormalizeISSN
({ issn
=> $issn, strip_hyphen
=> 1 });
1406 # Strip out any "empty" strings from the array
1407 @issns = grep { defined($_) && $_ =~ /\S/ } @issns;
1409 return wantarray ?
@issns : join( " | ", @issns );
1412 =head2 GetVariationsOfISSNs
1414 my @issns = GetVariationsOfISSNs( @issns );
1416 Returns a list of variations of the given issns in
1417 with and without a hyphen.
1419 In a scalar context, the issns are returned as a
1420 string delimited by ' | '.
1424 sub GetVariationsOfISSNs
{
1427 @issns = map { GetVariationsOfISSN
( $_ ) } @issns;
1429 return wantarray ?
@issns : join( " | ", @issns );
1433 =head2 IsKohaFieldLinked
1435 my $is_linked = IsKohaFieldLinked({
1436 kohafield => $kohafield,
1437 frameworkcode => $frameworkcode,
1440 Return 1 if the field is linked
1444 sub IsKohaFieldLinked
{
1445 my ( $params ) = @_;
1446 my $kohafield = $params->{kohafield
};
1447 my $frameworkcode = $params->{frameworkcode
} || '';
1448 my $dbh = C4
::Context
->dbh;
1449 my $is_linked = $dbh->selectcol_arrayref( q
|
1451 FROM marc_subfield_structure
1452 WHERE frameworkcode
= ?
1454 |,{}, $frameworkcode, $kohafield );
1455 return $is_linked->[0];