3 # Copyright 2000-2002 Katipo Communications
4 # Parts Copyright 2010 Nelsonville Public Library
6 # This file is part of Koha.
8 # Koha is free software; you can redistribute it and/or modify it under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 2 of the License, or (at your option) any later
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
23 #use warnings; FIXME - Bug 2505
26 use URI::Split qw(uri_split);
30 use vars qw($VERSION @ISA @EXPORT $DEBUG);
39 &subfield_is_koha_internal_p
40 &GetPrinters &GetPrinter
41 &GetItemTypes &getitemtypeinfo
43 &GetSupportName &GetSupportList
45 &getframeworks &getframeworkinfo
46 &getauthtypes &getauthtype
52 &get_notforloan_label_of
55 &getitemtypeimagelocation
57 &GetAuthorisedValueCategories
58 &GetKohaAuthorisedValues
59 &GetKohaAuthorisedValuesFromField
64 &GetNormalizedOCLCNumber
73 memoize('GetAuthorisedValues');
77 C4::Koha - Perl Module containing convenience functions for Koha scripts
85 Koha.pm provides many functions for Koha scripts.
93 $slash_date = &slashifyDate($dash_date);
95 Takes a string of the form "DD-MM-YYYY" (or anything separated by
96 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
102 # accepts a date of the form xx-xx-xx[xx] and returns it in the
104 my @dateOut = split( '-', shift );
105 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
111 my $string = DisplayISBN( $isbn );
117 if (length ($isbn)<13){
119 if ( substr( $isbn, 0, 1 ) <= 7 ) {
120 $seg1 = substr( $isbn, 0, 1 );
122 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
123 $seg1 = substr( $isbn, 0, 2 );
125 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
126 $seg1 = substr( $isbn, 0, 3 );
128 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
129 $seg1 = substr( $isbn, 0, 4 );
132 $seg1 = substr( $isbn, 0, 5 );
134 my $x = substr( $isbn, length($seg1) );
136 if ( substr( $x, 0, 2 ) <= 19 ) {
138 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
139 $seg2 = substr( $x, 0, 2 );
141 elsif ( substr( $x, 0, 3 ) <= 699 ) {
142 $seg2 = substr( $x, 0, 3 );
144 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
145 $seg2 = substr( $x, 0, 4 );
147 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
148 $seg2 = substr( $x, 0, 5 );
150 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
151 $seg2 = substr( $x, 0, 6 );
154 $seg2 = substr( $x, 0, 7 );
156 my $seg3 = substr( $x, length($seg2) );
157 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
158 my $seg4 = substr( $x, -1, 1 );
159 return "$seg1-$seg2-$seg3-$seg4";
162 $seg1 = substr( $isbn, 0, 3 );
164 if ( substr( $isbn, 3, 1 ) <= 7 ) {
165 $seg2 = substr( $isbn, 3, 1 );
167 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
168 $seg2 = substr( $isbn, 3, 2 );
170 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
171 $seg2 = substr( $isbn, 3, 3 );
173 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
174 $seg2 = substr( $isbn, 3, 4 );
177 $seg2 = substr( $isbn, 3, 5 );
179 my $x = substr( $isbn, length($seg2) +3);
181 if ( substr( $x, 0, 2 ) <= 19 ) {
183 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
184 $seg3 = substr( $x, 0, 2 );
186 elsif ( substr( $x, 0, 3 ) <= 699 ) {
187 $seg3 = substr( $x, 0, 3 );
189 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
190 $seg3 = substr( $x, 0, 4 );
192 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
193 $seg3 = substr( $x, 0, 5 );
195 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
196 $seg3 = substr( $x, 0, 6 );
199 $seg3 = substr( $x, 0, 7 );
201 my $seg4 = substr( $x, length($seg3) );
202 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
203 my $seg5 = substr( $x, -1, 1 );
204 return "$seg1-$seg2-$seg3-$seg4-$seg5";
208 # FIXME.. this should be moved to a MARC-specific module
209 sub subfield_is_koha_internal_p ($) {
212 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
213 # But real MARC subfields are always single-character
214 # so it really is safer just to check the length
216 return length $subfield != 1;
219 =head2 GetSupportName
221 $itemtypename = &GetSupportName($codestring);
223 Returns a string with the name of the itemtype.
229 return if (! $codestring);
231 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
232 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
239 my $sth = C4::Context->dbh->prepare($query);
240 $sth->execute($codestring);
241 ($resultstring)=$sth->fetchrow;
242 return $resultstring;
245 C4::Context->dbh->prepare(
246 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
248 $sth->execute( $advanced_search_types, $codestring );
249 my $data = $sth->fetchrow_hashref;
250 return $$data{'lib'};
254 =head2 GetSupportList
256 $itemtypes = &GetSupportList();
258 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
260 build a HTML select with the following code :
262 =head3 in PERL SCRIPT
264 my $itemtypes = GetSupportList();
265 $template->param(itemtypeloop => $itemtypes);
269 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
270 <select name="itemtype">
271 <option value="">Default</option>
272 <!-- TMPL_LOOP name="itemtypeloop" -->
273 <option value="<!-- TMPL_VAR name="itemtype" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->> <!--TMPL_IF Name="imageurl"--><img alt="<!-- TMPL_VAR name="description" -->" src="<!--TMPL_VAR Name="imageurl"-->><!--TMPL_ELSE-->"<!-- TMPL_VAR name="description" --><!--/TMPL_IF--></option>
276 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
277 <input type="submit" value="OK" class="button">
283 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
284 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
290 my $sth = C4::Context->dbh->prepare($query);
292 return $sth->fetchall_arrayref({});
294 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
295 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
301 $itemtypes = &GetItemTypes();
303 Returns information about existing itemtypes.
305 build a HTML select with the following code :
307 =head3 in PERL SCRIPT
309 my $itemtypes = GetItemTypes;
311 foreach my $thisitemtype (sort keys %$itemtypes) {
312 my $selected = 1 if $thisitemtype eq $itemtype;
313 my %row =(value => $thisitemtype,
314 selected => $selected,
315 description => $itemtypes->{$thisitemtype}->{'description'},
317 push @itemtypesloop, \%row;
319 $template->param(itemtypeloop => \@itemtypesloop);
323 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
324 <select name="itemtype">
325 <option value="">Default</option>
326 <!-- TMPL_LOOP name="itemtypeloop" -->
327 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
330 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
331 <input type="submit" value="OK" class="button">
338 # returns a reference to a hash of references to itemtypes...
340 my $dbh = C4::Context->dbh;
345 my $sth = $dbh->prepare($query);
347 while ( my $IT = $sth->fetchrow_hashref ) {
348 $itemtypes{ $IT->{'itemtype'} } = $IT;
350 return ( \%itemtypes );
353 sub get_itemtypeinfos_of {
356 my $placeholders = join( ', ', map { '?' } @itemtypes );
357 my $query = <<"END_SQL";
363 WHERE itemtype IN ( $placeholders )
366 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
369 # this is temporary until we separate collection codes and item types
373 my $dbh = C4::Context->dbh;
376 "SELECT * FROM authorised_values ORDER BY authorised_value");
378 while ( my $data = $sth->fetchrow_hashref ) {
379 if ( $data->{category} eq "CCODE" ) {
381 $results[$count] = $data;
387 return ( $count, @results );
392 $authtypes = &getauthtypes();
394 Returns information about existing authtypes.
396 build a HTML select with the following code :
398 =head3 in PERL SCRIPT
400 my $authtypes = getauthtypes;
402 foreach my $thisauthtype (keys %$authtypes) {
403 my $selected = 1 if $thisauthtype eq $authtype;
404 my %row =(value => $thisauthtype,
405 selected => $selected,
406 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
408 push @authtypesloop, \%row;
410 $template->param(itemtypeloop => \@itemtypesloop);
414 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
415 <select name="authtype">
416 <!-- TMPL_LOOP name="authtypeloop" -->
417 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
420 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
421 <input type="submit" value="OK" class="button">
429 # returns a reference to a hash of references to authtypes...
431 my $dbh = C4::Context->dbh;
432 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
434 while ( my $IT = $sth->fetchrow_hashref ) {
435 $authtypes{ $IT->{'authtypecode'} } = $IT;
437 return ( \%authtypes );
441 my ($authtypecode) = @_;
443 # returns a reference to a hash of references to authtypes...
445 my $dbh = C4::Context->dbh;
446 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
447 $sth->execute($authtypecode);
448 my $res = $sth->fetchrow_hashref;
454 $frameworks = &getframework();
456 Returns information about existing frameworks
458 build a HTML select with the following code :
460 =head3 in PERL SCRIPT
462 my $frameworks = frameworks();
464 foreach my $thisframework (keys %$frameworks) {
465 my $selected = 1 if $thisframework eq $frameworkcode;
466 my %row =(value => $thisframework,
467 selected => $selected,
468 description => $frameworks->{$thisframework}->{'frameworktext'},
470 push @frameworksloop, \%row;
472 $template->param(frameworkloop => \@frameworksloop);
476 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
477 <select name="frameworkcode">
478 <option value="">Default</option>
479 <!-- TMPL_LOOP name="frameworkloop" -->
480 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
483 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
484 <input type="submit" value="OK" class="button">
491 # returns a reference to a hash of references to branches...
493 my $dbh = C4::Context->dbh;
494 my $sth = $dbh->prepare("select * from biblio_framework");
496 while ( my $IT = $sth->fetchrow_hashref ) {
497 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
499 return ( \%itemtypes );
502 =head2 getframeworkinfo
504 $frameworkinfo = &getframeworkinfo($frameworkcode);
506 Returns information about an frameworkcode.
510 sub getframeworkinfo {
511 my ($frameworkcode) = @_;
512 my $dbh = C4::Context->dbh;
514 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
515 $sth->execute($frameworkcode);
516 my $res = $sth->fetchrow_hashref;
520 =head2 getitemtypeinfo
522 $itemtype = &getitemtype($itemtype);
524 Returns information about an itemtype.
528 sub getitemtypeinfo {
530 my $dbh = C4::Context->dbh;
531 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
532 $sth->execute($itemtype);
533 my $res = $sth->fetchrow_hashref;
535 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
540 =head2 getitemtypeimagedir
542 my $directory = getitemtypeimagedir( 'opac' );
544 pass in 'opac' or 'intranet'. Defaults to 'opac'.
546 returns the full path to the appropriate directory containing images.
550 sub getitemtypeimagedir {
551 my $src = shift || 'opac';
552 if ($src eq 'intranet') {
553 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
555 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
559 sub getitemtypeimagesrc {
560 my $src = shift || 'opac';
561 if ($src eq 'intranet') {
562 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
564 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
568 sub getitemtypeimagelocation($$) {
569 my ( $src, $image ) = @_;
571 return '' if ( !$image );
573 my $scheme = ( uri_split( $image ) )[0];
575 return $image if ( $scheme );
577 return getitemtypeimagesrc( $src ) . '/' . $image;
580 =head3 _getImagesFromDirectory
582 Find all of the image files in a directory in the filesystem
584 parameters: a directory name
586 returns: a list of images in that directory.
588 Notes: this does not traverse into subdirectories. See
589 _getSubdirectoryNames for help with that.
590 Images are assumed to be files with .gif or .png file extensions.
591 The image names returned do not have the directory name on them.
595 sub _getImagesFromDirectory {
596 my $directoryname = shift;
597 return unless defined $directoryname;
598 return unless -d $directoryname;
600 if ( opendir ( my $dh, $directoryname ) ) {
601 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
603 @images = sort(@images);
606 warn "unable to opendir $directoryname: $!";
611 =head3 _getSubdirectoryNames
613 Find all of the directories in a directory in the filesystem
615 parameters: a directory name
617 returns: a list of subdirectories in that directory.
619 Notes: this does not traverse into subdirectories. Only the first
620 level of subdirectories are returned.
621 The directory names returned don't have the parent directory name on them.
625 sub _getSubdirectoryNames {
626 my $directoryname = shift;
627 return unless defined $directoryname;
628 return unless -d $directoryname;
630 if ( opendir ( my $dh, $directoryname ) ) {
631 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
635 warn "unable to opendir $directoryname: $!";
642 returns: a listref of hashrefs. Each hash represents another collection of images.
644 { imagesetname => 'npl', # the name of the image set (npl is the original one)
645 images => listref of image hashrefs
648 each image is represented by a hashref like this:
650 { KohaImage => 'npl/image.gif',
651 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
652 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
653 checked => 0 or 1: was this the image passed to this method?
654 Note: I'd like to remove this somehow.
661 my $checked = $params{'checked'} || '';
663 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
664 url => getitemtypeimagesrc('intranet'),
666 opac => { filesystem => getitemtypeimagedir('opac'),
667 url => getitemtypeimagesrc('opac'),
671 my @imagesets = (); # list of hasrefs of image set data to pass to template
672 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
674 foreach my $imagesubdir ( @subdirectories ) {
675 my @imagelist = (); # hashrefs of image info
676 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
677 my $imagesetactive = 0;
678 foreach my $thisimage ( @imagenames ) {
680 { KohaImage => "$imagesubdir/$thisimage",
681 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
682 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
683 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
686 $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
688 push @imagesets, { imagesetname => $imagesubdir,
689 imagesetactive => $imagesetactive,
690 images => \@imagelist };
698 $printers = &GetPrinters();
699 @queues = keys %$printers;
701 Returns information about existing printer queues.
703 C<$printers> is a reference-to-hash whose keys are the print queues
704 defined in the printers table of the Koha database. The values are
705 references-to-hash, whose keys are the fields in the printers table.
711 my $dbh = C4::Context->dbh;
712 my $sth = $dbh->prepare("select * from printers");
714 while ( my $printer = $sth->fetchrow_hashref ) {
715 $printers{ $printer->{'printqueue'} } = $printer;
717 return ( \%printers );
722 $printer = GetPrinter( $query, $printers );
726 sub GetPrinter ($$) {
727 my ( $query, $printers ) = @_; # get printer for this query from printers
728 my $printer = $query->param('printer');
729 my %cookie = $query->cookie('userenv');
730 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
731 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
737 Returns the number of pages to display in a pagination bar, given the number
738 of items and the number of items per page.
743 my ( $nb_items, $nb_items_per_page ) = @_;
745 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
750 (@themes) = &getallthemes('opac');
751 (@themes) = &getallthemes('intranet');
753 Returns an array of all available themes.
761 if ( $type eq 'intranet' ) {
762 $htdocs = C4::Context->config('intrahtdocs');
765 $htdocs = C4::Context->config('opachtdocs');
767 opendir D, "$htdocs";
768 my @dirlist = readdir D;
769 foreach my $directory (@dirlist) {
770 -d "$htdocs/$directory/en" and push @themes, $directory;
777 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
780 link_value => 'su-to',
781 label_value => 'Topics',
783 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
787 link_value => 'su-geo',
788 label_value => 'Places',
793 link_value => 'su-ut',
794 label_value => 'Titles',
795 tags => [ '500', '501', '502', '503', '504', ],
800 label_value => 'Authors',
801 tags => [ '700', '701', '702', ],
806 label_value => 'Series',
815 link_value => 'branch',
816 label_value => 'Libraries',
821 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
826 link_value => 'su-to',
827 label_value => 'Topics',
833 # link_value => 'su-na',
834 # label_value => 'People and Organizations',
835 # tags => ['600', '610', '611'],
839 link_value => 'su-geo',
840 label_value => 'Places',
845 link_value => 'su-ut',
846 label_value => 'Titles',
852 label_value => 'Authors',
853 tags => [ '100', '110', '700', ],
858 label_value => 'Series',
859 tags => [ '440', '490', ],
865 link_value => 'branch',
866 label_value => 'Libraries',
871 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
878 Return a href where a key is associated to a href. You give a query,
879 the name of the key among the fields returned by the query. If you
880 also give as third argument the name of the value, the function
881 returns a href of scalar. The optional 4th argument is an arrayref of
882 items passed to the C<execute()> call. It is designed to bind
883 parameters to any placeholders in your SQL.
892 # generic href of any information on the item, href of href.
893 my $iteminfos_of = get_infos_of($query, 'itemnumber');
894 print $iteminfos_of->{$itemnumber}{barcode};
896 # specific information, href of scalar
897 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
898 print $barcode_of_item->{$itemnumber};
903 my ( $query, $key_name, $value_name, $bind_params ) = @_;
905 my $dbh = C4::Context->dbh;
907 my $sth = $dbh->prepare($query);
908 $sth->execute( @$bind_params );
911 while ( my $row = $sth->fetchrow_hashref ) {
912 if ( defined $value_name ) {
913 $infos_of{ $row->{$key_name} } = $row->{$value_name};
916 $infos_of{ $row->{$key_name} } = $row;
924 =head2 get_notforloan_label_of
926 my $notforloan_label_of = get_notforloan_label_of();
928 Each authorised value of notforloan (information available in items and
929 itemtypes) is link to a single label.
931 Returns a href where keys are authorised values and values are corresponding
934 foreach my $authorised_value (keys %{$notforloan_label_of}) {
936 "authorised_value: %s => %s\n",
938 $notforloan_label_of->{$authorised_value}
944 # FIXME - why not use GetAuthorisedValues ??
946 sub get_notforloan_label_of {
947 my $dbh = C4::Context->dbh;
950 SELECT authorised_value
951 FROM marc_subfield_structure
952 WHERE kohafield = \'items.notforloan\'
955 my $sth = $dbh->prepare($query);
957 my ($statuscode) = $sth->fetchrow_array();
962 FROM authorised_values
965 $sth = $dbh->prepare($query);
966 $sth->execute($statuscode);
967 my %notforloan_label_of;
968 while ( my $row = $sth->fetchrow_hashref ) {
969 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
973 return \%notforloan_label_of;
976 =head2 displayServers
978 my $servers = displayServers();
979 my $servers = displayServers( $position );
980 my $servers = displayServers( $position, $type );
982 displayServers returns a listref of hashrefs, each containing
983 information about available z3950 servers. Each hashref has a format
987 'checked' => 'checked',
988 'encoding' => 'MARC-8'
990 'id' => 'LIBRARY OF CONGRESS',
994 'value' => 'z3950.loc.gov:7090/',
1000 sub displayServers {
1001 my ( $position, $type ) = @_;
1002 my $dbh = C4::Context->dbh;
1004 my $strsth = 'SELECT * FROM z3950servers';
1009 push @bind_params, $position;
1010 push @where_clauses, ' position = ? ';
1014 push @bind_params, $type;
1015 push @where_clauses, ' type = ? ';
1018 # reassemble where clause from where clause pieces
1019 if (@where_clauses) {
1020 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1023 my $rq = $dbh->prepare($strsth);
1024 $rq->execute(@bind_params);
1025 my @primaryserverloop;
1027 while ( my $data = $rq->fetchrow_hashref ) {
1028 push @primaryserverloop,
1029 { label => $data->{description},
1030 id => $data->{name},
1032 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1033 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1034 checked => "checked",
1035 icon => $data->{icon},
1036 zed => $data->{type} eq 'zed',
1037 opensearch => $data->{type} eq 'opensearch'
1040 return \@primaryserverloop;
1043 =head2 GetAuthValCode
1045 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1049 sub GetAuthValCode {
1050 my ($kohafield,$fwcode) = @_;
1051 my $dbh = C4::Context->dbh;
1052 $fwcode='' unless $fwcode;
1053 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1054 $sth->execute($kohafield,$fwcode);
1055 my ($authvalcode) = $sth->fetchrow_array;
1056 return $authvalcode;
1059 =head2 GetAuthValCodeFromField
1061 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1063 C<$subfield> can be undefined
1067 sub GetAuthValCodeFromField {
1068 my ($field,$subfield,$fwcode) = @_;
1069 my $dbh = C4::Context->dbh;
1070 $fwcode='' unless $fwcode;
1072 if (defined $subfield) {
1073 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1074 $sth->execute($field,$subfield,$fwcode);
1076 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1077 $sth->execute($field,$fwcode);
1079 my ($authvalcode) = $sth->fetchrow_array;
1080 return $authvalcode;
1083 =head2 GetAuthorisedValues
1085 $authvalues = GetAuthorisedValues([$category], [$selected]);
1087 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1089 C<$category> returns authorised values for just one category (optional).
1091 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1095 sub GetAuthorisedValues {
1096 my ($category,$selected,$opac) = @_;
1098 my $dbh = C4::Context->dbh;
1099 my $query = "SELECT * FROM authorised_values";
1100 $query .= " WHERE category = '" . $category . "'" if $category;
1101 $query .= " ORDER BY category, lib, lib_opac";
1102 my $sth = $dbh->prepare($query);
1104 while (my $data=$sth->fetchrow_hashref) {
1105 if ($selected && $selected eq $data->{'authorised_value'} ) {
1106 $data->{'selected'} = 1;
1108 if ($opac && $data->{'lib_opac'}) {
1109 $data->{'lib'} = $data->{'lib_opac'};
1111 push @results, $data;
1113 #my $data = $sth->fetchall_arrayref({});
1114 return \@results; #$data;
1117 =head2 GetAuthorisedValueCategories
1119 $auth_categories = GetAuthorisedValueCategories();
1121 Return an arrayref of all of the available authorised
1126 sub GetAuthorisedValueCategories {
1127 my $dbh = C4::Context->dbh;
1128 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1131 while (my $category = $sth->fetchrow_array) {
1132 push @results, $category;
1137 =head2 GetKohaAuthorisedValues
1139 Takes $kohafield, $fwcode as parameters.
1141 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1143 Returns hashref of Code => description
1145 Returns undef if no authorised value category is defined for the kohafield.
1149 sub GetKohaAuthorisedValues {
1150 my ($kohafield,$fwcode,$opac) = @_;
1151 $fwcode='' unless $fwcode;
1153 my $dbh = C4::Context->dbh;
1154 my $avcode = GetAuthValCode($kohafield,$fwcode);
1156 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1157 $sth->execute($avcode);
1158 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1159 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1167 =head2 GetKohaAuthorisedValuesFromField
1169 Takes $field, $subfield, $fwcode as parameters.
1171 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1172 $subfield can be undefined
1174 Returns hashref of Code => description
1176 Returns undef if no authorised value category is defined for the given field and subfield
1180 sub GetKohaAuthorisedValuesFromField {
1181 my ($field, $subfield, $fwcode,$opac) = @_;
1182 $fwcode='' unless $fwcode;
1184 my $dbh = C4::Context->dbh;
1185 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1187 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1188 $sth->execute($avcode);
1189 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1190 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1200 my $escaped_string = C4::Koha::xml_escape($string);
1202 Convert &, <, >, ', and " in a string to XML entities
1208 return '' unless defined $str;
1209 $str =~ s/&/&/g;
1212 $str =~ s/'/'/g;
1213 $str =~ s/"/"/g;
1217 =head2 display_marc_indicators
1219 my $display_form = C4::Koha::display_marc_indicators($field);
1221 C<$field> is a MARC::Field object
1223 Generate a display form of the indicators of a variable
1224 MARC field, replacing any blanks with '#'.
1228 sub display_marc_indicators {
1230 my $indicators = '';
1231 if ($field->tag() >= 10) {
1232 $indicators = $field->indicator(1) . $field->indicator(2);
1233 $indicators =~ s/ /#/g;
1238 sub GetNormalizedUPC {
1239 my ($record,$marcflavour) = @_;
1242 if ($marcflavour eq 'MARC21') {
1243 @fields = $record->field('024');
1244 foreach my $field (@fields) {
1245 my $indicator = $field->indicator(1);
1246 my $upc = _normalize_match_point($field->subfield('a'));
1247 if ($indicator == 1 and $upc ne '') {
1252 else { # assume unimarc if not marc21
1253 @fields = $record->field('072');
1254 foreach my $field (@fields) {
1255 my $upc = _normalize_match_point($field->subfield('a'));
1263 # Normalizes and returns the first valid ISBN found in the record
1264 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1265 sub GetNormalizedISBN {
1266 my ($isbn,$record,$marcflavour) = @_;
1269 # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1270 # anything after " | " should be removed, along with the delimiter
1271 $isbn =~ s/(.*)( \| )(.*)/$1/;
1272 return _isbn_cleanup($isbn);
1274 return undef unless $record;
1276 if ($marcflavour eq 'MARC21') {
1277 @fields = $record->field('020');
1278 foreach my $field (@fields) {
1279 $isbn = $field->subfield('a');
1281 return _isbn_cleanup($isbn);
1287 else { # assume unimarc if not marc21
1288 @fields = $record->field('010');
1289 foreach my $field (@fields) {
1290 my $isbn = $field->subfield('a');
1292 return _isbn_cleanup($isbn);
1301 sub GetNormalizedEAN {
1302 my ($record,$marcflavour) = @_;
1305 if ($marcflavour eq 'MARC21') {
1306 @fields = $record->field('024');
1307 foreach my $field (@fields) {
1308 my $indicator = $field->indicator(1);
1309 $ean = _normalize_match_point($field->subfield('a'));
1310 if ($indicator == 3 and $ean ne '') {
1315 else { # assume unimarc if not marc21
1316 @fields = $record->field('073');
1317 foreach my $field (@fields) {
1318 $ean = _normalize_match_point($field->subfield('a'));
1325 sub GetNormalizedOCLCNumber {
1326 my ($record,$marcflavour) = @_;
1329 if ($marcflavour eq 'MARC21') {
1330 @fields = $record->field('035');
1331 foreach my $field (@fields) {
1332 $oclc = $field->subfield('a');
1333 if ($oclc =~ /OCoLC/) {
1334 $oclc =~ s/\(OCoLC\)//;
1341 else { # TODO: add UNIMARC fields
1345 sub _normalize_match_point {
1346 my $match_point = shift;
1347 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1348 $normalized_match_point =~ s/-//g;
1350 return $normalized_match_point;
1354 my $isbn = Business::ISBN->new( $_[0] );
1356 $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1357 if (defined $isbn) {
1358 return $isbn->as_string([]);