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(@ISA @EXPORT @EXPORT_OK $DEBUG);
41 &GetPrinters &GetPrinter
42 &GetItemTypes &getitemtypeinfo
43 &GetItemTypesCategorized &GetItemTypesByCategory
44 &GetSupportName &GetSupportList
45 &getframeworks &getframeworkinfo
51 &get_notforloan_label_of
54 &getitemtypeimagelocation
56 &GetAuthorisedValueCategories
57 &GetKohaAuthorisedValues
58 &GetKohaAuthorisedValuesFromField
59 &GetKohaAuthorisedValuesMapping
60 &GetKohaAuthorisedValueLib
61 &GetAuthorisedValueByCode
66 &GetNormalizedOCLCNumber
76 @EXPORT_OK = qw( GetDailyQuote );
81 C4::Koha - Perl Module containing convenience functions for Koha scripts
89 Koha.pm provides many functions for Koha scripts.
97 $itemtypename = &GetSupportName($codestring);
99 Returns a string with the name of the itemtype.
105 return if (! $codestring);
107 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
108 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
115 my $sth = C4::Context->dbh->prepare($query);
116 $sth->execute($codestring);
117 ($resultstring)=$sth->fetchrow;
118 return $resultstring;
121 C4::Context->dbh->prepare(
122 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
124 $sth->execute( $advanced_search_types, $codestring );
125 my $data = $sth->fetchrow_hashref;
126 return $$data{'lib'};
130 =head2 GetSupportList
132 $itemtypes = &GetSupportList();
134 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
136 build a HTML select with the following code :
138 =head3 in PERL SCRIPT
140 my $itemtypes = GetSupportList();
141 $template->param(itemtypeloop => $itemtypes);
145 <select name="itemtype" id="itemtype">
146 <option value=""></option>
147 [% FOREACH itemtypeloo IN itemtypeloop %]
148 [% IF ( itemtypeloo.selected ) %]
149 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
151 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
159 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
160 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
161 return GetItemTypes( style => 'array' );
163 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
164 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
170 $itemtypes = &GetItemTypes( style => $style );
172 Returns information about existing itemtypes.
175 style: either 'array' or 'hash', defaults to 'hash'.
176 'array' returns an arrayref,
177 'hash' return a hashref with the itemtype value as the key
179 build a HTML select with the following code :
181 =head3 in PERL SCRIPT
183 my $itemtypes = GetItemTypes;
185 foreach my $thisitemtype (sort keys %$itemtypes) {
186 my $selected = 1 if $thisitemtype eq $itemtype;
187 my %row =(value => $thisitemtype,
188 selected => $selected,
189 description => $itemtypes->{$thisitemtype}->{'description'},
191 push @itemtypesloop, \%row;
193 $template->param(itemtypeloop => \@itemtypesloop);
197 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
198 <select name="itemtype">
199 <option value="">Default</option>
200 <!-- TMPL_LOOP name="itemtypeloop" -->
201 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
204 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
205 <input type="submit" value="OK" class="button">
212 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
214 require C4::Languages;
215 my $language = C4::Languages::getlanguage();
216 # returns a reference to a hash of references to itemtypes...
217 my $dbh = C4::Context->dbh;
221 itemtypes.description,
222 itemtypes.rentalcharge,
223 itemtypes.notforloan,
226 itemtypes.checkinmsg,
227 itemtypes.checkinmsgtype,
228 itemtypes.sip_media_type,
229 itemtypes.hideinopac,
230 itemtypes.searchcategory,
231 COALESCE( localization.translation, itemtypes.description ) AS translated_description
233 LEFT JOIN localization ON itemtypes.itemtype = localization.code
234 AND localization.entity = 'itemtypes'
235 AND localization.lang = ?
238 my $sth = $dbh->prepare($query);
239 $sth->execute( $language );
241 if ( $style eq 'hash' ) {
243 while ( my $IT = $sth->fetchrow_hashref ) {
244 $itemtypes{ $IT->{'itemtype'} } = $IT;
246 return ( \%itemtypes );
248 return [ sort { lc $a->{translated_description} cmp lc $b->{translated_description} } @{ $sth->fetchall_arrayref( {} ) } ];
252 =head2 GetItemTypesCategorized
254 $categories = GetItemTypesCategorized();
256 Returns a hashref containing search categories.
257 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
258 The categories must be part of Authorized Values (ITEMTYPECAT)
262 sub GetItemTypesCategorized {
263 my $dbh = C4::Context->dbh;
264 # Order is important, so that partially hidden (some items are not visible in OPAC) search
265 # categories will be visible. hideinopac=0 must be last.
267 SELECT itemtype, description, imageurl, hideinopac, 0 as 'iscat' FROM itemtypes WHERE ISNULL(searchcategory) or length(searchcategory) = 0
269 SELECT DISTINCT searchcategory AS `itemtype`,
270 authorised_values.lib_opac AS description,
271 authorised_values.imageurl AS imageurl,
272 hideinopac, 1 as 'iscat'
274 LEFT JOIN authorised_values ON searchcategory = authorised_value
275 WHERE searchcategory > '' and hideinopac=1
277 SELECT DISTINCT searchcategory AS `itemtype`,
278 authorised_values.lib_opac AS description,
279 authorised_values.imageurl AS imageurl,
280 hideinopac, 1 as 'iscat'
282 LEFT JOIN authorised_values ON searchcategory = authorised_value
283 WHERE searchcategory > '' and hideinopac=0
285 return ($dbh->selectall_hashref($query,'itemtype'));
288 =head2 GetItemTypesByCategory
290 @results = GetItemTypesByCategory( $searchcategory );
292 Returns the itemtype code of all itemtypes included in a searchcategory.
296 sub GetItemTypesByCategory {
300 my $dbh = C4::Context->dbh;
301 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory=?|;
302 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
308 $frameworks = &getframework();
310 Returns information about existing frameworks
312 build a HTML select with the following code :
314 =head3 in PERL SCRIPT
316 my $frameworks = getframeworks();
318 foreach my $thisframework (keys %$frameworks) {
319 my $selected = 1 if $thisframework eq $frameworkcode;
321 value => $thisframework,
322 selected => $selected,
323 description => $frameworks->{$thisframework}->{'frameworktext'},
325 push @frameworksloop, \%row;
327 $template->param(frameworkloop => \@frameworksloop);
331 <form action="[% script_name %] method=post>
332 <select name="frameworkcode">
333 <option value="">Default</option>
334 [% FOREACH framework IN frameworkloop %]
335 [% IF ( framework.selected ) %]
336 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
338 <option value="[% framework.value %]">[% framework.description %]</option>
342 <input type=text name=searchfield value="[% searchfield %]">
343 <input type="submit" value="OK" class="button">
350 # returns a reference to a hash of references to branches...
352 my $dbh = C4::Context->dbh;
353 my $sth = $dbh->prepare("select * from biblio_framework");
355 while ( my $IT = $sth->fetchrow_hashref ) {
356 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
358 return ( \%itemtypes );
361 =head2 GetFrameworksLoop
363 $frameworks = GetFrameworksLoop( $frameworkcode );
365 Returns the loop suggested on getframework(), but ordered by framework description.
367 build a HTML select with the following code :
369 =head3 in PERL SCRIPT
371 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
375 Same as getframework()
377 <form action="[% script_name %] method=post>
378 <select name="frameworkcode">
379 <option value="">Default</option>
380 [% FOREACH framework IN frameworkloop %]
381 [% IF ( framework.selected ) %]
382 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
384 <option value="[% framework.value %]">[% framework.description %]</option>
388 <input type=text name=searchfield value="[% searchfield %]">
389 <input type="submit" value="OK" class="button">
394 sub GetFrameworksLoop {
395 my $frameworkcode = shift;
396 my $frameworks = getframeworks();
398 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
399 my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
401 value => $thisframework,
402 selected => $selected,
403 description => $frameworks->{$thisframework}->{'frameworktext'},
405 push @frameworkloop, \%row;
407 return \@frameworkloop;
410 =head2 getframeworkinfo
412 $frameworkinfo = &getframeworkinfo($frameworkcode);
414 Returns information about an frameworkcode.
418 sub getframeworkinfo {
419 my ($frameworkcode) = @_;
420 my $dbh = C4::Context->dbh;
422 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
423 $sth->execute($frameworkcode);
424 my $res = $sth->fetchrow_hashref;
428 =head2 getitemtypeinfo
430 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
432 Returns information about an itemtype. The optional $interface argument
433 sets which interface ('opac' or 'intranet') to return the imageurl for.
434 Defaults to intranet.
438 sub getitemtypeinfo {
439 my ($itemtype, $interface) = @_;
440 my $dbh = C4::Context->dbh;
441 require C4::Languages;
442 my $language = C4::Languages::getlanguage();
443 my $it = $dbh->selectrow_hashref(q|
446 itemtypes.description,
447 itemtypes.rentalcharge,
448 itemtypes.notforloan,
451 itemtypes.checkinmsg,
452 itemtypes.checkinmsgtype,
453 itemtypes.sip_media_type,
454 COALESCE( localization.translation, itemtypes.description ) AS translated_description
456 LEFT JOIN localization ON itemtypes.itemtype = localization.code
457 AND localization.entity = 'itemtypes'
458 AND localization.lang = ?
459 WHERE itemtypes.itemtype = ?
460 |, undef, $language, $itemtype );
462 $it->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $it->{imageurl} );
467 =head2 getitemtypeimagedir
469 my $directory = getitemtypeimagedir( 'opac' );
471 pass in 'opac' or 'intranet'. Defaults to 'opac'.
473 returns the full path to the appropriate directory containing images.
477 sub getitemtypeimagedir {
478 my $src = shift || 'opac';
479 if ($src eq 'intranet') {
480 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
482 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
486 sub getitemtypeimagesrc {
487 my $src = shift || 'opac';
488 if ($src eq 'intranet') {
489 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
491 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
495 sub getitemtypeimagelocation {
496 my ( $src, $image ) = @_;
498 return '' if ( !$image );
501 my $scheme = ( URI::Split::uri_split( $image ) )[0];
503 return $image if ( $scheme );
505 return getitemtypeimagesrc( $src ) . '/' . $image;
508 =head3 _getImagesFromDirectory
510 Find all of the image files in a directory in the filesystem
512 parameters: a directory name
514 returns: a list of images in that directory.
516 Notes: this does not traverse into subdirectories. See
517 _getSubdirectoryNames for help with that.
518 Images are assumed to be files with .gif or .png file extensions.
519 The image names returned do not have the directory name on them.
523 sub _getImagesFromDirectory {
524 my $directoryname = shift;
525 return unless defined $directoryname;
526 return unless -d $directoryname;
528 if ( opendir ( my $dh, $directoryname ) ) {
529 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
531 @images = sort(@images);
534 warn "unable to opendir $directoryname: $!";
539 =head3 _getSubdirectoryNames
541 Find all of the directories in a directory in the filesystem
543 parameters: a directory name
545 returns: a list of subdirectories in that directory.
547 Notes: this does not traverse into subdirectories. Only the first
548 level of subdirectories are returned.
549 The directory names returned don't have the parent directory name on them.
553 sub _getSubdirectoryNames {
554 my $directoryname = shift;
555 return unless defined $directoryname;
556 return unless -d $directoryname;
558 if ( opendir ( my $dh, $directoryname ) ) {
559 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
563 warn "unable to opendir $directoryname: $!";
570 returns: a listref of hashrefs. Each hash represents another collection of images.
572 { imagesetname => 'npl', # the name of the image set (npl is the original one)
573 images => listref of image hashrefs
576 each image is represented by a hashref like this:
578 { KohaImage => 'npl/image.gif',
579 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
580 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
581 checked => 0 or 1: was this the image passed to this method?
582 Note: I'd like to remove this somehow.
589 my $checked = $params{'checked'} || '';
591 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
592 url => getitemtypeimagesrc('intranet'),
594 opac => { filesystem => getitemtypeimagedir('opac'),
595 url => getitemtypeimagesrc('opac'),
599 my @imagesets = (); # list of hasrefs of image set data to pass to template
600 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
601 foreach my $imagesubdir ( @subdirectories ) {
602 warn $imagesubdir if $DEBUG;
603 my @imagelist = (); # hashrefs of image info
604 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
605 my $imagesetactive = 0;
606 foreach my $thisimage ( @imagenames ) {
608 { KohaImage => "$imagesubdir/$thisimage",
609 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
610 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
611 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
614 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
616 push @imagesets, { imagesetname => $imagesubdir,
617 imagesetactive => $imagesetactive,
618 images => \@imagelist };
626 $printers = &GetPrinters();
627 @queues = keys %$printers;
629 Returns information about existing printer queues.
631 C<$printers> is a reference-to-hash whose keys are the print queues
632 defined in the printers table of the Koha database. The values are
633 references-to-hash, whose keys are the fields in the printers table.
639 my $dbh = C4::Context->dbh;
640 my $sth = $dbh->prepare("select * from printers");
642 while ( my $printer = $sth->fetchrow_hashref ) {
643 $printers{ $printer->{'printqueue'} } = $printer;
645 return ( \%printers );
650 $printer = GetPrinter( $query, $printers );
655 my ( $query, $printers ) = @_; # get printer for this query from printers
656 my $printer = $query->param('printer');
657 my %cookie = $query->cookie('userenv');
658 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
659 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
665 Returns the number of pages to display in a pagination bar, given the number
666 of items and the number of items per page.
671 my ( $nb_items, $nb_items_per_page ) = @_;
673 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
678 (@themes) = &getallthemes('opac');
679 (@themes) = &getallthemes('intranet');
681 Returns an array of all available themes.
689 if ( $type eq 'intranet' ) {
690 $htdocs = C4::Context->config('intrahtdocs');
693 $htdocs = C4::Context->config('opachtdocs');
695 opendir D, "$htdocs";
696 my @dirlist = readdir D;
697 foreach my $directory (@dirlist) {
698 next if $directory eq 'lib';
699 -d "$htdocs/$directory/en" and push @themes, $directory;
706 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
711 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
717 tags => [ qw/ 607a / ],
723 tags => [ qw/ 500a 501a 503a / ],
729 tags => [ qw/ 700ab 701ab 702ab / ],
730 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
735 tags => [ qw/ 225a / ],
741 tags => [ qw/ 995e / ],
745 unless ( Koha::Libraries->search->count == 1 )
747 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
748 if ( $DisplayLibraryFacets eq 'both'
749 || $DisplayLibraryFacets eq 'holding' )
754 idx => 'holdingbranch',
755 label => 'HoldingLibrary',
756 tags => [qw / 995c /],
761 if ( $DisplayLibraryFacets eq 'both'
762 || $DisplayLibraryFacets eq 'home' )
768 label => 'HomeLibrary',
769 tags => [qw / 995b /],
780 tags => [ qw/ 650a / ],
785 # label => 'People and Organizations',
786 # tags => [ qw/ 600a 610a 611a / ],
792 tags => [ qw/ 651a / ],
798 tags => [ qw/ 630a / ],
804 tags => [ qw/ 100a 110a 700a / ],
810 tags => [ qw/ 440a 490a / ],
815 label => 'ItemTypes',
816 tags => [ qw/ 952y 942c / ],
822 tags => [ qw / 952c / ],
826 unless ( Koha::Libraries->search->count == 1 )
828 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
829 if ( $DisplayLibraryFacets eq 'both'
830 || $DisplayLibraryFacets eq 'holding' )
835 idx => 'holdingbranch',
836 label => 'HoldingLibrary',
837 tags => [qw / 952b /],
842 if ( $DisplayLibraryFacets eq 'both'
843 || $DisplayLibraryFacets eq 'home' )
849 label => 'HomeLibrary',
850 tags => [qw / 952a /],
861 Return a href where a key is associated to a href. You give a query,
862 the name of the key among the fields returned by the query. If you
863 also give as third argument the name of the value, the function
864 returns a href of scalar. The optional 4th argument is an arrayref of
865 items passed to the C<execute()> call. It is designed to bind
866 parameters to any placeholders in your SQL.
875 # generic href of any information on the item, href of href.
876 my $iteminfos_of = get_infos_of($query, 'itemnumber');
877 print $iteminfos_of->{$itemnumber}{barcode};
879 # specific information, href of scalar
880 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
881 print $barcode_of_item->{$itemnumber};
886 my ( $query, $key_name, $value_name, $bind_params ) = @_;
888 my $dbh = C4::Context->dbh;
890 my $sth = $dbh->prepare($query);
891 $sth->execute( @$bind_params );
894 while ( my $row = $sth->fetchrow_hashref ) {
895 if ( defined $value_name ) {
896 $infos_of{ $row->{$key_name} } = $row->{$value_name};
899 $infos_of{ $row->{$key_name} } = $row;
907 =head2 get_notforloan_label_of
909 my $notforloan_label_of = get_notforloan_label_of();
911 Each authorised value of notforloan (information available in items and
912 itemtypes) is link to a single label.
914 Returns a href where keys are authorised values and values are corresponding
917 foreach my $authorised_value (keys %{$notforloan_label_of}) {
919 "authorised_value: %s => %s\n",
921 $notforloan_label_of->{$authorised_value}
927 # FIXME - why not use GetAuthorisedValues ??
929 sub get_notforloan_label_of {
930 my $dbh = C4::Context->dbh;
933 SELECT authorised_value
934 FROM marc_subfield_structure
935 WHERE kohafield = \'items.notforloan\'
938 my $sth = $dbh->prepare($query);
940 my ($statuscode) = $sth->fetchrow_array();
945 FROM authorised_values
948 $sth = $dbh->prepare($query);
949 $sth->execute($statuscode);
950 my %notforloan_label_of;
951 while ( my $row = $sth->fetchrow_hashref ) {
952 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
956 return \%notforloan_label_of;
959 =head2 GetAuthValCode
961 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
966 my ($kohafield,$fwcode) = @_;
967 my $dbh = C4::Context->dbh;
968 $fwcode='' unless $fwcode;
969 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
970 $sth->execute($kohafield,$fwcode);
971 my ($authvalcode) = $sth->fetchrow_array;
975 =head2 GetAuthValCodeFromField
977 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
979 C<$subfield> can be undefined
983 sub GetAuthValCodeFromField {
984 my ($field,$subfield,$fwcode) = @_;
985 my $dbh = C4::Context->dbh;
986 $fwcode='' unless $fwcode;
988 if (defined $subfield) {
989 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
990 $sth->execute($field,$subfield,$fwcode);
992 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
993 $sth->execute($field,$fwcode);
995 my ($authvalcode) = $sth->fetchrow_array;
999 =head2 GetAuthorisedValues
1001 $authvalues = GetAuthorisedValues([$category], [$selected]);
1003 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1005 C<$category> returns authorised values for just one category (optional).
1007 C<$selected> adds a "selected => 1" entry to the hash if the
1008 authorised_value matches it. B<NOTE:> this feature should be considered
1009 deprecated as it may be removed in the future.
1011 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1015 sub GetAuthorisedValues {
1016 my ( $category, $selected, $opac ) = @_;
1018 # TODO: the "selected" feature should be replaced by a utility function
1019 # somewhere else, it doesn't belong in here. For starters it makes
1020 # caching much more complicated. Or just let the UI logic handle it, it's
1023 # Is this cached already?
1024 $opac = $opac ? 1 : 0; # normalise to be safe
1026 C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1027 my $selected_key = defined($selected) ? $selected : '';
1029 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1030 my $cache = Koha::Cache->get_instance();
1031 my $result = $cache->get_from_cache($cache_key);
1032 return $result if $result;
1035 my $dbh = C4::Context->dbh;
1038 FROM authorised_values
1041 LEFT JOIN authorised_values_branches ON ( id = av_id )
1046 push @where_strings, "category = ?";
1047 push @where_args, $category;
1050 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1051 push @where_args, $branch_limit;
1053 if(@where_strings > 0) {
1054 $query .= " WHERE " . join(" AND ", @where_strings);
1056 $query .= " GROUP BY lib";
1057 $query .= ' ORDER BY category, ' . (
1058 $opac ? 'COALESCE(lib_opac, lib)'
1062 my $sth = $dbh->prepare($query);
1064 $sth->execute( @where_args );
1065 while (my $data=$sth->fetchrow_hashref) {
1066 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1067 $data->{selected} = 1;
1070 $data->{selected} = 0;
1073 if ($opac && $data->{lib_opac}) {
1074 $data->{lib} = $data->{lib_opac};
1076 push @results, $data;
1080 # We can't cache for long because of that "selected" thing which
1081 # makes it impossible to clear the cache without iterating through every
1082 # value, which sucks. This'll cover this request, and not a whole lot more.
1083 $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1087 =head2 GetAuthorisedValueCategories
1089 $auth_categories = GetAuthorisedValueCategories();
1091 Return an arrayref of all of the available authorised
1096 sub GetAuthorisedValueCategories {
1097 my $dbh = C4::Context->dbh;
1098 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1101 while (defined (my $category = $sth->fetchrow_array) ) {
1102 push @results, $category;
1107 =head2 GetAuthorisedValueByCode
1109 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1111 Return the lib attribute from authorised_values from the row identified
1112 by the passed category and code
1116 sub GetAuthorisedValueByCode {
1117 my ( $category, $authvalcode, $opac ) = @_;
1119 my $field = $opac ? 'lib_opac' : 'lib';
1120 my $dbh = C4::Context->dbh;
1121 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1122 $sth->execute( $category, $authvalcode );
1123 while ( my $data = $sth->fetchrow_hashref ) {
1124 return $data->{ $field };
1128 =head2 GetKohaAuthorisedValues
1130 Takes $kohafield, $fwcode as parameters.
1132 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1134 Returns hashref of Code => description
1136 Returns undef if no authorised value category is defined for the kohafield.
1140 sub GetKohaAuthorisedValues {
1141 my ($kohafield,$fwcode,$opac) = @_;
1142 $fwcode='' unless $fwcode;
1144 my $dbh = C4::Context->dbh;
1145 my $avcode = GetAuthValCode($kohafield,$fwcode);
1147 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1148 $sth->execute($avcode);
1149 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1150 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1158 =head2 GetKohaAuthorisedValuesFromField
1160 Takes $field, $subfield, $fwcode as parameters.
1162 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1163 $subfield can be undefined
1165 Returns hashref of Code => description
1167 Returns undef if no authorised value category is defined for the given field and subfield
1171 sub GetKohaAuthorisedValuesFromField {
1172 my ($field, $subfield, $fwcode,$opac) = @_;
1173 $fwcode='' unless $fwcode;
1175 my $dbh = C4::Context->dbh;
1176 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1178 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1179 $sth->execute($avcode);
1180 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1181 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1189 =head2 GetKohaAuthorisedValuesMapping
1191 Takes a hash as a parameter. The interface key indicates the
1192 description to use in the mapping.
1195 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1196 for all the kohafields, frameworkcodes, and authorised values.
1198 Returns undef if nothing is found.
1202 sub GetKohaAuthorisedValuesMapping {
1203 my ($parameter) = @_;
1204 my $interface = $parameter->{'interface'} // '';
1206 my $query_mapping = q{
1207 SELECT TA.kohafield,TA.authorised_value AS category,
1208 TA.frameworkcode,TB.authorised_value,
1209 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1210 TB.lib AS Intranet,TB.lib_opac
1211 FROM marc_subfield_structure AS TA JOIN
1212 authorised_values as TB ON
1213 TA.authorised_value=TB.category
1214 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1216 my $dbh = C4::Context->dbh;
1217 my $sth = $dbh->prepare($query_mapping);
1220 if ($interface eq 'opac') {
1221 while (my $row = $sth->fetchrow_hashref) {
1222 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{OPAC};
1226 while (my $row = $sth->fetchrow_hashref) {
1227 $avmapping->{$row->{kohafield}.",".$row->{frameworkcode}.",".$row->{authorised_value}} = $row->{Intranet};
1235 my $escaped_string = C4::Koha::xml_escape($string);
1237 Convert &, <, >, ', and " in a string to XML entities
1243 return '' unless defined $str;
1244 $str =~ s/&/&/g;
1247 $str =~ s/'/'/g;
1248 $str =~ s/"/"/g;
1252 =head2 GetKohaAuthorisedValueLib
1254 Takes $category, $authorised_value as parameters.
1256 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1258 Returns authorised value description
1262 sub GetKohaAuthorisedValueLib {
1263 my ($category,$authorised_value,$opac) = @_;
1265 my $dbh = C4::Context->dbh;
1266 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1267 $sth->execute($category,$authorised_value);
1268 my $data = $sth->fetchrow_hashref;
1269 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1273 =head2 display_marc_indicators
1275 my $display_form = C4::Koha::display_marc_indicators($field);
1277 C<$field> is a MARC::Field object
1279 Generate a display form of the indicators of a variable
1280 MARC field, replacing any blanks with '#'.
1284 sub display_marc_indicators {
1286 my $indicators = '';
1287 if ($field && $field->tag() >= 10) {
1288 $indicators = $field->indicator(1) . $field->indicator(2);
1289 $indicators =~ s/ /#/g;
1294 sub GetNormalizedUPC {
1295 my ($marcrecord,$marcflavour) = @_;
1297 return unless $marcrecord;
1298 if ($marcflavour eq 'UNIMARC') {
1299 my @fields = $marcrecord->field('072');
1300 foreach my $field (@fields) {
1301 my $upc = _normalize_match_point($field->subfield('a'));
1308 else { # assume marc21 if not unimarc
1309 my @fields = $marcrecord->field('024');
1310 foreach my $field (@fields) {
1311 my $indicator = $field->indicator(1);
1312 my $upc = _normalize_match_point($field->subfield('a'));
1313 if ($upc && $indicator == 1 ) {
1320 # Normalizes and returns the first valid ISBN found in the record
1321 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1322 sub GetNormalizedISBN {
1323 my ($isbn,$marcrecord,$marcflavour) = @_;
1325 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1326 # anything after " | " should be removed, along with the delimiter
1327 ($isbn) = split(/\|/, $isbn );
1328 return _isbn_cleanup($isbn);
1331 return unless $marcrecord;
1333 if ($marcflavour eq 'UNIMARC') {
1334 my @fields = $marcrecord->field('010');
1335 foreach my $field (@fields) {
1336 my $isbn = $field->subfield('a');
1338 return _isbn_cleanup($isbn);
1342 else { # assume marc21 if not unimarc
1343 my @fields = $marcrecord->field('020');
1344 foreach my $field (@fields) {
1345 $isbn = $field->subfield('a');
1347 return _isbn_cleanup($isbn);
1353 sub GetNormalizedEAN {
1354 my ($marcrecord,$marcflavour) = @_;
1356 return unless $marcrecord;
1358 if ($marcflavour eq 'UNIMARC') {
1359 my @fields = $marcrecord->field('073');
1360 foreach my $field (@fields) {
1361 my $ean = _normalize_match_point($field->subfield('a'));
1367 else { # assume marc21 if not unimarc
1368 my @fields = $marcrecord->field('024');
1369 foreach my $field (@fields) {
1370 my $indicator = $field->indicator(1);
1371 my $ean = _normalize_match_point($field->subfield('a'));
1372 if ( $ean && $indicator == 3 ) {
1379 sub GetNormalizedOCLCNumber {
1380 my ($marcrecord,$marcflavour) = @_;
1381 return unless $marcrecord;
1383 if ($marcflavour ne 'UNIMARC' ) {
1384 my @fields = $marcrecord->field('035');
1385 foreach my $field (@fields) {
1386 my $oclc = $field->subfield('a');
1387 if ($oclc =~ /OCoLC/) {
1388 $oclc =~ s/\(OCoLC\)//;
1398 sub GetAuthvalueDropbox {
1399 my ( $authcat, $default ) = @_;
1400 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1401 my $dbh = C4::Context->dbh;
1405 FROM authorised_values
1408 LEFT JOIN authorised_values_branches ON ( id = av_id )
1413 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1414 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1415 my $sth = $dbh->prepare($query);
1416 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1419 my $option_list = [];
1420 my @authorised_values = ( q{} );
1421 while (my $av = $sth->fetchrow_hashref) {
1422 push @{$option_list}, {
1423 value => $av->{authorised_value},
1424 label => $av->{lib},
1425 default => ($default eq $av->{authorised_value}),
1429 if ( @{$option_list} ) {
1430 return $option_list;
1436 =head2 GetDailyQuote($opts)
1438 Takes a hashref of options
1440 Currently supported options are:
1442 'id' An exact quote id
1443 'random' Select a random quote
1444 noop When no option is passed in, this sub will return the quote timestamped for the current day
1446 The function returns an anonymous hash following this format:
1449 'source' => 'source-of-quote',
1450 'timestamp' => 'timestamp-value',
1451 'text' => 'text-of-quote',
1457 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1458 # at least for default option
1462 my $dbh = C4::Context->dbh;
1467 $query = 'SELECT * FROM quotes WHERE id = ?';
1468 $sth = $dbh->prepare($query);
1469 $sth->execute($opts{'id'});
1470 $quote = $sth->fetchrow_hashref();
1472 elsif ($opts{'random'}) {
1473 # Fall through... we also return a random quote as a catch-all if all else fails
1476 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1477 $sth = $dbh->prepare($query);
1479 $quote = $sth->fetchrow_hashref();
1481 unless ($quote) { # if there are not matches, choose a random quote
1482 # get a list of all available quote ids
1483 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1485 my $range = ($sth->fetchrow_array)[0];
1486 # chose a random id within that range if there is more than one quote
1487 my $offset = int(rand($range));
1489 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1490 $sth = C4::Context->dbh->prepare($query);
1491 # see http://www.perlmonks.org/?node_id=837422 for why
1492 # we're being verbose and using bind_param
1493 $sth->bind_param(1, $offset, SQL_INTEGER);
1495 $quote = $sth->fetchrow_hashref();
1496 # update the timestamp for that quote
1497 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1498 $sth = C4::Context->dbh->prepare($query);
1500 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1507 sub _normalize_match_point {
1508 my $match_point = shift;
1509 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1510 $normalized_match_point =~ s/-//g;
1512 return $normalized_match_point;
1517 return NormalizeISBN(
1520 format => 'ISBN-10',
1526 =head2 NormalizedISBN
1528 my $isbns = NormalizedISBN({
1530 strip_hyphens => [0,1],
1531 format => ['ISBN-10', 'ISBN-13']
1534 Returns an isbn validated by Business::ISBN.
1535 Optionally strips hyphens and/or forces the isbn
1536 to be of the specified format.
1538 If the string cannot be validated as an isbn,
1546 my $string = $params->{isbn};
1547 my $strip_hyphens = $params->{strip_hyphens};
1548 my $format = $params->{format};
1550 return unless $string;
1552 my $isbn = Business::ISBN->new($string);
1554 if ( $isbn && $isbn->is_valid() ) {
1556 if ( $format eq 'ISBN-10' ) {
1557 $isbn = $isbn->as_isbn10();
1559 elsif ( $format eq 'ISBN-13' ) {
1560 $isbn = $isbn->as_isbn13();
1562 return unless $isbn;
1564 if ($strip_hyphens) {
1565 $string = $isbn->as_string( [] );
1567 $string = $isbn->as_string();
1574 =head2 GetVariationsOfISBN
1576 my @isbns = GetVariationsOfISBN( $isbn );
1578 Returns a list of variations of the given isbn in
1579 both ISBN-10 and ISBN-13 formats, with and without
1582 In a scalar context, the isbns are returned as a
1583 string delimited by ' | '.
1587 sub GetVariationsOfISBN {
1590 return unless $isbn;
1594 push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1595 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1596 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1597 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1598 push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1600 # Strip out any "empty" strings from the array
1601 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1603 return wantarray ? @isbns : join( " | ", @isbns );
1606 =head2 GetVariationsOfISBNs
1608 my @isbns = GetVariationsOfISBNs( @isbns );
1610 Returns a list of variations of the given isbns in
1611 both ISBN-10 and ISBN-13 formats, with and without
1614 In a scalar context, the isbns are returned as a
1615 string delimited by ' | '.
1619 sub GetVariationsOfISBNs {
1622 @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1624 return wantarray ? @isbns : join( " | ", @isbns );
1627 =head2 IsKohaFieldLinked
1629 my $is_linked = IsKohaFieldLinked({
1630 kohafield => $kohafield,
1631 frameworkcode => $frameworkcode,
1634 Return 1 if the field is linked
1638 sub IsKohaFieldLinked {
1639 my ( $params ) = @_;
1640 my $kohafield = $params->{kohafield};
1641 my $frameworkcode = $params->{frameworkcode} || '';
1642 my $dbh = C4::Context->dbh;
1643 my $is_linked = $dbh->selectcol_arrayref( q|
1645 FROM marc_subfield_structure
1646 WHERE frameworkcode = ?
1648 |,{}, $frameworkcode, $kohafield );
1649 return $is_linked->[0];