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
qw(GetBranchesCount);
29 use Koha
::DateUtils
qw(dt_from_string);
30 use DateTime
::Format
::MySQL
;
32 use autouse
'Data::cselectall_arrayref' => qw(Dumper);
33 use DBI
qw(:sql_types);
34 use vars
qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
37 $VERSION = 3.07.00.049;
42 &subfield_is_koha_internal_p
43 &GetPrinters &GetPrinter
44 &GetItemTypes &getitemtypeinfo
45 &GetItemTypesCategorized &GetItemTypesByCategory
46 &GetSupportName &GetSupportList
48 &getframeworks &getframeworkinfo
50 &getauthtypes &getauthtype
56 &get_notforloan_label_of
59 &getitemtypeimagelocation
61 &GetAuthorisedValueCategories
62 &IsAuthorisedValueCategory
63 &GetKohaAuthorisedValues
64 &GetKohaAuthorisedValuesFromField
65 &GetKohaAuthorisedValuesMapping
66 &GetKohaAuthorisedValueLib
67 &GetAuthorisedValueByCode
68 &GetKohaImageurlFromAuthorisedValues
74 &GetNormalizedOCLCNumber
84 @EXPORT_OK = qw( GetDailyQuote );
89 C4::Koha - Perl Module containing convenience functions for Koha scripts
97 Koha.pm provides many functions for Koha scripts.
105 $slash_date = &slashifyDate($dash_date);
107 Takes a string of the form "DD-MM-YYYY" (or anything separated by
108 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
114 # accepts a date of the form xx-xx-xx[xx] and returns it in the
116 my @dateOut = split( '-', shift );
117 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
120 # FIXME.. this should be moved to a MARC-specific module
121 sub subfield_is_koha_internal_p
{
124 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
125 # But real MARC subfields are always single-character
126 # so it really is safer just to check the length
128 return length $subfield != 1;
131 =head2 GetSupportName
133 $itemtypename = &GetSupportName($codestring);
135 Returns a string with the name of the itemtype.
141 return if (! $codestring);
143 my $advanced_search_types = C4
::Context
->preference("AdvancedSearchTypes");
144 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
151 my $sth = C4
::Context
->dbh->prepare($query);
152 $sth->execute($codestring);
153 ($resultstring)=$sth->fetchrow;
154 return $resultstring;
157 C4
::Context
->dbh->prepare(
158 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
160 $sth->execute( $advanced_search_types, $codestring );
161 my $data = $sth->fetchrow_hashref;
162 return $$data{'lib'};
166 =head2 GetSupportList
168 $itemtypes = &GetSupportList();
170 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
172 build a HTML select with the following code :
174 =head3 in PERL SCRIPT
176 my $itemtypes = GetSupportList();
177 $template->param(itemtypeloop => $itemtypes);
181 <select name="itemtype" id="itemtype">
182 <option value=""></option>
183 [% FOREACH itemtypeloo IN itemtypeloop %]
184 [% IF ( itemtypeloo.selected ) %]
185 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
187 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
195 my $advanced_search_types = C4
::Context
->preference("AdvancedSearchTypes");
196 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
202 my $sth = C4
::Context
->dbh->prepare($query);
204 return $sth->fetchall_arrayref({});
206 my $advsearchtypes = GetAuthorisedValues
($advanced_search_types);
207 my @results= map {{itemtype
=>$$_{authorised_value
},description
=>$$_{lib
},imageurl
=>$$_{imageurl
}}} @
$advsearchtypes;
213 $itemtypes = &GetItemTypes( style => $style );
215 Returns information about existing itemtypes.
218 style: either 'array' or 'hash', defaults to 'hash'.
219 'array' returns an arrayref,
220 'hash' return a hashref with the itemtype value as the key
222 build a HTML select with the following code :
224 =head3 in PERL SCRIPT
226 my $itemtypes = GetItemTypes;
228 foreach my $thisitemtype (sort keys %$itemtypes) {
229 my $selected = 1 if $thisitemtype eq $itemtype;
230 my %row =(value => $thisitemtype,
231 selected => $selected,
232 description => $itemtypes->{$thisitemtype}->{'description'},
234 push @itemtypesloop, \%row;
236 $template->param(itemtypeloop => \@itemtypesloop);
240 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
241 <select name="itemtype">
242 <option value="">Default</option>
243 <!-- TMPL_LOOP name="itemtypeloop" -->
244 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
247 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
248 <input type="submit" value="OK" class="button">
255 my $style = defined( $params{'style'} ) ?
$params{'style'} : 'hash';
257 # returns a reference to a hash of references to itemtypes...
259 my $dbh = C4
::Context
->dbh;
264 my $sth = $dbh->prepare($query);
267 if ( $style eq 'hash' ) {
268 while ( my $IT = $sth->fetchrow_hashref ) {
269 $itemtypes{ $IT->{'itemtype'} } = $IT;
271 return ( \
%itemtypes );
273 return $sth->fetchall_arrayref({});
277 =head2 GetItemTypesCategorized
279 $categories = GetItemTypesCategorized();
281 Returns a hashref containing search categories.
282 A search category will be put in the hash if at least one of its itemtypes is visible in OPAC.
283 The categories must be part of Authorized Values (ITEMTYPECAT)
287 sub GetItemTypesCategorized
{
288 my $dbh = C4
::Context
->dbh;
289 # Order is important, so that partially hidden (some items are not visible in OPAC) search
290 # categories will be visible. hideinopac=0 must be last.
292 SELECT itemtype
, description
, imageurl
, hideinopac
, 0 as
'iscat' FROM itemtypes WHERE ISNULL
(searchcategory
) or length(searchcategory
) = 0
294 SELECT DISTINCT searchcategory AS
`itemtype`,
295 authorised_values
.lib_opac AS description
,
296 authorised_values
.imageurl AS imageurl
,
297 hideinopac
, 1 as
'iscat'
299 LEFT JOIN authorised_values ON searchcategory
= authorised_value
300 WHERE searchcategory
> '' and hideinopac
=1
302 SELECT DISTINCT searchcategory AS
`itemtype`,
303 authorised_values
.lib_opac AS description
,
304 authorised_values
.imageurl AS imageurl
,
305 hideinopac
, 1 as
'iscat'
307 LEFT JOIN authorised_values ON searchcategory
= authorised_value
308 WHERE searchcategory
> '' and hideinopac
=0
310 return ($dbh->selectall_hashref($query,'itemtype'));
313 =head2 GetItemTypesByCategory
315 @results = GetItemTypesByCategory( $searchcategory );
317 Returns the itemtype code of all itemtypes included in a searchcategory.
321 sub GetItemTypesByCategory
{
325 my $dbh = C4
::Context
->dbh;
326 my $query = qq|SELECT itemtype FROM itemtypes WHERE searchcategory
=?
|;
327 my $tmp=$dbh->selectcol_arrayref($query,undef,$category);
331 sub get_itemtypeinfos_of
{
334 my $placeholders = join( ', ', map { '?' } @itemtypes );
335 my $query = <<"END_SQL";
341 WHERE itemtype IN ( $placeholders )
344 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
349 $authtypes = &getauthtypes();
351 Returns information about existing authtypes.
353 build a HTML select with the following code :
355 =head3 in PERL SCRIPT
357 my $authtypes = getauthtypes;
359 foreach my $thisauthtype (keys %$authtypes) {
360 my $selected = 1 if $thisauthtype eq $authtype;
361 my %row =(value => $thisauthtype,
362 selected => $selected,
363 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
365 push @authtypesloop, \%row;
367 $template->param(itemtypeloop => \@itemtypesloop);
371 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
372 <select name="authtype">
373 <!-- TMPL_LOOP name="authtypeloop" -->
374 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
377 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
378 <input type="submit" value="OK" class="button">
386 # returns a reference to a hash of references to authtypes...
388 my $dbh = C4::Context->dbh;
389 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
391 while ( my $IT = $sth->fetchrow_hashref ) {
392 $authtypes{ $IT->{'authtypecode'} } = $IT;
394 return ( \%authtypes );
398 my ($authtypecode) = @_;
400 # returns a reference to a hash of references to authtypes...
402 my $dbh = C4::Context->dbh;
403 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
404 $sth->execute($authtypecode);
405 my $res = $sth->fetchrow_hashref;
411 $frameworks = &getframework();
413 Returns information about existing frameworks
415 build a HTML select with the following code :
417 =head3 in PERL SCRIPT
419 my $frameworks = getframeworks();
421 foreach my $thisframework (keys %$frameworks) {
422 my $selected = 1 if $thisframework eq $frameworkcode;
424 value => $thisframework,
425 selected => $selected,
426 description => $frameworks->{$thisframework}->{'frameworktext'},
428 push @frameworksloop, \%row;
430 $template->param(frameworkloop => \@frameworksloop);
434 <form action="[% script_name %] method=post>
435 <select name="frameworkcode">
436 <option value="">Default</option>
437 [% FOREACH framework IN frameworkloop %]
438 [% IF ( framework.selected ) %]
439 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
441 <option value="[% framework.value %]">[% framework.description %]</option>
445 <input type
=text name
=searchfield value
="[% searchfield %]">
446 <input type
="submit" value
="OK" class="button">
453 # returns a reference to a hash of references to branches...
455 my $dbh = C4
::Context
->dbh;
456 my $sth = $dbh->prepare("select * from biblio_framework");
458 while ( my $IT = $sth->fetchrow_hashref ) {
459 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
461 return ( \
%itemtypes );
464 =head2 GetFrameworksLoop
466 $frameworks = GetFrameworksLoop( $frameworkcode );
468 Returns the loop suggested on getframework(), but ordered by framework description.
470 build a HTML select with the following code :
472 =head3 in PERL SCRIPT
474 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
478 Same as getframework()
480 <form action="[% script_name %] method=post>
481 <select name="frameworkcode">
482 <option value="">Default</option>
483 [% FOREACH framework IN frameworkloop %]
484 [% IF ( framework.selected ) %]
485 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
487 <option value="[% framework.value %]">[% framework.description %]</option>
491 <input type=text name=searchfield value="[% searchfield %]">
492 <input type="submit" value="OK" class="button">
497 sub GetFrameworksLoop
{
498 my $frameworkcode = shift;
499 my $frameworks = getframeworks
();
501 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
502 my $selected = ( $thisframework eq $frameworkcode ) ?
1 : undef;
504 value
=> $thisframework,
505 selected
=> $selected,
506 description
=> $frameworks->{$thisframework}->{'frameworktext'},
508 push @frameworkloop, \
%row;
510 return \
@frameworkloop;
513 =head2 getframeworkinfo
515 $frameworkinfo = &getframeworkinfo($frameworkcode);
517 Returns information about an frameworkcode.
521 sub getframeworkinfo
{
522 my ($frameworkcode) = @_;
523 my $dbh = C4
::Context
->dbh;
525 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
526 $sth->execute($frameworkcode);
527 my $res = $sth->fetchrow_hashref;
531 =head2 getitemtypeinfo
533 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
535 Returns information about an itemtype. The optional $interface argument
536 sets which interface ('opac' or 'intranet') to return the imageurl for.
537 Defaults to intranet.
541 sub getitemtypeinfo
{
542 my ($itemtype, $interface) = @_;
543 my $dbh = C4
::Context
->dbh;
544 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
545 $sth->execute($itemtype);
546 my $res = $sth->fetchrow_hashref;
548 $res->{imageurl
} = getitemtypeimagelocation
( ( ( defined $interface && $interface eq 'opac' ) ?
'opac' : 'intranet' ), $res->{imageurl
} );
553 =head2 getitemtypeimagedir
555 my $directory = getitemtypeimagedir( 'opac' );
557 pass in 'opac' or 'intranet'. Defaults to 'opac'.
559 returns the full path to the appropriate directory containing images.
563 sub getitemtypeimagedir
{
564 my $src = shift || 'opac';
565 if ($src eq 'intranet') {
566 return C4
::Context
->config('intrahtdocs') . '/' .C4
::Context
->preference('template') . '/img/itemtypeimg';
568 return C4
::Context
->config('opachtdocs') . '/' . C4
::Context
->preference('opacthemes') . '/itemtypeimg';
572 sub getitemtypeimagesrc
{
573 my $src = shift || 'opac';
574 if ($src eq 'intranet') {
575 return '/intranet-tmpl' . '/' . C4
::Context
->preference('template') . '/img/itemtypeimg';
577 return '/opac-tmpl' . '/' . C4
::Context
->preference('opacthemes') . '/itemtypeimg';
581 sub getitemtypeimagelocation
{
582 my ( $src, $image ) = @_;
584 return '' if ( !$image );
587 my $scheme = ( URI
::Split
::uri_split
( $image ) )[0];
589 return $image if ( $scheme );
591 return getitemtypeimagesrc
( $src ) . '/' . $image;
594 =head3 _getImagesFromDirectory
596 Find all of the image files in a directory in the filesystem
598 parameters: a directory name
600 returns: a list of images in that directory.
602 Notes: this does not traverse into subdirectories. See
603 _getSubdirectoryNames for help with that.
604 Images are assumed to be files with .gif or .png file extensions.
605 The image names returned do not have the directory name on them.
609 sub _getImagesFromDirectory
{
610 my $directoryname = shift;
611 return unless defined $directoryname;
612 return unless -d
$directoryname;
614 if ( opendir ( my $dh, $directoryname ) ) {
615 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
617 @images = sort(@images);
620 warn "unable to opendir $directoryname: $!";
625 =head3 _getSubdirectoryNames
627 Find all of the directories in a directory in the filesystem
629 parameters: a directory name
631 returns: a list of subdirectories in that directory.
633 Notes: this does not traverse into subdirectories. Only the first
634 level of subdirectories are returned.
635 The directory names returned don't have the parent directory name on them.
639 sub _getSubdirectoryNames
{
640 my $directoryname = shift;
641 return unless defined $directoryname;
642 return unless -d
$directoryname;
644 if ( opendir ( my $dh, $directoryname ) ) {
645 my @directories = grep { -d File
::Spec
->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
649 warn "unable to opendir $directoryname: $!";
656 returns: a listref of hashrefs. Each hash represents another collection of images.
658 { imagesetname => 'npl', # the name of the image set (npl is the original one)
659 images => listref of image hashrefs
662 each image is represented by a hashref like this:
664 { KohaImage => 'npl/image.gif',
665 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
666 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
667 checked => 0 or 1: was this the image passed to this method?
668 Note: I'd like to remove this somehow.
675 my $checked = $params{'checked'} || '';
677 my $paths = { staff
=> { filesystem
=> getitemtypeimagedir
('intranet'),
678 url
=> getitemtypeimagesrc
('intranet'),
680 opac
=> { filesystem
=> getitemtypeimagedir
('opac'),
681 url
=> getitemtypeimagesrc
('opac'),
685 my @imagesets = (); # list of hasrefs of image set data to pass to template
686 my @subdirectories = _getSubdirectoryNames
( $paths->{'staff'}{'filesystem'} );
687 foreach my $imagesubdir ( @subdirectories ) {
688 warn $imagesubdir if $DEBUG;
689 my @imagelist = (); # hashrefs of image info
690 my @imagenames = _getImagesFromDirectory
( File
::Spec
->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
691 my $imagesetactive = 0;
692 foreach my $thisimage ( @imagenames ) {
694 { KohaImage
=> "$imagesubdir/$thisimage",
695 StaffImageUrl
=> join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
696 OpacImageUrl
=> join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
697 checked
=> "$imagesubdir/$thisimage" eq $checked ?
1 : 0,
700 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
702 push @imagesets, { imagesetname
=> $imagesubdir,
703 imagesetactive
=> $imagesetactive,
704 images
=> \
@imagelist };
712 $printers = &GetPrinters();
713 @queues = keys %$printers;
715 Returns information about existing printer queues.
717 C<$printers> is a reference-to-hash whose keys are the print queues
718 defined in the printers table of the Koha database. The values are
719 references-to-hash, whose keys are the fields in the printers table.
725 my $dbh = C4
::Context
->dbh;
726 my $sth = $dbh->prepare("select * from printers");
728 while ( my $printer = $sth->fetchrow_hashref ) {
729 $printers{ $printer->{'printqueue'} } = $printer;
731 return ( \
%printers );
736 $printer = GetPrinter( $query, $printers );
741 my ( $query, $printers ) = @_; # get printer for this query from printers
742 my $printer = $query->param('printer');
743 my %cookie = $query->cookie('userenv');
744 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
745 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
751 Returns the number of pages to display in a pagination bar, given the number
752 of items and the number of items per page.
757 my ( $nb_items, $nb_items_per_page ) = @_;
759 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
764 (@themes) = &getallthemes('opac');
765 (@themes) = &getallthemes('intranet');
767 Returns an array of all available themes.
775 if ( $type eq 'intranet' ) {
776 $htdocs = C4
::Context
->config('intrahtdocs');
779 $htdocs = C4
::Context
->config('opachtdocs');
781 opendir D
, "$htdocs";
782 my @dirlist = readdir D
;
783 foreach my $directory (@dirlist) {
784 next if $directory eq 'lib';
785 -d
"$htdocs/$directory/en" and push @themes, $directory;
792 if ( C4
::Context
->preference("marcflavour") eq "UNIMARC" ) {
797 tags
=> [ qw
/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
803 tags
=> [ qw
/ 607a / ],
809 tags
=> [ qw
/ 500a 501a 503a / ],
815 tags
=> [ qw
/ 700ab 701ab 702ab / ],
816 sep
=> C4
::Context
->preference("UNIMARCAuthorsFacetsSeparator"),
821 tags
=> [ qw
/ 225a / ],
827 tags
=> [ qw
/ 995e / ],
831 unless ( C4
::Context
->preference("singleBranchMode")
832 || GetBranchesCount
() == 1 )
834 my $DisplayLibraryFacets = C4
::Context
->preference('DisplayLibraryFacets');
835 if ( $DisplayLibraryFacets eq 'both'
836 || $DisplayLibraryFacets eq 'holding' )
841 idx
=> 'holdingbranch',
842 label
=> 'HoldingLibrary',
843 tags
=> [qw
/ 995c /],
848 if ( $DisplayLibraryFacets eq 'both'
849 || $DisplayLibraryFacets eq 'home' )
855 label
=> 'HomeLibrary',
856 tags
=> [qw
/ 995b /],
867 tags
=> [ qw
/ 650a / ],
872 # label => 'People and Organizations',
873 # tags => [ qw/ 600a 610a 611a / ],
879 tags
=> [ qw
/ 651a / ],
885 tags
=> [ qw
/ 630a / ],
891 tags
=> [ qw
/ 100a 110a 700a / ],
897 tags
=> [ qw
/ 440a 490a / ],
902 label
=> 'ItemTypes',
903 tags
=> [ qw
/ 952y 942c / ],
909 tags
=> [ qw
/ 952c / ],
913 unless ( C4
::Context
->preference("singleBranchMode")
914 || GetBranchesCount
() == 1 )
916 my $DisplayLibraryFacets = C4
::Context
->preference('DisplayLibraryFacets');
917 if ( $DisplayLibraryFacets eq 'both'
918 || $DisplayLibraryFacets eq 'holding' )
923 idx
=> 'holdingbranch',
924 label
=> 'HoldingLibrary',
925 tags
=> [qw
/ 952b /],
930 if ( $DisplayLibraryFacets eq 'both'
931 || $DisplayLibraryFacets eq 'home' )
937 label
=> 'HomeLibrary',
938 tags
=> [qw
/ 952a /],
949 Return a href where a key is associated to a href. You give a query,
950 the name of the key among the fields returned by the query. If you
951 also give as third argument the name of the value, the function
952 returns a href of scalar. The optional 4th argument is an arrayref of
953 items passed to the C<execute()> call. It is designed to bind
954 parameters to any placeholders in your SQL.
963 # generic href of any information on the item, href of href.
964 my $iteminfos_of = get_infos_of($query, 'itemnumber');
965 print $iteminfos_of->{$itemnumber}{barcode};
967 # specific information, href of scalar
968 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
969 print $barcode_of_item->{$itemnumber};
974 my ( $query, $key_name, $value_name, $bind_params ) = @_;
976 my $dbh = C4
::Context
->dbh;
978 my $sth = $dbh->prepare($query);
979 $sth->execute( @
$bind_params );
982 while ( my $row = $sth->fetchrow_hashref ) {
983 if ( defined $value_name ) {
984 $infos_of{ $row->{$key_name} } = $row->{$value_name};
987 $infos_of{ $row->{$key_name} } = $row;
995 =head2 get_notforloan_label_of
997 my $notforloan_label_of = get_notforloan_label_of();
999 Each authorised value of notforloan (information available in items and
1000 itemtypes) is link to a single label.
1002 Returns a href where keys are authorised values and values are corresponding
1005 foreach my $authorised_value (keys %{$notforloan_label_of}) {
1007 "authorised_value: %s => %s\n",
1009 $notforloan_label_of->{$authorised_value}
1015 # FIXME - why not use GetAuthorisedValues ??
1017 sub get_notforloan_label_of
{
1018 my $dbh = C4
::Context
->dbh;
1021 SELECT authorised_value
1022 FROM marc_subfield_structure
1023 WHERE kohafield = \'items.notforloan\'
1026 my $sth = $dbh->prepare($query);
1028 my ($statuscode) = $sth->fetchrow_array();
1033 FROM authorised_values
1036 $sth = $dbh->prepare($query);
1037 $sth->execute($statuscode);
1038 my %notforloan_label_of;
1039 while ( my $row = $sth->fetchrow_hashref ) {
1040 $notforloan_label_of{ $row->{authorised_value
} } = $row->{lib
};
1044 return \
%notforloan_label_of;
1047 =head2 displayServers
1049 my $servers = displayServers();
1050 my $servers = displayServers( $position );
1051 my $servers = displayServers( $position, $type );
1053 displayServers returns a listref of hashrefs, each containing
1054 information about available z3950 servers. Each hashref has a format
1058 'checked' => 'checked',
1059 'encoding' => 'utf8',
1061 'id' => 'LIBRARY OF CONGRESS',
1065 'value' => 'lx2.loc.gov:210/',
1071 sub displayServers
{
1072 my ( $position, $type ) = @_;
1073 my $dbh = C4
::Context
->dbh;
1075 my $strsth = 'SELECT * FROM z3950servers';
1080 push @bind_params, $position;
1081 push @where_clauses, ' position = ? ';
1085 push @bind_params, $type;
1086 push @where_clauses, ' type = ? ';
1089 # reassemble where clause from where clause pieces
1090 if (@where_clauses) {
1091 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1094 my $rq = $dbh->prepare($strsth);
1095 $rq->execute(@bind_params);
1096 my @primaryserverloop;
1098 while ( my $data = $rq->fetchrow_hashref ) {
1099 push @primaryserverloop,
1100 { label
=> $data->{description
},
1101 id
=> $data->{name
},
1103 value
=> $data->{host
} . ":" . $data->{port
} . "/" . $data->{database
},
1104 encoding
=> ( $data->{encoding
} ?
$data->{encoding
} : "iso-5426" ),
1105 checked
=> "checked",
1106 icon
=> $data->{icon
},
1107 zed
=> $data->{type
} eq 'zed',
1108 opensearch
=> $data->{type
} eq 'opensearch'
1111 return \
@primaryserverloop;
1115 =head2 GetKohaImageurlFromAuthorisedValues
1117 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
1119 Return the first url of the authorised value image represented by $lib.
1123 sub GetKohaImageurlFromAuthorisedValues
{
1124 my ( $category, $lib ) = @_;
1125 my $dbh = C4
::Context
->dbh;
1126 my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
1127 $sth->execute( $category, $lib );
1128 while ( my $data = $sth->fetchrow_hashref ) {
1129 return $data->{'imageurl'};
1133 =head2 GetAuthValCode
1135 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1139 sub GetAuthValCode
{
1140 my ($kohafield,$fwcode) = @_;
1141 my $dbh = C4
::Context
->dbh;
1142 $fwcode='' unless $fwcode;
1143 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1144 $sth->execute($kohafield,$fwcode);
1145 my ($authvalcode) = $sth->fetchrow_array;
1146 return $authvalcode;
1149 =head2 GetAuthValCodeFromField
1151 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1153 C<$subfield> can be undefined
1157 sub GetAuthValCodeFromField
{
1158 my ($field,$subfield,$fwcode) = @_;
1159 my $dbh = C4
::Context
->dbh;
1160 $fwcode='' unless $fwcode;
1162 if (defined $subfield) {
1163 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1164 $sth->execute($field,$subfield,$fwcode);
1166 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1167 $sth->execute($field,$fwcode);
1169 my ($authvalcode) = $sth->fetchrow_array;
1170 return $authvalcode;
1173 =head2 GetAuthorisedValues
1175 $authvalues = GetAuthorisedValues([$category], [$selected]);
1177 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1179 C<$category> returns authorised values for just one category (optional).
1181 C<$selected> adds a "selected => 1" entry to the hash if the
1182 authorised_value matches it. B<NOTE:> this feature should be considered
1183 deprecated as it may be removed in the future.
1185 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1189 sub GetAuthorisedValues
{
1190 my ( $category, $selected, $opac ) = @_;
1192 # TODO: the "selected" feature should be replaced by a utility function
1193 # somewhere else, it doesn't belong in here. For starters it makes
1194 # caching much more complicated. Or just let the UI logic handle it, it's
1197 # Is this cached already?
1198 $opac = $opac ?
1 : 0; # normalise to be safe
1200 C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : "";
1201 my $selected_key = defined($selected) ?
$selected : '';
1203 "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1204 my $cache = Koha
::Cache
->get_instance();
1205 my $result = $cache->get_from_cache($cache_key);
1206 return $result if $result;
1209 my $dbh = C4
::Context
->dbh;
1212 FROM authorised_values
1215 LEFT JOIN authorised_values_branches ON
( id
= av_id
)
1220 push @where_strings, "category = ?";
1221 push @where_args, $category;
1224 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1225 push @where_args, $branch_limit;
1227 if(@where_strings > 0) {
1228 $query .= " WHERE " . join(" AND ", @where_strings);
1230 $query .= " GROUP BY lib";
1231 $query .= ' ORDER BY category, ' . (
1232 $opac ?
'COALESCE(lib_opac, lib)'
1236 my $sth = $dbh->prepare($query);
1238 $sth->execute( @where_args );
1239 while (my $data=$sth->fetchrow_hashref) {
1240 if ( defined $selected and $selected eq $data->{authorised_value
} ) {
1241 $data->{selected
} = 1;
1244 $data->{selected
} = 0;
1247 if ($opac && $data->{lib_opac
}) {
1248 $data->{lib
} = $data->{lib_opac
};
1250 push @results, $data;
1254 # We can't cache for long because of that "selected" thing which
1255 # makes it impossible to clear the cache without iterating through every
1256 # value, which sucks. This'll cover this request, and not a whole lot more.
1257 $cache->set_in_cache( $cache_key, \
@results, { deepcopy
=> 1, expiry
=> 5 } );
1261 =head2 GetAuthorisedValueCategories
1263 $auth_categories = GetAuthorisedValueCategories();
1265 Return an arrayref of all of the available authorised
1270 sub GetAuthorisedValueCategories
{
1271 my $dbh = C4
::Context
->dbh;
1272 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1275 while (defined (my $category = $sth->fetchrow_array) ) {
1276 push @results, $category;
1281 =head2 IsAuthorisedValueCategory
1283 $is_auth_val_category = IsAuthorisedValueCategory($category);
1285 Returns whether a given category name is a valid one
1289 sub IsAuthorisedValueCategory
{
1290 my $category = shift;
1293 FROM authorised_values
1297 my $sth = C4
::Context
->dbh->prepare($query);
1298 $sth->execute($category);
1299 $sth->fetchrow ?
return 1
1303 =head2 GetAuthorisedValueByCode
1305 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1307 Return the lib attribute from authorised_values from the row identified
1308 by the passed category and code
1312 sub GetAuthorisedValueByCode
{
1313 my ( $category, $authvalcode, $opac ) = @_;
1315 my $field = $opac ?
'lib_opac' : 'lib';
1316 my $dbh = C4
::Context
->dbh;
1317 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1318 $sth->execute( $category, $authvalcode );
1319 while ( my $data = $sth->fetchrow_hashref ) {
1320 return $data->{ $field };
1324 =head2 GetKohaAuthorisedValues
1326 Takes $kohafield, $fwcode as parameters.
1328 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1330 Returns hashref of Code => description
1332 Returns undef if no authorised value category is defined for the kohafield.
1336 sub GetKohaAuthorisedValues
{
1337 my ($kohafield,$fwcode,$opac) = @_;
1338 $fwcode='' unless $fwcode;
1340 my $dbh = C4
::Context
->dbh;
1341 my $avcode = GetAuthValCode
($kohafield,$fwcode);
1343 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1344 $sth->execute($avcode);
1345 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1346 $values{$val} = ($opac && $lib_opac) ?
$lib_opac : $lib;
1354 =head2 GetKohaAuthorisedValuesFromField
1356 Takes $field, $subfield, $fwcode as parameters.
1358 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1359 $subfield can be undefined
1361 Returns hashref of Code => description
1363 Returns undef if no authorised value category is defined for the given field and subfield
1367 sub GetKohaAuthorisedValuesFromField
{
1368 my ($field, $subfield, $fwcode,$opac) = @_;
1369 $fwcode='' unless $fwcode;
1371 my $dbh = C4
::Context
->dbh;
1372 my $avcode = GetAuthValCodeFromField
($field, $subfield, $fwcode);
1374 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1375 $sth->execute($avcode);
1376 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1377 $values{$val} = ($opac && $lib_opac) ?
$lib_opac : $lib;
1385 =head2 GetKohaAuthorisedValuesMapping
1387 Takes a hash as a parameter. The interface key indicates the
1388 description to use in the mapping.
1391 "{kohafield},{frameworkcode},{authorised_value}" => "{description}"
1392 for all the kohafields, frameworkcodes, and authorised values.
1394 Returns undef if nothing is found.
1398 sub GetKohaAuthorisedValuesMapping
{
1399 my ($parameter) = @_;
1400 my $interface = $parameter->{'interface'} // '';
1402 my $query_mapping = q{
1403 SELECT TA.kohafield,TA.authorised_value AS category,
1404 TA.frameworkcode,TB.authorised_value,
1405 IF(TB.lib_opac>'',TB.lib_opac,TB.lib) AS OPAC,
1406 TB.lib AS Intranet,TB.lib_opac
1407 FROM marc_subfield_structure AS TA JOIN
1408 authorised_values as TB ON
1409 TA.authorised_value=TB.category
1410 WHERE TA.kohafield>'' AND TA.authorised_value>'';
1412 my $dbh = C4
::Context
->dbh;
1413 my $sth = $dbh->prepare($query_mapping);
1416 if ($interface eq 'opac') {
1417 while (my $row = $sth->fetchrow_hashref) {
1418 $avmapping->{$row->{kohafield
}.",".$row->{frameworkcode
}.",".$row->{authorised_value
}} = $row->{OPAC
};
1422 while (my $row = $sth->fetchrow_hashref) {
1423 $avmapping->{$row->{kohafield
}.",".$row->{frameworkcode
}.",".$row->{authorised_value
}} = $row->{Intranet
};
1431 my $escaped_string = C4::Koha::xml_escape($string);
1433 Convert &, <, >, ', and " in a string to XML entities
1439 return '' unless defined $str;
1440 $str =~ s/&/&/g;
1443 $str =~ s/'/'/g;
1444 $str =~ s/"/"/g;
1448 =head2 GetKohaAuthorisedValueLib
1450 Takes $category, $authorised_value as parameters.
1452 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1454 Returns authorised value description
1458 sub GetKohaAuthorisedValueLib
{
1459 my ($category,$authorised_value,$opac) = @_;
1461 my $dbh = C4
::Context
->dbh;
1462 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1463 $sth->execute($category,$authorised_value);
1464 my $data = $sth->fetchrow_hashref;
1465 $value = ($opac && $$data{'lib_opac'}) ?
$$data{'lib_opac'} : $$data{'lib'};
1469 =head2 AddAuthorisedValue
1471 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1473 Create a new authorised value.
1477 sub AddAuthorisedValue
{
1478 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1480 my $dbh = C4
::Context
->dbh;
1482 INSERT INTO authorised_values
(category
, authorised_value
, lib
, lib_opac
, imageurl
)
1485 my $sth = $dbh->prepare($query);
1486 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1489 =head2 display_marc_indicators
1491 my $display_form = C4::Koha::display_marc_indicators($field);
1493 C<$field> is a MARC::Field object
1495 Generate a display form of the indicators of a variable
1496 MARC field, replacing any blanks with '#'.
1500 sub display_marc_indicators
{
1502 my $indicators = '';
1503 if ($field->tag() >= 10) {
1504 $indicators = $field->indicator(1) . $field->indicator(2);
1505 $indicators =~ s/ /#/g;
1510 sub GetNormalizedUPC
{
1511 my ($record,$marcflavour) = @_;
1514 if ($marcflavour eq 'UNIMARC') {
1515 @fields = $record->field('072');
1516 foreach my $field (@fields) {
1517 my $upc = _normalize_match_point
($field->subfield('a'));
1524 else { # assume marc21 if not unimarc
1525 @fields = $record->field('024');
1526 foreach my $field (@fields) {
1527 my $indicator = $field->indicator(1);
1528 my $upc = _normalize_match_point
($field->subfield('a'));
1529 if ($indicator == 1 and $upc ne '') {
1536 # Normalizes and returns the first valid ISBN found in the record
1537 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1538 sub GetNormalizedISBN
{
1539 my ($isbn,$record,$marcflavour) = @_;
1542 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1543 # anything after " | " should be removed, along with the delimiter
1544 ($isbn) = split(/\|/, $isbn );
1545 return _isbn_cleanup
($isbn);
1547 return unless $record;
1549 if ($marcflavour eq 'UNIMARC') {
1550 @fields = $record->field('010');
1551 foreach my $field (@fields) {
1552 my $isbn = $field->subfield('a');
1554 return _isbn_cleanup
($isbn);
1560 else { # assume marc21 if not unimarc
1561 @fields = $record->field('020');
1562 foreach my $field (@fields) {
1563 $isbn = $field->subfield('a');
1565 return _isbn_cleanup
($isbn);
1573 sub GetNormalizedEAN
{
1574 my ($record,$marcflavour) = @_;
1577 if ($marcflavour eq 'UNIMARC') {
1578 @fields = $record->field('073');
1579 foreach my $field (@fields) {
1580 $ean = _normalize_match_point
($field->subfield('a'));
1586 else { # assume marc21 if not unimarc
1587 @fields = $record->field('024');
1588 foreach my $field (@fields) {
1589 my $indicator = $field->indicator(1);
1590 $ean = _normalize_match_point
($field->subfield('a'));
1591 if ($indicator == 3 and $ean ne '') {
1597 sub GetNormalizedOCLCNumber
{
1598 my ($record,$marcflavour) = @_;
1601 if ($marcflavour eq 'UNIMARC') {
1602 # TODO: add UNIMARC fields
1604 else { # assume marc21 if not unimarc
1605 @fields = $record->field('035');
1606 foreach my $field (@fields) {
1607 $oclc = $field->subfield('a');
1608 if ($oclc =~ /OCoLC/) {
1609 $oclc =~ s/\(OCoLC\)//;
1618 sub GetAuthvalueDropbox
{
1619 my ( $authcat, $default ) = @_;
1620 my $branch_limit = C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : "";
1621 my $dbh = C4
::Context
->dbh;
1625 FROM authorised_values
1628 LEFT JOIN authorised_values_branches ON
( id
= av_id
)
1633 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1634 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1635 my $sth = $dbh->prepare($query);
1636 $sth->execute( $authcat, $branch_limit ?
$branch_limit : () );
1639 my $option_list = [];
1640 my @authorised_values = ( q{} );
1641 while (my $av = $sth->fetchrow_hashref) {
1642 push @
{$option_list}, {
1643 value
=> $av->{authorised_value
},
1644 label
=> $av->{lib
},
1645 default => ($default eq $av->{authorised_value
}),
1649 if ( @
{$option_list} ) {
1650 return $option_list;
1656 =head2 GetDailyQuote($opts)
1658 Takes a hashref of options
1660 Currently supported options are:
1662 'id' An exact quote id
1663 'random' Select a random quote
1664 noop When no option is passed in, this sub will return the quote timestamped for the current day
1666 The function returns an anonymous hash following this format:
1669 'source' => 'source-of-quote',
1670 'timestamp' => 'timestamp-value',
1671 'text' => 'text-of-quote',
1677 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1678 # at least for default option
1682 my $dbh = C4
::Context
->dbh;
1687 $query = 'SELECT * FROM quotes WHERE id = ?';
1688 $sth = $dbh->prepare($query);
1689 $sth->execute($opts{'id'});
1690 $quote = $sth->fetchrow_hashref();
1692 elsif ($opts{'random'}) {
1693 # Fall through... we also return a random quote as a catch-all if all else fails
1696 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1697 $sth = $dbh->prepare($query);
1699 $quote = $sth->fetchrow_hashref();
1701 unless ($quote) { # if there are not matches, choose a random quote
1702 # get a list of all available quote ids
1703 $sth = C4
::Context
->dbh->prepare('SELECT count(*) FROM quotes;');
1705 my $range = ($sth->fetchrow_array)[0];
1706 # chose a random id within that range if there is more than one quote
1707 my $offset = int(rand($range));
1709 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1710 $sth = C4
::Context
->dbh->prepare($query);
1711 # see http://www.perlmonks.org/?node_id=837422 for why
1712 # we're being verbose and using bind_param
1713 $sth->bind_param(1, $offset, SQL_INTEGER
);
1715 $quote = $sth->fetchrow_hashref();
1716 # update the timestamp for that quote
1717 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1718 $sth = C4
::Context
->dbh->prepare($query);
1720 DateTime
::Format
::MySQL
->format_datetime( dt_from_string
() ),
1727 sub _normalize_match_point
{
1728 my $match_point = shift;
1729 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1730 $normalized_match_point =~ s/-//g;
1732 return $normalized_match_point;
1737 return NormalizeISBN
(
1740 format
=> 'ISBN-10',
1746 =head2 NormalizedISBN
1748 my $isbns = NormalizedISBN({
1750 strip_hyphens => [0,1],
1751 format => ['ISBN-10', 'ISBN-13']
1754 Returns an isbn validated by Business::ISBN.
1755 Optionally strips hyphens and/or forces the isbn
1756 to be of the specified format.
1758 If the string cannot be validated as an isbn,
1766 my $string = $params->{isbn
};
1767 my $strip_hyphens = $params->{strip_hyphens
};
1768 my $format = $params->{format
};
1770 return unless $string;
1772 my $isbn = Business
::ISBN
->new($string);
1774 if ( $isbn && $isbn->is_valid() ) {
1776 if ( $format eq 'ISBN-10' ) {
1777 $isbn = $isbn->as_isbn10();
1779 elsif ( $format eq 'ISBN-13' ) {
1780 $isbn = $isbn->as_isbn13();
1782 return unless $isbn;
1784 if ($strip_hyphens) {
1785 $string = $isbn->as_string( [] );
1787 $string = $isbn->as_string();
1794 =head2 GetVariationsOfISBN
1796 my @isbns = GetVariationsOfISBN( $isbn );
1798 Returns a list of variations of the given isbn in
1799 both ISBN-10 and ISBN-13 formats, with and without
1802 In a scalar context, the isbns are returned as a
1803 string delimited by ' | '.
1807 sub GetVariationsOfISBN
{
1810 return unless $isbn;
1814 push( @isbns, NormalizeISBN
({ isbn
=> $isbn }) );
1815 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-10' }) );
1816 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-13' }) );
1817 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-10', strip_hyphens
=> 1 }) );
1818 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-13', strip_hyphens
=> 1 }) );
1820 # Strip out any "empty" strings from the array
1821 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1823 return wantarray ?
@isbns : join( " | ", @isbns );
1826 =head2 GetVariationsOfISBNs
1828 my @isbns = GetVariationsOfISBNs( @isbns );
1830 Returns a list of variations of the given isbns in
1831 both ISBN-10 and ISBN-13 formats, with and without
1834 In a scalar context, the isbns are returned as a
1835 string delimited by ' | '.
1839 sub GetVariationsOfISBNs
{
1842 @isbns = map { GetVariationsOfISBN
( $_ ) } @isbns;
1844 return wantarray ?
@isbns : join( " | ", @isbns );
1847 =head2 IsKohaFieldLinked
1849 my $is_linked = IsKohaFieldLinked({
1850 kohafield => $kohafield,
1851 frameworkcode => $frameworkcode,
1854 Return 1 if the field is linked
1858 sub IsKohaFieldLinked
{
1859 my ( $params ) = @_;
1860 my $kohafield = $params->{kohafield
};
1861 my $frameworkcode = $params->{frameworkcode
} || '';
1862 my $dbh = C4
::Context
->dbh;
1863 my $is_linked = $dbh->selectcol_arrayref( q
|
1865 FROM marc_subfield_structure
1866 WHERE frameworkcode
= ?
1868 |,{}, $frameworkcode, $kohafield );
1869 return $is_linked->[0];