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 =~ /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/ 995e / ],
719 unless ( C4::Context->preference("singleBranchMode")
720 || GetBranchesCount() == 1 )
722 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
723 if ( $DisplayLibraryFacets eq 'both'
724 || $DisplayLibraryFacets eq 'holding' )
729 idx => 'holdingbranch',
730 label => 'HoldingLibrary',
731 tags => [qw / 995b /],
736 if ( $DisplayLibraryFacets eq 'both'
737 || $DisplayLibraryFacets eq 'home' )
743 label => 'HomeLibrary',
744 tags => [qw / 995a /],
755 tags => [ qw/ 650a / ],
760 # label => 'People and Organizations',
761 # tags => [ qw/ 600a 610a 611a / ],
767 tags => [ qw/ 651a / ],
773 tags => [ qw/ 630a / ],
779 tags => [ qw/ 100a 110a 700a / ],
785 tags => [ qw/ 440a 490a / ],
790 label => 'ItemTypes',
791 tags => [ qw/ 952y 942c / ],
797 tags => [ qw / 952c / ],
801 unless ( C4::Context->preference("singleBranchMode")
802 || GetBranchesCount() == 1 )
804 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
805 if ( $DisplayLibraryFacets eq 'both'
806 || $DisplayLibraryFacets eq 'holding' )
811 idx => 'holdingbranch',
812 label => 'HoldingLibrary',
813 tags => [qw / 952b /],
818 if ( $DisplayLibraryFacets eq 'both'
819 || $DisplayLibraryFacets eq 'home' )
825 label => 'HomeLibrary',
826 tags => [qw / 952a /],
837 Return a href where a key is associated to a href. You give a query,
838 the name of the key among the fields returned by the query. If you
839 also give as third argument the name of the value, the function
840 returns a href of scalar. The optional 4th argument is an arrayref of
841 items passed to the C<execute()> call. It is designed to bind
842 parameters to any placeholders in your SQL.
851 # generic href of any information on the item, href of href.
852 my $iteminfos_of = get_infos_of($query, 'itemnumber');
853 print $iteminfos_of->{$itemnumber}{barcode};
855 # specific information, href of scalar
856 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
857 print $barcode_of_item->{$itemnumber};
862 my ( $query, $key_name, $value_name, $bind_params ) = @_;
864 my $dbh = C4::Context->dbh;
866 my $sth = $dbh->prepare($query);
867 $sth->execute( @$bind_params );
870 while ( my $row = $sth->fetchrow_hashref ) {
871 if ( defined $value_name ) {
872 $infos_of{ $row->{$key_name} } = $row->{$value_name};
875 $infos_of{ $row->{$key_name} } = $row;
883 =head2 get_notforloan_label_of
885 my $notforloan_label_of = get_notforloan_label_of();
887 Each authorised value of notforloan (information available in items and
888 itemtypes) is link to a single label.
890 Returns a href where keys are authorised values and values are corresponding
893 foreach my $authorised_value (keys %{$notforloan_label_of}) {
895 "authorised_value: %s => %s\n",
897 $notforloan_label_of->{$authorised_value}
903 # FIXME - why not use GetAuthorisedValues ??
905 sub get_notforloan_label_of {
906 my $dbh = C4::Context->dbh;
909 SELECT authorised_value
910 FROM marc_subfield_structure
911 WHERE kohafield = \'items.notforloan\'
914 my $sth = $dbh->prepare($query);
916 my ($statuscode) = $sth->fetchrow_array();
921 FROM authorised_values
924 $sth = $dbh->prepare($query);
925 $sth->execute($statuscode);
926 my %notforloan_label_of;
927 while ( my $row = $sth->fetchrow_hashref ) {
928 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
932 return \%notforloan_label_of;
935 =head2 displayServers
937 my $servers = displayServers();
938 my $servers = displayServers( $position );
939 my $servers = displayServers( $position, $type );
941 displayServers returns a listref of hashrefs, each containing
942 information about available z3950 servers. Each hashref has a format
946 'checked' => 'checked',
947 'encoding' => 'utf8',
949 'id' => 'LIBRARY OF CONGRESS',
953 'value' => 'lx2.loc.gov:210/',
960 my ( $position, $type ) = @_;
961 my $dbh = C4::Context->dbh;
963 my $strsth = 'SELECT * FROM z3950servers';
968 push @bind_params, $position;
969 push @where_clauses, ' position = ? ';
973 push @bind_params, $type;
974 push @where_clauses, ' type = ? ';
977 # reassemble where clause from where clause pieces
978 if (@where_clauses) {
979 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
982 my $rq = $dbh->prepare($strsth);
983 $rq->execute(@bind_params);
984 my @primaryserverloop;
986 while ( my $data = $rq->fetchrow_hashref ) {
987 push @primaryserverloop,
988 { label => $data->{description},
991 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
992 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
993 checked => "checked",
994 icon => $data->{icon},
995 zed => $data->{type} eq 'zed',
996 opensearch => $data->{type} eq 'opensearch'
999 return \@primaryserverloop;
1003 =head2 GetKohaImageurlFromAuthorisedValues
1005 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
1007 Return the first url of the authorised value image represented by $lib.
1011 sub GetKohaImageurlFromAuthorisedValues {
1012 my ( $category, $lib ) = @_;
1013 my $dbh = C4::Context->dbh;
1014 my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
1015 $sth->execute( $category, $lib );
1016 while ( my $data = $sth->fetchrow_hashref ) {
1017 return $data->{'imageurl'};
1021 =head2 GetAuthValCode
1023 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1027 sub GetAuthValCode {
1028 my ($kohafield,$fwcode) = @_;
1029 my $dbh = C4::Context->dbh;
1030 $fwcode='' unless $fwcode;
1031 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1032 $sth->execute($kohafield,$fwcode);
1033 my ($authvalcode) = $sth->fetchrow_array;
1034 return $authvalcode;
1037 =head2 GetAuthValCodeFromField
1039 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1041 C<$subfield> can be undefined
1045 sub GetAuthValCodeFromField {
1046 my ($field,$subfield,$fwcode) = @_;
1047 my $dbh = C4::Context->dbh;
1048 $fwcode='' unless $fwcode;
1050 if (defined $subfield) {
1051 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1052 $sth->execute($field,$subfield,$fwcode);
1054 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1055 $sth->execute($field,$fwcode);
1057 my ($authvalcode) = $sth->fetchrow_array;
1058 return $authvalcode;
1061 =head2 GetAuthorisedValues
1063 $authvalues = GetAuthorisedValues([$category], [$selected]);
1065 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1067 C<$category> returns authorised values for just one category (optional).
1069 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1073 sub GetAuthorisedValues {
1074 my ( $category, $selected, $opac ) = @_;
1075 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1077 my $dbh = C4::Context->dbh;
1080 FROM authorised_values
1083 LEFT JOIN authorised_values_branches ON ( id = av_id )
1088 push @where_strings, "category = ?";
1089 push @where_args, $category;
1092 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1093 push @where_args, $branch_limit;
1095 if(@where_strings > 0) {
1096 $query .= " WHERE " . join(" AND ", @where_strings);
1098 $query .= " GROUP BY lib";
1099 $query .= ' ORDER BY category, ' . (
1100 $opac ? 'COALESCE(lib_opac, lib)'
1104 my $sth = $dbh->prepare($query);
1106 $sth->execute( @where_args );
1107 while (my $data=$sth->fetchrow_hashref) {
1108 if ( defined $selected and $selected eq $data->{authorised_value} ) {
1109 $data->{selected} = 1;
1112 $data->{selected} = 0;
1115 if ($opac && $data->{lib_opac}) {
1116 $data->{lib} = $data->{lib_opac};
1118 push @results, $data;
1124 =head2 GetAuthorisedValueCategories
1126 $auth_categories = GetAuthorisedValueCategories();
1128 Return an arrayref of all of the available authorised
1133 sub GetAuthorisedValueCategories {
1134 my $dbh = C4::Context->dbh;
1135 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1138 while (defined (my $category = $sth->fetchrow_array) ) {
1139 push @results, $category;
1144 =head2 IsAuthorisedValueCategory
1146 $is_auth_val_category = IsAuthorisedValueCategory($category);
1148 Returns whether a given category name is a valid one
1152 sub IsAuthorisedValueCategory {
1153 my $category = shift;
1156 FROM authorised_values
1157 WHERE BINARY category=?
1160 my $sth = C4::Context->dbh->prepare($query);
1161 $sth->execute($category);
1162 $sth->fetchrow ? return 1
1166 =head2 GetAuthorisedValueByCode
1168 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1170 Return the lib attribute from authorised_values from the row identified
1171 by the passed category and code
1175 sub GetAuthorisedValueByCode {
1176 my ( $category, $authvalcode, $opac ) = @_;
1178 my $field = $opac ? 'lib_opac' : 'lib';
1179 my $dbh = C4::Context->dbh;
1180 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1181 $sth->execute( $category, $authvalcode );
1182 while ( my $data = $sth->fetchrow_hashref ) {
1183 return $data->{ $field };
1187 =head2 GetKohaAuthorisedValues
1189 Takes $kohafield, $fwcode as parameters.
1191 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1193 Returns hashref of Code => description
1195 Returns undef if no authorised value category is defined for the kohafield.
1199 sub GetKohaAuthorisedValues {
1200 my ($kohafield,$fwcode,$opac) = @_;
1201 $fwcode='' unless $fwcode;
1203 my $dbh = C4::Context->dbh;
1204 my $avcode = GetAuthValCode($kohafield,$fwcode);
1206 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1207 $sth->execute($avcode);
1208 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1209 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1217 =head2 GetKohaAuthorisedValuesFromField
1219 Takes $field, $subfield, $fwcode as parameters.
1221 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1222 $subfield can be undefined
1224 Returns hashref of Code => description
1226 Returns undef if no authorised value category is defined for the given field and subfield
1230 sub GetKohaAuthorisedValuesFromField {
1231 my ($field, $subfield, $fwcode,$opac) = @_;
1232 $fwcode='' unless $fwcode;
1234 my $dbh = C4::Context->dbh;
1235 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1237 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1238 $sth->execute($avcode);
1239 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1240 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1250 my $escaped_string = C4::Koha::xml_escape($string);
1252 Convert &, <, >, ', and " in a string to XML entities
1258 return '' unless defined $str;
1259 $str =~ s/&/&/g;
1262 $str =~ s/'/'/g;
1263 $str =~ s/"/"/g;
1267 =head2 GetKohaAuthorisedValueLib
1269 Takes $category, $authorised_value as parameters.
1271 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1273 Returns authorised value description
1277 sub GetKohaAuthorisedValueLib {
1278 my ($category,$authorised_value,$opac) = @_;
1280 my $dbh = C4::Context->dbh;
1281 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1282 $sth->execute($category,$authorised_value);
1283 my $data = $sth->fetchrow_hashref;
1284 $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1288 =head2 AddAuthorisedValue
1290 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1292 Create a new authorised value.
1296 sub AddAuthorisedValue {
1297 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1299 my $dbh = C4::Context->dbh;
1301 INSERT INTO authorised_values (category, authorised_value, lib, lib_opac, imageurl)
1304 my $sth = $dbh->prepare($query);
1305 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1308 =head2 display_marc_indicators
1310 my $display_form = C4::Koha::display_marc_indicators($field);
1312 C<$field> is a MARC::Field object
1314 Generate a display form of the indicators of a variable
1315 MARC field, replacing any blanks with '#'.
1319 sub display_marc_indicators {
1321 my $indicators = '';
1322 if ($field->tag() >= 10) {
1323 $indicators = $field->indicator(1) . $field->indicator(2);
1324 $indicators =~ s/ /#/g;
1329 sub GetNormalizedUPC {
1330 my ($record,$marcflavour) = @_;
1333 if ($marcflavour eq 'UNIMARC') {
1334 @fields = $record->field('072');
1335 foreach my $field (@fields) {
1336 my $upc = _normalize_match_point($field->subfield('a'));
1343 else { # assume marc21 if not unimarc
1344 @fields = $record->field('024');
1345 foreach my $field (@fields) {
1346 my $indicator = $field->indicator(1);
1347 my $upc = _normalize_match_point($field->subfield('a'));
1348 if ($indicator == 1 and $upc ne '') {
1355 # Normalizes and returns the first valid ISBN found in the record
1356 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1357 sub GetNormalizedISBN {
1358 my ($isbn,$record,$marcflavour) = @_;
1361 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1362 # anything after " | " should be removed, along with the delimiter
1363 $isbn =~ s/(.*)( \| )(.*)/$1/;
1364 return _isbn_cleanup($isbn);
1366 return unless $record;
1368 if ($marcflavour eq 'UNIMARC') {
1369 @fields = $record->field('010');
1370 foreach my $field (@fields) {
1371 my $isbn = $field->subfield('a');
1373 return _isbn_cleanup($isbn);
1379 else { # assume marc21 if not unimarc
1380 @fields = $record->field('020');
1381 foreach my $field (@fields) {
1382 $isbn = $field->subfield('a');
1384 return _isbn_cleanup($isbn);
1392 sub GetNormalizedEAN {
1393 my ($record,$marcflavour) = @_;
1396 if ($marcflavour eq 'UNIMARC') {
1397 @fields = $record->field('073');
1398 foreach my $field (@fields) {
1399 $ean = _normalize_match_point($field->subfield('a'));
1405 else { # assume marc21 if not unimarc
1406 @fields = $record->field('024');
1407 foreach my $field (@fields) {
1408 my $indicator = $field->indicator(1);
1409 $ean = _normalize_match_point($field->subfield('a'));
1410 if ($indicator == 3 and $ean ne '') {
1416 sub GetNormalizedOCLCNumber {
1417 my ($record,$marcflavour) = @_;
1420 if ($marcflavour eq 'UNIMARC') {
1421 # TODO: add UNIMARC fields
1423 else { # assume marc21 if not unimarc
1424 @fields = $record->field('035');
1425 foreach my $field (@fields) {
1426 $oclc = $field->subfield('a');
1427 if ($oclc =~ /OCoLC/) {
1428 $oclc =~ s/\(OCoLC\)//;
1437 sub GetAuthvalueDropbox {
1438 my ( $authcat, $default ) = @_;
1439 my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1440 my $dbh = C4::Context->dbh;
1444 FROM authorised_values
1447 LEFT JOIN authorised_values_branches ON ( id = av_id )
1452 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1453 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1454 my $sth = $dbh->prepare($query);
1455 $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1458 my $option_list = [];
1459 my @authorised_values = ( q{} );
1460 while (my $av = $sth->fetchrow_hashref) {
1461 push @
{$option_list}, {
1462 value
=> $av->{authorised_value
},
1463 label
=> $av->{lib
},
1464 default => ($default eq $av->{authorised_value
}),
1468 if ( @
{$option_list} ) {
1469 return $option_list;
1475 =head2 GetDailyQuote($opts)
1477 Takes a hashref of options
1479 Currently supported options are:
1481 'id' An exact quote id
1482 'random' Select a random quote
1483 noop When no option is passed in, this sub will return the quote timestamped for the current day
1485 The function returns an anonymous hash following this format:
1488 'source' => 'source-of-quote',
1489 'timestamp' => 'timestamp-value',
1490 'text' => 'text-of-quote',
1496 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1497 # at least for default option
1501 my $dbh = C4
::Context
->dbh;
1506 $query = 'SELECT * FROM quotes WHERE id = ?';
1507 $sth = $dbh->prepare($query);
1508 $sth->execute($opts{'id'});
1509 $quote = $sth->fetchrow_hashref();
1511 elsif ($opts{'random'}) {
1512 # Fall through... we also return a random quote as a catch-all if all else fails
1515 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1516 $sth = $dbh->prepare($query);
1518 $quote = $sth->fetchrow_hashref();
1520 unless ($quote) { # if there are not matches, choose a random quote
1521 # get a list of all available quote ids
1522 $sth = C4
::Context
->dbh->prepare('SELECT count(*) FROM quotes;');
1524 my $range = ($sth->fetchrow_array)[0];
1525 # chose a random id within that range if there is more than one quote
1526 my $offset = int(rand($range));
1528 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1529 $sth = C4
::Context
->dbh->prepare($query);
1530 # see http://www.perlmonks.org/?node_id=837422 for why
1531 # we're being verbose and using bind_param
1532 $sth->bind_param(1, $offset, SQL_INTEGER
);
1534 $quote = $sth->fetchrow_hashref();
1535 # update the timestamp for that quote
1536 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1537 $sth = C4
::Context
->dbh->prepare($query);
1539 DateTime
::Format
::MySQL
->format_datetime( dt_from_string
() ),
1546 sub _normalize_match_point
{
1547 my $match_point = shift;
1548 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1549 $normalized_match_point =~ s/-//g;
1551 return $normalized_match_point;
1555 require Business
::ISBN
;
1556 my $isbn = Business
::ISBN
->new( $_[0] );
1558 $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1559 if (defined $isbn) {
1560 return $isbn->as_string([]);