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
;
32 use autouse
'Data::Dumper' => qw(Dumper);
33 use DBI
qw(:sql_types);
35 use vars
qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
38 $VERSION = 3.07.00.049;
43 &subfield_is_koha_internal_p
44 &GetPrinters &GetPrinter
45 &GetItemTypes &getitemtypeinfo
46 &GetSupportName &GetSupportList
48 &getframeworks &getframeworkinfo
50 &getauthtypes &getauthtype
56 &get_notforloan_label_of
59 &getitemtypeimagelocation
61 &GetAuthorisedValueCategories
62 &IsAuthorisedValueCategory
63 &GetKohaAuthorisedValues
64 &GetKohaAuthorisedValuesFromField
65 &GetKohaAuthorisedValueLib
66 &GetAuthorisedValueByCode
67 &GetKohaImageurlFromAuthorisedValues
73 &GetNormalizedOCLCNumber
83 @EXPORT_OK = qw( GetDailyQuote );
87 memoize
('GetAuthorisedValues');
91 C4::Koha - Perl Module containing convenience functions for Koha scripts
99 Koha.pm provides many functions for Koha scripts.
107 $slash_date = &slashifyDate($dash_date);
109 Takes a string of the form "DD-MM-YYYY" (or anything separated by
110 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
116 # accepts a date of the form xx-xx-xx[xx] and returns it in the
118 my @dateOut = split( '-', shift );
119 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
122 # FIXME.. this should be moved to a MARC-specific module
123 sub subfield_is_koha_internal_p
{
126 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
127 # But real MARC subfields are always single-character
128 # so it really is safer just to check the length
130 return length $subfield != 1;
133 =head2 GetSupportName
135 $itemtypename = &GetSupportName($codestring);
137 Returns a string with the name of the itemtype.
143 return if (! $codestring);
145 my $advanced_search_types = C4
::Context
->preference("AdvancedSearchTypes");
146 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
153 my $sth = C4
::Context
->dbh->prepare($query);
154 $sth->execute($codestring);
155 ($resultstring)=$sth->fetchrow;
156 return $resultstring;
159 C4
::Context
->dbh->prepare(
160 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
162 $sth->execute( $advanced_search_types, $codestring );
163 my $data = $sth->fetchrow_hashref;
164 return $$data{'lib'};
168 =head2 GetSupportList
170 $itemtypes = &GetSupportList();
172 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
174 build a HTML select with the following code :
176 =head3 in PERL SCRIPT
178 my $itemtypes = GetSupportList();
179 $template->param(itemtypeloop => $itemtypes);
183 <select name="itemtype" id="itemtype">
184 <option value=""></option>
185 [% FOREACH itemtypeloo IN itemtypeloop %]
186 [% IF ( itemtypeloo.selected ) %]
187 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
189 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
197 my $advanced_search_types = C4
::Context
->preference("AdvancedSearchTypes");
198 if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
204 my $sth = C4
::Context
->dbh->prepare($query);
206 return $sth->fetchall_arrayref({});
208 my $advsearchtypes = GetAuthorisedValues
($advanced_search_types);
209 my @results= map {{itemtype
=>$$_{authorised_value
},description
=>$$_{lib
},imageurl
=>$$_{imageurl
}}} @
$advsearchtypes;
215 $itemtypes = &GetItemTypes( style => $style );
217 Returns information about existing itemtypes.
220 style: either 'array' or 'hash', defaults to 'hash'.
221 'array' returns an arrayref,
222 'hash' return a hashref with the itemtype value as the key
224 build a HTML select with the following code :
226 =head3 in PERL SCRIPT
228 my $itemtypes = GetItemTypes;
230 foreach my $thisitemtype (sort keys %$itemtypes) {
231 my $selected = 1 if $thisitemtype eq $itemtype;
232 my %row =(value => $thisitemtype,
233 selected => $selected,
234 description => $itemtypes->{$thisitemtype}->{'description'},
236 push @itemtypesloop, \%row;
238 $template->param(itemtypeloop => \@itemtypesloop);
242 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
243 <select name="itemtype">
244 <option value="">Default</option>
245 <!-- TMPL_LOOP name="itemtypeloop" -->
246 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
249 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
250 <input type="submit" value="OK" class="button">
257 my $style = defined( $params{'style'} ) ?
$params{'style'} : 'hash';
259 # returns a reference to a hash of references to itemtypes...
261 my $dbh = C4
::Context
->dbh;
266 my $sth = $dbh->prepare($query);
269 if ( $style eq 'hash' ) {
270 while ( my $IT = $sth->fetchrow_hashref ) {
271 $itemtypes{ $IT->{'itemtype'} } = $IT;
273 return ( \
%itemtypes );
275 return $sth->fetchall_arrayref({});
279 sub get_itemtypeinfos_of
{
282 my $placeholders = join( ', ', map { '?' } @itemtypes );
283 my $query = <<"END_SQL";
289 WHERE itemtype IN ( $placeholders )
292 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
297 $authtypes = &getauthtypes();
299 Returns information about existing authtypes.
301 build a HTML select with the following code :
303 =head3 in PERL SCRIPT
305 my $authtypes = getauthtypes;
307 foreach my $thisauthtype (keys %$authtypes) {
308 my $selected = 1 if $thisauthtype eq $authtype;
309 my %row =(value => $thisauthtype,
310 selected => $selected,
311 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
313 push @authtypesloop, \%row;
315 $template->param(itemtypeloop => \@itemtypesloop);
319 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
320 <select name="authtype">
321 <!-- TMPL_LOOP name="authtypeloop" -->
322 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
325 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
326 <input type="submit" value="OK" class="button">
334 # returns a reference to a hash of references to authtypes...
336 my $dbh = C4::Context->dbh;
337 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
339 while ( my $IT = $sth->fetchrow_hashref ) {
340 $authtypes{ $IT->{'authtypecode'} } = $IT;
342 return ( \%authtypes );
346 my ($authtypecode) = @_;
348 # returns a reference to a hash of references to authtypes...
350 my $dbh = C4::Context->dbh;
351 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
352 $sth->execute($authtypecode);
353 my $res = $sth->fetchrow_hashref;
359 $frameworks = &getframework();
361 Returns information about existing frameworks
363 build a HTML select with the following code :
365 =head3 in PERL SCRIPT
367 my $frameworks = getframeworks();
369 foreach my $thisframework (keys %$frameworks) {
370 my $selected = 1 if $thisframework eq $frameworkcode;
372 value => $thisframework,
373 selected => $selected,
374 description => $frameworks->{$thisframework}->{'frameworktext'},
376 push @frameworksloop, \%row;
378 $template->param(frameworkloop => \@frameworksloop);
382 <form action="[% script_name %] method=post>
383 <select name="frameworkcode">
384 <option value="">Default</option>
385 [% FOREACH framework IN frameworkloop %]
386 [% IF ( framework.selected ) %]
387 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
389 <option value="[% framework.value %]">[% framework.description %]</option>
393 <input type
=text name
=searchfield value
="[% searchfield %]">
394 <input type
="submit" value
="OK" class="button">
401 # returns a reference to a hash of references to branches...
403 my $dbh = C4
::Context
->dbh;
404 my $sth = $dbh->prepare("select * from biblio_framework");
406 while ( my $IT = $sth->fetchrow_hashref ) {
407 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
409 return ( \
%itemtypes );
412 =head2 GetFrameworksLoop
414 $frameworks = GetFrameworksLoop( $frameworkcode );
416 Returns the loop suggested on getframework(), but ordered by framework description.
418 build a HTML select with the following code :
420 =head3 in PERL SCRIPT
422 $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
426 Same as getframework()
428 <form action="[% script_name %] method=post>
429 <select name="frameworkcode">
430 <option value="">Default</option>
431 [% FOREACH framework IN frameworkloop %]
432 [% IF ( framework.selected ) %]
433 <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
435 <option value="[% framework.value %]">[% framework.description %]</option>
439 <input type=text name=searchfield value="[% searchfield %]">
440 <input type="submit" value="OK" class="button">
445 sub GetFrameworksLoop
{
446 my $frameworkcode = shift;
447 my $frameworks = getframeworks
();
449 foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
450 my $selected = ( $thisframework eq $frameworkcode ) ?
1 : undef;
452 value
=> $thisframework,
453 selected
=> $selected,
454 description
=> $frameworks->{$thisframework}->{'frameworktext'},
456 push @frameworkloop, \
%row;
458 return \
@frameworkloop;
461 =head2 getframeworkinfo
463 $frameworkinfo = &getframeworkinfo($frameworkcode);
465 Returns information about an frameworkcode.
469 sub getframeworkinfo
{
470 my ($frameworkcode) = @_;
471 my $dbh = C4
::Context
->dbh;
473 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
474 $sth->execute($frameworkcode);
475 my $res = $sth->fetchrow_hashref;
479 =head2 getitemtypeinfo
481 $itemtype = &getitemtypeinfo($itemtype, [$interface]);
483 Returns information about an itemtype. The optional $interface argument
484 sets which interface ('opac' or 'intranet') to return the imageurl for.
485 Defaults to intranet.
489 sub getitemtypeinfo
{
490 my ($itemtype, $interface) = @_;
491 my $dbh = C4
::Context
->dbh;
492 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
493 $sth->execute($itemtype);
494 my $res = $sth->fetchrow_hashref;
496 $res->{imageurl
} = getitemtypeimagelocation
( ( ( defined $interface && $interface eq 'opac' ) ?
'opac' : 'intranet' ), $res->{imageurl
} );
501 =head2 getitemtypeimagedir
503 my $directory = getitemtypeimagedir( 'opac' );
505 pass in 'opac' or 'intranet'. Defaults to 'opac'.
507 returns the full path to the appropriate directory containing images.
511 sub getitemtypeimagedir
{
512 my $src = shift || 'opac';
513 if ($src eq 'intranet') {
514 return C4
::Context
->config('intrahtdocs') . '/' .C4
::Context
->preference('template') . '/img/itemtypeimg';
516 return C4
::Context
->config('opachtdocs') . '/' . C4
::Context
->preference('opacthemes') . '/itemtypeimg';
520 sub getitemtypeimagesrc
{
521 my $src = shift || 'opac';
522 if ($src eq 'intranet') {
523 return '/intranet-tmpl' . '/' . C4
::Context
->preference('template') . '/img/itemtypeimg';
525 return '/opac-tmpl' . '/' . C4
::Context
->preference('opacthemes') . '/itemtypeimg';
529 sub getitemtypeimagelocation
{
530 my ( $src, $image ) = @_;
532 return '' if ( !$image );
535 my $scheme = ( URI
::Split
::uri_split
( $image ) )[0];
537 return $image if ( $scheme );
539 return getitemtypeimagesrc
( $src ) . '/' . $image;
542 =head3 _getImagesFromDirectory
544 Find all of the image files in a directory in the filesystem
546 parameters: a directory name
548 returns: a list of images in that directory.
550 Notes: this does not traverse into subdirectories. See
551 _getSubdirectoryNames for help with that.
552 Images are assumed to be files with .gif or .png file extensions.
553 The image names returned do not have the directory name on them.
557 sub _getImagesFromDirectory
{
558 my $directoryname = shift;
559 return unless defined $directoryname;
560 return unless -d
$directoryname;
562 if ( opendir ( my $dh, $directoryname ) ) {
563 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
565 @images = sort(@images);
568 warn "unable to opendir $directoryname: $!";
573 =head3 _getSubdirectoryNames
575 Find all of the directories in a directory in the filesystem
577 parameters: a directory name
579 returns: a list of subdirectories in that directory.
581 Notes: this does not traverse into subdirectories. Only the first
582 level of subdirectories are returned.
583 The directory names returned don't have the parent directory name on them.
587 sub _getSubdirectoryNames
{
588 my $directoryname = shift;
589 return unless defined $directoryname;
590 return unless -d
$directoryname;
592 if ( opendir ( my $dh, $directoryname ) ) {
593 my @directories = grep { -d File
::Spec
->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
597 warn "unable to opendir $directoryname: $!";
604 returns: a listref of hashrefs. Each hash represents another collection of images.
606 { imagesetname => 'npl', # the name of the image set (npl is the original one)
607 images => listref of image hashrefs
610 each image is represented by a hashref like this:
612 { KohaImage => 'npl/image.gif',
613 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
614 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
615 checked => 0 or 1: was this the image passed to this method?
616 Note: I'd like to remove this somehow.
623 my $checked = $params{'checked'} || '';
625 my $paths = { staff
=> { filesystem
=> getitemtypeimagedir
('intranet'),
626 url
=> getitemtypeimagesrc
('intranet'),
628 opac
=> { filesystem
=> getitemtypeimagedir
('opac'),
629 url
=> getitemtypeimagesrc
('opac'),
633 my @imagesets = (); # list of hasrefs of image set data to pass to template
634 my @subdirectories = _getSubdirectoryNames
( $paths->{'staff'}{'filesystem'} );
635 foreach my $imagesubdir ( @subdirectories ) {
636 warn $imagesubdir if $DEBUG;
637 my @imagelist = (); # hashrefs of image info
638 my @imagenames = _getImagesFromDirectory
( File
::Spec
->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
639 my $imagesetactive = 0;
640 foreach my $thisimage ( @imagenames ) {
642 { KohaImage
=> "$imagesubdir/$thisimage",
643 StaffImageUrl
=> join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
644 OpacImageUrl
=> join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
645 checked
=> "$imagesubdir/$thisimage" eq $checked ?
1 : 0,
648 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
650 push @imagesets, { imagesetname
=> $imagesubdir,
651 imagesetactive
=> $imagesetactive,
652 images
=> \
@imagelist };
660 $printers = &GetPrinters();
661 @queues = keys %$printers;
663 Returns information about existing printer queues.
665 C<$printers> is a reference-to-hash whose keys are the print queues
666 defined in the printers table of the Koha database. The values are
667 references-to-hash, whose keys are the fields in the printers table.
673 my $dbh = C4
::Context
->dbh;
674 my $sth = $dbh->prepare("select * from printers");
676 while ( my $printer = $sth->fetchrow_hashref ) {
677 $printers{ $printer->{'printqueue'} } = $printer;
679 return ( \
%printers );
684 $printer = GetPrinter( $query, $printers );
689 my ( $query, $printers ) = @_; # get printer for this query from printers
690 my $printer = $query->param('printer');
691 my %cookie = $query->cookie('userenv');
692 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
693 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
699 Returns the number of pages to display in a pagination bar, given the number
700 of items and the number of items per page.
705 my ( $nb_items, $nb_items_per_page ) = @_;
707 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
712 (@themes) = &getallthemes('opac');
713 (@themes) = &getallthemes('intranet');
715 Returns an array of all available themes.
723 if ( $type eq 'intranet' ) {
724 $htdocs = C4
::Context
->config('intrahtdocs');
727 $htdocs = C4
::Context
->config('opachtdocs');
729 opendir D
, "$htdocs";
730 my @dirlist = readdir D
;
731 foreach my $directory (@dirlist) {
732 next if $directory eq 'lib';
733 -d
"$htdocs/$directory/en" and push @themes, $directory;
740 if ( C4
::Context
->preference("marcflavour") eq "UNIMARC" ) {
745 tags
=> [ qw
/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
751 tags
=> [ qw
/ 607a / ],
757 tags
=> [ qw
/ 500a 501a 503a / ],
763 tags
=> [ qw
/ 700ab 701ab 702ab / ],
764 sep
=> C4
::Context
->preference("UNIMARCAuthorsFacetsSeparator"),
769 tags
=> [ qw
/ 225a / ],
775 tags
=> [ qw
/ 995e / ],
779 unless ( C4
::Context
->preference("singleBranchMode")
780 || GetBranchesCount
() == 1 )
782 my $DisplayLibraryFacets = C4
::Context
->preference('DisplayLibraryFacets');
783 if ( $DisplayLibraryFacets eq 'both'
784 || $DisplayLibraryFacets eq 'holding' )
789 idx
=> 'holdingbranch',
790 label
=> 'HoldingLibrary',
791 tags
=> [qw
/ 995b /],
796 if ( $DisplayLibraryFacets eq 'both'
797 || $DisplayLibraryFacets eq 'home' )
803 label
=> 'HomeLibrary',
804 tags
=> [qw
/ 995a /],
815 tags
=> [ qw
/ 650a / ],
820 # label => 'People and Organizations',
821 # tags => [ qw/ 600a 610a 611a / ],
827 tags
=> [ qw
/ 651a / ],
833 tags
=> [ qw
/ 630a / ],
839 tags
=> [ qw
/ 100a 110a 700a / ],
845 tags
=> [ qw
/ 440a 490a / ],
850 label
=> 'ItemTypes',
851 tags
=> [ qw
/ 952y 942c / ],
857 tags
=> [ qw
/ 952c / ],
861 unless ( C4
::Context
->preference("singleBranchMode")
862 || GetBranchesCount
() == 1 )
864 my $DisplayLibraryFacets = C4
::Context
->preference('DisplayLibraryFacets');
865 if ( $DisplayLibraryFacets eq 'both'
866 || $DisplayLibraryFacets eq 'holding' )
871 idx
=> 'holdingbranch',
872 label
=> 'HoldingLibrary',
873 tags
=> [qw
/ 952b /],
878 if ( $DisplayLibraryFacets eq 'both'
879 || $DisplayLibraryFacets eq 'home' )
885 label
=> 'HomeLibrary',
886 tags
=> [qw
/ 952a /],
897 Return a href where a key is associated to a href. You give a query,
898 the name of the key among the fields returned by the query. If you
899 also give as third argument the name of the value, the function
900 returns a href of scalar. The optional 4th argument is an arrayref of
901 items passed to the C<execute()> call. It is designed to bind
902 parameters to any placeholders in your SQL.
911 # generic href of any information on the item, href of href.
912 my $iteminfos_of = get_infos_of($query, 'itemnumber');
913 print $iteminfos_of->{$itemnumber}{barcode};
915 # specific information, href of scalar
916 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
917 print $barcode_of_item->{$itemnumber};
922 my ( $query, $key_name, $value_name, $bind_params ) = @_;
924 my $dbh = C4
::Context
->dbh;
926 my $sth = $dbh->prepare($query);
927 $sth->execute( @
$bind_params );
930 while ( my $row = $sth->fetchrow_hashref ) {
931 if ( defined $value_name ) {
932 $infos_of{ $row->{$key_name} } = $row->{$value_name};
935 $infos_of{ $row->{$key_name} } = $row;
943 =head2 get_notforloan_label_of
945 my $notforloan_label_of = get_notforloan_label_of();
947 Each authorised value of notforloan (information available in items and
948 itemtypes) is link to a single label.
950 Returns a href where keys are authorised values and values are corresponding
953 foreach my $authorised_value (keys %{$notforloan_label_of}) {
955 "authorised_value: %s => %s\n",
957 $notforloan_label_of->{$authorised_value}
963 # FIXME - why not use GetAuthorisedValues ??
965 sub get_notforloan_label_of
{
966 my $dbh = C4
::Context
->dbh;
969 SELECT authorised_value
970 FROM marc_subfield_structure
971 WHERE kohafield = \'items.notforloan\'
974 my $sth = $dbh->prepare($query);
976 my ($statuscode) = $sth->fetchrow_array();
981 FROM authorised_values
984 $sth = $dbh->prepare($query);
985 $sth->execute($statuscode);
986 my %notforloan_label_of;
987 while ( my $row = $sth->fetchrow_hashref ) {
988 $notforloan_label_of{ $row->{authorised_value
} } = $row->{lib
};
992 return \
%notforloan_label_of;
995 =head2 displayServers
997 my $servers = displayServers();
998 my $servers = displayServers( $position );
999 my $servers = displayServers( $position, $type );
1001 displayServers returns a listref of hashrefs, each containing
1002 information about available z3950 servers. Each hashref has a format
1006 'checked' => 'checked',
1007 'encoding' => 'utf8',
1009 'id' => 'LIBRARY OF CONGRESS',
1013 'value' => 'lx2.loc.gov:210/',
1019 sub displayServers
{
1020 my ( $position, $type ) = @_;
1021 my $dbh = C4
::Context
->dbh;
1023 my $strsth = 'SELECT * FROM z3950servers';
1028 push @bind_params, $position;
1029 push @where_clauses, ' position = ? ';
1033 push @bind_params, $type;
1034 push @where_clauses, ' type = ? ';
1037 # reassemble where clause from where clause pieces
1038 if (@where_clauses) {
1039 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1042 my $rq = $dbh->prepare($strsth);
1043 $rq->execute(@bind_params);
1044 my @primaryserverloop;
1046 while ( my $data = $rq->fetchrow_hashref ) {
1047 push @primaryserverloop,
1048 { label
=> $data->{description
},
1049 id
=> $data->{name
},
1051 value
=> $data->{host
} . ":" . $data->{port
} . "/" . $data->{database
},
1052 encoding
=> ( $data->{encoding
} ?
$data->{encoding
} : "iso-5426" ),
1053 checked
=> "checked",
1054 icon
=> $data->{icon
},
1055 zed
=> $data->{type
} eq 'zed',
1056 opensearch
=> $data->{type
} eq 'opensearch'
1059 return \
@primaryserverloop;
1063 =head2 GetKohaImageurlFromAuthorisedValues
1065 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
1067 Return the first url of the authorised value image represented by $lib.
1071 sub GetKohaImageurlFromAuthorisedValues
{
1072 my ( $category, $lib ) = @_;
1073 my $dbh = C4
::Context
->dbh;
1074 my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
1075 $sth->execute( $category, $lib );
1076 while ( my $data = $sth->fetchrow_hashref ) {
1077 return $data->{'imageurl'};
1081 =head2 GetAuthValCode
1083 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1087 sub GetAuthValCode
{
1088 my ($kohafield,$fwcode) = @_;
1089 my $dbh = C4
::Context
->dbh;
1090 $fwcode='' unless $fwcode;
1091 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1092 $sth->execute($kohafield,$fwcode);
1093 my ($authvalcode) = $sth->fetchrow_array;
1094 return $authvalcode;
1097 =head2 GetAuthValCodeFromField
1099 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1101 C<$subfield> can be undefined
1105 sub GetAuthValCodeFromField
{
1106 my ($field,$subfield,$fwcode) = @_;
1107 my $dbh = C4
::Context
->dbh;
1108 $fwcode='' unless $fwcode;
1110 if (defined $subfield) {
1111 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1112 $sth->execute($field,$subfield,$fwcode);
1114 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1115 $sth->execute($field,$fwcode);
1117 my ($authvalcode) = $sth->fetchrow_array;
1118 return $authvalcode;
1121 =head2 GetAuthorisedValues
1123 $authvalues = GetAuthorisedValues([$category], [$selected]);
1125 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1127 C<$category> returns authorised values for just one category (optional).
1129 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1133 sub GetAuthorisedValues
{
1134 my ( $category, $selected, $opac ) = @_;
1135 my $branch_limit = C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : "";
1137 my $dbh = C4
::Context
->dbh;
1140 FROM authorised_values
1143 LEFT JOIN authorised_values_branches ON
( id
= av_id
)
1148 push @where_strings, "category = ?";
1149 push @where_args, $category;
1152 push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1153 push @where_args, $branch_limit;
1155 if(@where_strings > 0) {
1156 $query .= " WHERE " . join(" AND ", @where_strings);
1158 $query .= " GROUP BY lib";
1159 $query .= ' ORDER BY category, ' . (
1160 $opac ?
'COALESCE(lib_opac, lib)'
1164 my $sth = $dbh->prepare($query);
1166 $sth->execute( @where_args );
1167 while (my $data=$sth->fetchrow_hashref) {
1168 if ( defined $selected and $selected eq $data->{authorised_value
} ) {
1169 $data->{selected
} = 1;
1172 $data->{selected
} = 0;
1175 if ($opac && $data->{lib_opac
}) {
1176 $data->{lib
} = $data->{lib_opac
};
1178 push @results, $data;
1184 =head2 GetAuthorisedValueCategories
1186 $auth_categories = GetAuthorisedValueCategories();
1188 Return an arrayref of all of the available authorised
1193 sub GetAuthorisedValueCategories
{
1194 my $dbh = C4
::Context
->dbh;
1195 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1198 while (defined (my $category = $sth->fetchrow_array) ) {
1199 push @results, $category;
1204 =head2 IsAuthorisedValueCategory
1206 $is_auth_val_category = IsAuthorisedValueCategory($category);
1208 Returns whether a given category name is a valid one
1212 sub IsAuthorisedValueCategory
{
1213 my $category = shift;
1216 FROM authorised_values
1217 WHERE BINARY category=?
1220 my $sth = C4
::Context
->dbh->prepare($query);
1221 $sth->execute($category);
1222 $sth->fetchrow ?
return 1
1226 =head2 GetAuthorisedValueByCode
1228 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1230 Return the lib attribute from authorised_values from the row identified
1231 by the passed category and code
1235 sub GetAuthorisedValueByCode
{
1236 my ( $category, $authvalcode, $opac ) = @_;
1238 my $field = $opac ?
'lib_opac' : 'lib';
1239 my $dbh = C4
::Context
->dbh;
1240 my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1241 $sth->execute( $category, $authvalcode );
1242 while ( my $data = $sth->fetchrow_hashref ) {
1243 return $data->{ $field };
1247 =head2 GetKohaAuthorisedValues
1249 Takes $kohafield, $fwcode as parameters.
1251 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1253 Returns hashref of Code => description
1255 Returns undef if no authorised value category is defined for the kohafield.
1259 sub GetKohaAuthorisedValues
{
1260 my ($kohafield,$fwcode,$opac) = @_;
1261 $fwcode='' unless $fwcode;
1263 my $dbh = C4
::Context
->dbh;
1264 my $avcode = GetAuthValCode
($kohafield,$fwcode);
1266 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1267 $sth->execute($avcode);
1268 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1269 $values{$val} = ($opac && $lib_opac) ?
$lib_opac : $lib;
1277 =head2 GetKohaAuthorisedValuesFromField
1279 Takes $field, $subfield, $fwcode as parameters.
1281 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1282 $subfield can be undefined
1284 Returns hashref of Code => description
1286 Returns undef if no authorised value category is defined for the given field and subfield
1290 sub GetKohaAuthorisedValuesFromField
{
1291 my ($field, $subfield, $fwcode,$opac) = @_;
1292 $fwcode='' unless $fwcode;
1294 my $dbh = C4
::Context
->dbh;
1295 my $avcode = GetAuthValCodeFromField
($field, $subfield, $fwcode);
1297 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1298 $sth->execute($avcode);
1299 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1300 $values{$val} = ($opac && $lib_opac) ?
$lib_opac : $lib;
1310 my $escaped_string = C4::Koha::xml_escape($string);
1312 Convert &, <, >, ', and " in a string to XML entities
1318 return '' unless defined $str;
1319 $str =~ s/&/&/g;
1322 $str =~ s/'/'/g;
1323 $str =~ s/"/"/g;
1327 =head2 GetKohaAuthorisedValueLib
1329 Takes $category, $authorised_value as parameters.
1331 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1333 Returns authorised value description
1337 sub GetKohaAuthorisedValueLib
{
1338 my ($category,$authorised_value,$opac) = @_;
1340 my $dbh = C4
::Context
->dbh;
1341 my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1342 $sth->execute($category,$authorised_value);
1343 my $data = $sth->fetchrow_hashref;
1344 $value = ($opac && $$data{'lib_opac'}) ?
$$data{'lib_opac'} : $$data{'lib'};
1348 =head2 AddAuthorisedValue
1350 AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1352 Create a new authorised value.
1356 sub AddAuthorisedValue
{
1357 my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1359 my $dbh = C4
::Context
->dbh;
1361 INSERT INTO authorised_values
(category
, authorised_value
, lib
, lib_opac
, imageurl
)
1364 my $sth = $dbh->prepare($query);
1365 $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1368 =head2 display_marc_indicators
1370 my $display_form = C4::Koha::display_marc_indicators($field);
1372 C<$field> is a MARC::Field object
1374 Generate a display form of the indicators of a variable
1375 MARC field, replacing any blanks with '#'.
1379 sub display_marc_indicators
{
1381 my $indicators = '';
1382 if ($field->tag() >= 10) {
1383 $indicators = $field->indicator(1) . $field->indicator(2);
1384 $indicators =~ s/ /#/g;
1389 sub GetNormalizedUPC
{
1390 my ($record,$marcflavour) = @_;
1393 if ($marcflavour eq 'UNIMARC') {
1394 @fields = $record->field('072');
1395 foreach my $field (@fields) {
1396 my $upc = _normalize_match_point
($field->subfield('a'));
1403 else { # assume marc21 if not unimarc
1404 @fields = $record->field('024');
1405 foreach my $field (@fields) {
1406 my $indicator = $field->indicator(1);
1407 my $upc = _normalize_match_point
($field->subfield('a'));
1408 if ($indicator == 1 and $upc ne '') {
1415 # Normalizes and returns the first valid ISBN found in the record
1416 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1417 sub GetNormalizedISBN
{
1418 my ($isbn,$record,$marcflavour) = @_;
1421 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1422 # anything after " | " should be removed, along with the delimiter
1423 $isbn =~ s/(.*)( \| )(.*)/$1/;
1424 return _isbn_cleanup
($isbn);
1426 return unless $record;
1428 if ($marcflavour eq 'UNIMARC') {
1429 @fields = $record->field('010');
1430 foreach my $field (@fields) {
1431 my $isbn = $field->subfield('a');
1433 return _isbn_cleanup
($isbn);
1439 else { # assume marc21 if not unimarc
1440 @fields = $record->field('020');
1441 foreach my $field (@fields) {
1442 $isbn = $field->subfield('a');
1444 return _isbn_cleanup
($isbn);
1452 sub GetNormalizedEAN
{
1453 my ($record,$marcflavour) = @_;
1456 if ($marcflavour eq 'UNIMARC') {
1457 @fields = $record->field('073');
1458 foreach my $field (@fields) {
1459 $ean = _normalize_match_point
($field->subfield('a'));
1465 else { # assume marc21 if not unimarc
1466 @fields = $record->field('024');
1467 foreach my $field (@fields) {
1468 my $indicator = $field->indicator(1);
1469 $ean = _normalize_match_point
($field->subfield('a'));
1470 if ($indicator == 3 and $ean ne '') {
1476 sub GetNormalizedOCLCNumber
{
1477 my ($record,$marcflavour) = @_;
1480 if ($marcflavour eq 'UNIMARC') {
1481 # TODO: add UNIMARC fields
1483 else { # assume marc21 if not unimarc
1484 @fields = $record->field('035');
1485 foreach my $field (@fields) {
1486 $oclc = $field->subfield('a');
1487 if ($oclc =~ /OCoLC/) {
1488 $oclc =~ s/\(OCoLC\)//;
1497 sub GetAuthvalueDropbox
{
1498 my ( $authcat, $default ) = @_;
1499 my $branch_limit = C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : "";
1500 my $dbh = C4
::Context
->dbh;
1504 FROM authorised_values
1507 LEFT JOIN authorised_values_branches ON
( id
= av_id
)
1512 $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1513 $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1514 my $sth = $dbh->prepare($query);
1515 $sth->execute( $authcat, $branch_limit ?
$branch_limit : () );
1518 my $option_list = [];
1519 my @authorised_values = ( q{} );
1520 while (my $av = $sth->fetchrow_hashref) {
1521 push @
{$option_list}, {
1522 value
=> $av->{authorised_value
},
1523 label
=> $av->{lib
},
1524 default => ($default eq $av->{authorised_value
}),
1528 if ( @
{$option_list} ) {
1529 return $option_list;
1535 =head2 GetDailyQuote($opts)
1537 Takes a hashref of options
1539 Currently supported options are:
1541 'id' An exact quote id
1542 'random' Select a random quote
1543 noop When no option is passed in, this sub will return the quote timestamped for the current day
1545 The function returns an anonymous hash following this format:
1548 'source' => 'source-of-quote',
1549 'timestamp' => 'timestamp-value',
1550 'text' => 'text-of-quote',
1556 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1557 # at least for default option
1561 my $dbh = C4
::Context
->dbh;
1566 $query = 'SELECT * FROM quotes WHERE id = ?';
1567 $sth = $dbh->prepare($query);
1568 $sth->execute($opts{'id'});
1569 $quote = $sth->fetchrow_hashref();
1571 elsif ($opts{'random'}) {
1572 # Fall through... we also return a random quote as a catch-all if all else fails
1575 $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1576 $sth = $dbh->prepare($query);
1578 $quote = $sth->fetchrow_hashref();
1580 unless ($quote) { # if there are not matches, choose a random quote
1581 # get a list of all available quote ids
1582 $sth = C4
::Context
->dbh->prepare('SELECT count(*) FROM quotes;');
1584 my $range = ($sth->fetchrow_array)[0];
1585 # chose a random id within that range if there is more than one quote
1586 my $offset = int(rand($range));
1588 $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1589 $sth = C4
::Context
->dbh->prepare($query);
1590 # see http://www.perlmonks.org/?node_id=837422 for why
1591 # we're being verbose and using bind_param
1592 $sth->bind_param(1, $offset, SQL_INTEGER
);
1594 $quote = $sth->fetchrow_hashref();
1595 # update the timestamp for that quote
1596 $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1597 $sth = C4
::Context
->dbh->prepare($query);
1599 DateTime
::Format
::MySQL
->format_datetime( dt_from_string
() ),
1606 sub _normalize_match_point
{
1607 my $match_point = shift;
1608 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1609 $normalized_match_point =~ s/-//g;
1611 return $normalized_match_point;
1616 return NormalizeISBN
(
1619 format
=> 'ISBN-10',
1625 =head2 NormalizedISBN
1627 my $isbns = NormalizedISBN({
1629 strip_hyphens => [0,1],
1630 format => ['ISBN-10', 'ISBN-13']
1633 Returns an isbn validated by Business::ISBN.
1634 Optionally strips hyphens and/or forces the isbn
1635 to be of the specified format.
1637 If the string cannot be validated as an isbn,
1645 my $string = $params->{isbn
};
1646 my $strip_hyphens = $params->{strip_hyphens
};
1647 my $format = $params->{format
};
1649 return unless $string;
1651 my $isbn = Business
::ISBN
->new($string);
1653 if ( $isbn && $isbn->is_valid() ) {
1655 if ( $format eq 'ISBN-10' ) {
1656 $isbn = $isbn->as_isbn10();
1658 elsif ( $format eq 'ISBN-13' ) {
1659 $isbn = $isbn->as_isbn13();
1662 if ($strip_hyphens) {
1663 $string = $isbn->as_string( [] );
1665 $string = $isbn->as_string();
1672 =head2 GetVariationsOfISBN
1674 my @isbns = GetVariationsOfISBN( $isbn );
1676 Returns a list of varations of the given isbn in
1677 both ISBN-10 and ISBN-13 formats, with and without
1680 In a scalar context, the isbns are returned as a
1681 string delimited by ' | '.
1685 sub GetVariationsOfISBN
{
1688 return unless $isbn;
1692 push( @isbns, NormalizeISBN
({ isbn
=> $isbn }) );
1693 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-10' }) );
1694 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-13' }) );
1695 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-10', strip_hyphens
=> 1 }) );
1696 push( @isbns, NormalizeISBN
({ isbn
=> $isbn, format
=> 'ISBN-13', strip_hyphens
=> 1 }) );
1698 # Strip out any "empty" strings from the array
1699 @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1701 return wantarray ?
@isbns : join( " | ", @isbns );
1704 =head2 GetVariationsOfISBNs
1706 my @isbns = GetVariationsOfISBNs( @isbns );
1708 Returns a list of varations of the given isbns in
1709 both ISBN-10 and ISBN-13 formats, with and without
1712 In a scalar context, the isbns are returned as a
1713 string delimited by ' | '.
1717 sub GetVariationsOfISBNs
{
1720 @isbns = map { GetVariationsOfISBN
( $_ ) } @isbns;
1722 return wantarray ?
@isbns : join( " | ", @isbns );