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);
28 use vars qw($VERSION @ISA @EXPORT $DEBUG);
37 &subfield_is_koha_internal_p
38 &GetPrinters &GetPrinter
39 &GetItemTypes &getitemtypeinfo
41 &GetSupportName &GetSupportList
43 &getframeworks &getframeworkinfo
44 &getauthtypes &getauthtype
50 &get_notforloan_label_of
53 &getitemtypeimagelocation
55 &GetAuthorisedValueCategories
56 &GetKohaAuthorisedValues
57 &GetKohaAuthorisedValuesFromField
62 &GetNormalizedOCLCNumber
70 memoize('GetAuthorisedValues');
74 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.
228 return if (! $codestring);
230 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
231 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
238 my $sth = C4::Context->dbh->prepare($query);
239 $sth->execute($codestring);
240 ($resultstring)=$sth->fetchrow;
241 return $resultstring;
244 C4::Context->dbh->prepare(
245 "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
247 $sth->execute( $advanced_search_types, $codestring );
248 my $data = $sth->fetchrow_hashref;
249 return $$data{'lib'};
253 =head2 GetSupportList
255 $itemtypes = &GetSupportList();
257 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
259 build a HTML select with the following code :
261 =head3 in PERL SCRIPT
263 my $itemtypes = GetSupportList();
264 $template->param(itemtypeloop => $itemtypes);
268 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
269 <select name="itemtype">
270 <option value="">Default</option>
271 <!-- TMPL_LOOP name="itemtypeloop" -->
272 <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>
275 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
276 <input type="submit" value="OK" class="button">
282 my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
283 if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
289 my $sth = C4::Context->dbh->prepare($query);
291 return $sth->fetchall_arrayref({});
293 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
294 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
300 $itemtypes = &GetItemTypes();
302 Returns information about existing itemtypes.
304 build a HTML select with the following code :
306 =head3 in PERL SCRIPT
308 my $itemtypes = GetItemTypes;
310 foreach my $thisitemtype (sort keys %$itemtypes) {
311 my $selected = 1 if $thisitemtype eq $itemtype;
312 my %row =(value => $thisitemtype,
313 selected => $selected,
314 description => $itemtypes->{$thisitemtype}->{'description'},
316 push @itemtypesloop, \%row;
318 $template->param(itemtypeloop => \@itemtypesloop);
322 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
323 <select name="itemtype">
324 <option value="">Default</option>
325 <!-- TMPL_LOOP name="itemtypeloop" -->
326 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
329 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
330 <input type="submit" value="OK" class="button">
337 # returns a reference to a hash of references to itemtypes...
339 my $dbh = C4::Context->dbh;
344 my $sth = $dbh->prepare($query);
346 while ( my $IT = $sth->fetchrow_hashref ) {
347 $itemtypes{ $IT->{'itemtype'} } = $IT;
349 return ( \%itemtypes );
352 sub get_itemtypeinfos_of {
355 my $placeholders = join( ', ', map { '?' } @itemtypes );
356 my $query = <<"END_SQL";
362 WHERE itemtype IN ( $placeholders )
365 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
368 # this is temporary until we separate collection codes and item types
372 my $dbh = C4::Context->dbh;
375 "SELECT * FROM authorised_values ORDER BY authorised_value");
377 while ( my $data = $sth->fetchrow_hashref ) {
378 if ( $data->{category} eq "CCODE" ) {
380 $results[$count] = $data;
386 return ( $count, @results );
391 $authtypes = &getauthtypes();
393 Returns information about existing authtypes.
395 build a HTML select with the following code :
397 =head3 in PERL SCRIPT
399 my $authtypes = getauthtypes;
401 foreach my $thisauthtype (keys %$authtypes) {
402 my $selected = 1 if $thisauthtype eq $authtype;
403 my %row =(value => $thisauthtype,
404 selected => $selected,
405 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
407 push @authtypesloop, \%row;
409 $template->param(itemtypeloop => \@itemtypesloop);
413 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
414 <select name="authtype">
415 <!-- TMPL_LOOP name="authtypeloop" -->
416 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
419 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
420 <input type="submit" value="OK" class="button">
428 # returns a reference to a hash of references to authtypes...
430 my $dbh = C4::Context->dbh;
431 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
433 while ( my $IT = $sth->fetchrow_hashref ) {
434 $authtypes{ $IT->{'authtypecode'} } = $IT;
436 return ( \%authtypes );
440 my ($authtypecode) = @_;
442 # returns a reference to a hash of references to authtypes...
444 my $dbh = C4::Context->dbh;
445 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
446 $sth->execute($authtypecode);
447 my $res = $sth->fetchrow_hashref;
453 $frameworks = &getframework();
455 Returns information about existing frameworks
457 build a HTML select with the following code :
459 =head3 in PERL SCRIPT
461 my $frameworks = frameworks();
463 foreach my $thisframework (keys %$frameworks) {
464 my $selected = 1 if $thisframework eq $frameworkcode;
465 my %row =(value => $thisframework,
466 selected => $selected,
467 description => $frameworks->{$thisframework}->{'frameworktext'},
469 push @frameworksloop, \%row;
471 $template->param(frameworkloop => \@frameworksloop);
475 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
476 <select name="frameworkcode">
477 <option value="">Default</option>
478 <!-- TMPL_LOOP name="frameworkloop" -->
479 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
482 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
483 <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
546 my $directory = getitemtypeimagedir( 'opac' );
548 pass in 'opac' or 'intranet'. Defaults to 'opac'.
550 returns the full path to the appropriate directory containing images.
556 sub getitemtypeimagedir {
557 my $src = shift || 'opac';
558 if ($src eq 'intranet') {
559 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
561 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
565 sub getitemtypeimagesrc {
566 my $src = shift || 'opac';
567 if ($src eq 'intranet') {
568 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
570 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
574 sub getitemtypeimagelocation($$) {
575 my ( $src, $image ) = @_;
577 return '' if ( !$image );
579 my $scheme = ( uri_split( $image ) )[0];
581 return $image if ( $scheme );
583 return getitemtypeimagesrc( $src ) . '/' . $image;
586 =head3 _getImagesFromDirectory
588 Find all of the image files in a directory in the filesystem
593 returns: a list of images in that directory.
595 Notes: this does not traverse into subdirectories. See
596 _getSubdirectoryNames for help with that.
597 Images are assumed to be files with .gif or .png file extensions.
598 The image names returned do not have the directory name on them.
602 sub _getImagesFromDirectory {
603 my $directoryname = shift;
604 return unless defined $directoryname;
605 return unless -d $directoryname;
607 if ( opendir ( my $dh, $directoryname ) ) {
608 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
612 warn "unable to opendir $directoryname: $!";
617 =head3 _getSubdirectoryNames
619 Find all of the directories in a directory in the filesystem
624 returns: a list of subdirectories in that directory.
626 Notes: this does not traverse into subdirectories. Only the first
627 level of subdirectories are returned.
628 The directory names returned don't have the parent directory name
633 sub _getSubdirectoryNames {
634 my $directoryname = shift;
635 return unless defined $directoryname;
636 return unless -d $directoryname;
638 if ( opendir ( my $dh, $directoryname ) ) {
639 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
643 warn "unable to opendir $directoryname: $!";
650 returns: a listref of hashrefs. Each hash represents another collection of images.
651 { imagesetname => 'npl', # the name of the image set (npl is the original one)
652 images => listref of image hashrefs
655 each image is represented by a hashref like this:
656 { KohaImage => 'npl/image.gif',
657 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
658 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
659 checked => 0 or 1: was this the image passed to this method?
660 Note: I'd like to remove this somehow.
667 my $checked = $params{'checked'} || '';
669 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
670 url => getitemtypeimagesrc('intranet'),
672 opac => { filesystem => getitemtypeimagedir('opac'),
673 url => getitemtypeimagesrc('opac'),
677 my @imagesets = (); # list of hasrefs of image set data to pass to template
678 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
680 foreach my $imagesubdir ( @subdirectories ) {
681 my @imagelist = (); # hashrefs of image info
682 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
683 foreach my $thisimage ( @imagenames ) {
685 { KohaImage => "$imagesubdir/$thisimage",
686 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
687 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
688 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
692 push @imagesets, { imagesetname => $imagesubdir,
693 images => \@imagelist };
701 $printers = &GetPrinters();
702 @queues = keys %$printers;
704 Returns information about existing printer queues.
706 C<$printers> is a reference-to-hash whose keys are the print queues
707 defined in the printers table of the Koha database. The values are
708 references-to-hash, whose keys are the fields in the printers table.
714 my $dbh = C4::Context->dbh;
715 my $sth = $dbh->prepare("select * from printers");
717 while ( my $printer = $sth->fetchrow_hashref ) {
718 $printers{ $printer->{'printqueue'} } = $printer;
720 return ( \%printers );
725 $printer = GetPrinter( $query, $printers );
729 sub GetPrinter ($$) {
730 my ( $query, $printers ) = @_; # get printer for this query from printers
731 my $printer = $query->param('printer');
732 my %cookie = $query->cookie('userenv');
733 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
734 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
740 Returns the number of pages to display in a pagination bar, given the number
741 of items and the number of items per page.
746 my ( $nb_items, $nb_items_per_page ) = @_;
748 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
753 (@themes) = &getallthemes('opac');
754 (@themes) = &getallthemes('intranet');
756 Returns an array of all available themes.
764 if ( $type eq 'intranet' ) {
765 $htdocs = C4::Context->config('intrahtdocs');
768 $htdocs = C4::Context->config('opachtdocs');
770 opendir D, "$htdocs";
771 my @dirlist = readdir D;
772 foreach my $directory (@dirlist) {
773 -d "$htdocs/$directory/en" and push @themes, $directory;
780 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
783 link_value => 'su-to',
784 label_value => 'Topics',
786 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
790 link_value => 'su-geo',
791 label_value => 'Places',
796 link_value => 'su-ut',
797 label_value => 'Titles',
798 tags => [ '500', '501', '502', '503', '504', ],
803 label_value => 'Authors',
804 tags => [ '700', '701', '702', ],
809 label_value => 'Series',
818 link_value => 'branch',
819 label_value => 'Libraries',
824 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
829 link_value => 'su-to',
830 label_value => 'Topics',
836 # link_value => 'su-na',
837 # label_value => 'People and Organizations',
838 # tags => ['600', '610', '611'],
842 link_value => 'su-geo',
843 label_value => 'Places',
848 link_value => 'su-ut',
849 label_value => 'Titles',
855 label_value => 'Authors',
856 tags => [ '100', '110', '700', ],
861 label_value => 'Series',
862 tags => [ '440', '490', ],
868 link_value => 'branch',
869 label_value => 'Libraries',
874 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
881 Return a href where a key is associated to a href. You give a query,
882 the name of the key among the fields returned by the query. If you
883 also give as third argument the name of the value, the function
884 returns a href of scalar. The optional 4th argument is an arrayref of
885 items passed to the C<execute()> call. It is designed to bind
886 parameters to any placeholders in your SQL.
895 # generic href of any information on the item, href of href.
896 my $iteminfos_of = get_infos_of($query, 'itemnumber');
897 print $iteminfos_of->{$itemnumber}{barcode};
899 # specific information, href of scalar
900 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
901 print $barcode_of_item->{$itemnumber};
906 my ( $query, $key_name, $value_name, $bind_params ) = @_;
908 my $dbh = C4::Context->dbh;
910 my $sth = $dbh->prepare($query);
911 $sth->execute( @$bind_params );
914 while ( my $row = $sth->fetchrow_hashref ) {
915 if ( defined $value_name ) {
916 $infos_of{ $row->{$key_name} } = $row->{$value_name};
919 $infos_of{ $row->{$key_name} } = $row;
927 =head2 get_notforloan_label_of
929 my $notforloan_label_of = get_notforloan_label_of();
931 Each authorised value of notforloan (information available in items and
932 itemtypes) is link to a single label.
934 Returns a href where keys are authorised values and values are corresponding
937 foreach my $authorised_value (keys %{$notforloan_label_of}) {
939 "authorised_value: %s => %s\n",
941 $notforloan_label_of->{$authorised_value}
947 # FIXME - why not use GetAuthorisedValues ??
949 sub get_notforloan_label_of {
950 my $dbh = C4::Context->dbh;
953 SELECT authorised_value
954 FROM marc_subfield_structure
955 WHERE kohafield = \'items.notforloan\'
958 my $sth = $dbh->prepare($query);
960 my ($statuscode) = $sth->fetchrow_array();
965 FROM authorised_values
968 $sth = $dbh->prepare($query);
969 $sth->execute($statuscode);
970 my %notforloan_label_of;
971 while ( my $row = $sth->fetchrow_hashref ) {
972 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
976 return \%notforloan_label_of;
979 =head2 displayServers
983 my $servers = displayServers();
985 my $servers = displayServers( $position );
987 my $servers = displayServers( $position, $type );
991 displayServers returns a listref of hashrefs, each containing
992 information about available z3950 servers. Each hashref has a format
996 'checked' => 'checked',
997 'encoding' => 'MARC-8'
999 'id' => 'LIBRARY OF CONGRESS',
1003 'value' => 'z3950.loc.gov:7090/',
1010 sub displayServers {
1011 my ( $position, $type ) = @_;
1012 my $dbh = C4::Context->dbh;
1014 my $strsth = 'SELECT * FROM z3950servers';
1019 push @bind_params, $position;
1020 push @where_clauses, ' position = ? ';
1024 push @bind_params, $type;
1025 push @where_clauses, ' type = ? ';
1028 # reassemble where clause from where clause pieces
1029 if (@where_clauses) {
1030 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1033 my $rq = $dbh->prepare($strsth);
1034 $rq->execute(@bind_params);
1035 my @primaryserverloop;
1037 while ( my $data = $rq->fetchrow_hashref ) {
1038 push @primaryserverloop,
1039 { label => $data->{description},
1040 id => $data->{name},
1042 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1043 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1044 checked => "checked",
1045 icon => $data->{icon},
1046 zed => $data->{type} eq 'zed',
1047 opensearch => $data->{type} eq 'opensearch'
1050 return \@primaryserverloop;
1053 =head2 GetAuthValCode
1055 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1059 sub GetAuthValCode {
1060 my ($kohafield,$fwcode) = @_;
1061 my $dbh = C4::Context->dbh;
1062 $fwcode='' unless $fwcode;
1063 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1064 $sth->execute($kohafield,$fwcode);
1065 my ($authvalcode) = $sth->fetchrow_array;
1066 return $authvalcode;
1069 =head2 GetAuthValCodeFromField
1071 $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1073 C<$subfield> can be undefined
1077 sub GetAuthValCodeFromField {
1078 my ($field,$subfield,$fwcode) = @_;
1079 my $dbh = C4::Context->dbh;
1080 $fwcode='' unless $fwcode;
1082 if (defined $subfield) {
1083 $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1084 $sth->execute($field,$subfield,$fwcode);
1086 $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1087 $sth->execute($field,$fwcode);
1089 my ($authvalcode) = $sth->fetchrow_array;
1090 return $authvalcode;
1093 =head2 GetAuthorisedValues
1095 $authvalues = GetAuthorisedValues([$category], [$selected]);
1097 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1099 C<$category> returns authorised values for just one category (optional).
1101 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1105 sub GetAuthorisedValues {
1106 my ($category,$selected,$opac) = @_;
1108 my $dbh = C4::Context->dbh;
1109 my $query = "SELECT * FROM authorised_values";
1110 $query .= " WHERE category = '" . $category . "'" if $category;
1111 $query .= " ORDER BY category, lib, lib_opac";
1112 my $sth = $dbh->prepare($query);
1114 while (my $data=$sth->fetchrow_hashref) {
1115 if ($selected && $selected eq $data->{'authorised_value'} ) {
1116 $data->{'selected'} = 1;
1118 if ($opac && $data->{'lib_opac'}) {
1119 $data->{'lib'} = $data->{'lib_opac'};
1121 push @results, $data;
1123 #my $data = $sth->fetchall_arrayref({});
1124 return \@results; #$data;
1127 =head2 GetAuthorisedValueCategories
1129 $auth_categories = GetAuthorisedValueCategories();
1131 Return an arrayref of all of the available authorised
1136 sub GetAuthorisedValueCategories {
1137 my $dbh = C4::Context->dbh;
1138 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1141 while (my $category = $sth->fetchrow_array) {
1142 push @results, $category;
1147 =head2 GetKohaAuthorisedValues
1149 Takes $kohafield, $fwcode as parameters.
1150 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1151 Returns hashref of Code => description
1153 if no authorised value category is defined for the kohafield.
1157 sub GetKohaAuthorisedValues {
1158 my ($kohafield,$fwcode,$opac) = @_;
1159 $fwcode='' unless $fwcode;
1161 my $dbh = C4::Context->dbh;
1162 my $avcode = GetAuthValCode($kohafield,$fwcode);
1164 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1165 $sth->execute($avcode);
1166 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1167 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1175 =head2 GetKohaAuthorisedValuesFromField
1177 Takes $field, $subfield $fwcode as parameters.
1178 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1179 $subfield can be undefined
1180 Returns hashref of Code => description
1182 if no authorised value category is defined for the given field and subfield
1186 sub GetKohaAuthorisedValuesFromField {
1187 my ($field, $subfield, $fwcode,$opac) = @_;
1188 $fwcode='' unless $fwcode;
1190 my $dbh = C4::Context->dbh;
1191 my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1193 my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1194 $sth->execute($avcode);
1195 while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1196 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1204 =head2 display_marc_indicators
1208 # field is a MARC::Field object
1209 my $display_form = C4::Koha::display_marc_indicators($field);
1213 Generate a display form of the indicators of a variable
1214 MARC field, replacing any blanks with '#'.
1218 sub display_marc_indicators {
1220 my $indicators = '';
1221 if ($field->tag() >= 10) {
1222 $indicators = $field->indicator(1) . $field->indicator(2);
1223 $indicators =~ s/ /#/g;
1228 sub GetNormalizedUPC {
1229 my ($record,$marcflavour) = @_;
1232 if ($marcflavour eq 'MARC21') {
1233 @fields = $record->field('024');
1234 foreach my $field (@fields) {
1235 my $indicator = $field->indicator(1);
1236 my $upc = _normalize_match_point($field->subfield('a'));
1237 if ($indicator == 1 and $upc ne '') {
1242 else { # assume unimarc if not marc21
1243 @fields = $record->field('072');
1244 foreach my $field (@fields) {
1245 my $upc = _normalize_match_point($field->subfield('a'));
1253 # Normalizes and returns the first valid ISBN found in the record
1254 sub GetNormalizedISBN {
1255 my ($isbn,$record,$marcflavour) = @_;
1258 return _isbn_cleanup($isbn);
1260 return undef unless $record;
1262 if ($marcflavour eq 'MARC21') {
1263 @fields = $record->field('020');
1264 foreach my $field (@fields) {
1265 $isbn = $field->subfield('a');
1267 return _isbn_cleanup($isbn);
1273 else { # assume unimarc if not marc21
1274 @fields = $record->field('010');
1275 foreach my $field (@fields) {
1276 my $isbn = $field->subfield('a');
1278 return _isbn_cleanup($isbn);
1287 sub GetNormalizedEAN {
1288 my ($record,$marcflavour) = @_;
1291 if ($marcflavour eq 'MARC21') {
1292 @fields = $record->field('024');
1293 foreach my $field (@fields) {
1294 my $indicator = $field->indicator(1);
1295 $ean = _normalize_match_point($field->subfield('a'));
1296 if ($indicator == 3 and $ean ne '') {
1301 else { # assume unimarc if not marc21
1302 @fields = $record->field('073');
1303 foreach my $field (@fields) {
1304 $ean = _normalize_match_point($field->subfield('a'));
1311 sub GetNormalizedOCLCNumber {
1312 my ($record,$marcflavour) = @_;
1315 if ($marcflavour eq 'MARC21') {
1316 @fields = $record->field('035');
1317 foreach my $field (@fields) {
1318 $oclc = $field->subfield('a');
1319 if ($oclc =~ /OCoLC/) {
1320 $oclc =~ s/\(OCoLC\)//;
1327 else { # TODO: add UNIMARC fields
1331 sub _normalize_match_point {
1332 my $match_point = shift;
1333 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1334 $normalized_match_point =~ s/-//g;
1336 return $normalized_match_point;
1339 sub _isbn_cleanup ($) {
1340 my $normalized_isbn = shift;
1341 $normalized_isbn =~ s/-//g;
1342 $normalized_isbn =~/([0-9x]{1,})/i;
1343 $normalized_isbn = $1;
1345 $normalized_isbn =~ /\b(\d{13})\b/ or
1346 $normalized_isbn =~ /\b(\d{12})\b/i or
1347 $normalized_isbn =~ /\b(\d{10})\b/ or
1348 $normalized_isbn =~ /\b(\d{9}X)\b/i