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 under the
10 # terms of the GNU General Public License as published by the Free Software
11 # Foundation; either version 2 of the License, or (at your option) any later
14 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
15 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
16 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License along
19 # with Koha; if not, write to the Free Software Foundation, Inc.,
20 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
24 #use warnings; FIXME - Bug 2505
27 use C4::Branch qw(GetBranchesCount);
28 use Koha::DateUtils qw(dt_from_string);
30 use DateTime::Format::MySQL;
31 use autouse 'Data::Dumper' => qw(Dumper);
32 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 &GetSupportName &GetSupportList
47 &getframeworks &getframeworkinfo
48 &getauthtypes &getauthtype
54 &get_notforloan_label_of
57 &getitemtypeimagelocation
59 &GetAuthorisedValueCategories
60 &IsAuthorisedValueCategory
61 &GetKohaAuthorisedValues
62 &GetKohaAuthorisedValuesFromField
63 &GetKohaAuthorisedValueLib
64 &GetAuthorisedValueByCode
65 &GetKohaImageurlFromAuthorisedValues
71 &GetNormalizedOCLCNumber
77 @EXPORT_OK = qw( GetDailyQuote );
81 memoize('GetAuthorisedValues');
85 C4::Koha - Perl Module containing convenience functions for Koha scripts
93 Koha.pm provides many functions for Koha scripts.
101 $slash_date = &slashifyDate($dash_date);
103 Takes a string of the form "DD-MM-YYYY" (or anything separated by
104 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
110 # accepts a date of the form xx-xx-xx[xx] and returns it in the
112 my @dateOut = split( '-', shift );
113 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
116 # FIXME.. this should be moved to a MARC-specific module
117 sub subfield_is_koha_internal_p {
120 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
121 # But real MARC subfields are always single-character
122 # so it really is safer just to check the length
124 return length $subfield != 1;
127 =head2 GetSupportName
129 $itemtypename = &GetSupportName($codestring);
131 Returns a string with the name of the itemtype.
137 return if (! $codestring);
139 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
140 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
147 my $sth = C4::Context->dbh->prepare($query);
148 $sth->execute($codestring);
149 ($resultstring)=$sth->fetchrow;
150 return $resultstring;
153 C4::Context->dbh->prepare(
154 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
156 $sth->execute( $advanced_search_types, $codestring );
157 my $data = $sth->fetchrow_hashref;
158 return $$data{'lib'};
162 =head2 GetSupportList
164 $itemtypes = &GetSupportList();
166 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
168 build a HTML select with the following code :
170 =head3 in PERL SCRIPT
172 my $itemtypes = GetSupportList();
173 $template->param(itemtypeloop => $itemtypes);
177 <select name="itemtype" id="itemtype">
178 <option value=""></option>
179 [% FOREACH itemtypeloo IN itemtypeloop %]
180 [% IF ( itemtypeloo.selected ) %]
181 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
183 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
191 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
192 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
198 my $sth = C4::Context->dbh->prepare($query);
200 return $sth->fetchall_arrayref({});
202 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
203 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
209 $itemtypes = &GetItemTypes( style => $style );
211 Returns information about existing itemtypes.
214 style: either 'array' or 'hash', defaults to 'hash'.
215 'array' returns an arrayref,
216 'hash' return a hashref with the itemtype value as the key
218 build a HTML select with the following code :
220 =head3 in PERL SCRIPT
222 my $itemtypes = GetItemTypes;
224 foreach my $thisitemtype (sort keys %$itemtypes) {
225 my $selected = 1 if $thisitemtype eq $itemtype;
226 my %row =(value => $thisitemtype,
227 selected => $selected,
228 description => $itemtypes->{$thisitemtype}->{'description'},
230 push @itemtypesloop, \%row;
232 $template->param(itemtypeloop => \@itemtypesloop);
236 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
237 <select name="itemtype">
238 <option value="">Default</option>
239 <!-- TMPL_LOOP name="itemtypeloop" -->
240 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
243 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
244 <input type="submit" value="OK" class="button">
251 my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
253 # returns a reference to a hash of references to itemtypes...
255 my $dbh = C4::Context->dbh;
260 my $sth = $dbh->prepare($query);
263 if ( $style eq 'hash' ) {
264 while ( my $IT = $sth->fetchrow_hashref ) {
265 $itemtypes{ $IT->{'itemtype'} } = $IT;
267 return ( \%itemtypes );
269 return $sth->fetchall_arrayref({});
273 sub get_itemtypeinfos_of {
276 my $placeholders = join( ', ', map { '?' } @itemtypes );
277 my $query = <<"END_SQL";
283 WHERE itemtype IN ( $placeholders )
286 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
291 $authtypes = &getauthtypes();
293 Returns information about existing authtypes.
295 build a HTML select with the following code :
297 =head3 in PERL SCRIPT
299 my $authtypes = getauthtypes;
301 foreach my $thisauthtype (keys %$authtypes) {
302 my $selected = 1 if $thisauthtype eq $authtype;
303 my %row =(value => $thisauthtype,
304 selected => $selected,
305 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
307 push @authtypesloop, \%row;
309 $template->param(itemtypeloop => \@itemtypesloop);
313 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
314 <select name="authtype">
315 <!-- TMPL_LOOP name="authtypeloop" -->
316 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
319 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
320 <input type="submit" value="OK" class="button">
328 # returns a reference to a hash of references to authtypes...
330 my $dbh = C4::Context->dbh;
331 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
333 while ( my $IT = $sth->fetchrow_hashref ) {
334 $authtypes{ $IT->{'authtypecode'} } = $IT;
336 return ( \%authtypes );
340 my ($authtypecode) = @_;
342 # returns a reference to a hash of references to authtypes...
344 my $dbh = C4::Context->dbh;
345 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
346 $sth->execute($authtypecode);
347 my $res = $sth->fetchrow_hashref;
353 $frameworks = &getframework();
355 Returns information about existing frameworks
357 build a HTML select with the following code :
359 =head3 in PERL SCRIPT
361 my $frameworks = frameworks();
363 foreach my $thisframework (keys %$frameworks) {
364 my $selected = 1 if $thisframework eq $frameworkcode;
365 my %row =(value => $thisframework,
366 selected => $selected,
367 description => $frameworks->{$thisframework}->{'frameworktext'},
369 push @frameworksloop, \%row;
371 $template->param(frameworkloop => \@frameworksloop);
375 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
376 <select name="frameworkcode">
377 <option value="">Default</option>
378 <!-- TMPL_LOOP name="frameworkloop" -->
379 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
382 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
383 <input type="submit" value="OK" class="button">
390 # returns a reference to a hash of references to branches...
392 my $dbh = C4::Context->dbh;
393 my $sth = $dbh->prepare("select * from biblio_framework");
395 while ( my $IT = $sth->fetchrow_hashref ) {
396 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
398 return ( \%itemtypes );
401 =head2 getframeworkinfo
403 $frameworkinfo = &getframeworkinfo($frameworkcode);
405 Returns information about an frameworkcode.
409 sub getframeworkinfo {
410 my ($frameworkcode) = @_;
411 my $dbh = C4::Context->dbh;
413 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
414 $sth->execute($frameworkcode);
415 my $res = $sth->fetchrow_hashref;
419 =head2 getitemtypeinfo
421 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
423 Returns information about an itemtype. The optional $interface argument
424 sets which interface ('opac' or 'intranet') to return the imageurl for.
425 Defaults to intranet.
429 sub getitemtypeinfo {
430 my ($itemtype, $interface) = @_;
431 my $dbh = C4::Context->dbh;
432 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
433 $sth->execute($itemtype);
434 my $res = $sth->fetchrow_hashref;
436 $res->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $res->{imageurl} );
441 =head2 getitemtypeimagedir
443 my $directory = getitemtypeimagedir( 'opac' );
445 pass in 'opac' or 'intranet'. Defaults to 'opac'.
447 returns the full path to the appropriate directory containing images.
451 sub getitemtypeimagedir {
452 my $src = shift || 'opac';
453 if ($src eq 'intranet') {
454 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
456 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
460 sub getitemtypeimagesrc {
461 my $src = shift || 'opac';
462 if ($src eq 'intranet') {
463 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
465 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
469 sub getitemtypeimagelocation {
470 my ( $src, $image ) = @_;
472 return '' if ( !$image );
475 my $scheme = ( URI::Split::uri_split( $image ) )[0];
477 return $image if ( $scheme );
479 return getitemtypeimagesrc( $src ) . '/' . $image;
482 =head3 _getImagesFromDirectory
484 Find all of the image files in a directory in the filesystem
486 parameters: a directory name
488 returns: a list of images in that directory.
490 Notes: this does not traverse into subdirectories. See
491 _getSubdirectoryNames for help with that.
492 Images are assumed to be files with .gif or .png file extensions.
493 The image names returned do not have the directory name on them.
497 sub _getImagesFromDirectory {
498 my $directoryname = shift;
499 return unless defined $directoryname;
500 return unless -d $directoryname;
502 if ( opendir ( my $dh, $directoryname ) ) {
503 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
505 @images = sort(@images);
508 warn "unable to opendir $directoryname: $!";
513 =head3 _getSubdirectoryNames
515 Find all of the directories in a directory in the filesystem
517 parameters: a directory name
519 returns: a list of subdirectories in that directory.
521 Notes: this does not traverse into subdirectories. Only the first
522 level of subdirectories are returned.
523 The directory names returned don't have the parent directory name on them.
527 sub _getSubdirectoryNames {
528 my $directoryname = shift;
529 return unless defined $directoryname;
530 return unless -d $directoryname;
532 if ( opendir ( my $dh, $directoryname ) ) {
533 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
537 warn "unable to opendir $directoryname: $!";
544 returns: a listref of hashrefs. Each hash represents another collection of images.
546 { imagesetname => 'npl', # the name of the image set (npl is the original one)
547 images => listref of image hashrefs
550 each image is represented by a hashref like this:
552 { KohaImage => 'npl/image.gif',
553 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
554 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
555 checked => 0 or 1: was this the image passed to this method?
556 Note: I'd like to remove this somehow.
563 my $checked = $params{'checked'} || '';
565 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
566 url => getitemtypeimagesrc('intranet'),
568 opac => { filesystem => getitemtypeimagedir('opac'),
569 url => getitemtypeimagesrc('opac'),
573 my @imagesets = (); # list of hasrefs of image set data to pass to template
574 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
575 foreach my $imagesubdir ( @subdirectories ) {
576 warn $imagesubdir if $DEBUG;
577 my @imagelist = (); # hashrefs of image info
578 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
579 my $imagesetactive = 0;
580 foreach my $thisimage ( @imagenames ) {
582 { KohaImage => "$imagesubdir/$thisimage",
583 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
584 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
585 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
588 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
590 push @imagesets, { imagesetname => $imagesubdir,
591 imagesetactive => $imagesetactive,
592 images => \@imagelist };
600 $printers = &GetPrinters();
601 @queues = keys %$printers;
603 Returns information about existing printer queues.
605 C<$printers> is a reference-to-hash whose keys are the print queues
606 defined in the printers table of the Koha database. The values are
607 references-to-hash, whose keys are the fields in the printers table.
613 my $dbh = C4::Context->dbh;
614 my $sth = $dbh->prepare("select * from printers");
616 while ( my $printer = $sth->fetchrow_hashref ) {
617 $printers{ $printer->{'printqueue'} } = $printer;
619 return ( \%printers );
624 $printer = GetPrinter( $query, $printers );
629 my ( $query, $printers ) = @_; # get printer for this query from printers
630 my $printer = $query->param('printer');
631 my %cookie = $query->cookie('userenv');
632 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
633 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
639 Returns the number of pages to display in a pagination bar, given the number
640 of items and the number of items per page.
645 my ( $nb_items, $nb_items_per_page ) = @_;
647 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
652 (@themes) = &getallthemes('opac');
653 (@themes) = &getallthemes('intranet');
655 Returns an array of all available themes.
663 if ( $type eq 'intranet' ) {
664 $htdocs = C4::Context->config('intrahtdocs');
667 $htdocs = C4::Context->config('opachtdocs');
669 opendir D, "$htdocs";
670 my @dirlist = readdir D;
671 foreach my $directory (@dirlist) {
672 next if $directory eq 'lib';
673 -d "$htdocs/$directory/en" and push @themes, $directory;
680 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
685 tags => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
691 tags => [ qw/ 607a / ],
697 tags => [ qw/ 500a 501a 503a / ],
703 tags => [ qw/ 700ab 701ab 702ab / ],
704 sep => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
709 tags => [ qw/ 225a / ],
715 tags => [ qw/ 995c / ],
720 unless ( C4::Context->preference("singleBranchMode") || GetBranchesCount() == 1 ) {
723 label => 'Libraries',
724 tags => [ qw/ 995b / ],
727 push( @$facets, $library_facet );
734 tags => [ qw/ 650a / ],
739 # label => 'People and Organizations',
740 # tags => [ qw/ 600a 610a 611a / ],
746 tags => [ qw/ 651a / ],
752 tags => [ qw/ 630a / ],
758 tags => [ qw/ 100a 110a 700a / ],
764 tags => [ qw/ 440a 490a / ],
769 label => 'ItemTypes',
770 tags => [ qw/ 952y 942c / ],
776 tags => [ qw / 952c / ],
781 unless ( C4::Context->preference("singleBranchMode") || GetBranchesCount() == 1 ) {
784 label => 'Libraries',
785 tags => [ qw / 952b / ],
788 push( @$facets, $library_facet );
795 Return a href where a key is associated to a href. You give a query,
796 the name of the key among the fields returned by the query. If you
797 also give as third argument the name of the value, the function
798 returns a href of scalar. The optional 4th argument is an arrayref of
799 items passed to the C<execute()> call. It is designed to bind
800 parameters to any placeholders in your SQL.
809 # generic href of any information on the item, href of href.
810 my $iteminfos_of = get_infos_of($query, 'itemnumber');
811 print $iteminfos_of->{$itemnumber}{barcode};
813 # specific information, href of scalar
814 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
815 print $barcode_of_item->{$itemnumber};
820 my ( $query, $key_name, $value_name, $bind_params ) = @_;
822 my $dbh = C4::Context->dbh;
824 my $sth = $dbh->prepare($query);
825 $sth->execute( @$bind_params );
828 while ( my $row = $sth->fetchrow_hashref ) {
829 if ( defined $value_name ) {
830 $infos_of{ $row->{$key_name} } = $row->{$value_name};
833 $infos_of{ $row->{$key_name} } = $row;
841 =head2 get_notforloan_label_of
843 my $notforloan_label_of = get_notforloan_label_of();
845 Each authorised value of notforloan (information available in items and
846 itemtypes) is link to a single label.
848 Returns a href where keys are authorised values and values are corresponding
851 foreach my $authorised_value (keys %{$notforloan_label_of}) {
853 "authorised_value: %s => %s\n",
855 $notforloan_label_of->{$authorised_value}
861 # FIXME - why not use GetAuthorisedValues ??
863 sub get_notforloan_label_of {
864 my $dbh = C4::Context->dbh;
867 SELECT authorised_value
868 FROM marc_subfield_structure
869 WHERE kohafield = \'items.notforloan\'
872 my $sth = $dbh->prepare($query);
874 my ($statuscode) = $sth->fetchrow_array();
879 FROM authorised_values
882 $sth = $dbh->prepare($query);
883 $sth->execute($statuscode);
884 my %notforloan_label_of;
885 while ( my $row = $sth->fetchrow_hashref ) {
886 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
890 return \%notforloan_label_of;
893 =head2 displayServers
895 my $servers = displayServers();
896 my $servers = displayServers( $position );
897 my $servers = displayServers( $position, $type );
899 displayServers returns a listref of hashrefs, each containing
900 information about available z3950 servers. Each hashref has a format
904 'checked' => 'checked',
905 'encoding' => 'utf8',
907 'id' => 'LIBRARY OF CONGRESS',
911 'value' => 'lx2.loc.gov:210/',
918 my ( $position, $type ) = @_;
919 my $dbh = C4::Context->dbh;
921 my $strsth = 'SELECT * FROM z3950servers';
926 push @bind_params, $position;
927 push @where_clauses, ' position = ? ';
931 push @bind_params, $type;
932 push @where_clauses, ' type = ? ';
935 # reassemble where clause from where clause pieces
936 if (@where_clauses) {
937 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
940 my $rq = $dbh->prepare($strsth);
941 $rq->execute(@bind_params);
942 my @primaryserverloop;
944 while ( my $data = $rq->fetchrow_hashref ) {
945 push @primaryserverloop,
946 { label => $data->{description},
949 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
950 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
951 checked => "checked",
952 icon => $data->{icon},
953 zed => $data->{type} eq 'zed',
954 opensearch => $data->{type} eq 'opensearch'
957 return \@primaryserverloop;
961 =head2 GetKohaImageurlFromAuthorisedValues
963 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
965 Return the first url of the authorised value image represented by $lib.
969 sub GetKohaImageurlFromAuthorisedValues {
970 my ( $category, $lib ) = @_;
971 my $dbh = C4::Context->dbh;
972 my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
973 $sth->execute( $category, $lib );
974 while ( my $data = $sth->fetchrow_hashref ) {
975 return $data->{'imageurl'};
979 =head2 GetAuthValCode
981 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
986 my ($kohafield,$fwcode) = @_;
987 my $dbh = C4::Context->dbh;
988 $fwcode='' unless $fwcode;
989 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
990 $sth->execute($kohafield,$fwcode);
991 my ($authvalcode) = $sth->fetchrow_array;
995 =head2 GetAuthValCodeFromField
997 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
999 C<$subfield> can be undefined
1003 sub GetAuthValCodeFromField {
1004 my ($field,$subfield,$fwcode) = @_;
1005 my $dbh = C4::Context->dbh;
1006 $fwcode='' unless $fwcode;
1008 if (defined $subfield) {
1009 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1010 $sth->execute($field,$subfield,$fwcode);
1012 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1013 $sth->execute($field,$fwcode);
1015 my ($authvalcode) = $sth->fetchrow_array;
1016 return $authvalcode;
1019 =head2 GetAuthorisedValues
1021 $authvalues = GetAuthorisedValues([$category], [$selected]);
1023 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1025 C<$category> returns authorised values for just one category (optional).
1027 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1031 sub GetAuthorisedValues {
1032 my ( $category, $selected, $opac ) = @_;
1033 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
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;
1082 =head2 GetAuthorisedValueCategories
1084 $auth_categories = GetAuthorisedValueCategories();
1086 Return an arrayref of all of the available authorised
1091 sub GetAuthorisedValueCategories {
1092 my $dbh = C4::Context->dbh;
1093 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1096 while (defined (my $category = $sth->fetchrow_array) ) {
1097 push @results, $category;
1102 =head2 IsAuthorisedValueCategory
1104 $is_auth_val_category = IsAuthorisedValueCategory($category);
1106 Returns whether a given category name is a valid one
1110 sub IsAuthorisedValueCategory {
1111 my $category = shift;
1114 FROM authorised_values
1115 WHERE BINARY category=?
1118 my $sth = C4::Context->dbh->prepare($query);
1119 $sth->execute($category);
1120 $sth->fetchrow ? return 1
1124 =head2 GetAuthorisedValueByCode
1126 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1128 Return the lib attribute from authorised_values from the row identified
1129 by the passed category and code
1133 sub GetAuthorisedValueByCode {
1134 my ( $category, $authvalcode, $opac ) = @_;
1136 my $field = $opac ? 'lib_opac' : 'lib';
1137 my $dbh = C4::Context->dbh;
1138 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1139 $sth->execute( $category, $authvalcode );
1140 while ( my $data = $sth->fetchrow_hashref ) {
1141 return $data->{ $field };
1145 =head2 GetKohaAuthorisedValues
1147 Takes $kohafield, $fwcode as parameters.
1149 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1151 Returns hashref of Code => description
1153 Returns undef if no authorised value category is defined for the kohafield.
1157 sub GetKohaAuthorisedValues {
1158 my ($kohafield,$fwcode,$opac) = @_;
1159 $fwcode='' unless $fwcode;
1161 my $dbh = C4::Context->dbh;
1162 my $avcode = GetAuthValCode($kohafield,$fwcode);
1164 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1165 $sth->execute($avcode);
1166 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1167 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1175 =head2 GetKohaAuthorisedValuesFromField
1177 Takes $field, $subfield, $fwcode as parameters.
1179 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1180 $subfield can be undefined
1182 Returns hashref of Code => description
1184 Returns undef if no authorised value category is defined for the given field and subfield
1188 sub GetKohaAuthorisedValuesFromField {
1189 my ($field, $subfield, $fwcode,$opac) = @_;
1190 $fwcode='' unless $fwcode;
1192 my $dbh = C4::Context->dbh;
1193 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1195 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1196 $sth->execute($avcode);
1197 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1198 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1208 my $escaped_string = C4::Koha::xml_escape($string);
1210 Convert &, <, >, ', and " in a string to XML entities
1216 return '' unless defined $str;
1217 $str =~ s/&/&/g;
1220 $str =~ s/'/'/g;
1221 $str =~ s/"/"/g;
1225 =head2 GetKohaAuthorisedValueLib
1227 Takes $category, $authorised_value as parameters.
1229 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1231 Returns authorised value description
1235 sub GetKohaAuthorisedValueLib {
1236 my ($category,$authorised_value,$opac) = @_;
1238 my $dbh = C4::Context->dbh;
1239 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1240 $sth->execute($category,$authorised_value);
1241 my $data = $sth->fetchrow_hashref;
1242 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1246 =head2 AddAuthorisedValue
1248 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1250 Create a new authorised value.
1254 sub AddAuthorisedValue {
1255 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1257 my $dbh = C4::Context->dbh;
1259 INSERT INTO authorised_values (category, authorised_value, lib, lib_opac, imageurl)
1262 my $sth = $dbh->prepare($query);
1263 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1266 =head2 display_marc_indicators
1268 my $display_form = C4::Koha::display_marc_indicators($field);
1270 C<$field> is a MARC::Field object
1272 Generate a display form of the indicators of a variable
1273 MARC field, replacing any blanks with '#'.
1277 sub display_marc_indicators {
1279 my $indicators = '';
1280 if ($field->tag() >= 10) {
1281 $indicators = $field->indicator(1) . $field->indicator(2);
1282 $indicators =~ s/ /#/g;
1287 sub GetNormalizedUPC {
1288 my ($record,$marcflavour) = @_;
1291 if ($marcflavour eq 'UNIMARC') {
1292 @fields = $record->field('072');
1293 foreach my $field (@fields) {
1294 my $upc = _normalize_match_point($field->subfield('a'));
1301 else { # assume marc21 if not unimarc
1302 @fields = $record->field('024');
1303 foreach my $field (@fields) {
1304 my $indicator = $field->indicator(1);
1305 my $upc = _normalize_match_point($field->subfield('a'));
1306 if ($indicator == 1 and $upc ne '') {
1313 # Normalizes and returns the first valid ISBN found in the record
1314 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1315 sub GetNormalizedISBN {
1316 my ($isbn,$record,$marcflavour) = @_;
1319 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1320 # anything after " | " should be removed, along with the delimiter
1321 $isbn =~ s/(.*)( \| )(.*)/$1/;
1322 return _isbn_cleanup($isbn);
1324 return unless $record;
1326 if ($marcflavour eq 'UNIMARC') {
1327 @fields = $record->field('010');
1328 foreach my $field (@fields) {
1329 my $isbn = $field->subfield('a');
1331 return _isbn_cleanup($isbn);
1337 else { # assume marc21 if not unimarc
1338 @fields = $record->field('020');
1339 foreach my $field (@fields) {
1340 $isbn = $field->subfield('a');
1342 return _isbn_cleanup($isbn);
1350 sub GetNormalizedEAN {
1351 my ($record,$marcflavour) = @_;
1354 if ($marcflavour eq 'UNIMARC') {
1355 @fields = $record->field('073');
1356 foreach my $field (@fields) {
1357 $ean = _normalize_match_point($field->subfield('a'));
1363 else { # assume marc21 if not unimarc
1364 @fields = $record->field('024');
1365 foreach my $field (@fields) {
1366 my $indicator = $field->indicator(1);
1367 $ean = _normalize_match_point($field->subfield('a'));
1368 if ($indicator == 3 and $ean ne '') {
1374 sub GetNormalizedOCLCNumber {
1375 my ($record,$marcflavour) = @_;
1378 if ($marcflavour eq 'UNIMARC') {
1379 # TODO: add UNIMARC fields
1381 else { # assume marc21 if not unimarc
1382 @fields = $record->field('035');
1383 foreach my $field (@fields) {
1384 $oclc = $field->subfield('a');
1385 if ($oclc =~ /OCoLC/) {
1386 $oclc =~ s/\(OCoLC\)//;
1395 =head2 GetDailyQuote($opts)
1397 Takes a hashref of options
1399 Currently supported options are:
1401 'id' An exact quote id
1402 'random' Select a random quote
1403 noop When no option is passed in, this sub will return the quote timestamped for the current day
1405 The function returns an anonymous hash following this format:
1408 'source' => 'source-of-quote',
1409 'timestamp' => 'timestamp-value',
1410 'text' => 'text-of-quote',
1416 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1417 # at least for default option
1421 my $dbh = C4::Context->dbh;
1426 $query = 'SELECT * FROM quotes WHERE id = ?';
1427 $sth = $dbh->prepare($query);
1428 $sth->execute($opts{'id'});
1429 $quote = $sth->fetchrow_hashref();
1431 elsif ($opts{'random'}) {
1432 # Fall through... we also return a random quote as a catch-all if all else fails
1435 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1436 $sth = $dbh->prepare($query);
1438 $quote = $sth->fetchrow_hashref();
1440 unless ($quote) { # if there are not matches, choose a random quote
1441 # get a list of all available quote ids
1442 $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1444 my $range = ($sth->fetchrow_array)[0];
1445 # chose a random id within that range if there is more than one quote
1446 my $offset = int(rand($range));
1448 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1449 $sth = C4::Context->dbh->prepare($query);
1450 # see http://www.perlmonks.org/?node_id=837422 for why
1451 # we're being verbose and using bind_param
1452 $sth->bind_param(1, $offset, SQL_INTEGER);
1454 $quote = $sth->fetchrow_hashref();
1455 # update the timestamp for that quote
1456 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1457 $sth = C4::Context->dbh->prepare($query);
1459 DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1466 sub _normalize_match_point {
1467 my $match_point = shift;
1468 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1469 $normalized_match_point =~ s/-//g;
1471 return $normalized_match_point;
1475 require Business::ISBN;
1476 my $isbn = Business::ISBN->new( $_[0] );
1478 $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1479 if (defined $isbn) {
1480 return $isbn->as_string([]);