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;
42 &subfield_is_koha_internal_p
43 &GetPrinters &GetPrinter
44 &GetItemTypes &getitemtypeinfo
45 &GetItemTypesCategorized &GetItemTypesByCategory
46 &GetSupportName &GetSupportList
47 &getframeworks &getframeworkinfo
54 &get_notforloan_label_of
57 &getitemtypeimagelocation
59 &GetAuthorisedValueCategories
60 &IsAuthorisedValueCategory
61 &GetKohaAuthorisedValues
62 &GetKohaAuthorisedValuesFromField
63 &GetKohaAuthorisedValuesMapping
64 &GetKohaAuthorisedValueLib
65 &GetAuthorisedValueByCode
70 &GetNormalizedOCLCNumber
80 @EXPORT_OK = qw( GetDailyQuote );
85 C4::Koha - Perl Module containing convenience functions for Koha scripts
93 Koha.pm provides many functions for Koha scripts.
99 # FIXME.. this should be moved to a MARC-specific module
100 sub subfield_is_koha_internal_p {
103 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
104 # But real MARC subfields are always single-character
105 # so it really is safer just to check the length
107 return length $subfield != 1;
110 =head2 GetSupportName
112 $itemtypename = &GetSupportName($codestring);
114 Returns a string with the name of the itemtype.
120 return if (! $codestring);
122 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
123 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
130 my $sth = C4::Context->dbh->prepare($query);
131 $sth->execute($codestring);
132 ($resultstring)=$sth->fetchrow;
133 return $resultstring;
136 C4::Context->dbh->prepare(
137 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
139 $sth->execute( $advanced_search_types, $codestring );
140 my $data = $sth->fetchrow_hashref;
141 return $$data{'lib'};
145 =head2 GetSupportList
147 $itemtypes = &GetSupportList();
149 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
151 build a HTML select with the following code :
153 =head3 in PERL SCRIPT
155 my $itemtypes = GetSupportList();
156 $template->param(itemtypeloop => $itemtypes);
160 <select name="itemtype" id="itemtype">
161 <option value=""></option>
162 [% FOREACH itemtypeloo IN itemtypeloop %]
163 [% IF ( itemtypeloo.selected ) %]
164 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
166 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
174 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
175 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
176 return GetItemTypes( style => 'array' );
178 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
179 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
185 $itemtypes = &GetItemTypes( style => $style );
187 Returns information about existing itemtypes.
190 style: either 'array' or 'hash', defaults to 'hash'.
191 'array' returns an arrayref,
192 'hash' return a hashref with the itemtype value as the key
194 build a HTML select with the following code :
196 =head3 in PERL SCRIPT
198 my $itemtypes = GetItemTypes;
200 foreach my $thisitemtype (sort keys %$itemtypes) {
201 my $selected = 1 if $thisitemtype eq $itemtype;
202 my %row =(value => $thisitemtype,
203 selected => $selected,
204 description => $itemtypes->{$thisitemtype}->{'description'},
206 push @itemtypesloop, \%row;
208 $template->param(itemtypeloop => \@itemtypesloop);
212 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
213 <select name="itemtype">
214 <option value="">Default</option>
215 <!-- TMPL_LOOP name="itemtypeloop" -->
216 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
219 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
220 <input type="submit" value="OK" class="button">
227 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
229 require C4::Languages;
230 my $language = C4::Languages::getlanguage();
231 # returns a reference to a hash of references to itemtypes...
232 my $dbh = C4::Context->dbh;
236 itemtypes.description,
237 itemtypes.rentalcharge,
238 itemtypes.notforloan,
241 itemtypes.checkinmsg,
242 itemtypes.checkinmsgtype,
243 itemtypes.sip_media_type,
244 itemtypes.hideinopac,
245 itemtypes.searchcategory,
246 COALESCE( localization.translation, itemtypes.description ) AS translated_description
248 LEFT JOIN localization ON itemtypes.itemtype = localization.code
249 AND localization.entity = 'itemtypes'
250 AND localization.lang = ?
253 my $sth = $dbh->prepare($query);
254 $sth->execute( $language );
256 if ( $style eq 'hash' ) {
258 while ( my $IT = $sth->fetchrow_hashref ) {
259 $itemtypes{ $IT->{'itemtype'} } = $IT;
261 return ( \%itemtypes );
263 return [ sort { lc $a->{translated_description} cmp lc $b->{translated_description} } @{ $sth->fetchall_arrayref( {} ) } ];
267 =head2 GetItemTypesCategorized
269 $categories = GetItemTypesCategorized();
271 Returns a hashref containing search categories.
272 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
273 The categories must be part of Authorized Values (ITEMTYPECAT)
277 sub GetItemTypesCategorized {
278 my $dbh = C4::Context->dbh;
279 # Order is important, so that partially hidden (some items are not visible in OPAC) search
280 # categories will be visible. hideinopac=0 must be last.
282 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
284 SELECT DISTINCT searchcategory AS `itemtype`,
285 authorised_values.lib_opac AS description,
286 authorised_values.imageurl AS imageurl,
287 hideinopac, 1 as 'iscat'
289 LEFT JOIN authorised_values ON searchcategory = authorised_value
290 WHERE searchcategory > '' and hideinopac=1
292 SELECT DISTINCT searchcategory AS `itemtype`,
293 authorised_values.lib_opac AS description,
294 authorised_values.imageurl AS imageurl,
295 hideinopac, 1 as 'iscat'
297 LEFT JOIN authorised_values ON searchcategory = authorised_value
298 WHERE searchcategory > '' and hideinopac=0
300 return ($dbh->selectall_hashref($query,'itemtype'));
303 =head2 GetItemTypesByCategory
305 @results = GetItemTypesByCategory( $searchcategory );
307 Returns the itemtype code of all itemtypes included in a searchcategory.
311 sub GetItemTypesByCategory {
315 my $dbh = C4::Context->dbh;
316 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory=?|;
317 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
323 $frameworks = &getframework();
325 Returns information about existing frameworks
327 build a HTML select with the following code :
329 =head3 in PERL SCRIPT
331 my $frameworks = getframeworks();
333 foreach my $thisframework (keys %$frameworks) {
334 my $selected = 1 if $thisframework eq $frameworkcode;
336 value => $thisframework,
337 selected => $selected,
338 description => $frameworks->{$thisframework}->{'frameworktext'},
340 push @frameworksloop, \%row;
342 $template->param(frameworkloop => \@frameworksloop);
346 <form action="[% script_name %] method=post>
347 <select name="frameworkcode">
348 <option value="">Default</option>
349 [% FOREACH framework IN frameworkloop %]
350 [% IF ( framework.selected ) %]
351 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
353 <option value="[% framework.value %]">[% framework.description %]</option>
357 <input type=text name=searchfield value="[% searchfield %]">
358 <input type="submit" value="OK" class="button">
365 # returns a reference to a hash of references to branches...
367 my $dbh = C4::Context->dbh;
368 my $sth = $dbh->prepare("select * from biblio_framework");
370 while ( my $IT = $sth->fetchrow_hashref ) {
371 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
373 return ( \%itemtypes );
376 =head2 GetFrameworksLoop
378 $frameworks = GetFrameworksLoop( $frameworkcode );
380 Returns the loop suggested on getframework(), but ordered by framework description.
382 build a HTML select with the following code :
384 =head3 in PERL SCRIPT
386 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
390 Same as getframework()
392 <form action="[% script_name %] method=post>
393 <select name="frameworkcode">
394 <option value="">Default</option>
395 [% FOREACH framework IN frameworkloop %]
396 [% IF ( framework.selected ) %]
397 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
399 <option value="[% framework.value %]">[% framework.description %]</option>
403 <input type=text name=searchfield value="[% searchfield %]">
404 <input type="submit" value="OK" class="button">
409 sub GetFrameworksLoop {
410 my $frameworkcode = shift;
411 my $frameworks = getframeworks();
413 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
414 my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
416 value => $thisframework,
417 selected => $selected,
418 description => $frameworks->{$thisframework}->{'frameworktext'},
420 push @frameworkloop, \%row;
422 return \@frameworkloop;
425 =head2 getframeworkinfo
427 $frameworkinfo = &getframeworkinfo($frameworkcode);
429 Returns information about an frameworkcode.
433 sub getframeworkinfo {
434 my ($frameworkcode) = @_;
435 my $dbh = C4::Context->dbh;
437 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
438 $sth->execute($frameworkcode);
439 my $res = $sth->fetchrow_hashref;
443 =head2 getitemtypeinfo
445 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
447 Returns information about an itemtype. The optional $interface argument
448 sets which interface ('opac' or 'intranet') to return the imageurl for.
449 Defaults to intranet.
453 sub getitemtypeinfo {
454 my ($itemtype, $interface) = @_;
455 my $dbh = C4::Context->dbh;
456 require C4::Languages;
457 my $language = C4::Languages::getlanguage();
458 my $it = $dbh->selectrow_hashref(q|
461 itemtypes.description,
462 itemtypes.rentalcharge,
463 itemtypes.notforloan,
466 itemtypes.checkinmsg,
467 itemtypes.checkinmsgtype,
468 itemtypes.sip_media_type,
469 COALESCE( localization.translation, itemtypes.description ) AS translated_description
471 LEFT JOIN localization ON itemtypes.itemtype = localization.code
472 AND localization.entity = 'itemtypes'
473 AND localization.lang = ?
474 WHERE itemtypes.itemtype = ?
475 |, undef, $language, $itemtype );
477 $it->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $it->{imageurl} );
482 =head2 getitemtypeimagedir
484 my $directory = getitemtypeimagedir( 'opac' );
486 pass in 'opac' or 'intranet'. Defaults to 'opac'.
488 returns the full path to the appropriate directory containing images.
492 sub getitemtypeimagedir {
493 my $src = shift || 'opac';
494 if ($src eq 'intranet') {
495 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
497 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
501 sub getitemtypeimagesrc {
502 my $src = shift || 'opac';
503 if ($src eq 'intranet') {
504 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
506 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
510 sub getitemtypeimagelocation {
511 my ( $src, $image ) = @_;
513 return '' if ( !$image );
516 my $scheme = ( URI::Split::uri_split( $image ) )[0];
518 return $image if ( $scheme );
520 return getitemtypeimagesrc( $src ) . '/' . $image;
523 =head3 _getImagesFromDirectory
525 Find all of the image files in a directory in the filesystem
527 parameters: a directory name
529 returns: a list of images in that directory.
531 Notes: this does not traverse into subdirectories. See
532 _getSubdirectoryNames for help with that.
533 Images are assumed to be files with .gif or .png file extensions.
534 The image names returned do not have the directory name on them.
538 sub _getImagesFromDirectory {
539 my $directoryname = shift;
540 return unless defined $directoryname;
541 return unless -d $directoryname;
543 if ( opendir ( my $dh, $directoryname ) ) {
544 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
546 @images = sort(@images);
549 warn "unable to opendir $directoryname: $!";
554 =head3 _getSubdirectoryNames
556 Find all of the directories in a directory in the filesystem
558 parameters: a directory name
560 returns: a list of subdirectories in that directory.
562 Notes: this does not traverse into subdirectories. Only the first
563 level of subdirectories are returned.
564 The directory names returned don't have the parent directory name on them.
568 sub _getSubdirectoryNames {
569 my $directoryname = shift;
570 return unless defined $directoryname;
571 return unless -d $directoryname;
573 if ( opendir ( my $dh, $directoryname ) ) {
574 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
578 warn "unable to opendir $directoryname: $!";
585 returns: a listref of hashrefs. Each hash represents another collection of images.
587 { imagesetname => 'npl', # the name of the image set (npl is the original one)
588 images => listref of image hashrefs
591 each image is represented by a hashref like this:
593 { KohaImage => 'npl/image.gif',
594 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
595 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
596 checked => 0 or 1: was this the image passed to this method?
597 Note: I'd like to remove this somehow.
604 my $checked = $params{'checked'} || '';
606 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
607 url => getitemtypeimagesrc('intranet'),
609 opac => { filesystem => getitemtypeimagedir('opac'),
610 url => getitemtypeimagesrc('opac'),
614 my @imagesets = (); # list of hasrefs of image set data to pass to template
615 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
616 foreach my $imagesubdir ( @subdirectories ) {
617 warn $imagesubdir if $DEBUG;
618 my @imagelist = (); # hashrefs of image info
619 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
620 my $imagesetactive = 0;
621 foreach my $thisimage ( @imagenames ) {
623 { KohaImage => "$imagesubdir/$thisimage",
624 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
625 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
626 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
629 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
631 push @imagesets, { imagesetname => $imagesubdir,
632 imagesetactive => $imagesetactive,
633 images => \@imagelist };
641 $printers = &GetPrinters();
642 @queues = keys %$printers;
644 Returns information about existing printer queues.
646 C<$printers> is a reference-to-hash whose keys are the print queues
647 defined in the printers table of the Koha database. The values are
648 references-to-hash, whose keys are the fields in the printers table.
654 my $dbh = C4::Context->dbh;
655 my $sth = $dbh->prepare("select * from printers");
657 while ( my $printer = $sth->fetchrow_hashref ) {
658 $printers{ $printer->{'printqueue'} } = $printer;
660 return ( \%printers );
665 $printer = GetPrinter( $query, $printers );
670 my ( $query, $printers ) = @_; # get printer for this query from printers
671 my $printer = $query->param('printer');
672 my %cookie = $query->cookie('userenv');
673 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
674 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
680 Returns the number of pages to display in a pagination bar, given the number
681 of items and the number of items per page.
686 my ( $nb_items, $nb_items_per_page ) = @_;
688 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
693 (@themes) = &getallthemes('opac');
694 (@themes) = &getallthemes('intranet');
696 Returns an array of all available themes.
704 if ( $type eq 'intranet' ) {
705 $htdocs = C4::Context->config('intrahtdocs');
708 $htdocs = C4::Context->config('opachtdocs');
710 opendir D, "$htdocs";
711 my @dirlist = readdir D;
712 foreach my $directory (@dirlist) {
713 next if $directory eq 'lib';
714 -d "$htdocs/$directory/en" and push @themes, $directory;
721 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
726 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
732 tags => [ qw/ 607a / ],
738 tags => [ qw/ 500a 501a 503a / ],
744 tags => [ qw/ 700ab 701ab 702ab / ],
745 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
750 tags => [ qw/ 225a / ],
756 tags => [ qw/ 995e / ],
760 unless ( C4::Context->preference("singleBranchMode")
761 || Koha::Libraries->search->count == 1 )
763 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
764 if ( $DisplayLibraryFacets eq 'both'
765 || $DisplayLibraryFacets eq 'holding' )
770 idx => 'holdingbranch',
771 label => 'HoldingLibrary',
772 tags => [qw / 995c /],
777 if ( $DisplayLibraryFacets eq 'both'
778 || $DisplayLibraryFacets eq 'home' )
784 label => 'HomeLibrary',
785 tags => [qw / 995b /],
796 tags => [ qw/ 650a / ],
801 # label => 'People and Organizations',
802 # tags => [ qw/ 600a 610a 611a / ],
808 tags => [ qw/ 651a / ],
814 tags => [ qw/ 630a / ],
820 tags => [ qw/ 100a 110a 700a / ],
826 tags => [ qw/ 440a 490a / ],
831 label => 'ItemTypes',
832 tags => [ qw/ 952y 942c / ],
838 tags => [ qw / 952c / ],
842 unless ( C4::Context->preference("singleBranchMode")
843 || Koha::Libraries->search->count == 1 )
845 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
846 if ( $DisplayLibraryFacets eq 'both'
847 || $DisplayLibraryFacets eq 'holding' )
852 idx => 'holdingbranch',
853 label => 'HoldingLibrary',
854 tags => [qw / 952b /],
859 if ( $DisplayLibraryFacets eq 'both'
860 || $DisplayLibraryFacets eq 'home' )
866 label => 'HomeLibrary',
867 tags => [qw / 952a /],
878 Return a href where a key is associated to a href. You give a query,
879 the name of the key among the fields returned by the query. If you
880 also give as third argument the name of the value, the function
881 returns a href of scalar. The optional 4th argument is an arrayref of
882 items passed to the C<execute()> call. It is designed to bind
883 parameters to any placeholders in your SQL.
892 # generic href of any information on the item, href of href.
893 my $iteminfos_of = get_infos_of($query, 'itemnumber');
894 print $iteminfos_of->{$itemnumber}{barcode};
896 # specific information, href of scalar
897 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
898 print $barcode_of_item->{$itemnumber};
903 my ( $query, $key_name, $value_name, $bind_params ) = @_;
905 my $dbh = C4::Context->dbh;
907 my $sth = $dbh->prepare($query);
908 $sth->execute( @$bind_params );
911 while ( my $row = $sth->fetchrow_hashref ) {
912 if ( defined $value_name ) {
913 $infos_of{ $row->{$key_name} } = $row->{$value_name};
916 $infos_of{ $row->{$key_name} } = $row;
924 =head2 get_notforloan_label_of
926 my $notforloan_label_of = get_notforloan_label_of();
928 Each authorised value of notforloan (information available in items and
929 itemtypes) is link to a single label.
931 Returns a href where keys are authorised values and values are corresponding
934 foreach my $authorised_value (keys %{$notforloan_label_of}) {
936 "authorised_value: %s => %s\n",
938 $notforloan_label_of->{$authorised_value}
944 # FIXME - why not use GetAuthorisedValues ??
946 sub get_notforloan_label_of {
947 my $dbh = C4::Context->dbh;
950 SELECT authorised_value
951 FROM marc_subfield_structure
952 WHERE kohafield = \'items.notforloan\'
955 my $sth = $dbh->prepare($query);
957 my ($statuscode) = $sth->fetchrow_array();
962 FROM authorised_values
965 $sth = $dbh->prepare($query);
966 $sth->execute($statuscode);
967 my %notforloan_label_of;
968 while ( my $row = $sth->fetchrow_hashref ) {
969 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
973 return \%notforloan_label_of;
976 =head2 displayServers
978 my $servers = displayServers();
979 my $servers = displayServers( $position );
980 my $servers = displayServers( $position, $type );
982 displayServers returns a listref of hashrefs, each containing
983 information about available z3950 servers. Each hashref has a format
987 'checked' => 'checked',
988 'encoding' => 'utf8',
990 'id' => 'LIBRARY OF CONGRESS',
994 'value' => 'lx2.loc.gov:210/',
1000 sub displayServers {
1001 my ( $position, $type ) = @_;
1002 my $dbh = C4::Context->dbh;
1004 my $strsth = 'SELECT * FROM z3950servers';
1009 push @bind_params, $position;
1010 push @where_clauses, ' position = ? ';
1014 push @bind_params, $type;
1015 push @where_clauses, ' type = ? ';
1018 # reassemble where clause from where clause pieces
1019 if (@where_clauses) {
1020 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1023 my $rq = $dbh->prepare($strsth);
1024 $rq->execute(@bind_params);
1025 my @primaryserverloop;
1027 while ( my $data = $rq->fetchrow_hashref ) {
1028 push @primaryserverloop,
1029 { label => $data->{description},
1030 id => $data->{name},
1032 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1033 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1034 checked => "checked",
1035 icon => $data->{icon},
1036 zed => $data->{type} eq 'zed',
1037 opensearch => $data->{type} eq 'opensearch'
1040 return \@primaryserverloop;
1043 =head2 GetAuthValCode
1045 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1049 sub GetAuthValCode {
1050 my ($kohafield,$fwcode) = @_;
1051 my $dbh = C4::Context->dbh;
1052 $fwcode='' unless $fwcode;
1053 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1054 $sth->execute($kohafield,$fwcode);
1055 my ($authvalcode) = $sth->fetchrow_array;
1056 return $authvalcode;
1059 =head2 GetAuthValCodeFromField
1061 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1063 C<$subfield> can be undefined
1067 sub GetAuthValCodeFromField {
1068 my ($field,$subfield,$fwcode) = @_;
1069 my $dbh = C4::Context->dbh;
1070 $fwcode='' unless $fwcode;
1072 if (defined $subfield) {
1073 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1074 $sth->execute($field,$subfield,$fwcode);
1076 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1077 $sth->execute($field,$fwcode);
1079 my ($authvalcode) = $sth->fetchrow_array;
1080 return $authvalcode;
1083 =head2 GetAuthorisedValues
1085 $authvalues = GetAuthorisedValues([$category], [$selected]);
1087 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1089 C<$category> returns authorised values for just one category (optional).
1091 C<$selected> adds a "selected => 1" entry to the hash if the
1092 authorised_value matches it. B<NOTE:> this feature should be considered
1093 deprecated as it may be removed in the future.
1095 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1099 sub GetAuthorisedValues {
1100 my ( $category, $selected, $opac ) = @_;
1102 # TODO: the "selected" feature should be replaced by a utility function
1103 # somewhere else, it doesn't belong in here. For starters it makes
1104 # caching much more complicated. Or just let the UI logic handle it, it's
1107 # Is this cached already?
1108 $opac = $opac ? 1 : 0; # normalise to be safe
1110 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1111 my $selected_key = defined($selected) ? $selected : '';
1113 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1114 my $cache = Koha::Cache->get_instance();
1115 my $result = $cache->get_from_cache($cache_key);
1116 return $result if $result;
1119 my $dbh = C4::Context->dbh;
1122 FROM authorised_values
1125 LEFT JOIN authorised_values_branches ON ( id = av_id )
1130 push @where_strings, "category = ?";
1131 push @where_args, $category;
1134 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1135 push @where_args, $branch_limit;
1137 if(@where_strings > 0) {
1138 $query .= " WHERE " . join(" AND ", @where_strings);
1140 $query .= " GROUP BY lib";
1141 $query .= ' ORDER BY category, ' . (
1142 $opac ? 'COALESCE(lib_opac, lib)'
1146 my $sth = $dbh->prepare($query);
1148 $sth->execute( @where_args );
1149 while (my $data=$sth->fetchrow_hashref) {
1150 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1151 $data->{selected} = 1;
1154 $data->{selected} = 0;
1157 if ($opac && $data->{lib_opac}) {
1158 $data->{lib} = $data->{lib_opac};
1160 push @results, $data;
1164 # We can't cache for long because of that "selected" thing which
1165 # makes it impossible to clear the cache without iterating through every
1166 # value, which sucks. This'll cover this request, and not a whole lot more.
1167 $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1171 =head2 GetAuthorisedValueCategories
1173 $auth_categories = GetAuthorisedValueCategories();
1175 Return an arrayref of all of the available authorised
1180 sub GetAuthorisedValueCategories {
1181 my $dbh = C4::Context->dbh;
1182 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1185 while (defined (my $category = $sth->fetchrow_array) ) {
1186 push @results, $category;
1191 =head2 IsAuthorisedValueCategory
1193 $is_auth_val_category = IsAuthorisedValueCategory($category);
1195 Returns whether a given category name is a valid one
1199 sub IsAuthorisedValueCategory {
1200 my $category = shift;
1203 FROM authorised_values
1207 my $sth = C4::Context->dbh->prepare($query);
1208 $sth->execute($category);
1209 $sth->fetchrow ? return 1
1213 =head2 GetAuthorisedValueByCode
1215 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1217 Return the lib attribute from authorised_values from the row identified
1218 by the passed category and code
1222 sub GetAuthorisedValueByCode {
1223 my ( $category, $authvalcode, $opac ) = @_;
1225 my $field = $opac ? 'lib_opac' : 'lib';
1226 my $dbh = C4::Context->dbh;
1227 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1228 $sth->execute( $category, $authvalcode );
1229 while ( my $data = $sth->fetchrow_hashref ) {
1230 return $data->{ $field };
1234 =head2 GetKohaAuthorisedValues
1236 Takes $kohafield, $fwcode as parameters.
1238 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1240 Returns hashref of Code => description
1242 Returns undef if no authorised value category is defined for the kohafield.
1246 sub GetKohaAuthorisedValues {
1247 my ($kohafield,$fwcode,$opac) = @_;
1248 $fwcode='' unless $fwcode;
1250 my $dbh = C4::Context->dbh;
1251 my $avcode = GetAuthValCode($kohafield,$fwcode);
1253 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1254 $sth->execute($avcode);
1255 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1256 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1264 =head2 GetKohaAuthorisedValuesFromField
1266 Takes $field, $subfield, $fwcode as parameters.
1268 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1269 $subfield can be undefined
1271 Returns hashref of Code => description
1273 Returns undef if no authorised value category is defined for the given field and subfield
1277 sub GetKohaAuthorisedValuesFromField {
1278 my ($field, $subfield, $fwcode,$opac) = @_;
1279 $fwcode='' unless $fwcode;
1281 my $dbh = C4::Context->dbh;
1282 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1284 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1285 $sth->execute($avcode);
1286 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1287 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1295 =head2 GetKohaAuthorisedValuesMapping
1297 Takes a hash as a parameter. The interface key indicates the
1298 description to use in the mapping.
1301 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1302 for all the kohafields, frameworkcodes, and authorised values.
1304 Returns undef if nothing is found.
1308 sub GetKohaAuthorisedValuesMapping {
1309 my ($parameter) = @_;
1310 my $interface = $parameter->{'interface'} // '';
1312 my $query_mapping = q{
1313 SELECT TA.kohafield,TA.authorised_value AS category,
1314 TA.frameworkcode,TB.authorised_value,
1315 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1316 TB.lib AS Intranet,TB.lib_opac
1317 FROM marc_subfield_structure AS TA JOIN
1318 authorised_values as TB ON
1319 TA.authorised_value=TB.category
1320 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1322 my $dbh = C4::Context->dbh;
1323 my $sth = $dbh->prepare($query_mapping);
1326 if ($interface eq 'opac') {
1327 while (my $row = $sth->fetchrow_hashref) {
1328 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{OPAC};
1332 while (my $row = $sth->fetchrow_hashref) {
1333 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{Intranet};
1341 my $escaped_string = C4::Koha::xml_escape($string);
1343 Convert &, <, >, ', and " in a string to XML entities
1349 return '' unless defined $str;
1350 $str =~ s/&/&/g;
1353 $str =~ s/'/'/g;
1354 $str =~ s/"/"/g;
1358 =head2 GetKohaAuthorisedValueLib
1360 Takes $category, $authorised_value as parameters.
1362 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1364 Returns authorised value description
1368 sub GetKohaAuthorisedValueLib {
1369 my ($category,$authorised_value,$opac) = @_;
1371 my $dbh = C4::Context->dbh;
1372 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1373 $sth->execute($category,$authorised_value);
1374 my $data = $sth->fetchrow_hashref;
1375 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1379 =head2 display_marc_indicators
1381 my $display_form = C4::Koha::display_marc_indicators($field);
1383 C<$field> is a MARC::Field object
1385 Generate a display form of the indicators of a variable
1386 MARC field, replacing any blanks with '#'.
1390 sub display_marc_indicators {
1392 my $indicators = '';
1393 if ($field && $field->tag() >= 10) {
1394 $indicators = $field->indicator(1) . $field->indicator(2);
1395 $indicators =~ s/ /#/g;
1400 sub GetNormalizedUPC {
1401 my ($marcrecord,$marcflavour) = @_;
1403 return unless $marcrecord;
1404 if ($marcflavour eq 'UNIMARC') {
1405 my @fields = $marcrecord->field('072');
1406 foreach my $field (@fields) {
1407 my $upc = _normalize_match_point($field->subfield('a'));
1414 else { # assume marc21 if not unimarc
1415 my @fields = $marcrecord->field('024');
1416 foreach my $field (@fields) {
1417 my $indicator = $field->indicator(1);
1418 my $upc = _normalize_match_point($field->subfield('a'));
1419 if ($upc && $indicator == 1 ) {
1426 # Normalizes and returns the first valid ISBN found in the record
1427 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1428 sub GetNormalizedISBN {
1429 my ($isbn,$marcrecord,$marcflavour) = @_;
1431 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1432 # anything after " | " should be removed, along with the delimiter
1433 ($isbn) = split(/\|/, $isbn );
1434 return _isbn_cleanup($isbn);
1437 return unless $marcrecord;
1439 if ($marcflavour eq 'UNIMARC') {
1440 my @fields = $marcrecord->field('010');
1441 foreach my $field (@fields) {
1442 my $isbn = $field->subfield('a');
1444 return _isbn_cleanup($isbn);
1448 else { # assume marc21 if not unimarc
1449 my @fields = $marcrecord->field('020');
1450 foreach my $field (@fields) {
1451 $isbn = $field->subfield('a');
1453 return _isbn_cleanup($isbn);
1459 sub GetNormalizedEAN {
1460 my ($marcrecord,$marcflavour) = @_;
1462 return unless $marcrecord;
1464 if ($marcflavour eq 'UNIMARC') {
1465 my @fields = $marcrecord->field('073');
1466 foreach my $field (@fields) {
1467 my $ean = _normalize_match_point($field->subfield('a'));
1473 else { # assume marc21 if not unimarc
1474 my @fields = $marcrecord->field('024');
1475 foreach my $field (@fields) {
1476 my $indicator = $field->indicator(1);
1477 my $ean = _normalize_match_point($field->subfield('a'));
1478 if ( $ean && $indicator == 3 ) {
1485 sub GetNormalizedOCLCNumber {
1486 my ($marcrecord,$marcflavour) = @_;
1487 return unless $marcrecord;
1489 if ($marcflavour ne 'UNIMARC' ) {
1490 my @fields = $marcrecord->field('035');
1491 foreach my $field (@fields) {
1492 my $oclc = $field->subfield('a');
1493 if ($oclc =~ /OCoLC/) {
1494 $oclc =~ s/\(OCoLC\)//;
1504 sub GetAuthvalueDropbox {
1505 my ( $authcat, $default ) = @_;
1506 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1507 my $dbh = C4::Context->dbh;
1511 FROM authorised_values
1514 LEFT JOIN authorised_values_branches ON ( id = av_id )
1519 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1520 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1521 my $sth = $dbh->prepare($query);
1522 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1525 my $option_list = [];
1526 my @authorised_values = ( q{} );
1527 while (my $av = $sth->fetchrow_hashref) {
1528 push @{$option_list}, {
1529 value => $av->{authorised_value},
1530 label => $av->{lib},
1531 default => ($default eq $av->{authorised_value}),
1535 if ( @{$option_list} ) {
1536 return $option_list;
1542 =head2 GetDailyQuote($opts)
1544 Takes a hashref of options
1546 Currently supported options are:
1548 'id' An exact quote id
1549 'random' Select a random quote
1550 noop When no option is passed in, this sub will return the quote timestamped for the current day
1552 The function returns an anonymous hash following this format:
1555 'source' => 'source-of-quote',
1556 'timestamp' => 'timestamp-value',
1557 'text' => 'text-of-quote',
1563 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1564 # at least for default option
1568 my $dbh = C4::Context->dbh;
1573 $query = 'SELECT * FROM quotes WHERE id = ?';
1574 $sth = $dbh->prepare($query);
1575 $sth->execute($opts{'id'});
1576 $quote = $sth->fetchrow_hashref();
1578 elsif ($opts{'random'}) {
1579 # Fall through... we also return a random quote as a catch-all if all else fails
1582 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1583 $sth = $dbh->prepare($query);
1585 $quote = $sth->fetchrow_hashref();
1587 unless ($quote) { # if there are not matches, choose a random quote
1588 # get a list of all available quote ids
1589 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1591 my $range = ($sth->fetchrow_array)[0];
1592 # chose a random id within that range if there is more than one quote
1593 my $offset = int(rand($range));
1595 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1596 $sth = C4::Context->dbh->prepare($query);
1597 # see http://www.perlmonks.org/?node_id=837422 for why
1598 # we're being verbose and using bind_param
1599 $sth->bind_param(1, $offset, SQL_INTEGER);
1601 $quote = $sth->fetchrow_hashref();
1602 # update the timestamp for that quote
1603 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1604 $sth = C4::Context->dbh->prepare($query);
1606 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1613 sub _normalize_match_point {
1614 my $match_point = shift;
1615 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1616 $normalized_match_point =~ s/-//g;
1618 return $normalized_match_point;
1623 return NormalizeISBN(
1626 format => 'ISBN-10',
1632 =head2 NormalizedISBN
1634 my $isbns = NormalizedISBN({
1636 strip_hyphens => [0,1],
1637 format => ['ISBN-10', 'ISBN-13']
1640 Returns an isbn validated by Business::ISBN.
1641 Optionally strips hyphens and/or forces the isbn
1642 to be of the specified format.
1644 If the string cannot be validated as an isbn,
1652 my $string = $params->{isbn};
1653 my $strip_hyphens = $params->{strip_hyphens};
1654 my $format = $params->{format};
1656 return unless $string;
1658 my $isbn = Business::ISBN->new($string);
1660 if ( $isbn && $isbn->is_valid() ) {
1662 if ( $format eq 'ISBN-10' ) {
1663 $isbn = $isbn->as_isbn10();
1665 elsif ( $format eq 'ISBN-13' ) {
1666 $isbn = $isbn->as_isbn13();
1668 return unless $isbn;
1670 if ($strip_hyphens) {
1671 $string = $isbn->as_string( [] );
1673 $string = $isbn->as_string();
1680 =head2 GetVariationsOfISBN
1682 my @isbns = GetVariationsOfISBN( $isbn );
1684 Returns a list of variations of the given isbn in
1685 both ISBN-10 and ISBN-13 formats, with and without
1688 In a scalar context, the isbns are returned as a
1689 string delimited by ' | '.
1693 sub GetVariationsOfISBN {
1696 return unless $isbn;
1700 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1701 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1702 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1703 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1704 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1706 # Strip out any "empty" strings from the array
1707 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1709 return wantarray ? @isbns : join( " | ", @isbns );
1712 =head2 GetVariationsOfISBNs
1714 my @isbns = GetVariationsOfISBNs( @isbns );
1716 Returns a list of variations of the given isbns in
1717 both ISBN-10 and ISBN-13 formats, with and without
1720 In a scalar context, the isbns are returned as a
1721 string delimited by ' | '.
1725 sub GetVariationsOfISBNs {
1728 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1730 return wantarray ? @isbns : join( " | ", @isbns );
1733 =head2 IsKohaFieldLinked
1735 my $is_linked = IsKohaFieldLinked({
1736 kohafield => $kohafield,
1737 frameworkcode => $frameworkcode,
1740 Return 1 if the field is linked
1744 sub IsKohaFieldLinked {
1745 my ( $params ) = @_;
1746 my $kohafield = $params->{kohafield};
1747 my $frameworkcode = $params->{frameworkcode} || '';
1748 my $dbh = C4::Context->dbh;
1749 my $is_linked = $dbh->selectcol_arrayref( q|
1751 FROM marc_subfield_structure
1752 WHERE frameworkcode = ?
1754 |,{}, $frameworkcode, $kohafield );
1755 return $is_linked->[0];