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
27 use C4::Branch; # Can be removed?
29 use Koha::DateUtils qw(dt_from_string);
31 use DateTime::Format::MySQL;
33 use autouse 'Data::cselectall_arrayref' => qw(Dumper);
34 use DBI qw(:sql_types);
35 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
38 $VERSION = 3.07.00.049;
43 &subfield_is_koha_internal_p
44 &GetPrinters &GetPrinter
45 &GetItemTypes &getitemtypeinfo
46 &GetItemTypesCategorized &GetItemTypesByCategory
47 &GetSupportName &GetSupportList
48 &getframeworks &getframeworkinfo
55 &get_notforloan_label_of
58 &getitemtypeimagelocation
60 &GetAuthorisedValueCategories
61 &IsAuthorisedValueCategory
62 &GetKohaAuthorisedValues
63 &GetKohaAuthorisedValuesFromField
64 &GetKohaAuthorisedValuesMapping
65 &GetKohaAuthorisedValueLib
66 &GetAuthorisedValueByCode
71 &GetNormalizedOCLCNumber
81 @EXPORT_OK = qw( GetDailyQuote );
86 C4::Koha - Perl Module containing convenience functions for Koha scripts
94 Koha.pm provides many functions for Koha scripts.
102 $slash_date = &slashifyDate($dash_date);
104 Takes a string of the form "DD-MM-YYYY" (or anything separated by
105 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
111 # accepts a date of the form xx-xx-xx[xx] and returns it in the
113 my @dateOut = split( '-', shift );
114 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
117 # FIXME.. this should be moved to a MARC-specific module
118 sub subfield_is_koha_internal_p {
121 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
122 # But real MARC subfields are always single-character
123 # so it really is safer just to check the length
125 return length $subfield != 1;
128 =head2 GetSupportName
130 $itemtypename = &GetSupportName($codestring);
132 Returns a string with the name of the itemtype.
138 return if (! $codestring);
140 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
141 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
148 my $sth = C4::Context->dbh->prepare($query);
149 $sth->execute($codestring);
150 ($resultstring)=$sth->fetchrow;
151 return $resultstring;
154 C4::Context->dbh->prepare(
155 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
157 $sth->execute( $advanced_search_types, $codestring );
158 my $data = $sth->fetchrow_hashref;
159 return $$data{'lib'};
163 =head2 GetSupportList
165 $itemtypes = &GetSupportList();
167 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
169 build a HTML select with the following code :
171 =head3 in PERL SCRIPT
173 my $itemtypes = GetSupportList();
174 $template->param(itemtypeloop => $itemtypes);
178 <select name="itemtype" id="itemtype">
179 <option value=""></option>
180 [% FOREACH itemtypeloo IN itemtypeloop %]
181 [% IF ( itemtypeloo.selected ) %]
182 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
184 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
192 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
193 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
194 return GetItemTypes( style => 'array' );
196 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
197 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
203 $itemtypes = &GetItemTypes( style => $style );
205 Returns information about existing itemtypes.
208 style: either 'array' or 'hash', defaults to 'hash'.
209 'array' returns an arrayref,
210 'hash' return a hashref with the itemtype value as the key
212 build a HTML select with the following code :
214 =head3 in PERL SCRIPT
216 my $itemtypes = GetItemTypes;
218 foreach my $thisitemtype (sort keys %$itemtypes) {
219 my $selected = 1 if $thisitemtype eq $itemtype;
220 my %row =(value => $thisitemtype,
221 selected => $selected,
222 description => $itemtypes->{$thisitemtype}->{'description'},
224 push @itemtypesloop, \%row;
226 $template->param(itemtypeloop => \@itemtypesloop);
230 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
231 <select name="itemtype">
232 <option value="">Default</option>
233 <!-- TMPL_LOOP name="itemtypeloop" -->
234 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
237 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
238 <input type="submit" value="OK" class="button">
245 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
247 require C4::Languages;
248 my $language = C4::Languages::getlanguage();
249 # returns a reference to a hash of references to itemtypes...
250 my $dbh = C4::Context->dbh;
254 itemtypes.description,
255 itemtypes.rentalcharge,
256 itemtypes.notforloan,
259 itemtypes.checkinmsg,
260 itemtypes.checkinmsgtype,
261 itemtypes.sip_media_type,
262 itemtypes.hideinopac,
263 itemtypes.searchcategory,
264 COALESCE( localization.translation, itemtypes.description ) AS translated_description
266 LEFT JOIN localization ON itemtypes.itemtype = localization.code
267 AND localization.entity = 'itemtypes'
268 AND localization.lang = ?
271 my $sth = $dbh->prepare($query);
272 $sth->execute( $language );
274 if ( $style eq 'hash' ) {
276 while ( my $IT = $sth->fetchrow_hashref ) {
277 $itemtypes{ $IT->{'itemtype'} } = $IT;
279 return ( \%itemtypes );
281 return [ sort { lc $a->{translated_description} cmp lc $b->{translated_description} } @{ $sth->fetchall_arrayref( {} ) } ];
285 =head2 GetItemTypesCategorized
287 $categories = GetItemTypesCategorized();
289 Returns a hashref containing search categories.
290 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
291 The categories must be part of Authorized Values (ITEMTYPECAT)
295 sub GetItemTypesCategorized {
296 my $dbh = C4::Context->dbh;
297 # Order is important, so that partially hidden (some items are not visible in OPAC) search
298 # categories will be visible. hideinopac=0 must be last.
300 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
302 SELECT DISTINCT searchcategory AS `itemtype`,
303 authorised_values.lib_opac AS description,
304 authorised_values.imageurl AS imageurl,
305 hideinopac, 1 as 'iscat'
307 LEFT JOIN authorised_values ON searchcategory = authorised_value
308 WHERE searchcategory > '' and hideinopac=1
310 SELECT DISTINCT searchcategory AS `itemtype`,
311 authorised_values.lib_opac AS description,
312 authorised_values.imageurl AS imageurl,
313 hideinopac, 1 as 'iscat'
315 LEFT JOIN authorised_values ON searchcategory = authorised_value
316 WHERE searchcategory > '' and hideinopac=0
318 return ($dbh->selectall_hashref($query,'itemtype'));
321 =head2 GetItemTypesByCategory
323 @results = GetItemTypesByCategory( $searchcategory );
325 Returns the itemtype code of all itemtypes included in a searchcategory.
329 sub GetItemTypesByCategory {
333 my $dbh = C4::Context->dbh;
334 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory=?|;
335 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
341 $frameworks = &getframework();
343 Returns information about existing frameworks
345 build a HTML select with the following code :
347 =head3 in PERL SCRIPT
349 my $frameworks = getframeworks();
351 foreach my $thisframework (keys %$frameworks) {
352 my $selected = 1 if $thisframework eq $frameworkcode;
354 value => $thisframework,
355 selected => $selected,
356 description => $frameworks->{$thisframework}->{'frameworktext'},
358 push @frameworksloop, \%row;
360 $template->param(frameworkloop => \@frameworksloop);
364 <form action="[% script_name %] method=post>
365 <select name="frameworkcode">
366 <option value="">Default</option>
367 [% FOREACH framework IN frameworkloop %]
368 [% IF ( framework.selected ) %]
369 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
371 <option value="[% framework.value %]">[% framework.description %]</option>
375 <input type=text name=searchfield value="[% searchfield %]">
376 <input type="submit" value="OK" class="button">
383 # returns a reference to a hash of references to branches...
385 my $dbh = C4::Context->dbh;
386 my $sth = $dbh->prepare("select * from biblio_framework");
388 while ( my $IT = $sth->fetchrow_hashref ) {
389 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
391 return ( \%itemtypes );
394 =head2 GetFrameworksLoop
396 $frameworks = GetFrameworksLoop( $frameworkcode );
398 Returns the loop suggested on getframework(), but ordered by framework description.
400 build a HTML select with the following code :
402 =head3 in PERL SCRIPT
404 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
408 Same as getframework()
410 <form action="[% script_name %] method=post>
411 <select name="frameworkcode">
412 <option value="">Default</option>
413 [% FOREACH framework IN frameworkloop %]
414 [% IF ( framework.selected ) %]
415 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
417 <option value="[% framework.value %]">[% framework.description %]</option>
421 <input type=text name=searchfield value="[% searchfield %]">
422 <input type="submit" value="OK" class="button">
427 sub GetFrameworksLoop {
428 my $frameworkcode = shift;
429 my $frameworks = getframeworks();
431 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
432 my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
434 value => $thisframework,
435 selected => $selected,
436 description => $frameworks->{$thisframework}->{'frameworktext'},
438 push @frameworkloop, \%row;
440 return \@frameworkloop;
443 =head2 getframeworkinfo
445 $frameworkinfo = &getframeworkinfo($frameworkcode);
447 Returns information about an frameworkcode.
451 sub getframeworkinfo {
452 my ($frameworkcode) = @_;
453 my $dbh = C4::Context->dbh;
455 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
456 $sth->execute($frameworkcode);
457 my $res = $sth->fetchrow_hashref;
461 =head2 getitemtypeinfo
463 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
465 Returns information about an itemtype. The optional $interface argument
466 sets which interface ('opac' or 'intranet') to return the imageurl for.
467 Defaults to intranet.
471 sub getitemtypeinfo {
472 my ($itemtype, $interface) = @_;
473 my $dbh = C4::Context->dbh;
474 require C4::Languages;
475 my $language = C4::Languages::getlanguage();
476 my $it = $dbh->selectrow_hashref(q|
479 itemtypes.description,
480 itemtypes.rentalcharge,
481 itemtypes.notforloan,
484 itemtypes.checkinmsg,
485 itemtypes.checkinmsgtype,
486 itemtypes.sip_media_type,
487 COALESCE( localization.translation, itemtypes.description ) AS translated_description
489 LEFT JOIN localization ON itemtypes.itemtype = localization.code
490 AND localization.entity = 'itemtypes'
491 AND localization.lang = ?
492 WHERE itemtypes.itemtype = ?
493 |, undef, $language, $itemtype );
495 $it->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $it->{imageurl} );
500 =head2 getitemtypeimagedir
502 my $directory = getitemtypeimagedir( 'opac' );
504 pass in 'opac' or 'intranet'. Defaults to 'opac'.
506 returns the full path to the appropriate directory containing images.
510 sub getitemtypeimagedir {
511 my $src = shift || 'opac';
512 if ($src eq 'intranet') {
513 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
515 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
519 sub getitemtypeimagesrc {
520 my $src = shift || 'opac';
521 if ($src eq 'intranet') {
522 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
524 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
528 sub getitemtypeimagelocation {
529 my ( $src, $image ) = @_;
531 return '' if ( !$image );
534 my $scheme = ( URI::Split::uri_split( $image ) )[0];
536 return $image if ( $scheme );
538 return getitemtypeimagesrc( $src ) . '/' . $image;
541 =head3 _getImagesFromDirectory
543 Find all of the image files in a directory in the filesystem
545 parameters: a directory name
547 returns: a list of images in that directory.
549 Notes: this does not traverse into subdirectories. See
550 _getSubdirectoryNames for help with that.
551 Images are assumed to be files with .gif or .png file extensions.
552 The image names returned do not have the directory name on them.
556 sub _getImagesFromDirectory {
557 my $directoryname = shift;
558 return unless defined $directoryname;
559 return unless -d $directoryname;
561 if ( opendir ( my $dh, $directoryname ) ) {
562 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
564 @images = sort(@images);
567 warn "unable to opendir $directoryname: $!";
572 =head3 _getSubdirectoryNames
574 Find all of the directories in a directory in the filesystem
576 parameters: a directory name
578 returns: a list of subdirectories in that directory.
580 Notes: this does not traverse into subdirectories. Only the first
581 level of subdirectories are returned.
582 The directory names returned don't have the parent directory name on them.
586 sub _getSubdirectoryNames {
587 my $directoryname = shift;
588 return unless defined $directoryname;
589 return unless -d $directoryname;
591 if ( opendir ( my $dh, $directoryname ) ) {
592 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
596 warn "unable to opendir $directoryname: $!";
603 returns: a listref of hashrefs. Each hash represents another collection of images.
605 { imagesetname => 'npl', # the name of the image set (npl is the original one)
606 images => listref of image hashrefs
609 each image is represented by a hashref like this:
611 { KohaImage => 'npl/image.gif',
612 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
613 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
614 checked => 0 or 1: was this the image passed to this method?
615 Note: I'd like to remove this somehow.
622 my $checked = $params{'checked'} || '';
624 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
625 url => getitemtypeimagesrc('intranet'),
627 opac => { filesystem => getitemtypeimagedir('opac'),
628 url => getitemtypeimagesrc('opac'),
632 my @imagesets = (); # list of hasrefs of image set data to pass to template
633 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
634 foreach my $imagesubdir ( @subdirectories ) {
635 warn $imagesubdir if $DEBUG;
636 my @imagelist = (); # hashrefs of image info
637 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
638 my $imagesetactive = 0;
639 foreach my $thisimage ( @imagenames ) {
641 { KohaImage => "$imagesubdir/$thisimage",
642 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
643 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
644 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
647 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
649 push @imagesets, { imagesetname => $imagesubdir,
650 imagesetactive => $imagesetactive,
651 images => \@imagelist };
659 $printers = &GetPrinters();
660 @queues = keys %$printers;
662 Returns information about existing printer queues.
664 C<$printers> is a reference-to-hash whose keys are the print queues
665 defined in the printers table of the Koha database. The values are
666 references-to-hash, whose keys are the fields in the printers table.
672 my $dbh = C4::Context->dbh;
673 my $sth = $dbh->prepare("select * from printers");
675 while ( my $printer = $sth->fetchrow_hashref ) {
676 $printers{ $printer->{'printqueue'} } = $printer;
678 return ( \%printers );
683 $printer = GetPrinter( $query, $printers );
688 my ( $query, $printers ) = @_; # get printer for this query from printers
689 my $printer = $query->param('printer');
690 my %cookie = $query->cookie('userenv');
691 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
692 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
698 Returns the number of pages to display in a pagination bar, given the number
699 of items and the number of items per page.
704 my ( $nb_items, $nb_items_per_page ) = @_;
706 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
711 (@themes) = &getallthemes('opac');
712 (@themes) = &getallthemes('intranet');
714 Returns an array of all available themes.
722 if ( $type eq 'intranet' ) {
723 $htdocs = C4::Context->config('intrahtdocs');
726 $htdocs = C4::Context->config('opachtdocs');
728 opendir D, "$htdocs";
729 my @dirlist = readdir D;
730 foreach my $directory (@dirlist) {
731 next if $directory eq 'lib';
732 -d "$htdocs/$directory/en" and push @themes, $directory;
739 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
744 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
750 tags => [ qw/ 607a / ],
756 tags => [ qw/ 500a 501a 503a / ],
762 tags => [ qw/ 700ab 701ab 702ab / ],
763 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
768 tags => [ qw/ 225a / ],
774 tags => [ qw/ 995e / ],
778 unless ( C4::Context->preference("singleBranchMode")
779 || Koha::Libraries->search->count == 1 )
781 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
782 if ( $DisplayLibraryFacets eq 'both'
783 || $DisplayLibraryFacets eq 'holding' )
788 idx => 'holdingbranch',
789 label => 'HoldingLibrary',
790 tags => [qw / 995c /],
795 if ( $DisplayLibraryFacets eq 'both'
796 || $DisplayLibraryFacets eq 'home' )
802 label => 'HomeLibrary',
803 tags => [qw / 995b /],
814 tags => [ qw/ 650a / ],
819 # label => 'People and Organizations',
820 # tags => [ qw/ 600a 610a 611a / ],
826 tags => [ qw/ 651a / ],
832 tags => [ qw/ 630a / ],
838 tags => [ qw/ 100a 110a 700a / ],
844 tags => [ qw/ 440a 490a / ],
849 label => 'ItemTypes',
850 tags => [ qw/ 952y 942c / ],
856 tags => [ qw / 952c / ],
860 unless ( C4::Context->preference("singleBranchMode")
861 || Koha::Libraries->search->count == 1 )
863 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
864 if ( $DisplayLibraryFacets eq 'both'
865 || $DisplayLibraryFacets eq 'holding' )
870 idx => 'holdingbranch',
871 label => 'HoldingLibrary',
872 tags => [qw / 952b /],
877 if ( $DisplayLibraryFacets eq 'both'
878 || $DisplayLibraryFacets eq 'home' )
884 label => 'HomeLibrary',
885 tags => [qw / 952a /],
896 Return a href where a key is associated to a href. You give a query,
897 the name of the key among the fields returned by the query. If you
898 also give as third argument the name of the value, the function
899 returns a href of scalar. The optional 4th argument is an arrayref of
900 items passed to the C<execute()> call. It is designed to bind
901 parameters to any placeholders in your SQL.
910 # generic href of any information on the item, href of href.
911 my $iteminfos_of = get_infos_of($query, 'itemnumber');
912 print $iteminfos_of->{$itemnumber}{barcode};
914 # specific information, href of scalar
915 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
916 print $barcode_of_item->{$itemnumber};
921 my ( $query, $key_name, $value_name, $bind_params ) = @_;
923 my $dbh = C4::Context->dbh;
925 my $sth = $dbh->prepare($query);
926 $sth->execute( @$bind_params );
929 while ( my $row = $sth->fetchrow_hashref ) {
930 if ( defined $value_name ) {
931 $infos_of{ $row->{$key_name} } = $row->{$value_name};
934 $infos_of{ $row->{$key_name} } = $row;
942 =head2 get_notforloan_label_of
944 my $notforloan_label_of = get_notforloan_label_of();
946 Each authorised value of notforloan (information available in items and
947 itemtypes) is link to a single label.
949 Returns a href where keys are authorised values and values are corresponding
952 foreach my $authorised_value (keys %{$notforloan_label_of}) {
954 "authorised_value: %s => %s\n",
956 $notforloan_label_of->{$authorised_value}
962 # FIXME - why not use GetAuthorisedValues ??
964 sub get_notforloan_label_of {
965 my $dbh = C4::Context->dbh;
968 SELECT authorised_value
969 FROM marc_subfield_structure
970 WHERE kohafield = \'items.notforloan\'
973 my $sth = $dbh->prepare($query);
975 my ($statuscode) = $sth->fetchrow_array();
980 FROM authorised_values
983 $sth = $dbh->prepare($query);
984 $sth->execute($statuscode);
985 my %notforloan_label_of;
986 while ( my $row = $sth->fetchrow_hashref ) {
987 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
991 return \%notforloan_label_of;
994 =head2 displayServers
996 my $servers = displayServers();
997 my $servers = displayServers( $position );
998 my $servers = displayServers( $position, $type );
1000 displayServers returns a listref of hashrefs, each containing
1001 information about available z3950 servers. Each hashref has a format
1005 'checked' => 'checked',
1006 'encoding' => 'utf8',
1008 'id' => 'LIBRARY OF CONGRESS',
1012 'value' => 'lx2.loc.gov:210/',
1018 sub displayServers {
1019 my ( $position, $type ) = @_;
1020 my $dbh = C4::Context->dbh;
1022 my $strsth = 'SELECT * FROM z3950servers';
1027 push @bind_params, $position;
1028 push @where_clauses, ' position = ? ';
1032 push @bind_params, $type;
1033 push @where_clauses, ' type = ? ';
1036 # reassemble where clause from where clause pieces
1037 if (@where_clauses) {
1038 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1041 my $rq = $dbh->prepare($strsth);
1042 $rq->execute(@bind_params);
1043 my @primaryserverloop;
1045 while ( my $data = $rq->fetchrow_hashref ) {
1046 push @primaryserverloop,
1047 { label => $data->{description},
1048 id => $data->{name},
1050 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1051 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1052 checked => "checked",
1053 icon => $data->{icon},
1054 zed => $data->{type} eq 'zed',
1055 opensearch => $data->{type} eq 'opensearch'
1058 return \@primaryserverloop;
1061 =head2 GetAuthValCode
1063 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1067 sub GetAuthValCode {
1068 my ($kohafield,$fwcode) = @_;
1069 my $dbh = C4::Context->dbh;
1070 $fwcode='' unless $fwcode;
1071 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1072 $sth->execute($kohafield,$fwcode);
1073 my ($authvalcode) = $sth->fetchrow_array;
1074 return $authvalcode;
1077 =head2 GetAuthValCodeFromField
1079 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1081 C<$subfield> can be undefined
1085 sub GetAuthValCodeFromField {
1086 my ($field,$subfield,$fwcode) = @_;
1087 my $dbh = C4::Context->dbh;
1088 $fwcode='' unless $fwcode;
1090 if (defined $subfield) {
1091 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1092 $sth->execute($field,$subfield,$fwcode);
1094 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1095 $sth->execute($field,$fwcode);
1097 my ($authvalcode) = $sth->fetchrow_array;
1098 return $authvalcode;
1101 =head2 GetAuthorisedValues
1103 $authvalues = GetAuthorisedValues([$category], [$selected]);
1105 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1107 C<$category> returns authorised values for just one category (optional).
1109 C<$selected> adds a "selected => 1" entry to the hash if the
1110 authorised_value matches it. B<NOTE:> this feature should be considered
1111 deprecated as it may be removed in the future.
1113 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1117 sub GetAuthorisedValues {
1118 my ( $category, $selected, $opac ) = @_;
1120 # TODO: the "selected" feature should be replaced by a utility function
1121 # somewhere else, it doesn't belong in here. For starters it makes
1122 # caching much more complicated. Or just let the UI logic handle it, it's
1125 # Is this cached already?
1126 $opac = $opac ? 1 : 0; # normalise to be safe
1128 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1129 my $selected_key = defined($selected) ? $selected : '';
1131 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1132 my $cache = Koha::Cache->get_instance();
1133 my $result = $cache->get_from_cache($cache_key);
1134 return $result if $result;
1137 my $dbh = C4::Context->dbh;
1140 FROM authorised_values
1143 LEFT JOIN authorised_values_branches ON ( id = av_id )
1148 push @where_strings, "category = ?";
1149 push @where_args, $category;
1152 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1153 push @where_args, $branch_limit;
1155 if(@where_strings > 0) {
1156 $query .= " WHERE " . join(" AND ", @where_strings);
1158 $query .= " GROUP BY lib";
1159 $query .= ' ORDER BY category, ' . (
1160 $opac ? 'COALESCE(lib_opac, lib)'
1164 my $sth = $dbh->prepare($query);
1166 $sth->execute( @where_args );
1167 while (my $data=$sth->fetchrow_hashref) {
1168 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1169 $data->{selected} = 1;
1172 $data->{selected} = 0;
1175 if ($opac && $data->{lib_opac}) {
1176 $data->{lib} = $data->{lib_opac};
1178 push @results, $data;
1182 # We can't cache for long because of that "selected" thing which
1183 # makes it impossible to clear the cache without iterating through every
1184 # value, which sucks. This'll cover this request, and not a whole lot more.
1185 $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1189 =head2 GetAuthorisedValueCategories
1191 $auth_categories = GetAuthorisedValueCategories();
1193 Return an arrayref of all of the available authorised
1198 sub GetAuthorisedValueCategories {
1199 my $dbh = C4::Context->dbh;
1200 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1203 while (defined (my $category = $sth->fetchrow_array) ) {
1204 push @results, $category;
1209 =head2 IsAuthorisedValueCategory
1211 $is_auth_val_category = IsAuthorisedValueCategory($category);
1213 Returns whether a given category name is a valid one
1217 sub IsAuthorisedValueCategory {
1218 my $category = shift;
1221 FROM authorised_values
1225 my $sth = C4::Context->dbh->prepare($query);
1226 $sth->execute($category);
1227 $sth->fetchrow ? return 1
1231 =head2 GetAuthorisedValueByCode
1233 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1235 Return the lib attribute from authorised_values from the row identified
1236 by the passed category and code
1240 sub GetAuthorisedValueByCode {
1241 my ( $category, $authvalcode, $opac ) = @_;
1243 my $field = $opac ? 'lib_opac' : 'lib';
1244 my $dbh = C4::Context->dbh;
1245 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1246 $sth->execute( $category, $authvalcode );
1247 while ( my $data = $sth->fetchrow_hashref ) {
1248 return $data->{ $field };
1252 =head2 GetKohaAuthorisedValues
1254 Takes $kohafield, $fwcode as parameters.
1256 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1258 Returns hashref of Code => description
1260 Returns undef if no authorised value category is defined for the kohafield.
1264 sub GetKohaAuthorisedValues {
1265 my ($kohafield,$fwcode,$opac) = @_;
1266 $fwcode='' unless $fwcode;
1268 my $dbh = C4::Context->dbh;
1269 my $avcode = GetAuthValCode($kohafield,$fwcode);
1271 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1272 $sth->execute($avcode);
1273 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1274 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1282 =head2 GetKohaAuthorisedValuesFromField
1284 Takes $field, $subfield, $fwcode as parameters.
1286 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1287 $subfield can be undefined
1289 Returns hashref of Code => description
1291 Returns undef if no authorised value category is defined for the given field and subfield
1295 sub GetKohaAuthorisedValuesFromField {
1296 my ($field, $subfield, $fwcode,$opac) = @_;
1297 $fwcode='' unless $fwcode;
1299 my $dbh = C4::Context->dbh;
1300 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1302 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1303 $sth->execute($avcode);
1304 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1305 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1313 =head2 GetKohaAuthorisedValuesMapping
1315 Takes a hash as a parameter. The interface key indicates the
1316 description to use in the mapping.
1319 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1320 for all the kohafields, frameworkcodes, and authorised values.
1322 Returns undef if nothing is found.
1326 sub GetKohaAuthorisedValuesMapping {
1327 my ($parameter) = @_;
1328 my $interface = $parameter->{'interface'} // '';
1330 my $query_mapping = q{
1331 SELECT TA.kohafield,TA.authorised_value AS category,
1332 TA.frameworkcode,TB.authorised_value,
1333 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1334 TB.lib AS Intranet,TB.lib_opac
1335 FROM marc_subfield_structure AS TA JOIN
1336 authorised_values as TB ON
1337 TA.authorised_value=TB.category
1338 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1340 my $dbh = C4::Context->dbh;
1341 my $sth = $dbh->prepare($query_mapping);
1344 if ($interface eq 'opac') {
1345 while (my $row = $sth->fetchrow_hashref) {
1346 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{OPAC};
1350 while (my $row = $sth->fetchrow_hashref) {
1351 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{Intranet};
1359 my $escaped_string = C4::Koha::xml_escape($string);
1361 Convert &, <, >, ', and " in a string to XML entities
1367 return '' unless defined $str;
1368 $str =~ s/&/&/g;
1371 $str =~ s/'/'/g;
1372 $str =~ s/"/"/g;
1376 =head2 GetKohaAuthorisedValueLib
1378 Takes $category, $authorised_value as parameters.
1380 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1382 Returns authorised value description
1386 sub GetKohaAuthorisedValueLib {
1387 my ($category,$authorised_value,$opac) = @_;
1389 my $dbh = C4::Context->dbh;
1390 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1391 $sth->execute($category,$authorised_value);
1392 my $data = $sth->fetchrow_hashref;
1393 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1397 =head2 display_marc_indicators
1399 my $display_form = C4::Koha::display_marc_indicators($field);
1401 C<$field> is a MARC::Field object
1403 Generate a display form of the indicators of a variable
1404 MARC field, replacing any blanks with '#'.
1408 sub display_marc_indicators {
1410 my $indicators = '';
1411 if ($field && $field->tag() >= 10) {
1412 $indicators = $field->indicator(1) . $field->indicator(2);
1413 $indicators =~ s/ /#/g;
1418 sub GetNormalizedUPC {
1419 my ($marcrecord,$marcflavour) = @_;
1421 return unless $marcrecord;
1422 if ($marcflavour eq 'UNIMARC') {
1423 my @fields = $marcrecord->field('072');
1424 foreach my $field (@fields) {
1425 my $upc = _normalize_match_point($field->subfield('a'));
1432 else { # assume marc21 if not unimarc
1433 my @fields = $marcrecord->field('024');
1434 foreach my $field (@fields) {
1435 my $indicator = $field->indicator(1);
1436 my $upc = _normalize_match_point($field->subfield('a'));
1437 if ($upc && $indicator == 1 ) {
1444 # Normalizes and returns the first valid ISBN found in the record
1445 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1446 sub GetNormalizedISBN {
1447 my ($isbn,$marcrecord,$marcflavour) = @_;
1449 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1450 # anything after " | " should be removed, along with the delimiter
1451 ($isbn) = split(/\|/, $isbn );
1452 return _isbn_cleanup($isbn);
1455 return unless $marcrecord;
1457 if ($marcflavour eq 'UNIMARC') {
1458 my @fields = $marcrecord->field('010');
1459 foreach my $field (@fields) {
1460 my $isbn = $field->subfield('a');
1462 return _isbn_cleanup($isbn);
1466 else { # assume marc21 if not unimarc
1467 my @fields = $marcrecord->field('020');
1468 foreach my $field (@fields) {
1469 $isbn = $field->subfield('a');
1471 return _isbn_cleanup($isbn);
1477 sub GetNormalizedEAN {
1478 my ($marcrecord,$marcflavour) = @_;
1480 return unless $marcrecord;
1482 if ($marcflavour eq 'UNIMARC') {
1483 my @fields = $marcrecord->field('073');
1484 foreach my $field (@fields) {
1485 my $ean = _normalize_match_point($field->subfield('a'));
1491 else { # assume marc21 if not unimarc
1492 my @fields = $marcrecord->field('024');
1493 foreach my $field (@fields) {
1494 my $indicator = $field->indicator(1);
1495 my $ean = _normalize_match_point($field->subfield('a'));
1496 if ( $ean && $indicator == 3 ) {
1503 sub GetNormalizedOCLCNumber {
1504 my ($marcrecord,$marcflavour) = @_;
1505 return unless $marcrecord;
1507 if ($marcflavour ne 'UNIMARC' ) {
1508 my @fields = $marcrecord->field('035');
1509 foreach my $field (@fields) {
1510 my $oclc = $field->subfield('a');
1511 if ($oclc =~ /OCoLC/) {
1512 $oclc =~ s/\(OCoLC\)//;
1522 sub GetAuthvalueDropbox {
1523 my ( $authcat, $default ) = @_;
1524 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1525 my $dbh = C4::Context->dbh;
1529 FROM authorised_values
1532 LEFT JOIN authorised_values_branches ON ( id = av_id )
1537 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1538 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1539 my $sth = $dbh->prepare($query);
1540 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1543 my $option_list = [];
1544 my @authorised_values = ( q{} );
1545 while (my $av = $sth->fetchrow_hashref) {
1546 push @{$option_list}, {
1547 value => $av->{authorised_value},
1548 label => $av->{lib},
1549 default => ($default eq $av->{authorised_value}),
1553 if ( @{$option_list} ) {
1554 return $option_list;
1560 =head2 GetDailyQuote($opts)
1562 Takes a hashref of options
1564 Currently supported options are:
1566 'id' An exact quote id
1567 'random' Select a random quote
1568 noop When no option is passed in, this sub will return the quote timestamped for the current day
1570 The function returns an anonymous hash following this format:
1573 'source' => 'source-of-quote',
1574 'timestamp' => 'timestamp-value',
1575 'text' => 'text-of-quote',
1581 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1582 # at least for default option
1586 my $dbh = C4::Context->dbh;
1591 $query = 'SELECT * FROM quotes WHERE id = ?';
1592 $sth = $dbh->prepare($query);
1593 $sth->execute($opts{'id'});
1594 $quote = $sth->fetchrow_hashref();
1596 elsif ($opts{'random'}) {
1597 # Fall through... we also return a random quote as a catch-all if all else fails
1600 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1601 $sth = $dbh->prepare($query);
1603 $quote = $sth->fetchrow_hashref();
1605 unless ($quote) { # if there are not matches, choose a random quote
1606 # get a list of all available quote ids
1607 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1609 my $range = ($sth->fetchrow_array)[0];
1610 # chose a random id within that range if there is more than one quote
1611 my $offset = int(rand($range));
1613 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1614 $sth = C4::Context->dbh->prepare($query);
1615 # see http://www.perlmonks.org/?node_id=837422 for why
1616 # we're being verbose and using bind_param
1617 $sth->bind_param(1, $offset, SQL_INTEGER);
1619 $quote = $sth->fetchrow_hashref();
1620 # update the timestamp for that quote
1621 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1622 $sth = C4::Context->dbh->prepare($query);
1624 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1631 sub _normalize_match_point {
1632 my $match_point = shift;
1633 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1634 $normalized_match_point =~ s/-//g;
1636 return $normalized_match_point;
1641 return NormalizeISBN(
1644 format => 'ISBN-10',
1650 =head2 NormalizedISBN
1652 my $isbns = NormalizedISBN({
1654 strip_hyphens => [0,1],
1655 format => ['ISBN-10', 'ISBN-13']
1658 Returns an isbn validated by Business::ISBN.
1659 Optionally strips hyphens and/or forces the isbn
1660 to be of the specified format.
1662 If the string cannot be validated as an isbn,
1670 my $string = $params->{isbn};
1671 my $strip_hyphens = $params->{strip_hyphens};
1672 my $format = $params->{format};
1674 return unless $string;
1676 my $isbn = Business::ISBN->new($string);
1678 if ( $isbn && $isbn->is_valid() ) {
1680 if ( $format eq 'ISBN-10' ) {
1681 $isbn = $isbn->as_isbn10();
1683 elsif ( $format eq 'ISBN-13' ) {
1684 $isbn = $isbn->as_isbn13();
1686 return unless $isbn;
1688 if ($strip_hyphens) {
1689 $string = $isbn->as_string( [] );
1691 $string = $isbn->as_string();
1698 =head2 GetVariationsOfISBN
1700 my @isbns = GetVariationsOfISBN( $isbn );
1702 Returns a list of variations of the given isbn in
1703 both ISBN-10 and ISBN-13 formats, with and without
1706 In a scalar context, the isbns are returned as a
1707 string delimited by ' | '.
1711 sub GetVariationsOfISBN {
1714 return unless $isbn;
1718 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1719 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1720 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1721 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1722 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1724 # Strip out any "empty" strings from the array
1725 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1727 return wantarray ? @isbns : join( " | ", @isbns );
1730 =head2 GetVariationsOfISBNs
1732 my @isbns = GetVariationsOfISBNs( @isbns );
1734 Returns a list of variations of the given isbns in
1735 both ISBN-10 and ISBN-13 formats, with and without
1738 In a scalar context, the isbns are returned as a
1739 string delimited by ' | '.
1743 sub GetVariationsOfISBNs {
1746 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1748 return wantarray ? @isbns : join( " | ", @isbns );
1751 =head2 IsKohaFieldLinked
1753 my $is_linked = IsKohaFieldLinked({
1754 kohafield => $kohafield,
1755 frameworkcode => $frameworkcode,
1758 Return 1 if the field is linked
1762 sub IsKohaFieldLinked {
1763 my ( $params ) = @_;
1764 my $kohafield = $params->{kohafield};
1765 my $frameworkcode = $params->{frameworkcode} || '';
1766 my $dbh = C4::Context->dbh;
1767 my $is_linked = $dbh->selectcol_arrayref( q|
1769 FROM marc_subfield_structure
1770 WHERE frameworkcode = ?
1772 |,{}, $frameworkcode, $kohafield );
1773 return $is_linked->[0];