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
72 &GetNormalizedOCLCNumber
82 @EXPORT_OK = qw( GetDailyQuote );
87 C4::Koha - Perl Module containing convenience functions for Koha scripts
95 Koha.pm provides many functions for Koha scripts.
103 $slash_date = &slashifyDate($dash_date);
105 Takes a string of the form "DD-MM-YYYY" (or anything separated by
106 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
112 # accepts a date of the form xx-xx-xx[xx] and returns it in the
114 my @dateOut = split( '-', shift );
115 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
118 # FIXME.. this should be moved to a MARC-specific module
119 sub subfield_is_koha_internal_p {
122 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
123 # But real MARC subfields are always single-character
124 # so it really is safer just to check the length
126 return length $subfield != 1;
129 =head2 GetSupportName
131 $itemtypename = &GetSupportName($codestring);
133 Returns a string with the name of the itemtype.
139 return if (! $codestring);
141 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
142 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
149 my $sth = C4::Context->dbh->prepare($query);
150 $sth->execute($codestring);
151 ($resultstring)=$sth->fetchrow;
152 return $resultstring;
155 C4::Context->dbh->prepare(
156 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
158 $sth->execute( $advanced_search_types, $codestring );
159 my $data = $sth->fetchrow_hashref;
160 return $$data{'lib'};
164 =head2 GetSupportList
166 $itemtypes = &GetSupportList();
168 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
170 build a HTML select with the following code :
172 =head3 in PERL SCRIPT
174 my $itemtypes = GetSupportList();
175 $template->param(itemtypeloop => $itemtypes);
179 <select name="itemtype" id="itemtype">
180 <option value=""></option>
181 [% FOREACH itemtypeloo IN itemtypeloop %]
182 [% IF ( itemtypeloo.selected ) %]
183 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
185 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
193 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
194 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
195 return GetItemTypes( style => 'array' );
197 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
198 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
204 $itemtypes = &GetItemTypes( style => $style );
206 Returns information about existing itemtypes.
209 style: either 'array' or 'hash', defaults to 'hash'.
210 'array' returns an arrayref,
211 'hash' return a hashref with the itemtype value as the key
213 build a HTML select with the following code :
215 =head3 in PERL SCRIPT
217 my $itemtypes = GetItemTypes;
219 foreach my $thisitemtype (sort keys %$itemtypes) {
220 my $selected = 1 if $thisitemtype eq $itemtype;
221 my %row =(value => $thisitemtype,
222 selected => $selected,
223 description => $itemtypes->{$thisitemtype}->{'description'},
225 push @itemtypesloop, \%row;
227 $template->param(itemtypeloop => \@itemtypesloop);
231 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
232 <select name="itemtype">
233 <option value="">Default</option>
234 <!-- TMPL_LOOP name="itemtypeloop" -->
235 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
238 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
239 <input type="submit" value="OK" class="button">
246 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
248 require C4::Languages;
249 my $language = C4::Languages::getlanguage();
250 # returns a reference to a hash of references to itemtypes...
251 my $dbh = C4::Context->dbh;
255 itemtypes.description,
256 itemtypes.rentalcharge,
257 itemtypes.notforloan,
260 itemtypes.checkinmsg,
261 itemtypes.checkinmsgtype,
262 itemtypes.sip_media_type,
263 itemtypes.hideinopac,
264 itemtypes.searchcategory,
265 COALESCE( localization.translation, itemtypes.description ) AS translated_description
267 LEFT JOIN localization ON itemtypes.itemtype = localization.code
268 AND localization.entity = 'itemtypes'
269 AND localization.lang = ?
272 my $sth = $dbh->prepare($query);
273 $sth->execute( $language );
275 if ( $style eq 'hash' ) {
277 while ( my $IT = $sth->fetchrow_hashref ) {
278 $itemtypes{ $IT->{'itemtype'} } = $IT;
280 return ( \%itemtypes );
282 return [ sort { lc $a->{translated_description} cmp lc $b->{translated_description} } @{ $sth->fetchall_arrayref( {} ) } ];
286 =head2 GetItemTypesCategorized
288 $categories = GetItemTypesCategorized();
290 Returns a hashref containing search categories.
291 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
292 The categories must be part of Authorized Values (ITEMTYPECAT)
296 sub GetItemTypesCategorized {
297 my $dbh = C4::Context->dbh;
298 # Order is important, so that partially hidden (some items are not visible in OPAC) search
299 # categories will be visible. hideinopac=0 must be last.
301 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
303 SELECT DISTINCT searchcategory AS `itemtype`,
304 authorised_values.lib_opac AS description,
305 authorised_values.imageurl AS imageurl,
306 hideinopac, 1 as 'iscat'
308 LEFT JOIN authorised_values ON searchcategory = authorised_value
309 WHERE searchcategory > '' and hideinopac=1
311 SELECT DISTINCT searchcategory AS `itemtype`,
312 authorised_values.lib_opac AS description,
313 authorised_values.imageurl AS imageurl,
314 hideinopac, 1 as 'iscat'
316 LEFT JOIN authorised_values ON searchcategory = authorised_value
317 WHERE searchcategory > '' and hideinopac=0
319 return ($dbh->selectall_hashref($query,'itemtype'));
322 =head2 GetItemTypesByCategory
324 @results = GetItemTypesByCategory( $searchcategory );
326 Returns the itemtype code of all itemtypes included in a searchcategory.
330 sub GetItemTypesByCategory {
334 my $dbh = C4::Context->dbh;
335 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory=?|;
336 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
342 $frameworks = &getframework();
344 Returns information about existing frameworks
346 build a HTML select with the following code :
348 =head3 in PERL SCRIPT
350 my $frameworks = getframeworks();
352 foreach my $thisframework (keys %$frameworks) {
353 my $selected = 1 if $thisframework eq $frameworkcode;
355 value => $thisframework,
356 selected => $selected,
357 description => $frameworks->{$thisframework}->{'frameworktext'},
359 push @frameworksloop, \%row;
361 $template->param(frameworkloop => \@frameworksloop);
365 <form action="[% script_name %] method=post>
366 <select name="frameworkcode">
367 <option value="">Default</option>
368 [% FOREACH framework IN frameworkloop %]
369 [% IF ( framework.selected ) %]
370 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
372 <option value="[% framework.value %]">[% framework.description %]</option>
376 <input type=text name=searchfield value="[% searchfield %]">
377 <input type="submit" value="OK" class="button">
384 # returns a reference to a hash of references to branches...
386 my $dbh = C4::Context->dbh;
387 my $sth = $dbh->prepare("select * from biblio_framework");
389 while ( my $IT = $sth->fetchrow_hashref ) {
390 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
392 return ( \%itemtypes );
395 =head2 GetFrameworksLoop
397 $frameworks = GetFrameworksLoop( $frameworkcode );
399 Returns the loop suggested on getframework(), but ordered by framework description.
401 build a HTML select with the following code :
403 =head3 in PERL SCRIPT
405 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
409 Same as getframework()
411 <form action="[% script_name %] method=post>
412 <select name="frameworkcode">
413 <option value="">Default</option>
414 [% FOREACH framework IN frameworkloop %]
415 [% IF ( framework.selected ) %]
416 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
418 <option value="[% framework.value %]">[% framework.description %]</option>
422 <input type=text name=searchfield value="[% searchfield %]">
423 <input type="submit" value="OK" class="button">
428 sub GetFrameworksLoop {
429 my $frameworkcode = shift;
430 my $frameworks = getframeworks();
432 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
433 my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
435 value => $thisframework,
436 selected => $selected,
437 description => $frameworks->{$thisframework}->{'frameworktext'},
439 push @frameworkloop, \%row;
441 return \@frameworkloop;
444 =head2 getframeworkinfo
446 $frameworkinfo = &getframeworkinfo($frameworkcode);
448 Returns information about an frameworkcode.
452 sub getframeworkinfo {
453 my ($frameworkcode) = @_;
454 my $dbh = C4::Context->dbh;
456 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
457 $sth->execute($frameworkcode);
458 my $res = $sth->fetchrow_hashref;
462 =head2 getitemtypeinfo
464 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
466 Returns information about an itemtype. The optional $interface argument
467 sets which interface ('opac' or 'intranet') to return the imageurl for.
468 Defaults to intranet.
472 sub getitemtypeinfo {
473 my ($itemtype, $interface) = @_;
474 my $dbh = C4::Context->dbh;
475 require C4::Languages;
476 my $language = C4::Languages::getlanguage();
477 my $it = $dbh->selectrow_hashref(q|
480 itemtypes.description,
481 itemtypes.rentalcharge,
482 itemtypes.notforloan,
485 itemtypes.checkinmsg,
486 itemtypes.checkinmsgtype,
487 itemtypes.sip_media_type,
488 COALESCE( localization.translation, itemtypes.description ) AS translated_description
490 LEFT JOIN localization ON itemtypes.itemtype = localization.code
491 AND localization.entity = 'itemtypes'
492 AND localization.lang = ?
493 WHERE itemtypes.itemtype = ?
494 |, undef, $language, $itemtype );
496 $it->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $it->{imageurl} );
501 =head2 getitemtypeimagedir
503 my $directory = getitemtypeimagedir( 'opac' );
505 pass in 'opac' or 'intranet'. Defaults to 'opac'.
507 returns the full path to the appropriate directory containing images.
511 sub getitemtypeimagedir {
512 my $src = shift || 'opac';
513 if ($src eq 'intranet') {
514 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
516 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
520 sub getitemtypeimagesrc {
521 my $src = shift || 'opac';
522 if ($src eq 'intranet') {
523 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
525 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
529 sub getitemtypeimagelocation {
530 my ( $src, $image ) = @_;
532 return '' if ( !$image );
535 my $scheme = ( URI::Split::uri_split( $image ) )[0];
537 return $image if ( $scheme );
539 return getitemtypeimagesrc( $src ) . '/' . $image;
542 =head3 _getImagesFromDirectory
544 Find all of the image files in a directory in the filesystem
546 parameters: a directory name
548 returns: a list of images in that directory.
550 Notes: this does not traverse into subdirectories. See
551 _getSubdirectoryNames for help with that.
552 Images are assumed to be files with .gif or .png file extensions.
553 The image names returned do not have the directory name on them.
557 sub _getImagesFromDirectory {
558 my $directoryname = shift;
559 return unless defined $directoryname;
560 return unless -d $directoryname;
562 if ( opendir ( my $dh, $directoryname ) ) {
563 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
565 @images = sort(@images);
568 warn "unable to opendir $directoryname: $!";
573 =head3 _getSubdirectoryNames
575 Find all of the directories in a directory in the filesystem
577 parameters: a directory name
579 returns: a list of subdirectories in that directory.
581 Notes: this does not traverse into subdirectories. Only the first
582 level of subdirectories are returned.
583 The directory names returned don't have the parent directory name on them.
587 sub _getSubdirectoryNames {
588 my $directoryname = shift;
589 return unless defined $directoryname;
590 return unless -d $directoryname;
592 if ( opendir ( my $dh, $directoryname ) ) {
593 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
597 warn "unable to opendir $directoryname: $!";
604 returns: a listref of hashrefs. Each hash represents another collection of images.
606 { imagesetname => 'npl', # the name of the image set (npl is the original one)
607 images => listref of image hashrefs
610 each image is represented by a hashref like this:
612 { KohaImage => 'npl/image.gif',
613 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
614 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
615 checked => 0 or 1: was this the image passed to this method?
616 Note: I'd like to remove this somehow.
623 my $checked = $params{'checked'} || '';
625 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
626 url => getitemtypeimagesrc('intranet'),
628 opac => { filesystem => getitemtypeimagedir('opac'),
629 url => getitemtypeimagesrc('opac'),
633 my @imagesets = (); # list of hasrefs of image set data to pass to template
634 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
635 foreach my $imagesubdir ( @subdirectories ) {
636 warn $imagesubdir if $DEBUG;
637 my @imagelist = (); # hashrefs of image info
638 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
639 my $imagesetactive = 0;
640 foreach my $thisimage ( @imagenames ) {
642 { KohaImage => "$imagesubdir/$thisimage",
643 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
644 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
645 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
648 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
650 push @imagesets, { imagesetname => $imagesubdir,
651 imagesetactive => $imagesetactive,
652 images => \@imagelist };
660 $printers = &GetPrinters();
661 @queues = keys %$printers;
663 Returns information about existing printer queues.
665 C<$printers> is a reference-to-hash whose keys are the print queues
666 defined in the printers table of the Koha database. The values are
667 references-to-hash, whose keys are the fields in the printers table.
673 my $dbh = C4::Context->dbh;
674 my $sth = $dbh->prepare("select * from printers");
676 while ( my $printer = $sth->fetchrow_hashref ) {
677 $printers{ $printer->{'printqueue'} } = $printer;
679 return ( \%printers );
684 $printer = GetPrinter( $query, $printers );
689 my ( $query, $printers ) = @_; # get printer for this query from printers
690 my $printer = $query->param('printer');
691 my %cookie = $query->cookie('userenv');
692 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
693 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
699 Returns the number of pages to display in a pagination bar, given the number
700 of items and the number of items per page.
705 my ( $nb_items, $nb_items_per_page ) = @_;
707 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
712 (@themes) = &getallthemes('opac');
713 (@themes) = &getallthemes('intranet');
715 Returns an array of all available themes.
723 if ( $type eq 'intranet' ) {
724 $htdocs = C4::Context->config('intrahtdocs');
727 $htdocs = C4::Context->config('opachtdocs');
729 opendir D, "$htdocs";
730 my @dirlist = readdir D;
731 foreach my $directory (@dirlist) {
732 next if $directory eq 'lib';
733 -d "$htdocs/$directory/en" and push @themes, $directory;
740 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
745 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
751 tags => [ qw/ 607a / ],
757 tags => [ qw/ 500a 501a 503a / ],
763 tags => [ qw/ 700ab 701ab 702ab / ],
764 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
769 tags => [ qw/ 225a / ],
775 tags => [ qw/ 995e / ],
779 unless ( C4::Context->preference("singleBranchMode")
780 || Koha::Libraries->search->count == 1 )
782 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
783 if ( $DisplayLibraryFacets eq 'both'
784 || $DisplayLibraryFacets eq 'holding' )
789 idx => 'holdingbranch',
790 label => 'HoldingLibrary',
791 tags => [qw / 995c /],
796 if ( $DisplayLibraryFacets eq 'both'
797 || $DisplayLibraryFacets eq 'home' )
803 label => 'HomeLibrary',
804 tags => [qw / 995b /],
815 tags => [ qw/ 650a / ],
820 # label => 'People and Organizations',
821 # tags => [ qw/ 600a 610a 611a / ],
827 tags => [ qw/ 651a / ],
833 tags => [ qw/ 630a / ],
839 tags => [ qw/ 100a 110a 700a / ],
845 tags => [ qw/ 440a 490a / ],
850 label => 'ItemTypes',
851 tags => [ qw/ 952y 942c / ],
857 tags => [ qw / 952c / ],
861 unless ( C4::Context->preference("singleBranchMode")
862 || Koha::Libraries->search->count == 1 )
864 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
865 if ( $DisplayLibraryFacets eq 'both'
866 || $DisplayLibraryFacets eq 'holding' )
871 idx => 'holdingbranch',
872 label => 'HoldingLibrary',
873 tags => [qw / 952b /],
878 if ( $DisplayLibraryFacets eq 'both'
879 || $DisplayLibraryFacets eq 'home' )
885 label => 'HomeLibrary',
886 tags => [qw / 952a /],
897 Return a href where a key is associated to a href. You give a query,
898 the name of the key among the fields returned by the query. If you
899 also give as third argument the name of the value, the function
900 returns a href of scalar. The optional 4th argument is an arrayref of
901 items passed to the C<execute()> call. It is designed to bind
902 parameters to any placeholders in your SQL.
911 # generic href of any information on the item, href of href.
912 my $iteminfos_of = get_infos_of($query, 'itemnumber');
913 print $iteminfos_of->{$itemnumber}{barcode};
915 # specific information, href of scalar
916 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
917 print $barcode_of_item->{$itemnumber};
922 my ( $query, $key_name, $value_name, $bind_params ) = @_;
924 my $dbh = C4::Context->dbh;
926 my $sth = $dbh->prepare($query);
927 $sth->execute( @$bind_params );
930 while ( my $row = $sth->fetchrow_hashref ) {
931 if ( defined $value_name ) {
932 $infos_of{ $row->{$key_name} } = $row->{$value_name};
935 $infos_of{ $row->{$key_name} } = $row;
943 =head2 get_notforloan_label_of
945 my $notforloan_label_of = get_notforloan_label_of();
947 Each authorised value of notforloan (information available in items and
948 itemtypes) is link to a single label.
950 Returns a href where keys are authorised values and values are corresponding
953 foreach my $authorised_value (keys %{$notforloan_label_of}) {
955 "authorised_value: %s => %s\n",
957 $notforloan_label_of->{$authorised_value}
963 # FIXME - why not use GetAuthorisedValues ??
965 sub get_notforloan_label_of {
966 my $dbh = C4::Context->dbh;
969 SELECT authorised_value
970 FROM marc_subfield_structure
971 WHERE kohafield = \'items.notforloan\'
974 my $sth = $dbh->prepare($query);
976 my ($statuscode) = $sth->fetchrow_array();
981 FROM authorised_values
984 $sth = $dbh->prepare($query);
985 $sth->execute($statuscode);
986 my %notforloan_label_of;
987 while ( my $row = $sth->fetchrow_hashref ) {
988 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
992 return \%notforloan_label_of;
995 =head2 displayServers
997 my $servers = displayServers();
998 my $servers = displayServers( $position );
999 my $servers = displayServers( $position, $type );
1001 displayServers returns a listref of hashrefs, each containing
1002 information about available z3950 servers. Each hashref has a format
1006 'checked' => 'checked',
1007 'encoding' => 'utf8',
1009 'id' => 'LIBRARY OF CONGRESS',
1013 'value' => 'lx2.loc.gov:210/',
1019 sub displayServers {
1020 my ( $position, $type ) = @_;
1021 my $dbh = C4::Context->dbh;
1023 my $strsth = 'SELECT * FROM z3950servers';
1028 push @bind_params, $position;
1029 push @where_clauses, ' position = ? ';
1033 push @bind_params, $type;
1034 push @where_clauses, ' type = ? ';
1037 # reassemble where clause from where clause pieces
1038 if (@where_clauses) {
1039 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1042 my $rq = $dbh->prepare($strsth);
1043 $rq->execute(@bind_params);
1044 my @primaryserverloop;
1046 while ( my $data = $rq->fetchrow_hashref ) {
1047 push @primaryserverloop,
1048 { label => $data->{description},
1049 id => $data->{name},
1051 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1052 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1053 checked => "checked",
1054 icon => $data->{icon},
1055 zed => $data->{type} eq 'zed',
1056 opensearch => $data->{type} eq 'opensearch'
1059 return \@primaryserverloop;
1062 =head2 GetAuthValCode
1064 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1068 sub GetAuthValCode {
1069 my ($kohafield,$fwcode) = @_;
1070 my $dbh = C4::Context->dbh;
1071 $fwcode='' unless $fwcode;
1072 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1073 $sth->execute($kohafield,$fwcode);
1074 my ($authvalcode) = $sth->fetchrow_array;
1075 return $authvalcode;
1078 =head2 GetAuthValCodeFromField
1080 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1082 C<$subfield> can be undefined
1086 sub GetAuthValCodeFromField {
1087 my ($field,$subfield,$fwcode) = @_;
1088 my $dbh = C4::Context->dbh;
1089 $fwcode='' unless $fwcode;
1091 if (defined $subfield) {
1092 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1093 $sth->execute($field,$subfield,$fwcode);
1095 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1096 $sth->execute($field,$fwcode);
1098 my ($authvalcode) = $sth->fetchrow_array;
1099 return $authvalcode;
1102 =head2 GetAuthorisedValues
1104 $authvalues = GetAuthorisedValues([$category], [$selected]);
1106 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1108 C<$category> returns authorised values for just one category (optional).
1110 C<$selected> adds a "selected => 1" entry to the hash if the
1111 authorised_value matches it. B<NOTE:> this feature should be considered
1112 deprecated as it may be removed in the future.
1114 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1118 sub GetAuthorisedValues {
1119 my ( $category, $selected, $opac ) = @_;
1121 # TODO: the "selected" feature should be replaced by a utility function
1122 # somewhere else, it doesn't belong in here. For starters it makes
1123 # caching much more complicated. Or just let the UI logic handle it, it's
1126 # Is this cached already?
1127 $opac = $opac ? 1 : 0; # normalise to be safe
1129 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1130 my $selected_key = defined($selected) ? $selected : '';
1132 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1133 my $cache = Koha::Cache->get_instance();
1134 my $result = $cache->get_from_cache($cache_key);
1135 return $result if $result;
1138 my $dbh = C4::Context->dbh;
1141 FROM authorised_values
1144 LEFT JOIN authorised_values_branches ON ( id = av_id )
1149 push @where_strings, "category = ?";
1150 push @where_args, $category;
1153 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1154 push @where_args, $branch_limit;
1156 if(@where_strings > 0) {
1157 $query .= " WHERE " . join(" AND ", @where_strings);
1159 $query .= " GROUP BY lib";
1160 $query .= ' ORDER BY category, ' . (
1161 $opac ? 'COALESCE(lib_opac, lib)'
1165 my $sth = $dbh->prepare($query);
1167 $sth->execute( @where_args );
1168 while (my $data=$sth->fetchrow_hashref) {
1169 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1170 $data->{selected} = 1;
1173 $data->{selected} = 0;
1176 if ($opac && $data->{lib_opac}) {
1177 $data->{lib} = $data->{lib_opac};
1179 push @results, $data;
1183 # We can't cache for long because of that "selected" thing which
1184 # makes it impossible to clear the cache without iterating through every
1185 # value, which sucks. This'll cover this request, and not a whole lot more.
1186 $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1190 =head2 GetAuthorisedValueCategories
1192 $auth_categories = GetAuthorisedValueCategories();
1194 Return an arrayref of all of the available authorised
1199 sub GetAuthorisedValueCategories {
1200 my $dbh = C4::Context->dbh;
1201 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1204 while (defined (my $category = $sth->fetchrow_array) ) {
1205 push @results, $category;
1210 =head2 IsAuthorisedValueCategory
1212 $is_auth_val_category = IsAuthorisedValueCategory($category);
1214 Returns whether a given category name is a valid one
1218 sub IsAuthorisedValueCategory {
1219 my $category = shift;
1222 FROM authorised_values
1226 my $sth = C4::Context->dbh->prepare($query);
1227 $sth->execute($category);
1228 $sth->fetchrow ? return 1
1232 =head2 GetAuthorisedValueByCode
1234 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1236 Return the lib attribute from authorised_values from the row identified
1237 by the passed category and code
1241 sub GetAuthorisedValueByCode {
1242 my ( $category, $authvalcode, $opac ) = @_;
1244 my $field = $opac ? 'lib_opac' : 'lib';
1245 my $dbh = C4::Context->dbh;
1246 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1247 $sth->execute( $category, $authvalcode );
1248 while ( my $data = $sth->fetchrow_hashref ) {
1249 return $data->{ $field };
1253 =head2 GetKohaAuthorisedValues
1255 Takes $kohafield, $fwcode as parameters.
1257 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1259 Returns hashref of Code => description
1261 Returns undef if no authorised value category is defined for the kohafield.
1265 sub GetKohaAuthorisedValues {
1266 my ($kohafield,$fwcode,$opac) = @_;
1267 $fwcode='' unless $fwcode;
1269 my $dbh = C4::Context->dbh;
1270 my $avcode = GetAuthValCode($kohafield,$fwcode);
1272 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1273 $sth->execute($avcode);
1274 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1275 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1283 =head2 GetKohaAuthorisedValuesFromField
1285 Takes $field, $subfield, $fwcode as parameters.
1287 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1288 $subfield can be undefined
1290 Returns hashref of Code => description
1292 Returns undef if no authorised value category is defined for the given field and subfield
1296 sub GetKohaAuthorisedValuesFromField {
1297 my ($field, $subfield, $fwcode,$opac) = @_;
1298 $fwcode='' unless $fwcode;
1300 my $dbh = C4::Context->dbh;
1301 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1303 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1304 $sth->execute($avcode);
1305 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1306 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1314 =head2 GetKohaAuthorisedValuesMapping
1316 Takes a hash as a parameter. The interface key indicates the
1317 description to use in the mapping.
1320 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1321 for all the kohafields, frameworkcodes, and authorised values.
1323 Returns undef if nothing is found.
1327 sub GetKohaAuthorisedValuesMapping {
1328 my ($parameter) = @_;
1329 my $interface = $parameter->{'interface'} // '';
1331 my $query_mapping = q{
1332 SELECT TA.kohafield,TA.authorised_value AS category,
1333 TA.frameworkcode,TB.authorised_value,
1334 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1335 TB.lib AS Intranet,TB.lib_opac
1336 FROM marc_subfield_structure AS TA JOIN
1337 authorised_values as TB ON
1338 TA.authorised_value=TB.category
1339 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1341 my $dbh = C4::Context->dbh;
1342 my $sth = $dbh->prepare($query_mapping);
1345 if ($interface eq 'opac') {
1346 while (my $row = $sth->fetchrow_hashref) {
1347 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{OPAC};
1351 while (my $row = $sth->fetchrow_hashref) {
1352 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{Intranet};
1360 my $escaped_string = C4::Koha::xml_escape($string);
1362 Convert &, <, >, ', and " in a string to XML entities
1368 return '' unless defined $str;
1369 $str =~ s/&/&/g;
1372 $str =~ s/'/'/g;
1373 $str =~ s/"/"/g;
1377 =head2 GetKohaAuthorisedValueLib
1379 Takes $category, $authorised_value as parameters.
1381 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1383 Returns authorised value description
1387 sub GetKohaAuthorisedValueLib {
1388 my ($category,$authorised_value,$opac) = @_;
1390 my $dbh = C4::Context->dbh;
1391 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1392 $sth->execute($category,$authorised_value);
1393 my $data = $sth->fetchrow_hashref;
1394 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1398 =head2 AddAuthorisedValue
1400 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1402 Create a new authorised value.
1406 sub AddAuthorisedValue {
1407 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1409 my $dbh = C4::Context->dbh;
1411 INSERT INTO authorised_values (category, authorised_value, lib, lib_opac, imageurl)
1414 my $sth = $dbh->prepare($query);
1415 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1418 =head2 display_marc_indicators
1420 my $display_form = C4::Koha::display_marc_indicators($field);
1422 C<$field> is a MARC::Field object
1424 Generate a display form of the indicators of a variable
1425 MARC field, replacing any blanks with '#'.
1429 sub display_marc_indicators {
1431 my $indicators = '';
1432 if ($field && $field->tag() >= 10) {
1433 $indicators = $field->indicator(1) . $field->indicator(2);
1434 $indicators =~ s/ /#/g;
1439 sub GetNormalizedUPC {
1440 my ($marcrecord,$marcflavour) = @_;
1442 return unless $marcrecord;
1443 if ($marcflavour eq 'UNIMARC') {
1444 my @fields = $marcrecord->field('072');
1445 foreach my $field (@fields) {
1446 my $upc = _normalize_match_point($field->subfield('a'));
1453 else { # assume marc21 if not unimarc
1454 my @fields = $marcrecord->field('024');
1455 foreach my $field (@fields) {
1456 my $indicator = $field->indicator(1);
1457 my $upc = _normalize_match_point($field->subfield('a'));
1458 if ($upc && $indicator == 1 ) {
1465 # Normalizes and returns the first valid ISBN found in the record
1466 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1467 sub GetNormalizedISBN {
1468 my ($isbn,$marcrecord,$marcflavour) = @_;
1470 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1471 # anything after " | " should be removed, along with the delimiter
1472 ($isbn) = split(/\|/, $isbn );
1473 return _isbn_cleanup($isbn);
1476 return unless $marcrecord;
1478 if ($marcflavour eq 'UNIMARC') {
1479 my @fields = $marcrecord->field('010');
1480 foreach my $field (@fields) {
1481 my $isbn = $field->subfield('a');
1483 return _isbn_cleanup($isbn);
1487 else { # assume marc21 if not unimarc
1488 my @fields = $marcrecord->field('020');
1489 foreach my $field (@fields) {
1490 $isbn = $field->subfield('a');
1492 return _isbn_cleanup($isbn);
1498 sub GetNormalizedEAN {
1499 my ($marcrecord,$marcflavour) = @_;
1501 return unless $marcrecord;
1503 if ($marcflavour eq 'UNIMARC') {
1504 my @fields = $marcrecord->field('073');
1505 foreach my $field (@fields) {
1506 my $ean = _normalize_match_point($field->subfield('a'));
1512 else { # assume marc21 if not unimarc
1513 my @fields = $marcrecord->field('024');
1514 foreach my $field (@fields) {
1515 my $indicator = $field->indicator(1);
1516 my $ean = _normalize_match_point($field->subfield('a'));
1517 if ( $ean && $indicator == 3 ) {
1524 sub GetNormalizedOCLCNumber {
1525 my ($marcrecord,$marcflavour) = @_;
1526 return unless $marcrecord;
1528 if ($marcflavour ne 'UNIMARC' ) {
1529 my @fields = $marcrecord->field('035');
1530 foreach my $field (@fields) {
1531 my $oclc = $field->subfield('a');
1532 if ($oclc =~ /OCoLC/) {
1533 $oclc =~ s/\(OCoLC\)//;
1543 sub GetAuthvalueDropbox {
1544 my ( $authcat, $default ) = @_;
1545 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1546 my $dbh = C4::Context->dbh;
1550 FROM authorised_values
1553 LEFT JOIN authorised_values_branches ON ( id = av_id )
1558 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1559 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1560 my $sth = $dbh->prepare($query);
1561 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1564 my $option_list = [];
1565 my @authorised_values = ( q{} );
1566 while (my $av = $sth->fetchrow_hashref) {
1567 push @{$option_list}, {
1568 value => $av->{authorised_value},
1569 label => $av->{lib},
1570 default => ($default eq $av->{authorised_value}),
1574 if ( @{$option_list} ) {
1575 return $option_list;
1581 =head2 GetDailyQuote($opts)
1583 Takes a hashref of options
1585 Currently supported options are:
1587 'id' An exact quote id
1588 'random' Select a random quote
1589 noop When no option is passed in, this sub will return the quote timestamped for the current day
1591 The function returns an anonymous hash following this format:
1594 'source' => 'source-of-quote',
1595 'timestamp' => 'timestamp-value',
1596 'text' => 'text-of-quote',
1602 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1603 # at least for default option
1607 my $dbh = C4::Context->dbh;
1612 $query = 'SELECT * FROM quotes WHERE id = ?';
1613 $sth = $dbh->prepare($query);
1614 $sth->execute($opts{'id'});
1615 $quote = $sth->fetchrow_hashref();
1617 elsif ($opts{'random'}) {
1618 # Fall through... we also return a random quote as a catch-all if all else fails
1621 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1622 $sth = $dbh->prepare($query);
1624 $quote = $sth->fetchrow_hashref();
1626 unless ($quote) { # if there are not matches, choose a random quote
1627 # get a list of all available quote ids
1628 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1630 my $range = ($sth->fetchrow_array)[0];
1631 # chose a random id within that range if there is more than one quote
1632 my $offset = int(rand($range));
1634 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1635 $sth = C4::Context->dbh->prepare($query);
1636 # see http://www.perlmonks.org/?node_id=837422 for why
1637 # we're being verbose and using bind_param
1638 $sth->bind_param(1, $offset, SQL_INTEGER);
1640 $quote = $sth->fetchrow_hashref();
1641 # update the timestamp for that quote
1642 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1643 $sth = C4::Context->dbh->prepare($query);
1645 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1652 sub _normalize_match_point {
1653 my $match_point = shift;
1654 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1655 $normalized_match_point =~ s/-//g;
1657 return $normalized_match_point;
1662 return NormalizeISBN(
1665 format => 'ISBN-10',
1671 =head2 NormalizedISBN
1673 my $isbns = NormalizedISBN({
1675 strip_hyphens => [0,1],
1676 format => ['ISBN-10', 'ISBN-13']
1679 Returns an isbn validated by Business::ISBN.
1680 Optionally strips hyphens and/or forces the isbn
1681 to be of the specified format.
1683 If the string cannot be validated as an isbn,
1691 my $string = $params->{isbn};
1692 my $strip_hyphens = $params->{strip_hyphens};
1693 my $format = $params->{format};
1695 return unless $string;
1697 my $isbn = Business::ISBN->new($string);
1699 if ( $isbn && $isbn->is_valid() ) {
1701 if ( $format eq 'ISBN-10' ) {
1702 $isbn = $isbn->as_isbn10();
1704 elsif ( $format eq 'ISBN-13' ) {
1705 $isbn = $isbn->as_isbn13();
1707 return unless $isbn;
1709 if ($strip_hyphens) {
1710 $string = $isbn->as_string( [] );
1712 $string = $isbn->as_string();
1719 =head2 GetVariationsOfISBN
1721 my @isbns = GetVariationsOfISBN( $isbn );
1723 Returns a list of variations of the given isbn in
1724 both ISBN-10 and ISBN-13 formats, with and without
1727 In a scalar context, the isbns are returned as a
1728 string delimited by ' | '.
1732 sub GetVariationsOfISBN {
1735 return unless $isbn;
1739 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1740 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1741 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1742 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1743 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1745 # Strip out any "empty" strings from the array
1746 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1748 return wantarray ? @isbns : join( " | ", @isbns );
1751 =head2 GetVariationsOfISBNs
1753 my @isbns = GetVariationsOfISBNs( @isbns );
1755 Returns a list of variations of the given isbns in
1756 both ISBN-10 and ISBN-13 formats, with and without
1759 In a scalar context, the isbns are returned as a
1760 string delimited by ' | '.
1764 sub GetVariationsOfISBNs {
1767 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1769 return wantarray ? @isbns : join( " | ", @isbns );
1772 =head2 IsKohaFieldLinked
1774 my $is_linked = IsKohaFieldLinked({
1775 kohafield => $kohafield,
1776 frameworkcode => $frameworkcode,
1779 Return 1 if the field is linked
1783 sub IsKohaFieldLinked {
1784 my ( $params ) = @_;
1785 my $kohafield = $params->{kohafield};
1786 my $frameworkcode = $params->{frameworkcode} || '';
1787 my $dbh = C4::Context->dbh;
1788 my $is_linked = $dbh->selectcol_arrayref( q|
1790 FROM marc_subfield_structure
1791 WHERE frameworkcode = ?
1793 |,{}, $frameworkcode, $kohafield );
1794 return $is_linked->[0];