3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it under the
8 # terms of the GNU General Public License as published by the Free Software
9 # Foundation; either version 2 of the License, or (at your option) any later
12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License along
17 # with Koha; if not, write to the Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 #use warnings; FIXME - Bug 2505
25 use URI::Split qw(uri_split);
29 use vars qw($VERSION @ISA @EXPORT $DEBUG);
38 &subfield_is_koha_internal_p
39 &GetPrinters &GetPrinter
40 &GetItemTypes &getitemtypeinfo
42 &GetSupportName &GetSupportList
44 &getframeworks &getframeworkinfo
45 &getauthtypes &getauthtype
51 &get_notforloan_label_of
54 &getitemtypeimagelocation
56 &GetAuthorisedValueCategories
57 &GetKohaAuthorisedValues
58 &GetKohaAuthorisedValuesFromField
63 &GetNormalizedOCLCNumber
71 memoize('GetAuthorisedValues');
75 C4::Koha - Perl Module containing convenience functions for Koha scripts
83 Koha.pm provides many functions for Koha scripts.
91 $slash_date = &slashifyDate($dash_date);
93 Takes a string of the form "DD-MM-YYYY" (or anything separated by
94 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
100 # accepts a date of the form xx-xx-xx[xx] and returns it in the
102 my @dateOut = split( '-', shift );
103 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
109 my $string = DisplayISBN( $isbn );
115 if (length ($isbn)<13){
117 if ( substr( $isbn, 0, 1 ) <= 7 ) {
118 $seg1 = substr( $isbn, 0, 1 );
120 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
121 $seg1 = substr( $isbn, 0, 2 );
123 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
124 $seg1 = substr( $isbn, 0, 3 );
126 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
127 $seg1 = substr( $isbn, 0, 4 );
130 $seg1 = substr( $isbn, 0, 5 );
132 my $x = substr( $isbn, length($seg1) );
134 if ( substr( $x, 0, 2 ) <= 19 ) {
136 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
137 $seg2 = substr( $x, 0, 2 );
139 elsif ( substr( $x, 0, 3 ) <= 699 ) {
140 $seg2 = substr( $x, 0, 3 );
142 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
143 $seg2 = substr( $x, 0, 4 );
145 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
146 $seg2 = substr( $x, 0, 5 );
148 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
149 $seg2 = substr( $x, 0, 6 );
152 $seg2 = substr( $x, 0, 7 );
154 my $seg3 = substr( $x, length($seg2) );
155 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
156 my $seg4 = substr( $x, -1, 1 );
157 return "$seg1-$seg2-$seg3-$seg4";
160 $seg1 = substr( $isbn, 0, 3 );
162 if ( substr( $isbn, 3, 1 ) <= 7 ) {
163 $seg2 = substr( $isbn, 3, 1 );
165 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
166 $seg2 = substr( $isbn, 3, 2 );
168 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
169 $seg2 = substr( $isbn, 3, 3 );
171 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
172 $seg2 = substr( $isbn, 3, 4 );
175 $seg2 = substr( $isbn, 3, 5 );
177 my $x = substr( $isbn, length($seg2) +3);
179 if ( substr( $x, 0, 2 ) <= 19 ) {
181 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
182 $seg3 = substr( $x, 0, 2 );
184 elsif ( substr( $x, 0, 3 ) <= 699 ) {
185 $seg3 = substr( $x, 0, 3 );
187 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
188 $seg3 = substr( $x, 0, 4 );
190 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
191 $seg3 = substr( $x, 0, 5 );
193 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
194 $seg3 = substr( $x, 0, 6 );
197 $seg3 = substr( $x, 0, 7 );
199 my $seg4 = substr( $x, length($seg3) );
200 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
201 my $seg5 = substr( $x, -1, 1 );
202 return "$seg1-$seg2-$seg3-$seg4-$seg5";
206 # FIXME.. this should be moved to a MARC-specific module
207 sub subfield_is_koha_internal_p ($) {
210 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
211 # But real MARC subfields are always single-character
212 # so it really is safer just to check the length
214 return length $subfield != 1;
217 =head2 GetSupportName
219 $itemtypename = &GetSupportName($codestring);
221 Returns a string with the name of the itemtype.
227 return if (! $codestring);
229 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
230 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
237 my $sth = C4::Context->dbh->prepare($query);
238 $sth->execute($codestring);
239 ($resultstring)=$sth->fetchrow;
240 return $resultstring;
243 C4::Context->dbh->prepare(
244 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
246 $sth->execute( $advanced_search_types, $codestring );
247 my $data = $sth->fetchrow_hashref;
248 return $$data{'lib'};
252 =head2 GetSupportList
254 $itemtypes = &GetSupportList();
256 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
258 build a HTML select with the following code :
260 =head3 in PERL SCRIPT
262 my $itemtypes = GetSupportList();
263 $template->param(itemtypeloop => $itemtypes);
267 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
268 <select name="itemtype">
269 <option value="">Default</option>
270 <!-- TMPL_LOOP name="itemtypeloop" -->
271 <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>
274 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
275 <input type="submit" value="OK" class="button">
281 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
282 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
288 my $sth = C4::Context->dbh->prepare($query);
290 return $sth->fetchall_arrayref({});
292 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
293 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
299 $itemtypes = &GetItemTypes();
301 Returns information about existing itemtypes.
303 build a HTML select with the following code :
305 =head3 in PERL SCRIPT
307 my $itemtypes = GetItemTypes;
309 foreach my $thisitemtype (sort keys %$itemtypes) {
310 my $selected = 1 if $thisitemtype eq $itemtype;
311 my %row =(value => $thisitemtype,
312 selected => $selected,
313 description => $itemtypes->{$thisitemtype}->{'description'},
315 push @itemtypesloop, \%row;
317 $template->param(itemtypeloop => \@itemtypesloop);
321 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
322 <select name="itemtype">
323 <option value="">Default</option>
324 <!-- TMPL_LOOP name="itemtypeloop" -->
325 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
328 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
329 <input type="submit" value="OK" class="button">
336 # returns a reference to a hash of references to itemtypes...
338 my $dbh = C4::Context->dbh;
343 my $sth = $dbh->prepare($query);
345 while ( my $IT = $sth->fetchrow_hashref ) {
346 $itemtypes{ $IT->{'itemtype'} } = $IT;
348 return ( \%itemtypes );
351 sub get_itemtypeinfos_of {
354 my $placeholders = join( ', ', map { '?' } @itemtypes );
355 my $query = <<"END_SQL";
361 WHERE itemtype IN ( $placeholders )
364 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
367 # this is temporary until we separate collection codes and item types
371 my $dbh = C4::Context->dbh;
374 "SELECT * FROM authorised_values ORDER BY authorised_value");
376 while ( my $data = $sth->fetchrow_hashref ) {
377 if ( $data->{category} eq "CCODE" ) {
379 $results[$count] = $data;
385 return ( $count, @results );
390 $authtypes = &getauthtypes();
392 Returns information about existing authtypes.
394 build a HTML select with the following code :
396 =head3 in PERL SCRIPT
398 my $authtypes = getauthtypes;
400 foreach my $thisauthtype (keys %$authtypes) {
401 my $selected = 1 if $thisauthtype eq $authtype;
402 my %row =(value => $thisauthtype,
403 selected => $selected,
404 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
406 push @authtypesloop, \%row;
408 $template->param(itemtypeloop => \@itemtypesloop);
412 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
413 <select name="authtype">
414 <!-- TMPL_LOOP name="authtypeloop" -->
415 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
418 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
419 <input type="submit" value="OK" class="button">
427 # returns a reference to a hash of references to authtypes...
429 my $dbh = C4::Context->dbh;
430 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
432 while ( my $IT = $sth->fetchrow_hashref ) {
433 $authtypes{ $IT->{'authtypecode'} } = $IT;
435 return ( \%authtypes );
439 my ($authtypecode) = @_;
441 # returns a reference to a hash of references to authtypes...
443 my $dbh = C4::Context->dbh;
444 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
445 $sth->execute($authtypecode);
446 my $res = $sth->fetchrow_hashref;
452 $frameworks = &getframework();
454 Returns information about existing frameworks
456 build a HTML select with the following code :
458 =head3 in PERL SCRIPT
460 my $frameworks = frameworks();
462 foreach my $thisframework (keys %$frameworks) {
463 my $selected = 1 if $thisframework eq $frameworkcode;
464 my %row =(value => $thisframework,
465 selected => $selected,
466 description => $frameworks->{$thisframework}->{'frameworktext'},
468 push @frameworksloop, \%row;
470 $template->param(frameworkloop => \@frameworksloop);
474 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
475 <select name="frameworkcode">
476 <option value="">Default</option>
477 <!-- TMPL_LOOP name="frameworkloop" -->
478 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
481 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
482 <input type="submit" value="OK" class="button">
489 # returns a reference to a hash of references to branches...
491 my $dbh = C4::Context->dbh;
492 my $sth = $dbh->prepare("select * from biblio_framework");
494 while ( my $IT = $sth->fetchrow_hashref ) {
495 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
497 return ( \%itemtypes );
500 =head2 getframeworkinfo
502 $frameworkinfo = &getframeworkinfo($frameworkcode);
504 Returns information about an frameworkcode.
508 sub getframeworkinfo {
509 my ($frameworkcode) = @_;
510 my $dbh = C4::Context->dbh;
512 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
513 $sth->execute($frameworkcode);
514 my $res = $sth->fetchrow_hashref;
518 =head2 getitemtypeinfo
520 $itemtype = &getitemtype($itemtype);
522 Returns information about an itemtype.
526 sub getitemtypeinfo {
528 my $dbh = C4::Context->dbh;
529 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
530 $sth->execute($itemtype);
531 my $res = $sth->fetchrow_hashref;
533 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
538 =head2 getitemtypeimagedir
540 my $directory = getitemtypeimagedir( 'opac' );
542 pass in 'opac' or 'intranet'. Defaults to 'opac'.
544 returns the full path to the appropriate directory containing images.
548 sub getitemtypeimagedir {
549 my $src = shift || 'opac';
550 if ($src eq 'intranet') {
551 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
553 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
557 sub getitemtypeimagesrc {
558 my $src = shift || 'opac';
559 if ($src eq 'intranet') {
560 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
562 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
566 sub getitemtypeimagelocation($$) {
567 my ( $src, $image ) = @_;
569 return '' if ( !$image );
571 my $scheme = ( uri_split( $image ) )[0];
573 return $image if ( $scheme );
575 return getitemtypeimagesrc( $src ) . '/' . $image;
578 =head3 _getImagesFromDirectory
580 Find all of the image files in a directory in the filesystem
582 parameters: a directory name
584 returns: a list of images in that directory.
586 Notes: this does not traverse into subdirectories. See
587 _getSubdirectoryNames for help with that.
588 Images are assumed to be files with .gif or .png file extensions.
589 The image names returned do not have the directory name on them.
593 sub _getImagesFromDirectory {
594 my $directoryname = shift;
595 return unless defined $directoryname;
596 return unless -d $directoryname;
598 if ( opendir ( my $dh, $directoryname ) ) {
599 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
603 warn "unable to opendir $directoryname: $!";
608 =head3 _getSubdirectoryNames
610 Find all of the directories in a directory in the filesystem
612 parameters: a directory name
614 returns: a list of subdirectories in that directory.
616 Notes: this does not traverse into subdirectories. Only the first
617 level of subdirectories are returned.
618 The directory names returned don't have the parent directory name on them.
622 sub _getSubdirectoryNames {
623 my $directoryname = shift;
624 return unless defined $directoryname;
625 return unless -d $directoryname;
627 if ( opendir ( my $dh, $directoryname ) ) {
628 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
632 warn "unable to opendir $directoryname: $!";
639 returns: a listref of hashrefs. Each hash represents another collection of images.
641 { imagesetname => 'npl', # the name of the image set (npl is the original one)
642 images => listref of image hashrefs
645 each image is represented by a hashref like this:
647 { KohaImage => 'npl/image.gif',
648 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
649 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
650 checked => 0 or 1: was this the image passed to this method?
651 Note: I'd like to remove this somehow.
658 my $checked = $params{'checked'} || '';
660 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
661 url => getitemtypeimagesrc('intranet'),
663 opac => { filesystem => getitemtypeimagedir('opac'),
664 url => getitemtypeimagesrc('opac'),
668 my @imagesets = (); # list of hasrefs of image set data to pass to template
669 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
671 foreach my $imagesubdir ( @subdirectories ) {
672 my @imagelist = (); # hashrefs of image info
673 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
674 foreach my $thisimage ( @imagenames ) {
676 { KohaImage => "$imagesubdir/$thisimage",
677 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
678 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
679 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
683 push @imagesets, { imagesetname => $imagesubdir,
684 images => \@imagelist };
692 $printers = &GetPrinters();
693 @queues = keys %$printers;
695 Returns information about existing printer queues.
697 C<$printers> is a reference-to-hash whose keys are the print queues
698 defined in the printers table of the Koha database. The values are
699 references-to-hash, whose keys are the fields in the printers table.
705 my $dbh = C4::Context->dbh;
706 my $sth = $dbh->prepare("select * from printers");
708 while ( my $printer = $sth->fetchrow_hashref ) {
709 $printers{ $printer->{'printqueue'} } = $printer;
711 return ( \%printers );
716 $printer = GetPrinter( $query, $printers );
720 sub GetPrinter ($$) {
721 my ( $query, $printers ) = @_; # get printer for this query from printers
722 my $printer = $query->param('printer');
723 my %cookie = $query->cookie('userenv');
724 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
725 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
731 Returns the number of pages to display in a pagination bar, given the number
732 of items and the number of items per page.
737 my ( $nb_items, $nb_items_per_page ) = @_;
739 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
744 (@themes) = &getallthemes('opac');
745 (@themes) = &getallthemes('intranet');
747 Returns an array of all available themes.
755 if ( $type eq 'intranet' ) {
756 $htdocs = C4::Context->config('intrahtdocs');
759 $htdocs = C4::Context->config('opachtdocs');
761 opendir D, "$htdocs";
762 my @dirlist = readdir D;
763 foreach my $directory (@dirlist) {
764 -d "$htdocs/$directory/en" and push @themes, $directory;
771 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
774 link_value => 'su-to',
775 label_value => 'Topics',
777 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
781 link_value => 'su-geo',
782 label_value => 'Places',
787 link_value => 'su-ut',
788 label_value => 'Titles',
789 tags => [ '500', '501', '502', '503', '504', ],
794 label_value => 'Authors',
795 tags => [ '700', '701', '702', ],
800 label_value => 'Series',
809 link_value => 'branch',
810 label_value => 'Libraries',
815 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
820 link_value => 'su-to',
821 label_value => 'Topics',
827 # link_value => 'su-na',
828 # label_value => 'People and Organizations',
829 # tags => ['600', '610', '611'],
833 link_value => 'su-geo',
834 label_value => 'Places',
839 link_value => 'su-ut',
840 label_value => 'Titles',
846 label_value => 'Authors',
847 tags => [ '100', '110', '700', ],
852 label_value => 'Series',
853 tags => [ '440', '490', ],
859 link_value => 'branch',
860 label_value => 'Libraries',
865 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
872 Return a href where a key is associated to a href. You give a query,
873 the name of the key among the fields returned by the query. If you
874 also give as third argument the name of the value, the function
875 returns a href of scalar. The optional 4th argument is an arrayref of
876 items passed to the C<execute()> call. It is designed to bind
877 parameters to any placeholders in your SQL.
886 # generic href of any information on the item, href of href.
887 my $iteminfos_of = get_infos_of($query, 'itemnumber');
888 print $iteminfos_of->{$itemnumber}{barcode};
890 # specific information, href of scalar
891 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
892 print $barcode_of_item->{$itemnumber};
897 my ( $query, $key_name, $value_name, $bind_params ) = @_;
899 my $dbh = C4::Context->dbh;
901 my $sth = $dbh->prepare($query);
902 $sth->execute( @$bind_params );
905 while ( my $row = $sth->fetchrow_hashref ) {
906 if ( defined $value_name ) {
907 $infos_of{ $row->{$key_name} } = $row->{$value_name};
910 $infos_of{ $row->{$key_name} } = $row;
918 =head2 get_notforloan_label_of
920 my $notforloan_label_of = get_notforloan_label_of();
922 Each authorised value of notforloan (information available in items and
923 itemtypes) is link to a single label.
925 Returns a href where keys are authorised values and values are corresponding
928 foreach my $authorised_value (keys %{$notforloan_label_of}) {
930 "authorised_value: %s => %s\n",
932 $notforloan_label_of->{$authorised_value}
938 # FIXME - why not use GetAuthorisedValues ??
940 sub get_notforloan_label_of {
941 my $dbh = C4::Context->dbh;
944 SELECT authorised_value
945 FROM marc_subfield_structure
946 WHERE kohafield = \'items.notforloan\'
949 my $sth = $dbh->prepare($query);
951 my ($statuscode) = $sth->fetchrow_array();
956 FROM authorised_values
959 $sth = $dbh->prepare($query);
960 $sth->execute($statuscode);
961 my %notforloan_label_of;
962 while ( my $row = $sth->fetchrow_hashref ) {
963 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
967 return \%notforloan_label_of;
970 =head2 displayServers
972 my $servers = displayServers();
973 my $servers = displayServers( $position );
974 my $servers = displayServers( $position, $type );
976 displayServers returns a listref of hashrefs, each containing
977 information about available z3950 servers. Each hashref has a format
981 'checked' => 'checked',
982 'encoding' => 'MARC-8'
984 'id' => 'LIBRARY OF CONGRESS',
988 'value' => 'z3950.loc.gov:7090/',
995 my ( $position, $type ) = @_;
996 my $dbh = C4::Context->dbh;
998 my $strsth = 'SELECT * FROM z3950servers';
1003 push @bind_params, $position;
1004 push @where_clauses, ' position = ? ';
1008 push @bind_params, $type;
1009 push @where_clauses, ' type = ? ';
1012 # reassemble where clause from where clause pieces
1013 if (@where_clauses) {
1014 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1017 my $rq = $dbh->prepare($strsth);
1018 $rq->execute(@bind_params);
1019 my @primaryserverloop;
1021 while ( my $data = $rq->fetchrow_hashref ) {
1022 push @primaryserverloop,
1023 { label => $data->{description},
1024 id => $data->{name},
1026 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1027 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1028 checked => "checked",
1029 icon => $data->{icon},
1030 zed => $data->{type} eq 'zed',
1031 opensearch => $data->{type} eq 'opensearch'
1034 return \@primaryserverloop;
1037 =head2 GetAuthValCode
1039 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1043 sub GetAuthValCode {
1044 my ($kohafield,$fwcode) = @_;
1045 my $dbh = C4::Context->dbh;
1046 $fwcode='' unless $fwcode;
1047 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1048 $sth->execute($kohafield,$fwcode);
1049 my ($authvalcode) = $sth->fetchrow_array;
1050 return $authvalcode;
1053 =head2 GetAuthValCodeFromField
1055 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1057 C<$subfield> can be undefined
1061 sub GetAuthValCodeFromField {
1062 my ($field,$subfield,$fwcode) = @_;
1063 my $dbh = C4::Context->dbh;
1064 $fwcode='' unless $fwcode;
1066 if (defined $subfield) {
1067 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1068 $sth->execute($field,$subfield,$fwcode);
1070 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1071 $sth->execute($field,$fwcode);
1073 my ($authvalcode) = $sth->fetchrow_array;
1074 return $authvalcode;
1077 =head2 GetAuthorisedValues
1079 $authvalues = GetAuthorisedValues([$category], [$selected]);
1081 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1083 C<$category> returns authorised values for just one category (optional).
1085 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1089 sub GetAuthorisedValues {
1090 my ($category,$selected,$opac) = @_;
1092 my $dbh = C4::Context->dbh;
1093 my $query = "SELECT * FROM authorised_values";
1094 $query .= " WHERE category = '" . $category . "'" if $category;
1095 $query .= " ORDER BY category, lib, lib_opac";
1096 my $sth = $dbh->prepare($query);
1098 while (my $data=$sth->fetchrow_hashref) {
1099 if ($selected && $selected eq $data->{'authorised_value'} ) {
1100 $data->{'selected'} = 1;
1102 if ($opac && $data->{'lib_opac'}) {
1103 $data->{'lib'} = $data->{'lib_opac'};
1105 push @results, $data;
1107 #my $data = $sth->fetchall_arrayref({});
1108 return \@results; #$data;
1111 =head2 GetAuthorisedValueCategories
1113 $auth_categories = GetAuthorisedValueCategories();
1115 Return an arrayref of all of the available authorised
1120 sub GetAuthorisedValueCategories {
1121 my $dbh = C4::Context->dbh;
1122 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1125 while (my $category = $sth->fetchrow_array) {
1126 push @results, $category;
1131 =head2 GetKohaAuthorisedValues
1133 Takes $kohafield, $fwcode as parameters.
1135 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1137 Returns hashref of Code => description
1139 Returns undef if no authorised value category is defined for the kohafield.
1143 sub GetKohaAuthorisedValues {
1144 my ($kohafield,$fwcode,$opac) = @_;
1145 $fwcode='' unless $fwcode;
1147 my $dbh = C4::Context->dbh;
1148 my $avcode = GetAuthValCode($kohafield,$fwcode);
1150 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1151 $sth->execute($avcode);
1152 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1153 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1161 =head2 GetKohaAuthorisedValuesFromField
1163 Takes $field, $subfield, $fwcode as parameters.
1165 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1166 $subfield can be undefined
1168 Returns hashref of Code => description
1170 Returns undef if no authorised value category is defined for the given field and subfield
1174 sub GetKohaAuthorisedValuesFromField {
1175 my ($field, $subfield, $fwcode,$opac) = @_;
1176 $fwcode='' unless $fwcode;
1178 my $dbh = C4::Context->dbh;
1179 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1181 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1182 $sth->execute($avcode);
1183 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1184 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1192 =head2 display_marc_indicators
1194 my $display_form = C4::Koha::display_marc_indicators($field);
1196 C<$field> is a MARC::Field object
1198 Generate a display form of the indicators of a variable
1199 MARC field, replacing any blanks with '#'.
1203 sub display_marc_indicators {
1205 my $indicators = '';
1206 if ($field->tag() >= 10) {
1207 $indicators = $field->indicator(1) . $field->indicator(2);
1208 $indicators =~ s/ /#/g;
1213 sub GetNormalizedUPC {
1214 my ($record,$marcflavour) = @_;
1217 if ($marcflavour eq 'MARC21') {
1218 @fields = $record->field('024');
1219 foreach my $field (@fields) {
1220 my $indicator = $field->indicator(1);
1221 my $upc = _normalize_match_point($field->subfield('a'));
1222 if ($indicator == 1 and $upc ne '') {
1227 else { # assume unimarc if not marc21
1228 @fields = $record->field('072');
1229 foreach my $field (@fields) {
1230 my $upc = _normalize_match_point($field->subfield('a'));
1238 # Normalizes and returns the first valid ISBN found in the record
1239 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1240 sub GetNormalizedISBN {
1241 my ($isbn,$record,$marcflavour) = @_;
1244 return _isbn_cleanup($isbn);
1246 return undef unless $record;
1248 if ($marcflavour eq 'MARC21') {
1249 @fields = $record->field('020');
1250 foreach my $field (@fields) {
1251 $isbn = $field->subfield('a');
1253 return _isbn_cleanup($isbn);
1259 else { # assume unimarc if not marc21
1260 @fields = $record->field('010');
1261 foreach my $field (@fields) {
1262 my $isbn = $field->subfield('a');
1264 return _isbn_cleanup($isbn);
1273 sub GetNormalizedEAN {
1274 my ($record,$marcflavour) = @_;
1277 if ($marcflavour eq 'MARC21') {
1278 @fields = $record->field('024');
1279 foreach my $field (@fields) {
1280 my $indicator = $field->indicator(1);
1281 $ean = _normalize_match_point($field->subfield('a'));
1282 if ($indicator == 3 and $ean ne '') {
1287 else { # assume unimarc if not marc21
1288 @fields = $record->field('073');
1289 foreach my $field (@fields) {
1290 $ean = _normalize_match_point($field->subfield('a'));
1297 sub GetNormalizedOCLCNumber {
1298 my ($record,$marcflavour) = @_;
1301 if ($marcflavour eq 'MARC21') {
1302 @fields = $record->field('035');
1303 foreach my $field (@fields) {
1304 $oclc = $field->subfield('a');
1305 if ($oclc =~ /OCoLC/) {
1306 $oclc =~ s/\(OCoLC\)//;
1313 else { # TODO: add UNIMARC fields
1317 sub _normalize_match_point {
1318 my $match_point = shift;
1319 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1320 $normalized_match_point =~ s/-//g;
1322 return $normalized_match_point;
1325 sub _isbn_cleanup ($) {
1326 my $isbn = Business::ISBN->new( shift );
1327 return undef unless $isbn;
1328 $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1329 $isbn = $isbn->as_string;