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 with
17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
18 # Suite 330, Boston, MA 02111-1307 USA
24 use URI::Split qw(uri_split);
26 use vars qw($VERSION @ISA @EXPORT $DEBUG);
35 &subfield_is_koha_internal_p
36 &GetPrinters &GetPrinter
37 &GetItemTypes &getitemtypeinfo
40 &getframeworks &getframeworkinfo
41 &getauthtypes &getauthtype
47 &get_notforloan_label_of
50 &getitemtypeimagelocation
52 &GetAuthorisedValueCategories
53 &GetKohaAuthorisedValues
58 &GetNormalizedOCLCNumber
67 C4::Koha - Perl Module containing convenience functions for Koha scripts
76 Koha.pm provides many functions for Koha scripts.
84 $slash_date = &slashifyDate($dash_date);
86 Takes a string of the form "DD-MM-YYYY" (or anything separated by
87 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
93 # accepts a date of the form xx-xx-xx[xx] and returns it in the
95 my @dateOut = split( '-', shift );
96 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
102 my $string = DisplayISBN( $isbn );
108 if (length ($isbn)<13){
110 if ( substr( $isbn, 0, 1 ) <= 7 ) {
111 $seg1 = substr( $isbn, 0, 1 );
113 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
114 $seg1 = substr( $isbn, 0, 2 );
116 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
117 $seg1 = substr( $isbn, 0, 3 );
119 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
120 $seg1 = substr( $isbn, 0, 4 );
123 $seg1 = substr( $isbn, 0, 5 );
125 my $x = substr( $isbn, length($seg1) );
127 if ( substr( $x, 0, 2 ) <= 19 ) {
129 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
130 $seg2 = substr( $x, 0, 2 );
132 elsif ( substr( $x, 0, 3 ) <= 699 ) {
133 $seg2 = substr( $x, 0, 3 );
135 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
136 $seg2 = substr( $x, 0, 4 );
138 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
139 $seg2 = substr( $x, 0, 5 );
141 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
142 $seg2 = substr( $x, 0, 6 );
145 $seg2 = substr( $x, 0, 7 );
147 my $seg3 = substr( $x, length($seg2) );
148 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
149 my $seg4 = substr( $x, -1, 1 );
150 return "$seg1-$seg2-$seg3-$seg4";
153 $seg1 = substr( $isbn, 0, 3 );
155 if ( substr( $isbn, 3, 1 ) <= 7 ) {
156 $seg2 = substr( $isbn, 3, 1 );
158 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
159 $seg2 = substr( $isbn, 3, 2 );
161 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
162 $seg2 = substr( $isbn, 3, 3 );
164 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
165 $seg2 = substr( $isbn, 3, 4 );
168 $seg2 = substr( $isbn, 3, 5 );
170 my $x = substr( $isbn, length($seg2) +3);
172 if ( substr( $x, 0, 2 ) <= 19 ) {
174 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
175 $seg3 = substr( $x, 0, 2 );
177 elsif ( substr( $x, 0, 3 ) <= 699 ) {
178 $seg3 = substr( $x, 0, 3 );
180 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
181 $seg3 = substr( $x, 0, 4 );
183 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
184 $seg3 = substr( $x, 0, 5 );
186 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
187 $seg3 = substr( $x, 0, 6 );
190 $seg3 = substr( $x, 0, 7 );
192 my $seg4 = substr( $x, length($seg3) );
193 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
194 my $seg5 = substr( $x, -1, 1 );
195 return "$seg1-$seg2-$seg3-$seg4-$seg5";
199 # FIXME.. this should be moved to a MARC-specific module
200 sub subfield_is_koha_internal_p ($) {
203 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
204 # But real MARC subfields are always single-character
205 # so it really is safer just to check the length
207 return length $subfield != 1;
212 $itemtypes = &GetItemTypes();
214 Returns information about existing itemtypes.
216 build a HTML select with the following code :
218 =head3 in PERL SCRIPT
220 my $itemtypes = GetItemTypes;
222 foreach my $thisitemtype (sort keys %$itemtypes) {
223 my $selected = 1 if $thisitemtype eq $itemtype;
224 my %row =(value => $thisitemtype,
225 selected => $selected,
226 description => $itemtypes->{$thisitemtype}->{'description'},
228 push @itemtypesloop, \%row;
230 $template->param(itemtypeloop => \@itemtypesloop);
234 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
235 <select name="itemtype">
236 <option value="">Default</option>
237 <!-- TMPL_LOOP name="itemtypeloop" -->
238 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
241 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
242 <input type="submit" value="OK" class="button">
249 # returns a reference to a hash of references to itemtypes...
251 my $dbh = C4::Context->dbh;
256 my $sth = $dbh->prepare($query);
258 while ( my $IT = $sth->fetchrow_hashref ) {
259 $itemtypes{ $IT->{'itemtype'} } = $IT;
261 return ( \%itemtypes );
264 sub get_itemtypeinfos_of {
267 my $placeholders = join( ', ', map { '?' } @itemtypes );
268 my $query = <<"END_SQL";
274 WHERE itemtype IN ( $placeholders )
277 return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
280 # this is temporary until we separate collection codes and item types
284 my $dbh = C4::Context->dbh;
287 "SELECT * FROM authorised_values ORDER BY authorised_value");
289 while ( my $data = $sth->fetchrow_hashref ) {
290 if ( $data->{category} eq "CCODE" ) {
292 $results[$count] = $data;
298 return ( $count, @results );
303 $authtypes = &getauthtypes();
305 Returns information about existing authtypes.
307 build a HTML select with the following code :
309 =head3 in PERL SCRIPT
311 my $authtypes = getauthtypes;
313 foreach my $thisauthtype (keys %$authtypes) {
314 my $selected = 1 if $thisauthtype eq $authtype;
315 my %row =(value => $thisauthtype,
316 selected => $selected,
317 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
319 push @authtypesloop, \%row;
321 $template->param(itemtypeloop => \@itemtypesloop);
325 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
326 <select name="authtype">
327 <!-- TMPL_LOOP name="authtypeloop" -->
328 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
331 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
332 <input type="submit" value="OK" class="button">
340 # returns a reference to a hash of references to authtypes...
342 my $dbh = C4::Context->dbh;
343 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
345 while ( my $IT = $sth->fetchrow_hashref ) {
346 $authtypes{ $IT->{'authtypecode'} } = $IT;
348 return ( \%authtypes );
352 my ($authtypecode) = @_;
354 # returns a reference to a hash of references to authtypes...
356 my $dbh = C4::Context->dbh;
357 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
358 $sth->execute($authtypecode);
359 my $res = $sth->fetchrow_hashref;
365 $frameworks = &getframework();
367 Returns information about existing frameworks
369 build a HTML select with the following code :
371 =head3 in PERL SCRIPT
373 my $frameworks = frameworks();
375 foreach my $thisframework (keys %$frameworks) {
376 my $selected = 1 if $thisframework eq $frameworkcode;
377 my %row =(value => $thisframework,
378 selected => $selected,
379 description => $frameworks->{$thisframework}->{'frameworktext'},
381 push @frameworksloop, \%row;
383 $template->param(frameworkloop => \@frameworksloop);
387 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
388 <select name="frameworkcode">
389 <option value="">Default</option>
390 <!-- TMPL_LOOP name="frameworkloop" -->
391 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
394 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
395 <input type="submit" value="OK" class="button">
403 # returns a reference to a hash of references to branches...
405 my $dbh = C4::Context->dbh;
406 my $sth = $dbh->prepare("select * from biblio_framework");
408 while ( my $IT = $sth->fetchrow_hashref ) {
409 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
411 return ( \%itemtypes );
414 =head2 getframeworkinfo
416 $frameworkinfo = &getframeworkinfo($frameworkcode);
418 Returns information about an frameworkcode.
422 sub getframeworkinfo {
423 my ($frameworkcode) = @_;
424 my $dbh = C4::Context->dbh;
426 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
427 $sth->execute($frameworkcode);
428 my $res = $sth->fetchrow_hashref;
432 =head2 getitemtypeinfo
434 $itemtype = &getitemtype($itemtype);
436 Returns information about an itemtype.
440 sub getitemtypeinfo {
442 my $dbh = C4::Context->dbh;
443 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
444 $sth->execute($itemtype);
445 my $res = $sth->fetchrow_hashref;
447 $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
452 =head2 getitemtypeimagedir
458 my $directory = getitemtypeimagedir( 'opac' );
460 pass in 'opac' or 'intranet'. Defaults to 'opac'.
462 returns the full path to the appropriate directory containing images.
468 sub getitemtypeimagedir {
469 my $src = shift || 'opac';
470 if ($src eq 'intranet') {
471 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
473 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
477 sub getitemtypeimagesrc {
478 my $src = shift || 'opac';
479 if ($src eq 'intranet') {
480 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
482 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
486 sub getitemtypeimagelocation($$) {
487 my ( $src, $image ) = @_;
489 return '' if ( !$image );
491 my $scheme = ( uri_split( $image ) )[0];
493 return $image if ( $scheme );
495 return getitemtypeimagesrc( $src ) . '/' . $image;
498 =head3 _getImagesFromDirectory
500 Find all of the image files in a directory in the filesystem
505 returns: a list of images in that directory.
507 Notes: this does not traverse into subdirectories. See
508 _getSubdirectoryNames for help with that.
509 Images are assumed to be files with .gif or .png file extensions.
510 The image names returned do not have the directory name on them.
514 sub _getImagesFromDirectory {
515 my $directoryname = shift;
516 return unless defined $directoryname;
517 return unless -d $directoryname;
519 if ( opendir ( my $dh, $directoryname ) ) {
520 my @images = grep { /\.(gif|png)$/i } readdir( $dh );
524 warn "unable to opendir $directoryname: $!";
529 =head3 _getSubdirectoryNames
531 Find all of the directories in a directory in the filesystem
536 returns: a list of subdirectories in that directory.
538 Notes: this does not traverse into subdirectories. Only the first
539 level of subdirectories are returned.
540 The directory names returned don't have the parent directory name
545 sub _getSubdirectoryNames {
546 my $directoryname = shift;
547 return unless defined $directoryname;
548 return unless -d $directoryname;
550 if ( opendir ( my $dh, $directoryname ) ) {
551 my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
555 warn "unable to opendir $directoryname: $!";
562 returns: a listref of hashrefs. Each hash represents another collection of images.
563 { imagesetname => 'npl', # the name of the image set (npl is the original one)
564 images => listref of image hashrefs
567 each image is represented by a hashref like this:
568 { KohaImage => 'npl/image.gif',
569 StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
570 OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
571 checked => 0 or 1: was this the image passed to this method?
572 Note: I'd like to remove this somehow.
579 my $checked = $params{'checked'} || '';
581 my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
582 url => getitemtypeimagesrc('intranet'),
584 opac => { filesystem => getitemtypeimagedir('opac'),
585 url => getitemtypeimagesrc('opac'),
589 my @imagesets = (); # list of hasrefs of image set data to pass to template
590 my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
592 foreach my $imagesubdir ( @subdirectories ) {
593 my @imagelist = (); # hashrefs of image info
594 my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
595 foreach my $thisimage ( @imagenames ) {
597 { KohaImage => "$imagesubdir/$thisimage",
598 StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
599 OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
600 checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
604 push @imagesets, { imagesetname => $imagesubdir,
605 images => \@imagelist };
613 $printers = &GetPrinters();
614 @queues = keys %$printers;
616 Returns information about existing printer queues.
618 C<$printers> is a reference-to-hash whose keys are the print queues
619 defined in the printers table of the Koha database. The values are
620 references-to-hash, whose keys are the fields in the printers table.
626 my $dbh = C4::Context->dbh;
627 my $sth = $dbh->prepare("select * from printers");
629 while ( my $printer = $sth->fetchrow_hashref ) {
630 $printers{ $printer->{'printqueue'} } = $printer;
632 return ( \%printers );
637 $printer = GetPrinter( $query, $printers );
641 sub GetPrinter ($$) {
642 my ( $query, $printers ) = @_; # get printer for this query from printers
643 my $printer = $query->param('printer');
644 my %cookie = $query->cookie('userenv');
645 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
646 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
652 Returns the number of pages to display in a pagination bar, given the number
653 of items and the number of items per page.
658 my ( $nb_items, $nb_items_per_page ) = @_;
660 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
665 (@themes) = &getallthemes('opac');
666 (@themes) = &getallthemes('intranet');
668 Returns an array of all available themes.
676 if ( $type eq 'intranet' ) {
677 $htdocs = C4::Context->config('intrahtdocs');
680 $htdocs = C4::Context->config('opachtdocs');
682 opendir D, "$htdocs";
683 my @dirlist = readdir D;
684 foreach my $directory (@dirlist) {
685 -d "$htdocs/$directory/en" and push @themes, $directory;
692 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
695 link_value => 'su-to',
696 label_value => 'Topics',
698 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
702 link_value => 'su-geo',
703 label_value => 'Places',
708 link_value => 'su-ut',
709 label_value => 'Titles',
710 tags => [ '500', '501', '502', '503', '504', ],
715 label_value => 'Authors',
716 tags => [ '700', '701', '702', ],
721 label_value => 'Series',
730 link_value => 'branch',
731 label_value => 'Libraries',
736 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
741 link_value => 'su-to',
742 label_value => 'Topics',
748 # link_value => 'su-na',
749 # label_value => 'People and Organizations',
750 # tags => ['600', '610', '611'],
754 link_value => 'su-geo',
755 label_value => 'Places',
760 link_value => 'su-ut',
761 label_value => 'Titles',
767 label_value => 'Authors',
768 tags => [ '100', '110', '700', ],
773 label_value => 'Series',
774 tags => [ '440', '490', ],
780 link_value => 'branch',
781 label_value => 'Libraries',
786 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
793 Return a href where a key is associated to a href. You give a query,
794 the name of the key among the fields returned by the query. If you
795 also give as third argument the name of the value, the function
796 returns a href of scalar. The optional 4th argument is an arrayref of
797 items passed to the C<execute()> call. It is designed to bind
798 parameters to any placeholders in your SQL.
807 # generic href of any information on the item, href of href.
808 my $iteminfos_of = get_infos_of($query, 'itemnumber');
809 print $iteminfos_of->{$itemnumber}{barcode};
811 # specific information, href of scalar
812 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
813 print $barcode_of_item->{$itemnumber};
818 my ( $query, $key_name, $value_name, $bind_params ) = @_;
820 my $dbh = C4::Context->dbh;
822 my $sth = $dbh->prepare($query);
823 $sth->execute( @$bind_params );
826 while ( my $row = $sth->fetchrow_hashref ) {
827 if ( defined $value_name ) {
828 $infos_of{ $row->{$key_name} } = $row->{$value_name};
831 $infos_of{ $row->{$key_name} } = $row;
839 =head2 get_notforloan_label_of
841 my $notforloan_label_of = get_notforloan_label_of();
843 Each authorised value of notforloan (information available in items and
844 itemtypes) is link to a single label.
846 Returns a href where keys are authorised values and values are corresponding
849 foreach my $authorised_value (keys %{$notforloan_label_of}) {
851 "authorised_value: %s => %s\n",
853 $notforloan_label_of->{$authorised_value}
859 # FIXME - why not use GetAuthorisedValues ??
861 sub get_notforloan_label_of {
862 my $dbh = C4::Context->dbh;
865 SELECT authorised_value
866 FROM marc_subfield_structure
867 WHERE kohafield = \'items.notforloan\'
870 my $sth = $dbh->prepare($query);
872 my ($statuscode) = $sth->fetchrow_array();
877 FROM authorised_values
880 $sth = $dbh->prepare($query);
881 $sth->execute($statuscode);
882 my %notforloan_label_of;
883 while ( my $row = $sth->fetchrow_hashref ) {
884 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
888 return \%notforloan_label_of;
891 =head2 displayServers
895 my $servers = displayServers();
897 my $servers = displayServers( $position );
899 my $servers = displayServers( $position, $type );
903 displayServers returns a listref of hashrefs, each containing
904 information about available z3950 servers. Each hashref has a format
908 'checked' => 'checked',
909 'encoding' => 'MARC-8'
911 'id' => 'LIBRARY OF CONGRESS',
915 'value' => 'z3950.loc.gov:7090/',
923 my ( $position, $type ) = @_;
924 my $dbh = C4::Context->dbh;
926 my $strsth = 'SELECT * FROM z3950servers';
931 push @bind_params, $position;
932 push @where_clauses, ' position = ? ';
936 push @bind_params, $type;
937 push @where_clauses, ' type = ? ';
940 # reassemble where clause from where clause pieces
941 if (@where_clauses) {
942 $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
945 my $rq = $dbh->prepare($strsth);
946 $rq->execute(@bind_params);
947 my @primaryserverloop;
949 while ( my $data = $rq->fetchrow_hashref ) {
950 push @primaryserverloop,
951 { label => $data->{description},
954 value => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
955 encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
956 checked => "checked",
957 icon => $data->{icon},
958 zed => $data->{type} eq 'zed',
959 opensearch => $data->{type} eq 'opensearch'
962 return \@primaryserverloop;
965 sub displaySecondaryServers {
967 # my $secondary_servers_loop = [
968 # { inner_sup_servers_loop => [
969 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
970 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
971 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
972 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
976 return; #$secondary_servers_loop;
979 =head2 GetAuthValCode
981 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
986 my ($kohafield,$fwcode) = @_;
987 my $dbh = C4::Context->dbh;
988 $fwcode='' unless $fwcode;
989 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
990 $sth->execute($kohafield,$fwcode);
991 my ($authvalcode) = $sth->fetchrow_array;
995 =head2 GetAuthorisedValues
997 $authvalues = GetAuthorisedValues([$category], [$selected]);
999 This function returns all authorised values from the'authosied_value' table in a reference to array of hashrefs.
1001 C<$category> returns authorised values for just one category (optional).
1005 sub GetAuthorisedValues {
1006 my ($category,$selected) = @_;
1008 my $dbh = C4::Context->dbh;
1009 my $query = "SELECT * FROM authorised_values";
1010 $query .= " WHERE category = '" . $category . "'" if $category;
1012 my $sth = $dbh->prepare($query);
1014 while (my $data=$sth->fetchrow_hashref) {
1015 if ($selected eq $data->{'authorised_value'} ) {
1016 $data->{'selected'} = 1;
1018 push @results, $data;
1020 #my $data = $sth->fetchall_arrayref({});
1021 return \@results; #$data;
1024 =head2 GetAuthorisedValueCategories
1026 $auth_categories = GetAuthorisedValueCategories();
1028 Return an arrayref of all of the available authorised
1033 sub GetAuthorisedValueCategories {
1034 my $dbh = C4::Context->dbh;
1035 my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1038 while (my $category = $sth->fetchrow_array) {
1039 push @results, $category;
1044 =head2 GetKohaAuthorisedValues
1046 Takes $kohafield, $fwcode as parameters.
1047 Returns hashref of Code => description
1049 if no authorised value category is defined for the kohafield.
1053 sub GetKohaAuthorisedValues {
1054 my ($kohafield,$fwcode,$codedvalue) = @_;
1055 $fwcode='' unless $fwcode;
1057 my $dbh = C4::Context->dbh;
1058 my $avcode = GetAuthValCode($kohafield,$fwcode);
1060 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
1061 $sth->execute($avcode);
1062 while ( my ($val, $lib) = $sth->fetchrow_array ) {
1063 $values{$val}= $lib;
1071 =head2 display_marc_indicators
1075 # field is a MARC::Field object
1076 my $display_form = C4::Koha::display_marc_indicators($field);
1080 Generate a display form of the indicators of a variable
1081 MARC field, replacing any blanks with '#'.
1085 sub display_marc_indicators {
1087 my $indicators = '';
1088 if ($field->tag() >= 10) {
1089 $indicators = $field->indicator(1) . $field->indicator(2);
1090 $indicators =~ s/ /#/g;
1095 sub GetNormalizedUPC {
1096 my ($record,$marcflavour) = @_;
1099 if ($marcflavour eq 'MARC21') {
1100 @fields = $record->field('024');
1101 foreach my $field (@fields) {
1102 my $indicator = $field->indicator(1);
1103 my $upc = _normalize_match_point($field->subfield('a'));
1104 if ($indicator == 1 and $upc ne '') {
1109 else { # assume unimarc if not marc21
1110 @fields = $record->field('072');
1111 foreach my $field (@fields) {
1112 my $upc = _normalize_match_point($field->subfield('a'));
1120 # Normalizes and returns the first valid ISBN found in the record
1121 sub GetNormalizedISBN {
1122 my ($isbn,$record,$marcflavour) = @_;
1125 return _isbn_cleanup($isbn);
1127 return undef unless $record;
1129 if ($marcflavour eq 'MARC21') {
1130 @fields = $record->field('020');
1131 foreach my $field (@fields) {
1132 $isbn = $field->subfield('a');
1134 return _isbn_cleanup($isbn);
1140 else { # assume unimarc if not marc21
1141 @fields = $record->field('010');
1142 foreach my $field (@fields) {
1143 my $isbn = $field->subfield('a');
1145 return _isbn_cleanup($isbn);
1154 sub GetNormalizedEAN {
1155 my ($record,$marcflavour) = @_;
1158 if ($marcflavour eq 'MARC21') {
1159 @fields = $record->field('024');
1160 foreach my $field (@fields) {
1161 my $indicator = $field->indicator(1);
1162 $ean = _normalize_match_point($field->subfield('a'));
1163 if ($indicator == 3 and $ean ne '') {
1168 else { # assume unimarc if not marc21
1169 @fields = $record->field('073');
1170 foreach my $field (@fields) {
1171 $ean = _normalize_match_point($field->subfield('a'));
1178 sub GetNormalizedOCLCNumber {
1179 my ($record,$marcflavour) = @_;
1182 if ($marcflavour eq 'MARC21') {
1183 @fields = $record->field('035');
1184 foreach my $field (@fields) {
1185 $oclc = $field->subfield('a');
1186 if ($oclc =~ /OCoLC/) {
1187 $oclc =~ s/\(OCoLC\)//;
1194 else { # TODO: add UNIMARC fields
1198 sub _normalize_match_point {
1199 my $match_point = shift;
1200 (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1201 $normalized_match_point =~ s/-//g;
1203 return $normalized_match_point;
1206 sub _isbn_cleanup ($) {
1207 my $normalized_isbn = shift;
1208 $normalized_isbn =~ s/-//g;
1209 $normalized_isbn =~/([0-9]{1,})/;
1210 $normalized_isbn = $1;
1212 $normalized_isbn =~ /\b(\d{13})\b/ or
1213 $normalized_isbn =~ /\b(\d{10})\b/ or
1214 $normalized_isbn =~ /\b(\d{9}X)\b/i