C4/Biblio.pm

   1 package C4::Biblio;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   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
  10 # version.
  11 #
  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.
  15 #
  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
  19
  20 use strict;
  21
  22 require Exporter;
  23 # use utf8;
  24 use C4::Context;
  25 use MARC::Record;
  26 use MARC::File::USMARC;
  27 use MARC::File::XML;
  28 use ZOOM;
  29 use C4::Koha;
  30 use C4::Date;
  31 use C4::Log; # logaction
  32
  33 use vars qw($VERSION @ISA @EXPORT);
  34
  35 # set the version for version checking
  36 $VERSION = do { my @v = '$Revision$' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
  37
  38 @ISA = qw( Exporter );
  39
  40 # EXPORTED FUNCTIONS.
  41
  42 # to add biblios or items
  43 push @EXPORT, qw( &AddBiblio &AddItem );
  44
  45 # to get something
  46 push @EXPORT, qw(
  47   &GetBiblio
  48   &GetBiblioData
  49   &GetBiblioItemData
  50   &GetBiblioItemInfosOf
  51   &GetBiblioItemByBiblioNumber
  52   &GetBiblioFromItemNumber
  53
  54   &GetMarcItem
  55   &GetItem
  56   &GetItemInfosOf
  57   &GetItemStatus
  58   &GetItemLocation
  59   &GetLostItems
  60   &GetItemsForInventory
  61   &GetItemsCount
  62
  63   &GetMarcNotes
  64   &GetMarcSubjects
  65   &GetMarcBiblio
  66   &GetMarcAuthors
  67   &GetMarcSeries
  68   &GetUsedMarcStructure
  69
  70   &GetItemsInfo
  71   &GetItemnumberFromBarcode
  72   &get_itemnumbers_of
  73   &GetXmlBiblio
  74
  75   &GetAuthorisedValueDesc
  76   &GetMarcStructure
  77   &GetMarcFromKohaField
  78   &GetFrameworkCode
  79   &GetPublisherNameFromIsbn
  80   &TransformKohaToMarc
  81 );
  82
  83 # To modify something
  84 push @EXPORT, qw(
  85   &ModBiblio
  86   &ModItem
  87   &ModItemTransfer
  88   &ModBiblioframework
  89   &ModZebra
  90   &ModItemInMarc
  91   &ModItemInMarconefield
  92   &ModDateLastSeen
  93 );
  94
  95 # To delete something
  96 push @EXPORT, qw(
  97   &DelBiblio
  98   &DelItem
  99 );
 100
 101 # Internal functions
 102 # those functions are exported but should not be used
 103 # they are usefull is few circumstances, so are exported.
 104 # but don't use them unless you're a core developer ;-)
 105 push @EXPORT, qw(
 106   &ModBiblioMarc
 107   &AddItemInMarc
 108   &calculatelc
 109   &itemcalculator
 110 );
 111
 112 # Others functions
 113 push @EXPORT, qw(
 114   &TransformMarcToKoha
 115   &TransformHtmlToMarc2
 116   &TransformHtmlToMarc
 117   &TransformHtmlToXml
 118   &PrepareItemrecordDisplay
 119   &char_decode
 120   &GetNoZebraIndexes
 121 );
 122
 123 =head1 NAME
 124
 125 C4::Biblio - cataloging management functions
 126
 127 =head1 DESCRIPTION
 128
 129 Biblio.pm contains functions for managing storage and editing of bibliographic data within Koha. Most of the functions in this module are used for cataloging records: adding, editing, or removing biblios, biblioitems, or items. Koha's stores bibliographic information in three places:
 130
 131 =over 4
 132
 133 =item 1. in the biblio,biblioitems,items, etc tables, which are limited to a one-to-one mapping to underlying MARC data
 134
 135 =item 2. as raw MARC in the Zebra index and storage engine
 136
 137 =item 3. as raw MARC the biblioitems.marc and biblioitems.marcxml
 138
 139 =back
 140
 141 In the 3.0 version of Koha, the authoritative record-level information is in biblioitems.marcxml
 142
 143 Because the data isn't completely normalized there's a chance for information to get out of sync. The design choice to go with a un-normalized schema was driven by performance and stability concerns. However, if this occur, it can be considered as a bug : The API is (or should be) complete & the only entry point for all biblio/items managements.
 144
 145 =over 4
 146
 147 =item 1. Compared with MySQL, Zebra is slow to update an index for small data changes -- especially for proc-intensive operations like circulation
 148
 149 =item 2. Zebra's index has been known to crash and a backup of the data is necessary to rebuild it in such cases
 150
 151 =back
 152
 153 Because of this design choice, the process of managing storage and editing is a bit convoluted. Historically, Biblio.pm's grown to an unmanagable size and as a result we have several types of functions currently:
 154
 155 =over 4
 156
 157 =item 1. Add*/Mod*/Del*/ - high-level external functions suitable for being called from external scripts to manage the collection
 158
 159 =item 2. _koha_* - low-level internal functions for managing the koha tables
 160
 161 =item 3. Marc management function : as the MARC record is stored in biblioitems.marc(xml), some subs dedicated to it's management are in this package. They should be used only internally by Biblio.pm, the only official entry points being AddBiblio, AddItem, ModBiblio, ModItem.
 162
 163 =item 4. Zebra functions used to update the Zebra index
 164
 165 =item 5. internal helper functions such as char_decode, checkitems, etc. Some of these probably belong in Koha.pm
 166
 167 =back
 168
 169 The MARC record (in biblioitems.marcxml) contains the complete marc record, including items. It also contains the biblionumber. That is the reason why it is not stored directly by AddBiblio, with all other fields . To save a biblio, we need to :
 170
 171 =over 4
 172
 173 =item 1. save datas in biblio and biblioitems table, that gives us a biblionumber and a biblioitemnumber
 174
 175 =item 2. add the biblionumber and biblioitemnumber into the MARC records
 176
 177 =item 3. save the marc record
 178
 179 =back
 180
 181 When dealing with items, we must :
 182
 183 =over 4
 184
 185 =item 1. save the item in items table, that gives us an itemnumber
 186
 187 =item 2. add the itemnumber to the item MARC field
 188
 189 =item 3. overwrite the MARC record (with the added item) into biblioitems.marc(xml)
 190
 191 When modifying a biblio or an item, the behaviour is quite similar.
 192
 193 =back
 194
 195 =head1 EXPORTED FUNCTIONS
 196
 197 =head2 AddBiblio
 198
 199 =over 4
 200
 201 ($biblionumber,$biblioitemnumber) = AddBiblio($record,$frameworkcode);
 202 Exported function (core API) for adding a new biblio to koha.
 203
 204 =back
 205
 206 =cut
 207
 208 sub AddBiblio {
 209     my ( $record, $frameworkcode ) = @_;
 210     my $biblionumber;
 211     my $biblioitemnumber;
 212     my $dbh = C4::Context->dbh;
 213     # transform the data into koha-table style data
 214     my $olddata = TransformMarcToKoha( $dbh, $record, $frameworkcode );
 215     $biblionumber = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
 216     $olddata->{'biblionumber'} = $biblionumber;
 217     $biblioitemnumber = _koha_add_biblioitem( $dbh, $olddata );
 218
 219     # we must add bibnum and bibitemnum in MARC::Record...
 220     # we build the new field with biblionumber and biblioitemnumber
 221     # we drop the original field
 222     # we add the new builded field.
 223     ( my $biblio_tag, my $biblio_subfield ) = GetMarcFromKohaField("biblio.biblionumber",$frameworkcode);
 224     ( my $biblioitem_tag, my $biblioitem_subfield ) = GetMarcFromKohaField("biblioitems.biblioitemnumber",$frameworkcode);
 225
 226     my $newfield;
 227
 228     # biblionumber & biblioitemnumber are in different fields
 229     if ( $biblio_tag != $biblioitem_tag ) {
 230
 231         # deal with biblionumber
 232         if ( $biblio_tag < 10 ) {
 233             $newfield = MARC::Field->new( $biblio_tag, $biblionumber );
 234         }
 235         else {
 236             $newfield =
 237               MARC::Field->new( $biblio_tag, '', '',
 238                 "$biblio_subfield" => $biblionumber );
 239         }
 240
 241         # drop old field and create new one...
 242         my $old_field = $record->field($biblio_tag);
 243         $record->delete_field($old_field);
 244         $record->append_fields($newfield);
 245
 246         # deal with biblioitemnumber
 247         if ( $biblioitem_tag < 10 ) {
 248             $newfield = MARC::Field->new( $biblioitem_tag, $biblioitemnumber, );
 249         }
 250         else {
 251             $newfield =
 252               MARC::Field->new( $biblioitem_tag, '', '',
 253                 "$biblioitem_subfield" => $biblioitemnumber, );
 254         }
 255         # drop old field and create new one...
 256         $old_field = $record->field($biblioitem_tag);
 257         $record->delete_field($old_field);
 258         $record->insert_fields_ordered($newfield);
 259
 260 # biblionumber & biblioitemnumber are in the same field (can't be <10 as fields <10 have only 1 value)
 261     }
 262     else {
 263         my $newfield = MARC::Field->new(
 264             $biblio_tag, '', '',
 265             "$biblio_subfield" => $biblionumber,
 266             "$biblioitem_subfield" => $biblioitemnumber
 267         );
 268
 269         # drop old field and create new one...
 270         my $old_field = $record->field($biblio_tag);
 271         $record->delete_field($old_field);
 272         $record->insert_fields_ordered($newfield);
 273     }
 274
 275     # now add the record
 276     $biblionumber = ModBiblioMarc( $record, $biblionumber, $frameworkcode );
 277
 278     &logaction(C4::Context->userenv->{'number'},"CATALOGUING","ADD",$biblionumber,"biblio")
 279         if C4::Context->preference("CataloguingLog");
 280
 281     return ( $biblionumber, $biblioitemnumber );
 282 }
 283
 284 =head2 AddItem
 285
 286 =over 2
 287
 288     $biblionumber = AddItem( $record, $biblionumber)
 289     Exported function (core API) for adding a new item to Koha
 290
 291 =back
 292
 293 =cut
 294
 295 sub AddItem {
 296     my ( $record, $biblionumber ) = @_;
 297     my $dbh = C4::Context->dbh;
 298
 299     # add item in old-DB
 300     my $frameworkcode = GetFrameworkCode( $biblionumber );
 301     my $item = &TransformMarcToKoha( $dbh, $record, $frameworkcode );
 302
 303     # needs old biblionumber and biblioitemnumber
 304     $item->{'biblionumber'} = $biblionumber;
 305     my $sth =
 306       $dbh->prepare(
 307         "select biblioitemnumber,itemtype from biblioitems where biblionumber=?"
 308       );
 309     $sth->execute( $item->{'biblionumber'} );
 310     my $itemtype;
 311     ( $item->{'biblioitemnumber'}, $itemtype ) = $sth->fetchrow;
 312     $sth =
 313       $dbh->prepare(
 314         "select notforloan from itemtypes where itemtype='$itemtype'");
 315     $sth->execute();
 316     my $notforloan = $sth->fetchrow;
 317     ##Change the notforloan field if $notforloan found
 318     if ( $notforloan > 0 ) {
 319         $item->{'notforloan'} = $notforloan;
 320         &MARCitemchange( $record, "items.notforloan", $notforloan );
 321     }
 322     if ( !$item->{'dateaccessioned'} || $item->{'dateaccessioned'} eq '' ) {
 323
 324         # find today's date
 325         my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
 326           localtime(time);
 327         $year += 1900;
 328         $mon  += 1;
 329         my $date =
 330           "$year-" . sprintf( "%0.2d", $mon ) . "-" . sprintf( "%0.2d", $mday );
 331         $item->{'dateaccessioned'} = $date;
 332         &MARCitemchange( $record, "items.dateaccessioned", $date );
 333     }
 334     my ( $itemnumber, $error ) =
 335       &_koha_new_items( $dbh, $item, $item->{barcode} );
 336
 337     # add itemnumber to MARC::Record before adding the item.
 338     $sth = $dbh->prepare(
 339 "select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
 340       );
 341     &TransformKohaToMarcOneField( $sth, $record, "items.itemnumber", $itemnumber,
 342         $frameworkcode );
 343
 344     # add the item
 345     &AddItemInMarc( $record, $item->{'biblionumber'},$frameworkcode );
 346
 347     &logaction(C4::Context->userenv->{'number'},"CATALOGUING","ADD",$itemnumber,"item")
 348         if C4::Context->preference("CataloguingLog");
 349
 350     return ($item->{biblionumber}, $item->{biblioitemnumber},$itemnumber);
 351 }
 352
 353 =head2 ModBiblio
 354
 355     ModBiblio( $record,$biblionumber,$frameworkcode);
 356     Exported function (core API) to modify a biblio
 357
 358 =cut
 359
 360 sub ModBiblio {
 361     my ( $record, $biblionumber, $frameworkcode ) = @_;
 362     if (C4::Context->preference("CataloguingLog")) {
 363         my $newrecord = GetMarcBiblio($biblionumber);
 364         &logaction(C4::Context->userenv->{'number'},"CATALOGUING","MODIFY",$biblionumber,"BEFORE=>".$newrecord->as_formatted);
 365     }
 366
 367     my $dbh = C4::Context->dbh;
 368
 369     $frameworkcode = "" unless $frameworkcode;
 370
 371     # get the items before and append them to the biblio before updating the record, atm we just have the biblio
 372     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField("items.itemnumber",$frameworkcode);
 373     my $oldRecord = GetMarcBiblio( $biblionumber );
 374
 375     # parse each item, and, for an unknown reason, re-encode each subfield
 376     # if you don't do that, the record will have encoding mixed
 377     # and the biblio will be re-encoded.
 378     # strange, I (Paul P.) searched more than 1 day to understand what happends
 379     # but could only solve the problem this way...
 380    my @fields = $oldRecord->field( $itemtag );
 381     foreach my $fielditem ( @fields ){
 382         my $field;
 383         foreach ($fielditem->subfields()) {
 384             if ($field) {
 385                 $field->add_subfields(Encode::encode('utf-8',$_->[0]) => Encode::encode('utf-8',$_->[1]));
 386             } else {
 387                 $field = MARC::Field->new("$itemtag",'','',Encode::encode('utf-8',$_->[0]) => Encode::encode('utf-8',$_->[1]));
 388             }
 389           }
 390         $record->append_fields($field);
 391     }
 392
 393     # adding biblionumber
 394     my ($tag_biblionumber, $subfield_biblionumber) = GetMarcFromKohaField('biblio.biblionumber',$frameworkcode);
 395     $record->append_fields(
 396         MARC::Field->new(
 397                 $tag_biblionumber,'','',$subfield_biblionumber => $biblionumber
 398         )
 399     );
 400
 401     # update the MARC record (that now contains biblio and items) with the new record data
 402     &ModBiblioMarc( $record, $biblionumber, $frameworkcode );
 403
 404     # load the koha-table data object
 405     my $oldbiblio = TransformMarcToKoha( $dbh, $record, $frameworkcode );
 406
 407     # modify the other koha tables
 408     _koha_modify_biblio( $dbh, $oldbiblio );
 409     _koha_modify_biblioitem( $dbh, $oldbiblio );
 410     return 1;
 411 }
 412
 413 =head2 ModItem
 414
 415 =over 2
 416
 417 Exported function (core API) for modifying an item in Koha.
 418
 419 =back
 420
 421 =cut
 422
 423 sub ModItem {
 424     my ( $record, $biblionumber, $itemnumber, $delete, $new_item_hashref )
 425       = @_;
 426
 427     #logging
 428     &logaction(C4::Context->userenv->{'number'},"CATALOGUING","MODIFY",$itemnumber,$record->as_formatted)
 429         if C4::Context->preference("CataloguingLog");
 430
 431     my $dbh = C4::Context->dbh;
 432
 433     # if we have a MARC record, we're coming from cataloging and so
 434     # we do the whole routine: update the MARC and zebra, then update the koha
 435     # tables
 436     if ($record) {
 437         my $frameworkcode = GetFrameworkCode( $biblionumber );
 438         ModItemInMarc( $record, $biblionumber, $itemnumber, $frameworkcode );
 439         my $olditem       = TransformMarcToKoha( $dbh, $record, $frameworkcode );
 440         _koha_modify_item( $dbh, $olditem );
 441         return $biblionumber;
 442     }
 443
 444     # otherwise, we're just looking to modify something quickly
 445     # (like a status) so we just update the koha tables
 446     elsif ($new_item_hashref) {
 447         _koha_modify_item( $dbh, $new_item_hashref );
 448     }
 449 }
 450
 451 sub ModItemTransfer {
 452     my ( $itemnumber, $frombranch, $tobranch ) = @_;
 453
 454     my $dbh = C4::Context->dbh;
 455
 456     #new entry in branchtransfers....
 457     my $sth = $dbh->prepare(
 458         "INSERT INTO branchtransfers (itemnumber, frombranch, datesent, tobranch)
 459         VALUES (?, ?, now(), ?)");
 460     $sth->execute($itemnumber, $frombranch, $tobranch);
 461     #update holdingbranch in items .....
 462      $sth= $dbh->prepare(
 463           "UPDATE items set holdingbranch = ? WHERE items.itemnumber = ?");
 464     $sth->execute($tobranch,$itemnumber);
 465     &ModDateLastSeen($itemnumber);
 466     $sth = $dbh->prepare(
 467         "SELECT biblionumber FROM items WHERE itemnumber=?"
 468       );
 469     $sth->execute($itemnumber);
 470     while ( my ( $biblionumber ) = $sth->fetchrow ) {
 471         &ModItemInMarconefield( $biblionumber, $itemnumber,
 472             'items.holdingbranch', $tobranch );
 473     }
 474     return;
 475 }
 476
 477 =head2 ModBiblioframework
 478
 479     ModBiblioframework($biblionumber,$frameworkcode);
 480     Exported function to modify a biblio framework
 481
 482 =cut
 483
 484 sub ModBiblioframework {
 485     my ( $biblionumber, $frameworkcode ) = @_;
 486     my $dbh = C4::Context->dbh;
 487     my $sth = $dbh->prepare(
 488         "UPDATE biblio SET frameworkcode=? WHERE biblionumber=$biblionumber"
 489     );
 490     $sth->execute($frameworkcode);
 491     return 1;
 492 }
 493
 494 =head2 ModItemInMarconefield
 495
 496 =over
 497
 498 modify only 1 field in a MARC item (mainly used for holdingbranch, but could also be used for status modif - moving a book to "lost" on a long overdu for example)
 499 &ModItemInMarconefield( $biblionumber, $itemnumber, $itemfield, $newvalue )
 500
 501 =back
 502
 503 =cut
 504
 505 sub ModItemInMarconefield {
 506     my ( $biblionumber, $itemnumber, $itemfield, $newvalue ) = @_;
 507     my $dbh = C4::Context->dbh;
 508     if ( !defined $newvalue ) {
 509         $newvalue = "";
 510     }
 511
 512     my $record = GetMarcItem( $biblionumber, $itemnumber );
 513     my ($tagfield, $tagsubfield) = GetMarcFromKohaField( $itemfield,'');
 514     if ($tagfield && $tagsubfield) {
 515         my $tag = $record->field($tagfield);
 516         if ($tag) {
 517 #             my $tagsubs = $record->field($tagfield)->subfield($tagsubfield);
 518             $tag->update( $tagsubfield => $newvalue );
 519             $record->delete_field($tag);
 520             $record->insert_fields_ordered($tag);
 521             &ModItemInMarc( $record, $biblionumber, $itemnumber, 0 );
 522         }
 523     }
 524 }
 525
 526 =head2 ModItemInMarc
 527
 528 =over
 529
 530 &ModItemInMarc( $record, $biblionumber, $itemnumber )
 531
 532 =back
 533
 534 =cut
 535
 536 sub ModItemInMarc {
 537     my ( $ItemRecord, $biblionumber, $itemnumber, $frameworkcode) = @_;
 538     my $dbh = C4::Context->dbh;
 539
 540     # get complete MARC record & replace the item field by the new one
 541     my $completeRecord = GetMarcBiblio($biblionumber);
 542     my ($itemtag,$itemsubfield) = GetMarcFromKohaField("items.itemnumber",$frameworkcode);
 543     my $itemField = $ItemRecord->field($itemtag);
 544     my @items = $completeRecord->field($itemtag);
 545     foreach (@items) {
 546         if ($_->subfield($itemsubfield) eq $itemnumber) {
 547 #             $completeRecord->delete_field($_);
 548             $_->replace_with($itemField);
 549         }
 550     }
 551     # save the record
 552     my $sth = $dbh->prepare("update biblioitems set marc=?,marcxml=?  where biblionumber=?");
 553     $sth->execute( $completeRecord->as_usmarc(), $completeRecord->as_xml_record(),$biblionumber );
 554     $sth->finish;
 555     ModZebra($biblionumber,"specialUpdate","biblioserver",$completeRecord);
 556 }
 557
 558 =head2 ModDateLastSeen
 559
 560 &ModDateLastSeen($itemnum)
 561 Mark item as seen. Is called when an item is issued, returned or manually marked during inventory/stocktaking
 562 C<$itemnum> is the item number
 563
 564 =cut
 565
 566 sub ModDateLastSeen {
 567     my ($itemnum) = @_;
 568     my $dbh       = C4::Context->dbh;
 569     my $sth       =
 570       $dbh->prepare(
 571           "update items set itemlost=0, datelastseen  = now() where items.itemnumber = ?"
 572       );
 573     $sth->execute($itemnum);
 574     return;
 575 }
 576 =head2 DelBiblio
 577
 578 =over
 579
 580 my $error = &DelBiblio($dbh,$biblionumber);
 581 Exported function (core API) for deleting a biblio in koha.
 582 Deletes biblio record from Zebra and Koha tables (biblio,biblioitems,items)
 583 Also backs it up to deleted* tables
 584 Checks to make sure there are not issues on any of the items
 585 return:
 586 C<$error> : undef unless an error occurs
 587
 588 =back
 589
 590 =cut
 591
 592 sub DelBiblio {
 593     my ( $biblionumber ) = @_;
 594     my $dbh = C4::Context->dbh;
 595     my $error;    # for error handling
 596
 597     # First make sure there are no items with issues are still attached
 598     my $sth =
 599       $dbh->prepare(
 600         "SELECT itemnumber FROM items WHERE biblionumber=?");
 601     $sth->execute($biblionumber);
 602     while ( my $itemnumber = $sth->fetchrow ) {
 603         my $issues = GetItemIssues($itemnumber);
 604         foreach my $issue (@$issues) {
 605             if (   ( $issue->{date_due} )
 606                 && ( $issue->{date_due} ne "Available" ) )
 607             {
 608
 609 #FIXME: we need a status system in Biblio like in Circ to return standard codes and messages
 610 # instead of hard-coded strings
 611                 $error .=
 612 "Item is checked out to a patron -- you must return it before deleting the Biblio";
 613             }
 614         }
 615     }
 616     return $error if $error;
 617
 618     # Delete in Zebra. Be careful NOT to move this line after _koha_delete_biblio
 619     # for at least 2 reasons :
 620     # - we need to read the biblio if NoZebra is set (to remove it from the indexes
 621     # - if something goes wrong, the biblio may be deleted from Koha but not from zebra
 622     #   and we would have no way to remove it (except manually in zebra, but I bet it would be very hard to handle the problem)
 623     ModZebra($biblionumber, "delete_record", "biblioserver", undef);
 624
 625     # delete biblio from Koha tables and save in deletedbiblio
 626     $error = &_koha_delete_biblio( $dbh, $biblionumber );
 627
 628     # delete biblioitems and items from Koha tables and save in deletedbiblioitems,deleteditems
 629     $sth =
 630       $dbh->prepare(
 631         "SELECT biblioitemnumber FROM biblioitems WHERE biblionumber=?");
 632     $sth->execute($biblionumber);
 633     while ( my $biblioitemnumber = $sth->fetchrow ) {
 634
 635         # delete this biblioitem
 636         $error = &_koha_delete_biblioitems( $dbh, $biblioitemnumber );
 637         return $error if $error;
 638
 639         # delete items
 640         my $items_sth =
 641           $dbh->prepare(
 642             "SELECT itemnumber FROM items WHERE biblioitemnumber=?");
 643         $items_sth->execute($biblioitemnumber);
 644         while ( my $itemnumber = $items_sth->fetchrow ) {
 645             $error = &_koha_delete_item( $dbh, $itemnumber );
 646             return $error if $error;
 647         }
 648     }
 649     &logaction(C4::Context->userenv->{'number'},"CATALOGUING","DELETE",$biblionumber,"")
 650         if C4::Context->preference("CataloguingLog");
 651     return;
 652 }
 653
 654 =head2 DelItem
 655
 656 =over
 657
 658 DelItem( $biblionumber, $itemnumber );
 659 Exported function (core API) for deleting an item record in Koha.
 660
 661 =back
 662
 663 =cut
 664
 665 sub DelItem {
 666     my ( $biblionumber, $itemnumber ) = @_;
 667     my $dbh = C4::Context->dbh;
 668     &_koha_delete_item( $dbh, $itemnumber );
 669     # get the MARC record
 670     my $record = GetMarcBiblio($biblionumber);
 671     my $frameworkcode = GetFrameworkCode($biblionumber);
 672
 673     # backup the record
 674     my $copy2deleted =
 675       $dbh->prepare("UPDATE deleteditems SET marc=? WHERE itemnumber=?");
 676     $copy2deleted->execute( $record->as_usmarc(), $itemnumber );
 677
 678     #search item field code
 679     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField("items.itemnumber",$frameworkcode);
 680     my @fields = $record->field($itemtag);
 681     # delete the item specified
 682     foreach my $field (@fields) {
 683         if ( $field->subfield($itemsubfield) eq $itemnumber ) {
 684             $record->delete_field($field);
 685         }
 686     }
 687     &ModBiblioMarc( $record, $biblionumber, $frameworkcode );
 688     &logaction(C4::Context->userenv->{'number'},"CATALOGUING","DELETE",$itemnumber,"item")
 689         if C4::Context->preference("CataloguingLog");
 690 }
 691
 692 =head2 GetBiblioData
 693
 694 =over 4
 695
 696 $data = &GetBiblioData($biblionumber);
 697 Returns information about the book with the given biblionumber.
 698 C<&GetBiblioData> returns a reference-to-hash. The keys are the fields in
 699 the C<biblio> and C<biblioitems> tables in the
 700 Koha database.
 701 In addition, C<$data-E<gt>{subject}> is the list of the book's
 702 subjects, separated by C<" , "> (space, comma, space).
 703 If there are multiple biblioitems with the given biblionumber, only
 704 the first one is considered.
 705
 706 =back
 707
 708 =cut
 709
 710 sub GetBiblioData {
 711     my ( $bibnum ) = @_;
 712     my $dbh = C4::Context->dbh;
 713
 714     my $query = "
 715         SELECT * , biblioitems.notes AS bnotes, biblio.notes
 716         FROM biblio
 717             LEFT JOIN biblioitems ON biblio.biblionumber = biblioitems.biblionumber
 718             LEFT JOIN itemtypes ON biblioitems.itemtype = itemtypes.itemtype
 719         WHERE biblio.biblionumber = ?
 720             AND biblioitems.biblionumber = biblio.biblionumber
 721     ";
 722     my $sth = $dbh->prepare($query);
 723     $sth->execute($bibnum);
 724     my $data;
 725     $data = $sth->fetchrow_hashref;
 726     $sth->finish;
 727
 728     return ($data);
 729 }    # sub GetBiblioData
 730
 731
 732 =head2 GetItemsInfo
 733
 734 =over 4
 735
 736   @results = &GetItemsInfo($biblionumber, $type);
 737
 738 Returns information about books with the given biblionumber.
 739
 740 C<$type> may be either C<intra> or anything else. If it is not set to
 741 C<intra>, then the search will exclude lost, very overdue, and
 742 withdrawn items.
 743
 744 C<&GetItemsInfo> returns a list of references-to-hash. Each element
 745 contains a number of keys. Most of them are table items from the
 746 C<biblio>, C<biblioitems>, C<items>, and C<itemtypes> tables in the
 747 Koha database. Other keys include:
 748
 749 =over 4
 750
 751 =item C<$data-E<gt>{branchname}>
 752
 753 The name (not the code) of the branch to which the book belongs.
 754
 755 =item C<$data-E<gt>{datelastseen}>
 756
 757 This is simply C<items.datelastseen>, except that while the date is
 758 stored in YYYY-MM-DD format in the database, here it is converted to
 759 DD/MM/YYYY format. A NULL date is returned as C<//>.
 760
 761 =item C<$data-E<gt>{datedue}>
 762
 763 =item C<$data-E<gt>{class}>
 764
 765 This is the concatenation of C<biblioitems.classification>, the book's
 766 Dewey code, and C<biblioitems.subclass>.
 767
 768 =item C<$data-E<gt>{ocount}>
 769
 770 I think this is the number of copies of the book available.
 771
 772 =item C<$data-E<gt>{order}>
 773
 774 If this is set, it is set to C<One Order>.
 775
 776 =back
 777
 778 =back
 779
 780 =cut
 781
 782 sub GetItemsInfo {
 783     my ( $biblionumber, $type ) = @_;
 784     my $dbh   = C4::Context->dbh;
 785     my $query = "SELECT *,items.notforloan as itemnotforloan
 786                  FROM items, biblio, biblioitems
 787                  LEFT JOIN itemtypes on biblioitems.itemtype = itemtypes.itemtype
 788                 WHERE items.biblionumber = ?
 789                     AND biblioitems.biblioitemnumber = items.biblioitemnumber
 790                     AND biblio.biblionumber = items.biblionumber
 791                 ORDER BY items.dateaccessioned desc
 792                  ";
 793     my $sth = $dbh->prepare($query);
 794     $sth->execute($biblionumber);
 795     my $i = 0;
 796     my @results;
 797     my ( $date_due, $count_reserves );
 798
 799     while ( my $data = $sth->fetchrow_hashref ) {
 800         my $datedue = '';
 801         my $isth    = $dbh->prepare(
 802             "SELECT issues.*,borrowers.cardnumber
 803             FROM   issues, borrowers
 804             WHERE  itemnumber = ?
 805                 AND returndate IS NULL
 806                 AND issues.borrowernumber=borrowers.borrowernumber"
 807         );
 808         $isth->execute( $data->{'itemnumber'} );
 809         if ( my $idata = $isth->fetchrow_hashref ) {
 810             $data->{borrowernumber} = $idata->{borrowernumber};
 811             $data->{cardnumber}     = $idata->{cardnumber};
 812             $datedue                = format_date( $idata->{'date_due'} );
 813         }
 814         if ( $datedue eq '' ) {
 815             #$datedue="Available";
 816             my ( $restype, $reserves ) =
 817               C4::Reserves::CheckReserves( $data->{'itemnumber'} );
 818             if ($restype) {
 819
 820                 #$datedue=$restype;
 821                 $count_reserves = $restype;
 822             }
 823         }
 824         $isth->finish;
 825
 826         #get branch information.....
 827         my $bsth = $dbh->prepare(
 828             "SELECT * FROM branches WHERE branchcode = ?
 829         "
 830         );
 831         $bsth->execute( $data->{'holdingbranch'} );
 832         if ( my $bdata = $bsth->fetchrow_hashref ) {
 833             $data->{'branchname'} = $bdata->{'branchname'};
 834         }
 835         my $date = format_date( $data->{'datelastseen'} );
 836         $data->{'datelastseen'}   = $date;
 837         $data->{'datedue'}        = $datedue;
 838         $data->{'count_reserves'} = $count_reserves;
 839
 840         # get notforloan complete status if applicable
 841         my $sthnflstatus = $dbh->prepare(
 842             'SELECT authorised_value
 843             FROM   marc_subfield_structure
 844             WHERE  kohafield="items.notforloan"
 845         '
 846         );
 847
 848         $sthnflstatus->execute;
 849         my ($authorised_valuecode) = $sthnflstatus->fetchrow;
 850         if ($authorised_valuecode) {
 851             $sthnflstatus = $dbh->prepare(
 852                 "SELECT lib FROM authorised_values
 853                  WHERE  category=?
 854                  AND authorised_value=?"
 855             );
 856             $sthnflstatus->execute( $authorised_valuecode,
 857                 $data->{itemnotforloan} );
 858             my ($lib) = $sthnflstatus->fetchrow;
 859             $data->{notforloan} = $lib;
 860         }
 861
 862         # my stack procedures
 863         my $stackstatus = $dbh->prepare(
 864             'SELECT authorised_value
 865              FROM   marc_subfield_structure
 866              WHERE  kohafield="items.stack"
 867         '
 868         );
 869         $stackstatus->execute;
 870
 871         ($authorised_valuecode) = $stackstatus->fetchrow;
 872         if ($authorised_valuecode) {
 873             $stackstatus = $dbh->prepare(
 874                 "SELECT lib
 875                  FROM   authorised_values
 876                  WHERE  category=?
 877                  AND    authorised_value=?
 878             "
 879             );
 880             $stackstatus->execute( $authorised_valuecode, $data->{stack} );
 881             my ($lib) = $stackstatus->fetchrow;
 882             $data->{stack} = $lib;
 883         }
 884         $results[$i] = $data;
 885         $i++;
 886     }
 887     $sth->finish;
 888
 889     return (@results);
 890 }
 891
 892 =head2 getitemstatus
 893
 894 =over 4
 895
 896 $itemstatushash = &getitemstatus($fwkcode);
 897 returns information about status.
 898 Can be MARC dependant.
 899 fwkcode is optional.
 900 But basically could be can be loan or not
 901 Create a status selector with the following code
 902
 903 =head3 in PERL SCRIPT
 904
 905 my $itemstatushash = getitemstatus;
 906 my @itemstatusloop;
 907 foreach my $thisstatus (keys %$itemstatushash) {
 908     my %row =(value => $thisstatus,
 909                 statusname => $itemstatushash->{$thisstatus}->{'statusname'},
 910             );
 911     push @itemstatusloop, \%row;
 912 }
 913 $template->param(statusloop=>\@itemstatusloop);
 914
 915
 916 =head3 in TEMPLATE
 917
 918             <select name="statusloop">
 919                 <option value="">Default</option>
 920             <!-- TMPL_LOOP name="statusloop" -->
 921                 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="statusname" --></option>
 922             <!-- /TMPL_LOOP -->
 923             </select>
 924
 925 =cut
 926
 927 sub GetItemStatus {
 928
 929     # returns a reference to a hash of references to status...
 930     my ($fwk) = @_;
 931     my %itemstatus;
 932     my $dbh = C4::Context->dbh;
 933     my $sth;
 934     $fwk = '' unless ($fwk);
 935     my ( $tag, $subfield ) =
 936       GetMarcFromKohaField( "items.notforloan", $fwk );
 937     if ( $tag and $subfield ) {
 938         my $sth =
 939           $dbh->prepare(
 940 "select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?"
 941           );
 942         $sth->execute( $tag, $subfield, $fwk );
 943         if ( my ($authorisedvaluecat) = $sth->fetchrow ) {
 944             my $authvalsth =
 945               $dbh->prepare(
 946 "select authorised_value, lib from authorised_values where category=? order by lib"
 947               );
 948             $authvalsth->execute($authorisedvaluecat);
 949             while ( my ( $authorisedvalue, $lib ) = $authvalsth->fetchrow ) {
 950                 $itemstatus{$authorisedvalue} = $lib;
 951             }
 952             $authvalsth->finish;
 953             return \%itemstatus;
 954             exit 1;
 955         }
 956         else {
 957
 958             #No authvalue list
 959             # build default
 960         }
 961         $sth->finish;
 962     }
 963
 964     #No authvalue list
 965     #build default
 966     $itemstatus{"1"} = "Not For Loan";
 967     return \%itemstatus;
 968 }
 969
 970 =head2 getitemlocation
 971
 972 =over 4
 973
 974 $itemlochash = &getitemlocation($fwk);
 975 returns informations about location.
 976 where fwk stands for an optional framework code.
 977 Create a location selector with the following code
 978
 979 =head3 in PERL SCRIPT
 980
 981 my $itemlochash = getitemlocation;
 982 my @itemlocloop;
 983 foreach my $thisloc (keys %$itemlochash) {
 984     my $selected = 1 if $thisbranch eq $branch;
 985     my %row =(locval => $thisloc,
 986                 selected => $selected,
 987                 locname => $itemlochash->{$thisloc},
 988             );
 989     push @itemlocloop, \%row;
 990 }
 991 $template->param(itemlocationloop => \@itemlocloop);
 992
 993 =head3 in TEMPLATE
 994
 995 <select name="location">
 996     <option value="">Default</option>
 997 <!-- TMPL_LOOP name="itemlocationloop" -->
 998     <option value="<!-- TMPL_VAR name="locval" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="locname" --></option>
 999 <!-- /TMPL_LOOP -->
1000 </select>
1001
1002 =back
1003
1004 =cut
1005
1006 sub GetItemLocation {
1007
1008     # returns a reference to a hash of references to location...
1009     my ($fwk) = @_;
1010     my %itemlocation;
1011     my $dbh = C4::Context->dbh;
1012     my $sth;
1013     $fwk = '' unless ($fwk);
1014     my ( $tag, $subfield ) =
1015       GetMarcFromKohaField( "items.location", $fwk );
1016     if ( $tag and $subfield ) {
1017         my $sth =
1018           $dbh->prepare(
1019 "select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?"
1020           );
1021         $sth->execute( $tag, $subfield, $fwk );
1022         if ( my ($authorisedvaluecat) = $sth->fetchrow ) {
1023             my $authvalsth =
1024               $dbh->prepare(
1025 "select authorised_value, lib from authorised_values where category=? order by lib"
1026               );
1027             $authvalsth->execute($authorisedvaluecat);
1028             while ( my ( $authorisedvalue, $lib ) = $authvalsth->fetchrow ) {
1029                 $itemlocation{$authorisedvalue} = $lib;
1030             }
1031             $authvalsth->finish;
1032             return \%itemlocation;
1033             exit 1;
1034         }
1035         else {
1036
1037             #No authvalue list
1038             # build default
1039         }
1040         $sth->finish;
1041     }
1042
1043     #No authvalue list
1044     #build default
1045     $itemlocation{"1"} = "Not For Loan";
1046     return \%itemlocation;
1047 }
1048
1049 =head2 GetLostItems
1050
1051 $items = GetLostItems($where,$orderby);
1052
1053 This function get the items lost into C<$items>.
1054
1055 =over 2
1056
1057 =item input:
1058 C<$where> is a hashref. it containts a field of the items table as key
1059 and the value to match as value.
1060 C<$orderby> is a field of the items table.
1061
1062 =item return:
1063 C<$items> is a reference to an array full of hasref which keys are items' table column.
1064
1065 =item usage in the perl script:
1066
1067 my %where;
1068 $where{barcode} = 0001548;
1069 my $items = GetLostItems( \%where, "homebranch" );
1070 $template->param(itemsloop => $items);
1071
1072 =back
1073
1074 =cut
1075
1076 sub GetLostItems {
1077     # Getting input args.
1078     my $where   = shift;
1079     my $orderby = shift;
1080     my $dbh     = C4::Context->dbh;
1081
1082     my $query   = "
1083         SELECT *
1084         FROM   items
1085         WHERE  itemlost IS NOT NULL
1086           AND  itemlost <> 0
1087     ";
1088     foreach my $key (keys %$where) {
1089         $query .= " AND " . $key . " LIKE '%" . $where->{$key} . "%'";
1090     }
1091     $query .= " ORDER BY ".$orderby if defined $orderby;
1092
1093     my $sth = $dbh->prepare($query);
1094     $sth->execute;
1095     my @items;
1096     while ( my $row = $sth->fetchrow_hashref ){
1097         push @items, $row;
1098     }
1099     return \@items;
1100 }
1101
1102 =head2 GetItemsForInventory
1103
1104 $itemlist = GetItemsForInventory($minlocation,$maxlocation,$datelastseen,$offset,$size)
1105
1106 Retrieve a list of title/authors/barcode/callnumber, for biblio inventory.
1107
1108 The sub returns a list of hashes, containing itemnumber, author, title, barcode & item callnumber.
1109 It is ordered by callnumber,title.
1110
1111 The minlocation & maxlocation parameters are used to specify a range of item callnumbers
1112 the datelastseen can be used to specify that you want to see items not seen since a past date only.
1113 offset & size can be used to retrieve only a part of the whole listing (defaut behaviour)
1114
1115 =cut
1116
1117 sub GetItemsForInventory {
1118     my ( $minlocation, $maxlocation,$location, $datelastseen, $branch, $offset, $size ) = @_;
1119     my $dbh = C4::Context->dbh;
1120     my $sth;
1121     if ($datelastseen) {
1122         $datelastseen=format_date_in_iso($datelastseen);
1123         my $query =
1124                 "SELECT itemnumber,barcode,itemcallnumber,title,author,biblio.biblionumber,datelastseen
1125                  FROM items
1126                    LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
1127                  WHERE itemcallnumber>= ?
1128                    AND itemcallnumber <=?
1129                    AND (datelastseen< ? OR datelastseen IS NULL)";
1130         $query.= " AND items.location=".$dbh->quote($location) if $location;
1131         $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
1132         $query .= " ORDER BY itemcallnumber,title";
1133         $sth = $dbh->prepare($query);
1134         $sth->execute( $minlocation, $maxlocation, $datelastseen );
1135     }
1136     else {
1137         my $query ="
1138                 SELECT itemnumber,barcode,itemcallnumber,biblio.biblionumber,title,author,datelastseen
1139                 FROM items
1140                   LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
1141                 WHERE itemcallnumber>= ?
1142                   AND itemcallnumber <=?";
1143         $query.= " AND items.location=".$dbh->quote($location) if $location;
1144         $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
1145         $query .= " ORDER BY itemcallnumber,title";
1146         $sth = $dbh->prepare($query);
1147         $sth->execute( $minlocation, $maxlocation );
1148     }
1149     my @results;
1150     while ( my $row = $sth->fetchrow_hashref ) {
1151         $offset-- if ($offset);
1152         $row->{datelastseen}=format_date($row->{datelastseen});
1153         if ( ( !$offset ) && $size ) {
1154             push @results, $row;
1155             $size--;
1156         }
1157     }
1158     return \@results;
1159 }
1160
1161 =head2 &GetBiblioItemData
1162
1163 =over 4
1164
1165 $itemdata = &GetBiblioItemData($biblioitemnumber);
1166
1167 Looks up the biblioitem with the given biblioitemnumber. Returns a
1168 reference-to-hash. The keys are the fields from the C<biblio>,
1169 C<biblioitems>, and C<itemtypes> tables in the Koha database, except
1170 that C<biblioitems.notes> is given as C<$itemdata-E<gt>{bnotes}>.
1171
1172 =back
1173
1174 =cut
1175
1176 #'
1177 sub GetBiblioItemData {
1178     my ($bibitem) = @_;
1179     my $dbh       = C4::Context->dbh;
1180     my $sth       =
1181       $dbh->prepare(
1182 "Select *,biblioitems.notes as bnotes from biblioitems, biblio,itemtypes where biblio.biblionumber = biblioitems.biblionumber and biblioitemnumber = ? and biblioitems.itemtype = itemtypes.itemtype"
1183       );
1184     my $data;
1185
1186     $sth->execute($bibitem);
1187
1188     $data = $sth->fetchrow_hashref;
1189
1190     $sth->finish;
1191     return ($data);
1192 }    # sub &GetBiblioItemData
1193
1194 =head2 GetItemnumberFromBarcode
1195
1196 =over 4
1197
1198 $result = GetItemnumberFromBarcode($barcode);
1199
1200 =back
1201
1202 =cut
1203
1204 sub GetItemnumberFromBarcode {
1205     my ($barcode) = @_;
1206     my $dbh = C4::Context->dbh;
1207
1208     my $rq =
1209       $dbh->prepare("SELECT itemnumber from items where items.barcode=?");
1210     $rq->execute($barcode);
1211     my ($result) = $rq->fetchrow;
1212     return ($result);
1213 }
1214
1215 =head2 GetBiblioItemByBiblioNumber
1216
1217 =over 4
1218
1219 NOTE : This function has been copy/paste from C4/Biblio.pm from head before zebra integration.
1220
1221 =back
1222
1223 =cut
1224
1225 sub GetBiblioItemByBiblioNumber {
1226     my ($biblionumber) = @_;
1227     my $dbh = C4::Context->dbh;
1228     my $sth = $dbh->prepare("Select * from biblioitems where biblionumber = ?");
1229     my $count = 0;
1230     my @results;
1231
1232     $sth->execute($biblionumber);
1233
1234     while ( my $data = $sth->fetchrow_hashref ) {
1235         push @results, $data;
1236     }
1237
1238     $sth->finish;
1239     return @results;
1240 }
1241
1242 =head2 GetBiblioFromItemNumber
1243
1244 =over 4
1245
1246 $item = &GetBiblioFromItemNumber($itemnumber);
1247
1248 Looks up the item with the given itemnumber.
1249
1250 C<&itemnodata> returns a reference-to-hash whose keys are the fields
1251 from the C<biblio>, C<biblioitems>, and C<items> tables in the Koha
1252 database.
1253
1254 =back
1255
1256 =cut
1257
1258 #'
1259 sub GetBiblioFromItemNumber {
1260     my ( $itemnumber ) = @_;
1261     my $dbh = C4::Context->dbh;
1262     my $sth = $dbh->prepare(
1263         "SELECT * FROM biblio,items,biblioitems
1264          WHERE items.itemnumber = ?
1265            AND biblio.biblionumber = items.biblionumber
1266            AND biblioitems.biblioitemnumber = items.biblioitemnumber"
1267     );
1268
1269     $sth->execute($itemnumber);
1270     my $data = $sth->fetchrow_hashref;
1271     $sth->finish;
1272     return ($data);
1273 }
1274
1275 =head2 GetBiblio
1276
1277 =over 4
1278
1279 ( $count, @results ) = &GetBiblio($biblionumber);
1280
1281 =back
1282
1283 =cut
1284
1285 sub GetBiblio {
1286     my ($biblionumber) = @_;
1287     my $dbh = C4::Context->dbh;
1288     my $sth = $dbh->prepare("Select * from biblio where biblionumber = ?");
1289     my $count = 0;
1290     my @results;
1291     $sth->execute($biblionumber);
1292     while ( my $data = $sth->fetchrow_hashref ) {
1293         $results[$count] = $data;
1294         $count++;
1295     }    # while
1296     $sth->finish;
1297     return ( $count, @results );
1298 }    # sub GetBiblio
1299
1300 =head2 GetItem
1301
1302 =over 4
1303
1304 $data = &GetItem($itemnumber,$barcode);
1305
1306 return Item information, for a given itemnumber or barcode
1307
1308 =back
1309
1310 =cut
1311
1312 sub GetItem {
1313     my ($itemnumber,$barcode) = @_;
1314     my $dbh = C4::Context->dbh;
1315     if ($itemnumber) {
1316         my $sth = $dbh->prepare("
1317             SELECT * FROM items
1318             WHERE itemnumber = ?");
1319         $sth->execute($itemnumber);
1320         my $data = $sth->fetchrow_hashref;
1321         return $data;
1322     } else {
1323         my $sth = $dbh->prepare("
1324             SELECT * FROM items
1325             WHERE barcode = ?"
1326             );
1327         $sth->execute($barcode);
1328         my $data = $sth->fetchrow_hashref;
1329         return $data;
1330     }
1331 }    # sub GetItem
1332
1333 =head2 get_itemnumbers_of
1334
1335 =over 4
1336
1337 my @itemnumbers_of = get_itemnumbers_of(@biblionumbers);
1338
1339 Given a list of biblionumbers, return the list of corresponding itemnumbers
1340 for each biblionumber.
1341
1342 Return a reference on a hash where keys are biblionumbers and values are
1343 references on array of itemnumbers.
1344
1345 =back
1346
1347 =cut
1348
1349 sub get_itemnumbers_of {
1350     my @biblionumbers = @_;
1351
1352     my $dbh = C4::Context->dbh;
1353
1354     my $query = '
1355         SELECT itemnumber,
1356             biblionumber
1357         FROM items
1358         WHERE biblionumber IN (?' . ( ',?' x scalar @biblionumbers - 1 ) . ')
1359     ';
1360     my $sth = $dbh->prepare($query);
1361     $sth->execute(@biblionumbers);
1362
1363     my %itemnumbers_of;
1364
1365     while ( my ( $itemnumber, $biblionumber ) = $sth->fetchrow_array ) {
1366         push @{ $itemnumbers_of{$biblionumber} }, $itemnumber;
1367     }
1368
1369     return \%itemnumbers_of;
1370 }
1371
1372 =head2 GetItemInfosOf
1373
1374 =over 4
1375
1376 GetItemInfosOf(@itemnumbers);
1377
1378 =back
1379
1380 =cut
1381
1382 sub GetItemInfosOf {
1383     my @itemnumbers = @_;
1384
1385     my $query = '
1386         SELECT *
1387         FROM items
1388         WHERE itemnumber IN (' . join( ',', @itemnumbers ) . ')
1389     ';
1390     return get_infos_of( $query, 'itemnumber' );
1391 }
1392
1393 =head2 GetBiblioItemInfosOf
1394
1395 =over 4
1396
1397 GetBiblioItemInfosOf(@biblioitemnumbers);
1398
1399 =back
1400
1401 =cut
1402
1403 sub GetBiblioItemInfosOf {
1404     my @biblioitemnumbers = @_;
1405
1406     my $query = '
1407         SELECT biblioitemnumber,
1408             publicationyear,
1409             itemtype
1410         FROM biblioitems
1411         WHERE biblioitemnumber IN (' . join( ',', @biblioitemnumbers ) . ')
1412     ';
1413     return get_infos_of( $query, 'biblioitemnumber' );
1414 }
1415
1416 =head1 FUNCTIONS FOR HANDLING MARC MANAGEMENT
1417
1418 =head2 GetMarcStructure
1419
1420 =over 4
1421
1422 $res = GetMarcStructure($forlibrarian,$frameworkcode);
1423
1424 Returns a reference to a big hash of hash, with the Marc structure for the given frameworkcode
1425 $forlibrarian  :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
1426 $frameworkcode : the framework code to read
1427
1428 =back
1429
1430 =cut
1431
1432 sub GetMarcStructure {
1433     my ( $forlibrarian, $frameworkcode ) = @_;
1434     my $dbh=C4::Context->dbh;
1435     $frameworkcode = "" unless $frameworkcode;
1436     my $sth;
1437     my $libfield = ( $forlibrarian eq 1 ) ? 'liblibrarian' : 'libopac';
1438
1439     # check that framework exists
1440     $sth =
1441       $dbh->prepare(
1442         "select count(*) from marc_tag_structure where frameworkcode=?");
1443     $sth->execute($frameworkcode);
1444     my ($total) = $sth->fetchrow;
1445     $frameworkcode = "" unless ( $total > 0 );
1446     $sth =
1447       $dbh->prepare(
1448 "select tagfield,liblibrarian,libopac,mandatory,repeatable from marc_tag_structure where frameworkcode=? order by tagfield"
1449       );
1450     $sth->execute($frameworkcode);
1451     my ( $liblibrarian, $libopac, $tag, $res, $tab, $mandatory, $repeatable );
1452
1453     while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable ) =
1454         $sth->fetchrow )
1455     {
1456         $res->{$tag}->{lib} =
1457           ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
1458           # why the hell do we need to explicitly decode utf8 ?
1459           # that's a good question, but we must do it...
1460         $res->{$tab}->{tab}        = "";            # XXX
1461         $res->{$tag}->{mandatory}  = $mandatory;
1462         $res->{$tag}->{repeatable} = $repeatable;
1463     }
1464
1465     $sth =
1466       $dbh->prepare(
1467 "select tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,authtypecode,value_builder,kohafield,seealso,hidden,isurl,link,defaultvalue from marc_subfield_structure where frameworkcode=? order by tagfield,tagsubfield"
1468     );
1469
1470     $sth->execute($frameworkcode);
1471
1472     my $subfield;
1473     my $authorised_value;
1474     my $authtypecode;
1475     my $value_builder;
1476     my $kohafield;
1477     my $seealso;
1478     my $hidden;
1479     my $isurl;
1480     my $link;
1481     my $defaultvalue;
1482
1483     while (
1484         (
1485             $tag,          $subfield,      $liblibrarian,
1486             ,              $libopac,       $tab,
1487             $mandatory,    $repeatable,    $authorised_value,
1488             $authtypecode, $value_builder, $kohafield,
1489             $seealso,      $hidden,        $isurl,
1490             $link,$defaultvalue
1491         )
1492         = $sth->fetchrow
1493       )
1494     {
1495         $res->{$tag}->{$subfield}->{lib} =
1496           ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
1497         $res->{$tag}->{$subfield}->{tab}              = $tab;
1498         $res->{$tag}->{$subfield}->{mandatory}        = $mandatory;
1499         $res->{$tag}->{$subfield}->{repeatable}       = $repeatable;
1500         $res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
1501         $res->{$tag}->{$subfield}->{authtypecode}     = $authtypecode;
1502         $res->{$tag}->{$subfield}->{value_builder}    = $value_builder;
1503         $res->{$tag}->{$subfield}->{kohafield}        = $kohafield;
1504         $res->{$tag}->{$subfield}->{seealso}          = $seealso;
1505         $res->{$tag}->{$subfield}->{hidden}           = $hidden;
1506         $res->{$tag}->{$subfield}->{isurl}            = $isurl;
1507         $res->{$tag}->{$subfield}->{'link'}           = $link;
1508         $res->{$tag}->{$subfield}->{defaultvalue}     = $defaultvalue;
1509     }
1510     return $res;
1511 }
1512
1513 =head2 GetUsedMarcStructure
1514
1515     the same function as GetMarcStructure expcet it just take field
1516     in tab 0-9. (used field)
1517
1518     my $results = GetUsedMarcStructure($frameworkcode);
1519
1520     L<$results> is a ref to an array which each case containts a ref
1521     to a hash which each keys is the columns from marc_subfield_structure
1522
1523     L<$frameworkcode> is the framework code.
1524
1525 =cut
1526
1527 sub GetUsedMarcStructure($){
1528     my $frameworkcode = shift || '';
1529     my $dbh           = C4::Context->dbh;
1530     my $query         = qq/
1531         SELECT *
1532         FROM   marc_subfield_structure
1533         WHERE   tab > -1
1534             AND frameworkcode = ?
1535     /;
1536     my @results;
1537     my $sth = $dbh->prepare($query);
1538     $sth->execute($frameworkcode);
1539     while (my $row = $sth->fetchrow_hashref){
1540         push @results,$row;
1541     }
1542     return \@results;
1543 }
1544
1545 =head2 GetMarcFromKohaField
1546
1547 =over 4
1548
1549 ($MARCfield,$MARCsubfield)=GetMarcFromKohaField($kohafield,$frameworkcode);
1550 Returns the MARC fields & subfields mapped to the koha field
1551 for the given frameworkcode
1552
1553 =back
1554
1555 =cut
1556
1557 sub GetMarcFromKohaField {
1558     my ( $kohafield, $frameworkcode ) = @_;
1559     return 0, 0 unless $kohafield;
1560     my $relations = C4::Context->marcfromkohafield;
1561     return (
1562         $relations->{$frameworkcode}->{$kohafield}->[0],
1563         $relations->{$frameworkcode}->{$kohafield}->[1]
1564     );
1565 }
1566
1567 =head2 GetMarcBiblio
1568
1569 =over 4
1570
1571 Returns MARC::Record of the biblionumber passed in parameter.
1572 the marc record contains both biblio & item datas
1573
1574 =back
1575
1576 =cut
1577
1578 sub GetMarcBiblio {
1579     my $biblionumber = shift;
1580     my $dbh          = C4::Context->dbh;
1581     my $sth          =
1582       $dbh->prepare("select marcxml from biblioitems where biblionumber=? ");
1583     $sth->execute($biblionumber);
1584      my ($marcxml) = $sth->fetchrow;
1585      MARC::File::XML->default_record_format(C4::Context->preference('marcflavour'));
1586      $marcxml =~ s/\x1e//g;
1587      $marcxml =~ s/\x1f//g;
1588      $marcxml =~ s/\x1d//g;
1589      $marcxml =~ s/\x0f//g;
1590      $marcxml =~ s/\x0c//g;
1591 #   warn $marcxml;
1592     my $record = MARC::Record->new();
1593      $record = MARC::Record::new_from_xml( $marcxml, "utf8",C4::Context->preference('marcflavour')) if $marcxml;
1594 #      $record = MARC::Record::new_from_usmarc( $marc) if $marc;
1595     return $record;
1596 }
1597
1598 =head2 GetXmlBiblio
1599
1600 =over 4
1601
1602 my $marcxml = GetXmlBiblio($biblionumber);
1603
1604 Returns biblioitems.marcxml of the biblionumber passed in parameter.
1605 The XML contains both biblio & item datas
1606
1607 =back
1608
1609 =cut
1610
1611 sub GetXmlBiblio {
1612     my ( $biblionumber ) = @_;
1613     my $dbh = C4::Context->dbh;
1614     my $sth =
1615       $dbh->prepare("select marcxml from biblioitems where biblionumber=? ");
1616     $sth->execute($biblionumber);
1617     my ($marcxml) = $sth->fetchrow;
1618     return $marcxml;
1619 }
1620
1621 =head2 GetAuthorisedValueDesc
1622
1623 =over 4
1624
1625 my $subfieldvalue =get_authorised_value_desc(
1626     $tag, $subf[$i][0],$subf[$i][1], '', $taglib);
1627 Retrieve the complete description for a given authorised value.
1628
1629 =back
1630
1631 =cut
1632
1633 sub GetAuthorisedValueDesc {
1634     my ( $tag, $subfield, $value, $framework, $tagslib ) = @_;
1635     my $dbh = C4::Context->dbh;
1636
1637     #---- branch
1638     if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "branches" ) {
1639         return C4::Branch::GetBranchName($value);
1640     }
1641
1642     #---- itemtypes
1643     if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "itemtypes" ) {
1644         return getitemtypeinfo($value)->{description};
1645     }
1646
1647     #---- "true" authorized value
1648     my $category = $tagslib->{$tag}->{$subfield}->{'authorised_value'};
1649     if ( $category ne "" ) {
1650         my $sth =
1651           $dbh->prepare(
1652             "select lib from authorised_values where category = ? and authorised_value = ?"
1653           );
1654         $sth->execute( $category, $value );
1655         my $data = $sth->fetchrow_hashref;
1656         return $data->{'lib'};
1657     }
1658     else {
1659         return $value;    # if nothing is found return the original value
1660     }
1661 }
1662
1663 =head2 GetMarcItem
1664
1665 =over 4
1666
1667 Returns MARC::Record of the item passed in parameter.
1668
1669 =back
1670
1671 =cut
1672
1673 sub GetMarcItem {
1674     my ( $biblionumber, $itemnumber ) = @_;
1675     my $dbh = C4::Context->dbh;
1676     my $newrecord = MARC::Record->new();
1677     my $marcflavour = C4::Context->preference('marcflavour');
1678
1679     my $marcxml = GetXmlBiblio($biblionumber);
1680     my $record = MARC::Record->new();
1681     $record = MARC::Record::new_from_xml( $marcxml, "utf8", $marcflavour );
1682     # now, find where the itemnumber is stored & extract only the item
1683     my ( $itemnumberfield, $itemnumbersubfield ) =
1684       GetMarcFromKohaField( 'items.itemnumber', '' );
1685     my @fields = $record->field($itemnumberfield);
1686     foreach my $field (@fields) {
1687         if ( $field->subfield($itemnumbersubfield) eq $itemnumber ) {
1688             $newrecord->insert_fields_ordered($field);
1689         }
1690     }
1691     return $newrecord;
1692 }
1693
1694
1695
1696 =head2 GetMarcNotes
1697
1698 =over 4
1699
1700 $marcnotesarray = GetMarcNotes( $record, $marcflavour );
1701 Get all notes from the MARC record and returns them in an array.
1702 The note are stored in differents places depending on MARC flavour
1703
1704 =back
1705
1706 =cut
1707
1708 sub GetMarcNotes {
1709     my ( $record, $marcflavour ) = @_;
1710     my $scope;
1711     if ( $marcflavour eq "MARC21" ) {
1712         $scope = '5..';
1713     }
1714     else {    # assume unimarc if not marc21
1715         $scope = '3..';
1716     }
1717     my @marcnotes;
1718     my $note = "";
1719     my $tag  = "";
1720     my $marcnote;
1721     foreach my $field ( $record->field($scope) ) {
1722         my $value = $field->as_string();
1723         if ( $note ne "" ) {
1724             $marcnote = { marcnote => $note, };
1725             push @marcnotes, $marcnote;
1726             $note = $value;
1727         }
1728         if ( $note ne $value ) {
1729             $note = $note . " " . $value;
1730         }
1731     }
1732
1733     if ( $note ) {
1734         $marcnote = { marcnote => $note };
1735         push @marcnotes, $marcnote;    #load last tag into array
1736     }
1737     return \@marcnotes;
1738 }    # end GetMarcNotes
1739
1740 =head2 GetMarcSubjects
1741
1742 =over 4
1743
1744 $marcsubjcts = GetMarcSubjects($record,$marcflavour);
1745 Get all subjects from the MARC record and returns them in an array.
1746 The subjects are stored in differents places depending on MARC flavour
1747
1748 =back
1749
1750 =cut
1751
1752 sub GetMarcSubjects {
1753     my ( $record, $marcflavour ) = @_;
1754     my ( $mintag, $maxtag );
1755     if ( $marcflavour eq "MARC21" ) {
1756         $mintag = "600";
1757         $maxtag = "699";
1758     }
1759     else {    # assume unimarc if not marc21
1760         $mintag = "600";
1761         $maxtag = "611";
1762     }
1763
1764     my @marcsubjcts;
1765
1766     foreach my $field ( $record->fields ) {
1767         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
1768         my @subfields = $field->subfields();
1769         my $link = "su:";
1770         my $label;
1771         my $flag = 0;
1772         my $authoritysep=C4::Context->preference("authoritysep");
1773         for my $subject_subfield ( @subfields ) {
1774             if (
1775                 $marcflavour ne 'MARC21'
1776                 and (
1777                     ($subject_subfield->[0] eq '3') or
1778                     ($subject_subfield->[0] eq '4') or
1779                     ($subject_subfield->[0] eq '5')
1780                 )
1781             )
1782             {
1783                 next;
1784             }
1785             my $code = $subject_subfield->[0];
1786             $label .= $subject_subfield->[1].$authoritysep unless ( $code == 9 );
1787             $link  .= " and su-to:".$subject_subfield->[1]  unless ( $code == 9 );
1788             if ( $code == 9 ) {
1789                 $link = "an:".$subject_subfield->[1];
1790                 $flag = 1;
1791             }
1792             elsif ( ! $flag ) {
1793                 $link =~ s/ and\ssu-to:$//;
1794             }
1795         }
1796          $label =~ s/$authoritysep$//;
1797         push @marcsubjcts,
1798           {
1799             label => $label,
1800             link  => $link
1801           }
1802     }
1803     return \@marcsubjcts;
1804 }    #end GetMarcSubjects
1805
1806 =head2 GetMarcAuthors
1807
1808 =over 4
1809
1810 authors = GetMarcAuthors($record,$marcflavour);
1811 Get all authors from the MARC record and returns them in an array.
1812 The authors are stored in differents places depending on MARC flavour
1813
1814 =back
1815
1816 =cut
1817
1818 sub GetMarcAuthors {
1819     my ( $record, $marcflavour ) = @_;
1820     my ( $mintag, $maxtag );
1821     if ( $marcflavour eq "MARC21" ) {
1822         $mintag = "100";
1823         $maxtag = "111";
1824     }
1825     else {    # assume unimarc if not marc21
1826         $mintag = "701";
1827         $maxtag = "712";
1828     }
1829
1830     my @marcauthors;
1831
1832     foreach my $field ( $record->fields ) {
1833         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
1834         my %hash;
1835         my @subfields = $field->subfields();
1836         my $count_auth = 0;
1837         my $and ;
1838         for my $authors_subfield (@subfields) {
1839             if (
1840                 $marcflavour ne 'MARC21'
1841                 and (
1842                     ($authors_subfield->[0] eq '3') or
1843                     ($authors_subfield->[0] eq '4') or
1844                     ($authors_subfield->[0] eq '5')
1845                 )
1846             )
1847             {
1848                 next;
1849             }
1850             if ($count_auth ne '0'){
1851                 $and = " and au:";
1852             }
1853             $count_auth++;
1854             my $subfieldcode = $authors_subfield->[0];
1855             my $value        = $authors_subfield->[1];
1856             $hash{tag}       = $field->tag;
1857             $hash{value}    .= $value . " " if ($subfieldcode != 9) ;
1858             $hash{link}     .= $value if ($subfieldcode eq 9);
1859         }
1860         push @marcauthors, \%hash;
1861     }
1862     return \@marcauthors;
1863 }
1864
1865 =head2 GetMarcSeries
1866
1867 =over 4
1868
1869 $marcseriessarray = GetMarcSeries($record,$marcflavour);
1870 Get all series from the MARC record and returns them in an array.
1871 The series are stored in differents places depending on MARC flavour
1872
1873 =back
1874
1875 =cut
1876
1877 sub GetMarcSeries {
1878     my ($record, $marcflavour) = @_;
1879     my ($mintag, $maxtag);
1880     if ($marcflavour eq "MARC21") {
1881         $mintag = "440";
1882         $maxtag = "490";
1883     } else {           # assume unimarc if not marc21
1884         $mintag = "600";
1885         $maxtag = "619";
1886     }
1887
1888     my @marcseries;
1889     my $subjct = "";
1890     my $subfield = "";
1891     my $marcsubjct;
1892
1893     foreach my $field ($record->field('440'), $record->field('490')) {
1894         my @subfields_loop;
1895         #my $value = $field->subfield('a');
1896         #$marcsubjct = {MARCSUBJCT => $value,};
1897         my @subfields = $field->subfields();
1898         #warn "subfields:".join " ", @$subfields;
1899         my $counter = 0;
1900         my @link_loop;
1901         for my $series_subfield (@subfields) {
1902                         my $volume_number;
1903                         undef $volume_number;
1904                         # see if this is an instance of a volume
1905                         if ($series_subfield->[0] eq 'v') {
1906                                 $volume_number=1;
1907                         }
1908
1909             my $code = $series_subfield->[0];
1910             my $value = $series_subfield->[1];
1911             my $linkvalue = $value;
1912             $linkvalue =~ s/(\(|\))//g;
1913             my $operator = " and " unless $counter==0;
1914             push @link_loop, {link => $linkvalue, operator => $operator };
1915             my $separator = C4::Context->preference("authoritysep") unless $counter==0;
1916                         if ($volume_number) {
1917                         push @subfields_loop, {volumenum => $value};
1918                         }
1919                         else {
1920             push @subfields_loop, {code => $code, value => $value, link_loop => \@link_loop, separator => $separator, volumenum => $volume_number};
1921                         }
1922             $counter++;
1923         }
1924         push @marcseries, { MARCSERIES_SUBFIELDS_LOOP => \@subfields_loop };
1925         #$marcsubjct = {MARCSUBJCT => $field->as_string(),};
1926         #push @marcsubjcts, $marcsubjct;
1927         #$subjct = $value;
1928
1929     }
1930     my $marcseriessarray=\@marcseries;
1931     return $marcseriessarray;
1932 }  #end getMARCseriess
1933
1934 =head2 GetFrameworkCode
1935
1936 =over 4
1937
1938     $frameworkcode = GetFrameworkCode( $biblionumber )
1939
1940 =back
1941
1942 =cut
1943
1944 sub GetFrameworkCode {
1945     my ( $biblionumber ) = @_;
1946     my $dbh = C4::Context->dbh;
1947     my $sth = $dbh->prepare("select frameworkcode from biblio where biblionumber=?");
1948     $sth->execute($biblionumber);
1949     my ($frameworkcode) = $sth->fetchrow;
1950     return $frameworkcode;
1951 }
1952
1953 =head2 GetPublisherNameFromIsbn
1954
1955     $name = GetPublishercodeFromIsbn($isbn);
1956     if(defined $name){
1957         ...
1958     }
1959
1960 =cut
1961
1962 sub GetPublisherNameFromIsbn($){
1963     my $isbn = shift;
1964     $isbn =~ s/[- _]//g;
1965     $isbn =~ s/^0*//;
1966     my @codes = (split '-', DisplayISBN($isbn));
1967     my $code = $codes[0].$codes[1].$codes[2];
1968     my $dbh  = C4::Context->dbh;
1969     my $query = qq{
1970         SELECT distinct publishercode
1971         FROM   biblioitems
1972         WHERE  isbn LIKE ?
1973         AND    publishercode IS NOT NULL
1974         LIMIT 1
1975     };
1976     my $sth = $dbh->prepare($query);
1977     $sth->execute("$code%");
1978     my $name = $sth->fetchrow;
1979     return $name if length $name;
1980     return undef;
1981 }
1982
1983 =head2 TransformKohaToMarc
1984
1985 =over 4
1986
1987     $record = TransformKohaToMarc( $hash )
1988     This function builds partial MARC::Record from a hash
1989     Hash entries can be from biblio or biblioitems.
1990     This function is called in acquisition module, to create a basic catalogue entry from user entry
1991
1992 =back
1993
1994 =cut
1995
1996 sub TransformKohaToMarc {
1997
1998     my ( $hash ) = @_;
1999     my $dbh = C4::Context->dbh;
2000     my $sth =
2001     $dbh->prepare(
2002         "select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
2003     );
2004     my $record = MARC::Record->new();
2005     foreach (keys %{$hash}) {
2006         &TransformKohaToMarcOneField( $sth, $record, $_,
2007             $hash->{$_}, '' );
2008         }
2009     return $record;
2010 }
2011
2012 =head2 TransformKohaToMarcOneField
2013
2014 =over 4
2015
2016     $record = TransformKohaToMarcOneField( $sth, $record, $kohafieldname, $value, $frameworkcode );
2017
2018 =back
2019
2020 =cut
2021
2022 sub TransformKohaToMarcOneField {
2023     my ( $sth, $record, $kohafieldname, $value, $frameworkcode ) = @_;
2024     $frameworkcode='' unless $frameworkcode;
2025     my $tagfield;
2026     my $tagsubfield;
2027
2028     if ( !defined $sth ) {
2029         my $dbh = C4::Context->dbh;
2030         $sth = $dbh->prepare(
2031             "select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
2032         );
2033     }
2034     $sth->execute( $frameworkcode, $kohafieldname );
2035     if ( ( $tagfield, $tagsubfield ) = $sth->fetchrow ) {
2036         my $tag = $record->field($tagfield);
2037         if ($tag) {
2038             $tag->update( $tagsubfield => $value );
2039             $record->delete_field($tag);
2040             $record->insert_fields_ordered($tag);
2041         }
2042         else {
2043             $record->add_fields( $tagfield, " ", " ", $tagsubfield => $value );
2044         }
2045     }
2046     return $record;
2047 }
2048
2049 =head2 TransformHtmlToXml
2050
2051 =over 4
2052
2053 $xml = TransformHtmlToXml( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type )
2054
2055 $auth_type contains :
2056 - nothing : rebuild a biblio, un UNIMARC the encoding is in 100$a pos 26/27
2057 - UNIMARCAUTH : rebuild an authority. In UNIMARC, the encoding is in 100$a pos 13/14
2058 - ITEM : rebuild an item : in UNIMARC, 100$a, it's in the biblio ! (otherwise, we would get 2 100 fields !)
2059
2060 =back
2061
2062 =cut
2063
2064 sub TransformHtmlToXml {
2065     my ( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type ) = @_;
2066     my $xml = MARC::File::XML::header('UTF-8');
2067     $auth_type = C4::Context->preference('marcflavour') unless $auth_type;
2068     MARC::File::XML->default_record_format($auth_type);
2069     # in UNIMARC, field 100 contains the encoding
2070     # check that there is one, otherwise the
2071     # MARC::Record->new_from_xml will fail (and Koha will die)
2072     my $unimarc_and_100_exist=0;
2073     $unimarc_and_100_exist=1 if $auth_type eq 'ITEM'; # if we rebuild an item, no need of a 100 field
2074     my $prevvalue;
2075     my $prevtag = -1;
2076     my $first   = 1;
2077     my $j       = -1;
2078     for ( my $i = 0 ; $i <= @$tags ; $i++ ) {
2079         if (C4::Context->preference('marcflavour') eq 'UNIMARC' and @$tags[$i] eq "100" and @$subfields[$i] eq "a") {
2080             # if we have a 100 field and it's values are not correct, skip them.
2081             # if we don't have any valid 100 field, we will create a default one at the end
2082             my $enc = substr( @$values[$i], 26, 2 );
2083             if ($enc eq '01' or $enc eq '50' or $enc eq '03') {
2084                 $unimarc_and_100_exist=1;
2085             } else {
2086                 next;
2087             }
2088         }
2089         @$values[$i] =~ s/&/&amp;/g;
2090         @$values[$i] =~ s/</&lt;/g;
2091         @$values[$i] =~ s/>/&gt;/g;
2092         @$values[$i] =~ s/"/&quot;/g;
2093         @$values[$i] =~ s/'/&apos;/g;
2094 #         if ( !utf8::is_utf8( @$values[$i] ) ) {
2095 #             utf8::decode( @$values[$i] );
2096 #         }
2097         if ( ( @$tags[$i] ne $prevtag ) ) {
2098             $j++ unless ( @$tags[$i] eq "" );
2099             if ( !$first ) {
2100                 $xml .= "</datafield>\n";
2101                 if (   ( @$tags[$i] && @$tags[$i] > 10 )
2102                     && ( @$values[$i] ne "" ) )
2103                 {
2104                     my $ind1 = substr( @$indicator[$j], 0, 1 );
2105                     my $ind2;
2106                     if ( @$indicator[$j] ) {
2107                         $ind2 = substr( @$indicator[$j], 1, 1 );
2108                     }
2109                     else {
2110                         warn "Indicator in @$tags[$i] is empty";
2111                         $ind2 = " ";
2112                     }
2113                     $xml .=
2114 "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2115                     $xml .=
2116 "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2117                     $first = 0;
2118                 }
2119                 else {
2120                     $first = 1;
2121                 }
2122             }
2123             else {
2124                 if ( @$values[$i] ne "" ) {
2125
2126                     # leader
2127                     if ( @$tags[$i] eq "000" ) {
2128                         $xml .= "<leader>@$values[$i]</leader>\n";
2129                         $first = 1;
2130
2131                         # rest of the fixed fields
2132                     }
2133                     elsif ( @$tags[$i] < 10 ) {
2134                         $xml .=
2135 "<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
2136                         $first = 1;
2137                     }
2138                     else {
2139                         my $ind1 = substr( @$indicator[$j], 0, 1 );
2140                         my $ind2 = substr( @$indicator[$j], 1, 1 );
2141                         $xml .=
2142 "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2143                         $xml .=
2144 "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2145                         $first = 0;
2146                     }
2147                 }
2148             }
2149         }
2150         else {    # @$tags[$i] eq $prevtag
2151             if ( @$values[$i] eq "" ) {
2152             }
2153             else {
2154                 if ($first) {
2155                     my $ind1 = substr( @$indicator[$j], 0, 1 );
2156                     my $ind2 = substr( @$indicator[$j], 1, 1 );
2157                     $xml .=
2158 "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2159                     $first = 0;
2160                 }
2161                 $xml .=
2162 "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2163             }
2164         }
2165         $prevtag = @$tags[$i];
2166     }
2167     if (C4::Context->preference('marcflavour') and !$unimarc_and_100_exist) {
2168 #     warn "SETTING 100 for $auth_type";
2169         use POSIX qw(strftime);
2170         my $string = strftime( "%Y%m%d", localtime(time) );
2171         # set 50 to position 26 is biblios, 13 if authorities
2172         my $pos=26;
2173         $pos=13 if $auth_type eq 'UNIMARCAUTH';
2174         $string = sprintf( "%-*s", 35, $string );
2175         substr( $string, $pos , 6, "50" );
2176         $xml .= "<datafield tag=\"100\" ind1=\"\" ind2=\"\">\n";
2177         $xml .= "<subfield code=\"a\">$string</subfield>\n";
2178         $xml .= "</datafield>\n";
2179     }
2180     $xml .= MARC::File::XML::footer();
2181     return $xml;
2182 }
2183
2184 =head2 TransformHtmlToMarc
2185
2186     L<$record> = TransformHtmlToMarc(L<$params>,L<$cgi>)
2187     L<$params> is a ref to an array as below:
2188     {
2189         'tag_010_indicator_531951' ,
2190         'tag_010_code_a_531951_145735' ,
2191         'tag_010_subfield_a_531951_145735' ,
2192         'tag_200_indicator_873510' ,
2193         'tag_200_code_a_873510_673465' ,
2194         'tag_200_subfield_a_873510_673465' ,
2195         'tag_200_code_b_873510_704318' ,
2196         'tag_200_subfield_b_873510_704318' ,
2197         'tag_200_code_e_873510_280822' ,
2198         'tag_200_subfield_e_873510_280822' ,
2199         'tag_200_code_f_873510_110730' ,
2200         'tag_200_subfield_f_873510_110730' ,
2201     }
2202     L<$cgi> is the CGI object which containts the value.
2203     L<$record> is the MARC::Record object.
2204
2205 =cut
2206
2207 sub TransformHtmlToMarc {
2208     my $params = shift;
2209     my $cgi    = shift;
2210
2211     # creating a new record
2212     my $record  = MARC::Record->new();
2213     my $i=0;
2214     my @fields;
2215
2216     while ($params->[$i]){ # browse all CGI params
2217         my $param = $params->[$i];
2218
2219         if($param =~ /^tag_(\d*)_indicator_/){ # new field start when having 'input name="..._indicator_..."
2220             my $tag  = $1;
2221
2222             my $ind1 = substr($cgi->param($param),0,1);
2223             my $ind2 = substr($cgi->param($param),1,1);
2224
2225             my $newfield=0;
2226             my $j=$i+1;
2227
2228             if($tag < 10){ # no code for theses fields
2229     # in MARC editor, 000 contains the leader.
2230                 if ($tag eq '000' ) {
2231                     $record->leader($cgi->param($params->[$j+1])) if length($cgi->param($params->[$j+1]))==24;
2232     # between 001 and 009 (included)
2233                 } else {
2234                     $newfield = MARC::Field->new(
2235                         $tag,
2236                         $cgi->param($params->[$j+1]),
2237                     );
2238                 }
2239     # > 009, deal with subfields
2240             } else {
2241                 while($params->[$j] =~ /_code_/){ # browse all it's subfield
2242                     my $inner_param = $params->[$j];
2243                     if ($newfield){
2244                         if($cgi->param($params->[$j+1])){  # only if there is a value (code => value)
2245                             $newfield->add_subfields(
2246                                 $cgi->param($inner_param) => $cgi->param($params->[$j+1])
2247                             );
2248                         }
2249                     } else {
2250                         if ( $cgi->param($params->[$j+1]) ) { # creating only if there is a value (code => value)
2251                             $newfield = MARC::Field->new(
2252                                 $tag,
2253                                 ''.$ind1,
2254                                 ''.$ind2,
2255                                 $cgi->param($inner_param) => $cgi->param($params->[$j+1]),
2256                             );
2257                         }
2258                     }
2259                     $j+=2;
2260                 }
2261             }
2262             push @fields,$newfield if($newfield);
2263         }
2264         $i++;
2265     }
2266
2267     $record->append_fields(@fields);
2268     return $record;
2269 }
2270
2271 =head2 TransformMarcToKoha
2272
2273 =over 4
2274
2275         $result = TransformMarcToKoha( $dbh, $record, $frameworkcode )
2276
2277 =back
2278
2279 =cut
2280
2281 sub TransformMarcToKoha {
2282     my ( $dbh, $record, $frameworkcode ) = @_;
2283
2284     #  FIXME :: This query is unused..
2285     #    my $sth =
2286     #      $dbh->prepare(
2287     #"select tagfield,tagsubfield from marc_subfield_structure where frameworkcode=? and kohafield=?"
2288     #      );
2289
2290     my $result;
2291     my $sth2 = $dbh->prepare("SHOW COLUMNS from biblio");
2292     $sth2->execute;
2293     my $field;
2294     while ( ($field) = $sth2->fetchrow ) {
2295         $result =
2296           &TransformMarcToKohaOneField( "biblio", $field, $record, $result,
2297             $frameworkcode );
2298     }
2299     $sth2->execute;
2300     while ( ($field) = $sth2->fetchrow ) {
2301         if ( $field eq 'notes' ) { $field = 'bnotes'; }
2302         $result =
2303           &TransformMarcToKohaOneField( "biblioitems", $field, $record, $result,
2304             $frameworkcode );
2305     }
2306     $sth2 = $dbh->prepare("SHOW COLUMNS from items");
2307     $sth2->execute;
2308     while ( ($field) = $sth2->fetchrow ) {
2309         $result =
2310           &TransformMarcToKohaOneField( "items", $field, $record, $result,
2311             $frameworkcode );
2312     }
2313
2314     #
2315     # modify copyrightdate to keep only the 1st year found
2316     my $temp = $result->{'copyrightdate'};
2317     $temp =~ m/c(\d\d\d\d)/;    # search cYYYY first
2318     if ( $1 > 0 ) {
2319         $result->{'copyrightdate'} = $1;
2320     }
2321     else {                      # if no cYYYY, get the 1st date.
2322         $temp =~ m/(\d\d\d\d)/;
2323         $result->{'copyrightdate'} = $1;
2324     }
2325
2326     # modify publicationyear to keep only the 1st year found
2327     $temp = $result->{'publicationyear'};
2328     $temp =~ m/c(\d\d\d\d)/;    # search cYYYY first
2329     if ( $1 > 0 ) {
2330         $result->{'publicationyear'} = $1;
2331     }
2332     else {                      # if no cYYYY, get the 1st date.
2333         $temp =~ m/(\d\d\d\d)/;
2334         $result->{'publicationyear'} = $1;
2335     }
2336     return $result;
2337 }
2338
2339 =head2 TransformMarcToKohaOneField
2340
2341 =over 4
2342
2343 $result = TransformMarcToKohaOneField( $kohatable, $kohafield, $record, $result, $frameworkcode )
2344
2345 =back
2346
2347 =cut
2348
2349 sub TransformMarcToKohaOneField {
2350
2351     # FIXME ? if a field has a repeatable subfield that is used in old-db,
2352     # only the 1st will be retrieved...
2353     my ( $kohatable, $kohafield, $record, $result, $frameworkcode ) = @_;
2354     my $res = "";
2355     my ( $tagfield, $subfield ) =
2356       GetMarcFromKohaField( $kohatable . "." . $kohafield,
2357         $frameworkcode );
2358     foreach my $field ( $record->field($tagfield) ) {
2359         if ( $field->tag() < 10 ) {
2360             if ( $result->{$kohafield} ) {
2361                 $result->{$kohafield} .= " | " . $field->data();
2362             }
2363             else {
2364                 $result->{$kohafield} = $field->data();
2365             }
2366         }
2367         else {
2368             if ( $field->subfields ) {
2369                 my @subfields = $field->subfields();
2370                 foreach my $subfieldcount ( 0 .. $#subfields ) {
2371                     if ( $subfields[$subfieldcount][0] eq $subfield ) {
2372                         if ( $result->{$kohafield} ) {
2373                             $result->{$kohafield} .=
2374                               " | " . $subfields[$subfieldcount][1];
2375                         }
2376                         else {
2377                             $result->{$kohafield} =
2378                               $subfields[$subfieldcount][1];
2379                         }
2380                     }
2381                 }
2382             }
2383         }
2384     }
2385     return $result;
2386 }
2387
2388 =head1  OTHER FUNCTIONS
2389
2390 =head2 char_decode
2391
2392 =over 4
2393
2394 my $string = char_decode( $string, $encoding );
2395
2396 converts ISO 5426 coded string to UTF-8
2397 sloppy code : should be improved in next issue
2398
2399 =back
2400
2401 =cut
2402
2403 sub char_decode {
2404     my ( $string, $encoding ) = @_;
2405     $_ = $string;
2406
2407     $encoding = C4::Context->preference("marcflavour") unless $encoding;
2408     if ( $encoding eq "UNIMARC" ) {
2409
2410         #         s/\xe1/Æ/gm;
2411         s/\xe2/Ğ/gm;
2412         s/\xe9/Ø/gm;
2413         s/\xec/ş/gm;
2414         s/\xf1/æ/gm;
2415         s/\xf3/ğ/gm;
2416         s/\xf9/ø/gm;
2417         s/\xfb/ß/gm;
2418         s/\xc1\x61/à/gm;
2419         s/\xc1\x65/è/gm;
2420         s/\xc1\x69/ì/gm;
2421         s/\xc1\x6f/ò/gm;
2422         s/\xc1\x75/ù/gm;
2423         s/\xc1\x41/À/gm;
2424         s/\xc1\x45/È/gm;
2425         s/\xc1\x49/Ì/gm;
2426         s/\xc1\x4f/Ò/gm;
2427         s/\xc1\x55/Ù/gm;
2428         s/\xc2\x41/Á/gm;
2429         s/\xc2\x45/É/gm;
2430         s/\xc2\x49/Í/gm;
2431         s/\xc2\x4f/Ó/gm;
2432         s/\xc2\x55/Ú/gm;
2433         s/\xc2\x59/İ/gm;
2434         s/\xc2\x61/á/gm;
2435         s/\xc2\x65/é/gm;
2436         s/\xc2\x69/í/gm;
2437         s/\xc2\x6f/ó/gm;
2438         s/\xc2\x75/ú/gm;
2439         s/\xc2\x79/ı/gm;
2440         s/\xc3\x41/Â/gm;
2441         s/\xc3\x45/Ê/gm;
2442         s/\xc3\x49/Î/gm;
2443         s/\xc3\x4f/Ô/gm;
2444         s/\xc3\x55/Û/gm;
2445         s/\xc3\x61/â/gm;
2446         s/\xc3\x65/ê/gm;
2447         s/\xc3\x69/î/gm;
2448         s/\xc3\x6f/ô/gm;
2449         s/\xc3\x75/û/gm;
2450         s/\xc4\x41/Ã/gm;
2451         s/\xc4\x4e/Ñ/gm;
2452         s/\xc4\x4f/Õ/gm;
2453         s/\xc4\x61/ã/gm;
2454         s/\xc4\x6e/ñ/gm;
2455         s/\xc4\x6f/õ/gm;
2456         s/\xc8\x41/Ä/gm;
2457         s/\xc8\x45/Ë/gm;
2458         s/\xc8\x49/Ï/gm;
2459         s/\xc8\x61/ä/gm;
2460         s/\xc8\x65/ë/gm;
2461         s/\xc8\x69/ï/gm;
2462         s/\xc8\x6F/ö/gm;
2463         s/\xc8\x75/ü/gm;
2464         s/\xc8\x76/ÿ/gm;
2465         s/\xc9\x41/Ä/gm;
2466         s/\xc9\x45/Ë/gm;
2467         s/\xc9\x49/Ï/gm;
2468         s/\xc9\x4f/Ö/gm;
2469         s/\xc9\x55/Ü/gm;
2470         s/\xc9\x61/ä/gm;
2471         s/\xc9\x6f/ö/gm;
2472         s/\xc9\x75/ü/gm;
2473         s/\xca\x41/Å/gm;
2474         s/\xca\x61/å/gm;
2475         s/\xd0\x43/Ç/gm;
2476         s/\xd0\x63/ç/gm;
2477
2478         # this handles non-sorting blocks (if implementation requires this)
2479         $string = nsb_clean($_);
2480     }
2481     elsif ( $encoding eq "USMARC" || $encoding eq "MARC21" ) {
2482         ##MARC-8 to UTF-8
2483
2484         s/\xe1\x61/à/gm;
2485         s/\xe1\x65/è/gm;
2486         s/\xe1\x69/ì/gm;
2487         s/\xe1\x6f/ò/gm;
2488         s/\xe1\x75/ù/gm;
2489         s/\xe1\x41/À/gm;
2490         s/\xe1\x45/È/gm;
2491         s/\xe1\x49/Ì/gm;
2492         s/\xe1\x4f/Ò/gm;
2493         s/\xe1\x55/Ù/gm;
2494         s/\xe2\x41/Á/gm;
2495         s/\xe2\x45/É/gm;
2496         s/\xe2\x49/Í/gm;
2497         s/\xe2\x4f/Ó/gm;
2498         s/\xe2\x55/Ú/gm;
2499         s/\xe2\x59/İ/gm;
2500         s/\xe2\x61/á/gm;
2501         s/\xe2\x65/é/gm;
2502         s/\xe2\x69/í/gm;
2503         s/\xe2\x6f/ó/gm;
2504         s/\xe2\x75/ú/gm;
2505         s/\xe2\x79/ı/gm;
2506         s/\xe3\x41/Â/gm;
2507         s/\xe3\x45/Ê/gm;
2508         s/\xe3\x49/Î/gm;
2509         s/\xe3\x4f/Ô/gm;
2510         s/\xe3\x55/Û/gm;
2511         s/\xe3\x61/â/gm;
2512         s/\xe3\x65/ê/gm;
2513         s/\xe3\x69/î/gm;
2514         s/\xe3\x6f/ô/gm;
2515         s/\xe3\x75/û/gm;
2516         s/\xe4\x41/Ã/gm;
2517         s/\xe4\x4e/Ñ/gm;
2518         s/\xe4\x4f/Õ/gm;
2519         s/\xe4\x61/ã/gm;
2520         s/\xe4\x6e/ñ/gm;
2521         s/\xe4\x6f/õ/gm;
2522         s/\xe6\x41/Ă/gm;
2523         s/\xe6\x45/Ĕ/gm;
2524         s/\xe6\x65/ĕ/gm;
2525         s/\xe6\x61/ă/gm;
2526         s/\xe8\x45/Ë/gm;
2527         s/\xe8\x49/Ï/gm;
2528         s/\xe8\x65/ë/gm;
2529         s/\xe8\x69/ï/gm;
2530         s/\xe8\x76/ÿ/gm;
2531         s/\xe9\x41/A/gm;
2532         s/\xe9\x4f/O/gm;
2533         s/\xe9\x55/U/gm;
2534         s/\xe9\x61/a/gm;
2535         s/\xe9\x6f/o/gm;
2536         s/\xe9\x75/u/gm;
2537         s/\xea\x41/A/gm;
2538         s/\xea\x61/a/gm;
2539
2540         #Additional Turkish characters
2541         s/\x1b//gm;
2542         s/\x1e//gm;
2543         s/(\xf0)s/\xc5\x9f/gm;
2544         s/(\xf0)S/\xc5\x9e/gm;
2545         s/(\xf0)c/ç/gm;
2546         s/(\xf0)C/Ç/gm;
2547         s/\xe7\x49/\\xc4\xb0/gm;
2548         s/(\xe6)G/\xc4\x9e/gm;
2549         s/(\xe6)g/ğ\xc4\x9f/gm;
2550         s/\xB8/ı/gm;
2551         s/\xB9/£/gm;
2552         s/(\xe8|\xc8)o/ö/gm;
2553         s/(\xe8|\xc8)O/Ö/gm;
2554         s/(\xe8|\xc8)u/ü/gm;
2555         s/(\xe8|\xc8)U/Ü/gm;
2556         s/\xc2\xb8/\xc4\xb1/gm;
2557         s/¸/\xc4\xb1/gm;
2558
2559         # this handles non-sorting blocks (if implementation requires this)
2560         $string = nsb_clean($_);
2561     }
2562     return ($string);
2563 }
2564
2565 =head2 nsb_clean
2566
2567 =over 4
2568
2569 my $string = nsb_clean( $string, $encoding );
2570
2571 =back
2572
2573 =cut
2574
2575 sub nsb_clean {
2576     my $NSB      = '\x88';    # NSB : begin Non Sorting Block
2577     my $NSE      = '\x89';    # NSE : Non Sorting Block end
2578                               # handles non sorting blocks
2579     my ($string) = @_;
2580     $_ = $string;
2581     s/$NSB/(/gm;
2582     s/[ ]{0,1}$NSE/) /gm;
2583     $string = $_;
2584     return ($string);
2585 }
2586
2587 =head2 PrepareItemrecordDisplay
2588
2589 =over 4
2590
2591 PrepareItemrecordDisplay($itemrecord,$bibnum,$itemumber);
2592
2593 Returns a hash with all the fields for Display a given item data in a template
2594
2595 =back
2596
2597 =cut
2598
2599 sub PrepareItemrecordDisplay {
2600
2601     my ( $bibnum, $itemnum ) = @_;
2602
2603     my $dbh = C4::Context->dbh;
2604     my $frameworkcode = &GetFrameworkCode( $bibnum );
2605     my ( $itemtagfield, $itemtagsubfield ) =
2606       &GetMarcFromKohaField( "items.itemnumber", $frameworkcode );
2607     my $tagslib = &GetMarcStructure( 1, $frameworkcode );
2608     my $itemrecord = GetMarcItem( $bibnum, $itemnum) if ($itemnum);
2609     my @loop_data;
2610     my $authorised_values_sth =
2611       $dbh->prepare(
2612 "select authorised_value,lib from authorised_values where category=? order by lib"
2613       );
2614     foreach my $tag ( sort keys %{$tagslib} ) {
2615         my $previous_tag = '';
2616         if ( $tag ne '' ) {
2617             # loop through each subfield
2618             my $cntsubf;
2619             foreach my $subfield ( sort keys %{ $tagslib->{$tag} } ) {
2620                 next if ( subfield_is_koha_internal_p($subfield) );
2621                 next if ( $tagslib->{$tag}->{$subfield}->{'tab'} ne "10" );
2622                 my %subfield_data;
2623                 $subfield_data{tag}           = $tag;
2624                 $subfield_data{subfield}      = $subfield;
2625                 $subfield_data{countsubfield} = $cntsubf++;
2626                 $subfield_data{kohafield}     =
2627                   $tagslib->{$tag}->{$subfield}->{'kohafield'};
2628
2629          #        $subfield_data{marc_lib}=$tagslib->{$tag}->{$subfield}->{lib};
2630                 $subfield_data{marc_lib} =
2631                     "<span id=\"error\" title=\""
2632                   . $tagslib->{$tag}->{$subfield}->{lib} . "\">"
2633                   . substr( $tagslib->{$tag}->{$subfield}->{lib}, 0, 12 )
2634                   . "</span>";
2635                 $subfield_data{mandatory} =
2636                   $tagslib->{$tag}->{$subfield}->{mandatory};
2637                 $subfield_data{repeatable} =
2638                   $tagslib->{$tag}->{$subfield}->{repeatable};
2639                 $subfield_data{hidden} = "display:none"
2640                   if $tagslib->{$tag}->{$subfield}->{hidden};
2641                 my ( $x, $value );
2642                 ( $x, $value ) = _find_value( $tag, $subfield, $itemrecord )
2643                   if ($itemrecord);
2644                 $value =~ s/"/&quot;/g;
2645
2646                 # search for itemcallnumber if applicable
2647                 if ( $tagslib->{$tag}->{$subfield}->{kohafield} eq
2648                     'items.itemcallnumber'
2649                     && C4::Context->preference('itemcallnumber') )
2650                 {
2651                     my $CNtag =
2652                       substr( C4::Context->preference('itemcallnumber'), 0, 3 );
2653                     my $CNsubfield =
2654                       substr( C4::Context->preference('itemcallnumber'), 3, 1 );
2655                     my $temp = $itemrecord->field($CNtag) if ($itemrecord);
2656                     if ($temp) {
2657                         $value = $temp->subfield($CNsubfield);
2658                     }
2659                 }
2660                 if ( $tagslib->{$tag}->{$subfield}->{authorised_value} ) {
2661                     my @authorised_values;
2662                     my %authorised_lib;
2663
2664                     # builds list, depending on authorised value...
2665                     #---- branch
2666                     if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq
2667                         "branches" )
2668                     {
2669                         if ( ( C4::Context->preference("IndependantBranches") )
2670                             && ( C4::Context->userenv->{flags} != 1 ) )
2671                         {
2672                             my $sth =
2673                               $dbh->prepare(
2674 "select branchcode,branchname from branches where branchcode = ? order by branchname"
2675                               );
2676                             $sth->execute( C4::Context->userenv->{branch} );
2677                             push @authorised_values, ""
2678                               unless (
2679                                 $tagslib->{$tag}->{$subfield}->{mandatory} );
2680                             while ( my ( $branchcode, $branchname ) =
2681                                 $sth->fetchrow_array )
2682                             {
2683                                 push @authorised_values, $branchcode;
2684                                 $authorised_lib{$branchcode} = $branchname;
2685                             }
2686                         }
2687                         else {
2688                             my $sth =
2689                               $dbh->prepare(
2690 "select branchcode,branchname from branches order by branchname"
2691                               );
2692                             $sth->execute;
2693                             push @authorised_values, ""
2694                               unless (
2695                                 $tagslib->{$tag}->{$subfield}->{mandatory} );
2696                             while ( my ( $branchcode, $branchname ) =
2697                                 $sth->fetchrow_array )
2698                             {
2699                                 push @authorised_values, $branchcode;
2700                                 $authorised_lib{$branchcode} = $branchname;
2701                             }
2702                         }
2703
2704                         #----- itemtypes
2705                     }
2706                     elsif ( $tagslib->{$tag}->{$subfield}->{authorised_value} eq
2707                         "itemtypes" )
2708                     {
2709                         my $sth =
2710                           $dbh->prepare(
2711 "select itemtype,description from itemtypes order by description"
2712                           );
2713                         $sth->execute;
2714                         push @authorised_values, ""
2715                           unless ( $tagslib->{$tag}->{$subfield}->{mandatory} );
2716                         while ( my ( $itemtype, $description ) =
2717                             $sth->fetchrow_array )
2718                         {
2719                             push @authorised_values, $itemtype;
2720                             $authorised_lib{$itemtype} = $description;
2721                         }
2722
2723                         #---- "true" authorised value
2724                     }
2725                     else {
2726                         $authorised_values_sth->execute(
2727                             $tagslib->{$tag}->{$subfield}->{authorised_value} );
2728                         push @authorised_values, ""
2729                           unless ( $tagslib->{$tag}->{$subfield}->{mandatory} );
2730                         while ( my ( $value, $lib ) =
2731                             $authorised_values_sth->fetchrow_array )
2732                         {
2733                             push @authorised_values, $value;
2734                             $authorised_lib{$value} = $lib;
2735                         }
2736                     }
2737                     $subfield_data{marc_value} = CGI::scrolling_list(
2738                         -name     => 'field_value',
2739                         -values   => \@authorised_values,
2740                         -default  => "$value",
2741                         -labels   => \%authorised_lib,
2742                         -size     => 1,
2743                         -tabindex => '',
2744                         -multiple => 0,
2745                     );
2746                 }
2747                 elsif ( $tagslib->{$tag}->{$subfield}->{thesaurus_category} ) {
2748                     $subfield_data{marc_value} =
2749 "<input type=\"text\" name=\"field_value\"  size=47 maxlength=255> <a href=\"javascript:Dopop('cataloguing/thesaurus_popup.pl?category=$tagslib->{$tag}->{$subfield}->{thesaurus_category}&index=',)\">...</a>";
2750
2751 #"
2752 # COMMENTED OUT because No $i is provided with this API.
2753 # And thus, no value_builder can be activated.
2754 # BUT could be thought over.
2755 #         } elsif ($tagslib->{$tag}->{$subfield}->{'value_builder'}) {
2756 #             my $plugin="value_builder/".$tagslib->{$tag}->{$subfield}->{'value_builder'};
2757 #             require $plugin;
2758 #             my $extended_param = plugin_parameters($dbh,$itemrecord,$tagslib,$i,0);
2759 #             my ($function_name,$javascript) = plugin_javascript($dbh,$record,$tagslib,$i,0);
2760 #             $subfield_data{marc_value}="<input type=\"text\" value=\"$value\" name=\"field_value\"  size=47 maxlength=255 DISABLE READONLY OnFocus=\"javascript:Focus$function_name()\" OnBlur=\"javascript:Blur$function_name()\"> <a href=\"javascript:Clic$function_name()\">...</a> $javascript";
2761                 }
2762                 else {
2763                     $subfield_data{marc_value} =
2764 "<input type=\"text\" name=\"field_value\" value=\"$value\" size=50 maxlength=255>";
2765                 }
2766                 push( @loop_data, \%subfield_data );
2767             }
2768         }
2769     }
2770     my $itemnumber = $itemrecord->subfield( $itemtagfield, $itemtagsubfield )
2771       if ( $itemrecord && $itemrecord->field($itemtagfield) );
2772     return {
2773         'itemtagfield'    => $itemtagfield,
2774         'itemtagsubfield' => $itemtagsubfield,
2775         'itemnumber'      => $itemnumber,
2776         'iteminformation' => \@loop_data
2777     };
2778 }
2779 #"
2780
2781 #
2782 # true ModZebra commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
2783 # at the same time
2784 # replaced by a zebraqueue table, that is filled with ModZebra to run.
2785 # the table is emptied by misc/cronjobs/zebraqueue_start.pl script
2786 # =head2 ModZebrafiles
2787 #
2788 # &ModZebrafiles( $dbh, $biblionumber, $record, $folder, $server );
2789 #
2790 # =cut
2791 #
2792 # sub ModZebrafiles {
2793 #
2794 #     my ( $dbh, $biblionumber, $record, $folder, $server ) = @_;
2795 #
2796 #     my $op;
2797 #     my $zebradir =
2798 #       C4::Context->zebraconfig($server)->{directory} . "/" . $folder . "/";
2799 #     unless ( opendir( DIR, "$zebradir" ) ) {
2800 #         warn "$zebradir not found";
2801 #         return;
2802 #     }
2803 #     closedir DIR;
2804 #     my $filename = $zebradir . $biblionumber;
2805 #
2806 #     if ($record) {
2807 #         open( OUTPUT, ">", $filename . ".xml" );
2808 #         print OUTPUT $record;
2809 #         close OUTPUT;
2810 #     }
2811 # }
2812
2813 =head2 ModZebra
2814
2815 =over 4
2816
2817 ModZebra( $biblionumber, $op, $server, $newRecord );
2818
2819     $biblionumber is the biblionumber we want to index
2820     $op is specialUpdate or delete, and is used to know what we want to do
2821     $server is the server that we want to update
2822     $newRecord is the MARC::Record containing the new record. It is usefull only when NoZebra=1, and is used to know what to add to the nozebra database. (the record in mySQL being, if it exist, the previous record, the one just before the modif. We need both : the previous and the new one.
2823
2824 =back
2825
2826 =cut
2827
2828 sub ModZebra {
2829 ###Accepts a $server variable thus we can use it for biblios authorities or other zebra dbs
2830     my ( $biblionumber, $op, $server, $newRecord ) = @_;
2831     my $dbh=C4::Context->dbh;
2832
2833     # true ModZebra commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
2834     # at the same time
2835     # replaced by a zebraqueue table, that is filled with ModZebra to run.
2836     # the table is emptied by misc/cronjobs/zebraqueue_start.pl script
2837
2838     if (C4::Context->preference("NoZebra")) {
2839         # lock the nozebra table : we will read index lines, update them in Perl process
2840         # and write everything in 1 transaction.
2841         # lock the table to avoid someone else overwriting what we are doing
2842         $dbh->do('LOCK TABLES nozebra WRITE,biblio WRITE,biblioitems WRITE, systempreferences WRITE, auth_types WRITE, auth_header WRITE');
2843         my %result; # the result hash that will be builded by deletion / add, and written on mySQL at the end, to improve speed
2844         my $record;
2845         if ($server eq 'biblioserver') {
2846             $record= GetMarcBiblio($biblionumber);
2847         } else {
2848             $record= C4::AuthoritiesMarc::GetAuthority($biblionumber);
2849         }
2850         if ($op eq 'specialUpdate') {
2851             # OK, we have to add or update the record
2852             # 1st delete (virtually, in indexes) ...
2853             %result = _DelBiblioNoZebra($biblionumber,$record,$server);
2854             # ... add the record
2855             %result=_AddBiblioNoZebra($biblionumber,$newRecord, $server, %result);
2856         } else {
2857             # it's a deletion, delete the record...
2858             # warn "DELETE the record $biblionumber on $server".$record->as_formatted;
2859             %result=_DelBiblioNoZebra($biblionumber,$record,$server);
2860         }
2861         # ok, now update the database...
2862         my $sth = $dbh->prepare("UPDATE nozebra SET biblionumbers=? WHERE server=? AND indexname=? AND value=?");
2863         foreach my $key (keys %result) {
2864             foreach my $index (keys %{$result{$key}}) {
2865                 $sth->execute($result{$key}->{$index}, $server, $key, $index);
2866             }
2867         }
2868         $dbh->do('UNLOCK TABLES');
2869
2870     } else {
2871         #
2872         # we use zebra, just fill zebraqueue table
2873         #
2874         my $sth=$dbh->prepare("insert into zebraqueue  (biblio_auth_number ,server,operation) values(?,?,?)");
2875         $sth->execute($biblionumber,$server,$op);
2876         $sth->finish;
2877     }
2878 }
2879
2880 =head2 GetNoZebraIndexes
2881
2882     %indexes = GetNoZebraIndexes;
2883
2884     return the data from NoZebraIndexes syspref.
2885
2886 =cut
2887
2888 sub GetNoZebraIndexes {
2889     my $index = C4::Context->preference('NoZebraIndexes');
2890     my %indexes;
2891     foreach my $line (split /('|"),/,$index) {
2892         $line =~ /(.*)=>(.*)/;
2893         my $index = substr($1,1); # get the index, don't forget to remove initial ' or "
2894         my $fields = $2;
2895         $index =~ s/'|"| //g;
2896         $fields =~ s/'|"| //g;
2897         $indexes{$index}=$fields;
2898     }
2899     return %indexes;
2900 }
2901
2902 =head1 INTERNAL FUNCTIONS
2903
2904 =head2 _DelBiblioNoZebra($biblionumber,$record,$server);
2905
2906     function to delete a biblio in NoZebra indexes
2907     This function does NOT delete anything in database : it reads all the indexes entries
2908     that have to be deleted & delete them in the hash
2909     The SQL part is done either :
2910     - after the Add if we are modifying a biblio (delete + add again)
2911     - immediatly after this sub if we are doing a true deletion.
2912     $server can be 'biblioserver' or 'authorityserver' : it indexes biblios or authorities (in the same table, $server being part of the table itself
2913
2914 =cut
2915
2916
2917 sub _DelBiblioNoZebra {
2918     my ($biblionumber, $record, $server)=@_;
2919
2920     # Get the indexes
2921     my $dbh = C4::Context->dbh;
2922     # Get the indexes
2923     my %index;
2924     my $title;
2925     if ($server eq 'biblioserver') {
2926         %index=GetNoZebraIndexes;
2927         # get title of the record (to store the 10 first letters with the index)
2928         my ($titletag,$titlesubfield) = GetMarcFromKohaField('biblio.title');
2929         $title = lc($record->subfield($titletag,$titlesubfield));
2930     } else {
2931         # for authorities, the "title" is the $a mainentry
2932         my $authref = C4::AuthoritiesMarc::GetAuthType($record->subfield(152,'b'));
2933         warn "ERROR : authtype undefined for ".$record->as_formatted unless $authref;
2934         $title = $record->subfield($authref->{auth_tag_to_report},'a');
2935         $index{'mainmainentry'}= $authref->{'auth_tag_to_report'}.'a';
2936         $index{'mainentry'}    = $authref->{'auth_tag_to_report'}.'*';
2937         $index{'auth_type'}    = '152b';
2938     }
2939
2940     my %result;
2941     # remove blancks comma (that could cause problem when decoding the string for CQL retrieval) and regexp specific values
2942     $title =~ s/ |,|;|\[|\]|\(|\)|\*|-|'|=//g;
2943     # limit to 10 char, should be enough, and limit the DB size
2944     $title = substr($title,0,10);
2945     #parse each field
2946     my $sth2=$dbh->prepare('SELECT biblionumbers FROM nozebra WHERE server=? AND indexname=? AND value=?');
2947     foreach my $field ($record->fields()) {
2948         #parse each subfield
2949         next if $field->tag <10;
2950         foreach my $subfield ($field->subfields()) {
2951             my $tag = $field->tag();
2952             my $subfieldcode = $subfield->[0];
2953             my $indexed=0;
2954             # check each index to see if the subfield is stored somewhere
2955             # otherwise, store it in __RAW__ index
2956             foreach my $key (keys %index) {
2957 #                 warn "examining $key index : ".$index{$key}." for $tag $subfieldcode";
2958                 if ($index{$key} =~ /$tag\*/ or $index{$key} =~ /$tag$subfieldcode/) {
2959                     $indexed=1;
2960                     my $line= lc $subfield->[1];
2961                     # remove meaningless value in the field...
2962                     $line =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|<|>|&|\+|\*|\/|=|:/ /g;
2963                     # ... and split in words
2964                     foreach (split / /,$line) {
2965                         next unless $_; # skip  empty values (multiple spaces)
2966                         # if the entry is already here, do nothing, the biblionumber has already be removed
2967                         unless ($result{$key}->{$_} =~ /$biblionumber,$title\-(\d);/) {
2968                             # get the index value if it exist in the nozebra table and remove the entry, otherwise, do nothing
2969                             $sth2->execute($server,$key,$_);
2970                             my $existing_biblionumbers = $sth2->fetchrow;
2971                             # it exists
2972                             if ($existing_biblionumbers) {
2973 #                                 warn " existing for $key $_: $existing_biblionumbers";
2974                                 $result{$key}->{$_} =$existing_biblionumbers;
2975                                 $result{$key}->{$_} =~ s/$biblionumber,$title\-(\d);//;
2976                             }
2977                         }
2978                     }
2979                 }
2980             }
2981             # the subfield is not indexed, store it in __RAW__ index anyway
2982             unless ($indexed) {
2983                 my $line= lc $subfield->[1];
2984                 $line =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|<|>|&|\+|\*|\/|=|:/ /g;
2985                 # ... and split in words
2986                 foreach (split / /,$line) {
2987                     next unless $_; # skip  empty values (multiple spaces)
2988                     # if the entry is already here, do nothing, the biblionumber has already be removed
2989                     unless ($result{'__RAW__'}->{$_} =~ /$biblionumber,$title\-(\d);/) {
2990                         # get the index value if it exist in the nozebra table and remove the entry, otherwise, do nothing
2991                         $sth2->execute($server,'__RAW__',$_);
2992                         my $existing_biblionumbers = $sth2->fetchrow;
2993                         # it exists
2994                         if ($existing_biblionumbers) {
2995                             $result{'__RAW__'}->{$_} =$existing_biblionumbers;
2996                             $result{'__RAW__'}->{$_} =~ s/$biblionumber,$title\-(\d);//;
2997                         }
2998                     }
2999                 }
3000             }
3001         }
3002     }
3003     return %result;
3004 }
3005
3006 =head2 _AddBiblioNoZebra($biblionumber, $record, $server, %result);
3007
3008     function to add a biblio in NoZebra indexes
3009
3010 =cut
3011
3012 sub _AddBiblioNoZebra {
3013     my ($biblionumber, $record, $server, %result)=@_;
3014     my $dbh = C4::Context->dbh;
3015     # Get the indexes
3016     my %index;
3017     my $title;
3018     if ($server eq 'biblioserver') {
3019         %index=GetNoZebraIndexes;
3020         # get title of the record (to store the 10 first letters with the index)
3021         my ($titletag,$titlesubfield) = GetMarcFromKohaField('biblio.title');
3022         $title = lc($record->subfield($titletag,$titlesubfield));
3023     } else {
3024         # warn "server : $server";
3025         # for authorities, the "title" is the $a mainentry
3026         my $authref = C4::AuthoritiesMarc::GetAuthType($record->subfield(152,'b'));
3027         warn "ERROR : authtype undefined for ".$record->as_formatted unless $authref;
3028         $title = $record->subfield($authref->{auth_tag_to_report},'a');
3029         $index{'mainmainentry'} = $authref->{auth_tag_to_report}.'a';
3030         $index{'mainentry'}     = $authref->{auth_tag_to_report}.'*';
3031         $index{'auth_type'}     = '152b';
3032     }
3033
3034     # remove blancks comma (that could cause problem when decoding the string for CQL retrieval) and regexp specific values
3035     $title =~ s/ |,|;|\[|\]|\(|\)|\*|-|'|=//g;
3036     # limit to 10 char, should be enough, and limit the DB size
3037     $title = substr($title,0,10);
3038     #parse each field
3039     my $sth2=$dbh->prepare('SELECT biblionumbers FROM nozebra WHERE server=? AND indexname=? AND value=?');
3040     foreach my $field ($record->fields()) {
3041         #parse each subfield
3042         next if $field->tag <10;
3043         foreach my $subfield ($field->subfields()) {
3044             my $tag = $field->tag();
3045             my $subfieldcode = $subfield->[0];
3046             my $indexed=0;
3047             # check each index to see if the subfield is stored somewhere
3048             # otherwise, store it in __RAW__ index
3049             foreach my $key (keys %index) {
3050 #                 warn "examining $key index : ".$index{$key}." for $tag $subfieldcode";
3051                 if ($index{$key} =~ /$tag\*/ or $index{$key} =~ /$tag$subfieldcode/) {
3052                     $indexed=1;
3053                     my $line= lc $subfield->[1];
3054                     # remove meaningless value in the field...
3055                     $line =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|<|>|&|\+|\*|\/|=|:/ /g;
3056                     # ... and split in words
3057                     foreach (split / /,$line) {
3058                         next unless $_; # skip  empty values (multiple spaces)
3059                         # if the entry is already here, improve weight
3060 #                         warn "managing $_";
3061                         if ($result{$key}->{$_} =~ /$biblionumber,$title\-(\d);/) {
3062                             my $weight=$1+1;
3063                             $result{$key}->{$_} =~ s/$biblionumber,$title\-(\d);//;
3064                             $result{$key}->{$_} .= "$biblionumber,$title-$weight;";
3065                         } else {
3066                             # get the value if it exist in the nozebra table, otherwise, create it
3067                             $sth2->execute($server,$key,$_);
3068                             my $existing_biblionumbers = $sth2->fetchrow;
3069                             # it exists
3070                             if ($existing_biblionumbers) {
3071                                 $result{$key}->{$_} =$existing_biblionumbers;
3072                                 my $weight=$1+1;
3073                                 $result{$key}->{$_} =~ s/$biblionumber,$title\-(\d);//;
3074                                 $result{$key}->{$_} .= "$biblionumber,$title-$weight;";
3075                             # create a new ligne for this entry
3076                             } else {
3077 #                             warn "INSERT : $server / $key / $_";
3078                                 $dbh->do('INSERT INTO nozebra SET server='.$dbh->quote($server).', indexname='.$dbh->quote($key).',value='.$dbh->quote($_));
3079                                 $result{$key}->{$_}.="$biblionumber,$title-1;";
3080                             }
3081                         }
3082                     }
3083                 }
3084             }
3085             # the subfield is not indexed, store it in __RAW__ index anyway
3086             unless ($indexed) {
3087                 my $line= lc $subfield->[1];
3088                 $line =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|<|>|&|\+|\*|\/|=|:/ /g;
3089                 # ... and split in words
3090                 foreach (split / /,$line) {
3091                     next unless $_; # skip  empty values (multiple spaces)
3092                     # if the entry is already here, improve weight
3093                     if ($result{'__RAW__'}->{$_} =~ /$biblionumber,$title\-(\d);/) {
3094                         my $weight=$1+1;
3095                         $result{'__RAW__'}->{$_} =~ s/$biblionumber,$title\-(\d);//;
3096                         $result{'__RAW__'}->{$_} .= "$biblionumber,$title-$weight;";
3097                     } else {
3098                         # get the value if it exist in the nozebra table, otherwise, create it
3099                         $sth2->execute($server,'__RAW__',$_);
3100                         my $existing_biblionumbers = $sth2->fetchrow;
3101                         # it exists
3102                         if ($existing_biblionumbers) {
3103                             $result{'__RAW__'}->{$_} =$existing_biblionumbers;
3104                             my $weight=$1+1;
3105                             $result{'__RAW__'}->{$_} =~ s/$biblionumber,$title\-(\d);//;
3106                             $result{'__RAW__'}->{$_} .= "$biblionumber,$title-$weight;";
3107                         # create a new ligne for this entry
3108                         } else {
3109                             $dbh->do('INSERT INTO nozebra SET server='.$dbh->quote($server).',  indexname="__RAW__",value='.$dbh->quote($_));
3110                             $result{'__RAW__'}->{$_}.="$biblionumber,$title-1;";
3111                         }
3112                     }
3113                 }
3114             }
3115         }
3116     }
3117     return %result;
3118 }
3119
3120
3121 =head2 MARCitemchange
3122
3123 =over 4
3124
3125 &MARCitemchange( $record, $itemfield, $newvalue )
3126
3127 Function to update a single value in an item field.
3128 Used twice, could probably be replaced by something else, but works well...
3129
3130 =back
3131
3132 =back
3133
3134 =cut
3135
3136 sub MARCitemchange {
3137     my ( $record, $itemfield, $newvalue ) = @_;
3138     my $dbh = C4::Context->dbh;
3139
3140     my ( $tagfield, $tagsubfield ) =
3141       GetMarcFromKohaField( $itemfield, "" );
3142     if ( ($tagfield) && ($tagsubfield) ) {
3143         my $tag = $record->field($tagfield);
3144         if ($tag) {
3145             $tag->update( $tagsubfield => $newvalue );
3146             $record->delete_field($tag);
3147             $record->insert_fields_ordered($tag);
3148         }
3149     }
3150 }
3151
3152 =head2 _koha_add_biblio
3153
3154 =over 4
3155
3156 _koha_add_biblio($dbh,$biblioitem);
3157
3158 Internal function to add a biblio ($biblio is a hash with the values)
3159
3160 =back
3161
3162 =cut
3163
3164 sub _koha_add_biblio {
3165     my ( $dbh, $biblio, $frameworkcode ) = @_;
3166     my $sth = $dbh->prepare("Select max(biblionumber) from biblio");
3167     $sth->execute;
3168     my $data         = $sth->fetchrow_arrayref;
3169     my $biblionumber = $$data[0] + 1;
3170     my $series       = 0;
3171
3172     if ( $biblio->{'seriestitle'} ) { $series = 1 }
3173     $sth->finish;
3174     $sth = $dbh->prepare(
3175         "INSERT INTO biblio
3176     SET biblionumber  = ?, title = ?, author = ?, copyrightdate = ?, serial = ?, seriestitle = ?, notes = ?, abstract = ?, unititle = ?, frameworkcode = ? "
3177     );
3178     $sth->execute(
3179         $biblionumber,         $biblio->{'title'},
3180         $biblio->{'author'},   $biblio->{'copyrightdate'},
3181         $biblio->{'serial'},   $biblio->{'seriestitle'},
3182         $biblio->{'notes'},    $biblio->{'abstract'},
3183         $biblio->{'unititle'}, $frameworkcode
3184     );
3185
3186     $sth->finish;
3187     return ($biblionumber);
3188 }
3189
3190 =head2 _find_value
3191
3192 =over 4
3193
3194 ($indicators, $value) = _find_value($tag, $subfield, $record,$encoding);
3195
3196 Find the given $subfield in the given $tag in the given
3197 MARC::Record $record.  If the subfield is found, returns
3198 the (indicators, value) pair; otherwise, (undef, undef) is
3199 returned.
3200
3201 PROPOSITION :
3202 Such a function is used in addbiblio AND additem and serial-edit and maybe could be used in Authorities.
3203 I suggest we export it from this module.
3204
3205 =back
3206
3207 =cut
3208
3209 sub _find_value {
3210     my ( $tagfield, $insubfield, $record, $encoding ) = @_;
3211     my @result;
3212     my $indicator;
3213     if ( $tagfield < 10 ) {
3214         if ( $record->field($tagfield) ) {
3215             push @result, $record->field($tagfield)->data();
3216         }
3217         else {
3218             push @result, "";
3219         }
3220     }
3221     else {
3222         foreach my $field ( $record->field($tagfield) ) {
3223             my @subfields = $field->subfields();
3224             foreach my $subfield (@subfields) {
3225                 if ( @$subfield[0] eq $insubfield ) {
3226                     push @result, @$subfield[1];
3227                     $indicator = $field->indicator(1) . $field->indicator(2);
3228                 }
3229             }
3230         }
3231     }
3232     return ( $indicator, @result );
3233 }
3234
3235 =head2 _koha_modify_biblio
3236
3237 =over 4
3238
3239 $biblionumber = _koha_modify_biblio($dbh,$biblio);
3240 Internal function for updating the biblio table
3241
3242 =back
3243
3244 =cut
3245
3246 sub _koha_modify_biblio {
3247     my ( $dbh, $biblio ) = @_;
3248     # FIXME: this code could be made more portable by not hard-coding
3249     #        the values that are supposed to be in biblio table
3250     my $query = qq{
3251         UPDATE biblio
3252         SET    title = ?,
3253                author = ?,
3254                abstract = ?,
3255                copyrightdate = ?,
3256                seriestitle = ?,
3257                serial = ?,
3258                unititle = ?,
3259                notes = ?
3260         WHERE  biblionumber = ?
3261     };
3262     my $sth = $dbh->prepare($query);
3263
3264     $sth->execute(
3265         $biblio->{'title'},
3266         $biblio->{'author'},
3267         $biblio->{'abstract'},
3268         $biblio->{'copyrightdate'},
3269         $biblio->{'seriestitle'},
3270         $biblio->{'serial'},
3271         $biblio->{'unititle'},
3272         $biblio->{'notes'},
3273         $biblio->{'biblionumber'}
3274     ) if $biblio->{'biblionumber'};
3275
3276     warn $sth->err if $sth->err;
3277     warn "BIG ERROR :: No biblionumber for $biblio->{title}" if $biblio->{biblionumber} !~ /\d+/; # if it is not a number
3278     return ( $biblio->{'biblionumber'} );
3279 }
3280
3281 =head2 _koha_modify_biblioitem
3282
3283 =over 4
3284
3285 _koha_modify_biblioitem( $dbh, $biblioitem );
3286
3287 =back
3288
3289 =cut
3290
3291 sub _koha_modify_biblioitem {
3292     my ( $dbh, $biblioitem ) = @_;
3293     my $query;
3294 ##Recalculate LC in case it changed --TG
3295
3296     $biblioitem->{'itemtype'}      = $dbh->quote( $biblioitem->{'itemtype'} );
3297     $biblioitem->{'url'}           = $dbh->quote( $biblioitem->{'url'} );
3298     $biblioitem->{'isbn'}          = $dbh->quote( $biblioitem->{'isbn'} );
3299     $biblioitem->{'issn'}          = $dbh->quote( $biblioitem->{'issn'} );
3300     $biblioitem->{'publishercode'} =
3301       $dbh->quote( $biblioitem->{'publishercode'} );
3302     $biblioitem->{'publicationyear'} =
3303       $dbh->quote( $biblioitem->{'publicationyear'} );
3304     $biblioitem->{'classification'} =
3305       $dbh->quote( $biblioitem->{'classification'} );
3306     $biblioitem->{'dewey'}        = $dbh->quote( $biblioitem->{'dewey'} );
3307     $biblioitem->{'subclass'}     = $dbh->quote( $biblioitem->{'subclass'} );
3308     $biblioitem->{'illus'}        = $dbh->quote( $biblioitem->{'illus'} );
3309     $biblioitem->{'pages'}        = $dbh->quote( $biblioitem->{'pages'} );
3310     $biblioitem->{'volumeddesc'}  = $dbh->quote( $biblioitem->{'volumeddesc'} );
3311     $biblioitem->{'bnotes'}       = $dbh->quote( $biblioitem->{'bnotes'} );
3312     $biblioitem->{'size'}         = $dbh->quote( $biblioitem->{'size'} );
3313     $biblioitem->{'place'}        = $dbh->quote( $biblioitem->{'place'} );
3314     $biblioitem->{'ccode'}        = $dbh->quote( $biblioitem->{'ccode'} );
3315     $biblioitem->{'biblionumber'} =
3316       $dbh->quote( $biblioitem->{'biblionumber'} );
3317
3318     $query = "Update biblioitems set
3319         itemtype        = $biblioitem->{'itemtype'},
3320         url             = $biblioitem->{'url'},
3321         isbn            = $biblioitem->{'isbn'},
3322         issn            = $biblioitem->{'issn'},
3323         publishercode   = $biblioitem->{'publishercode'},
3324         publicationyear = $biblioitem->{'publicationyear'},
3325         classification  = $biblioitem->{'classification'},
3326         dewey           = $biblioitem->{'dewey'},
3327         subclass        = $biblioitem->{'subclass'},
3328         illus           = $biblioitem->{'illus'},
3329         pages           = $biblioitem->{'pages'},
3330         volumeddesc     = $biblioitem->{'volumeddesc'},
3331         notes           = $biblioitem->{'bnotes'},
3332         size            = $biblioitem->{'size'},
3333         place           = $biblioitem->{'place'},
3334         ccode           = $biblioitem->{'ccode'}
3335         where biblionumber = $biblioitem->{'biblionumber'}";
3336
3337     $dbh->do($query);
3338     if ( $dbh->errstr ) {
3339         warn "ERROR in _koha_modify_biblioitem $query";
3340     }
3341 }
3342
3343 =head2 _koha_add_biblioitem
3344
3345 =over 4
3346
3347 _koha_add_biblioitem( $dbh, $biblioitem );
3348
3349 Internal function to add a biblioitem
3350
3351 =back
3352
3353 =cut
3354
3355 sub _koha_add_biblioitem {
3356     my ( $dbh, $biblioitem ) = @_;
3357
3358     #  my $dbh   = C4Connect;
3359     my $sth = $dbh->prepare("SELECT max(biblioitemnumber) FROM biblioitems");
3360     my $data;
3361     my $bibitemnum;
3362
3363     $sth->execute;
3364     $data       = $sth->fetchrow_arrayref;
3365     $bibitemnum = $$data[0] + 1;
3366
3367     $sth->finish;
3368
3369     $sth = $dbh->prepare(
3370         "INSERT INTO biblioitems SET
3371             biblioitemnumber = ?, biblionumber    = ?,
3372             volume           = ?, number          = ?,
3373             classification   = ?, itemtype        = ?,
3374             url              = ?, isbn            = ?,
3375             issn             = ?, dewey           = ?,
3376             subclass         = ?, publicationyear = ?,
3377             publishercode    = ?, volumedate      = ?,
3378             volumeddesc      = ?, illus           = ?,
3379             pages            = ?, notes           = ?,
3380             size             = ?, lccn            = ?,
3381             marc             = ?, lcsort          =?,
3382             place            = ?, ccode           = ?
3383           "
3384     );
3385     my ($lcsort) =
3386       calculatelc( $biblioitem->{'classification'} )
3387       . $biblioitem->{'subclass'};
3388     $sth->execute(
3389         $bibitemnum,                     $biblioitem->{'biblionumber'},
3390         $biblioitem->{'volume'},         $biblioitem->{'number'},
3391         $biblioitem->{'classification'}, $biblioitem->{'itemtype'},
3392         $biblioitem->{'url'},            $biblioitem->{'isbn'},
3393         $biblioitem->{'issn'},           $biblioitem->{'dewey'},
3394         $biblioitem->{'subclass'},       $biblioitem->{'publicationyear'},
3395         $biblioitem->{'publishercode'},  $biblioitem->{'volumedate'},
3396         $biblioitem->{'volumeddesc'},    $biblioitem->{'illus'},
3397         $biblioitem->{'pages'},          $biblioitem->{'bnotes'},
3398         $biblioitem->{'size'},           $biblioitem->{'lccn'},
3399         $biblioitem->{'marc'},           $biblioitem->{'place'},
3400         $lcsort,                         $biblioitem->{'ccode'}
3401     );
3402     $sth->finish;
3403     return ($bibitemnum);
3404 }
3405
3406 =head2 _koha_new_items
3407
3408 =over 4
3409
3410 _koha_new_items( $dbh, $item, $barcode );
3411
3412 =back
3413
3414 =cut
3415
3416 sub _koha_new_items {
3417     my ( $dbh, $item, $barcode ) = @_;
3418
3419     #  my $dbh   = C4Connect;
3420     my $sth = $dbh->prepare("Select max(itemnumber) from items");
3421     my $data;
3422     my $itemnumber;
3423     my $error = "";
3424
3425     $sth->execute;
3426     $data       = $sth->fetchrow_hashref;
3427     $itemnumber = $data->{'max(itemnumber)'} + 1;
3428     $sth->finish;
3429 ## Now calculate lccalnumber
3430     my ($cutterextra) = itemcalculator(
3431         $dbh,
3432         $item->{'biblioitemnumber'},
3433         $item->{'itemcallnumber'}
3434     );
3435
3436 # FIXME the "notforloan" field seems to be named "loan" in some places. workaround bugfix.
3437     if ( $item->{'loan'} ) {
3438         $item->{'notforloan'} = $item->{'loan'};
3439     }
3440
3441     # if dateaccessioned is provided, use it. Otherwise, set to NOW()
3442     if ( $item->{'dateaccessioned'} eq '' || !$item->{'dateaccessioned'} ) {
3443
3444         $sth = $dbh->prepare(
3445             "Insert into items set
3446             itemnumber           = ?,     biblionumber     = ?,
3447             multivolumepart      = ?,
3448             biblioitemnumber     = ?,     barcode          = ?,
3449             booksellerid         = ?,     dateaccessioned  = NOW(),
3450             homebranch           = ?,     holdingbranch    = ?,
3451             price                = ?,     replacementprice = ?,
3452             replacementpricedate = NOW(), datelastseen     = NOW(),
3453             multivolume          = ?,     stack            = ?,
3454             itemlost             = ?,     wthdrawn         = ?,
3455             paidfor              = ?,     itemnotes        = ?,
3456             itemcallnumber       =?,      notforloan       = ?,
3457             location             = ?,     Cutterextra      = ?
3458           "
3459         );
3460         $sth->execute(
3461             $itemnumber,                $item->{'biblionumber'},
3462             $item->{'multivolumepart'}, $item->{'biblioitemnumber'},
3463             $barcode,                   $item->{'booksellerid'},
3464             $item->{'homebranch'},      $item->{'holdingbranch'},
3465             $item->{'price'},           $item->{'replacementprice'},
3466             $item->{multivolume},       $item->{stack},
3467             $item->{itemlost},          $item->{wthdrawn},
3468             $item->{paidfor},           $item->{'itemnotes'},
3469             $item->{'itemcallnumber'},  $item->{'notforloan'},
3470             $item->{'location'},        $cutterextra
3471         );
3472     }
3473     else {
3474         $sth = $dbh->prepare(
3475             "INSERT INTO items SET
3476             itemnumber           = ?,     biblionumber     = ?,
3477             multivolumepart      = ?,
3478             biblioitemnumber     = ?,     barcode          = ?,
3479             booksellerid         = ?,     dateaccessioned  = ?,
3480             homebranch           = ?,     holdingbranch    = ?,
3481             price                = ?,     replacementprice = ?,
3482             replacementpricedate = NOW(), datelastseen     = NOW(),
3483             multivolume          = ?,     stack            = ?,
3484             itemlost             = ?,     wthdrawn         = ?,
3485             paidfor              = ?,     itemnotes        = ?,
3486             itemcallnumber       = ?,     notforloan       = ?,
3487             location             = ?,
3488             Cutterextra          = ?
3489                             "
3490         );
3491         $sth->execute(
3492             $itemnumber,                 $item->{'biblionumber'},
3493             $item->{'multivolumepart'},  $item->{'biblioitemnumber'},
3494             $barcode,                    $item->{'booksellerid'},
3495             $item->{'dateaccessioned'},  $item->{'homebranch'},
3496             $item->{'holdingbranch'},    $item->{'price'},
3497             $item->{'replacementprice'}, $item->{multivolume},
3498             $item->{stack},              $item->{itemlost},
3499             $item->{wthdrawn},           $item->{paidfor},
3500             $item->{'itemnotes'},        $item->{'itemcallnumber'},
3501             $item->{'notforloan'},       $item->{'location'},
3502             $cutterextra
3503         );
3504     }
3505     if ( defined $sth->errstr ) {
3506         $error .= $sth->errstr;
3507     }
3508     return ( $itemnumber, $error );
3509 }
3510
3511 =head2 _koha_modify_item
3512
3513 =over 4
3514
3515 _koha_modify_item( $dbh, $item, $op );
3516
3517 =back
3518
3519 =cut
3520
3521 sub _koha_modify_item {
3522     my ( $dbh, $item, $op ) = @_;
3523     $item->{'itemnum'} = $item->{'itemnumber'} unless $item->{'itemnum'};
3524
3525     # if all we're doing is setting statuses, just update those and get out
3526     if ( $op eq "setstatus" ) {
3527         my $query =
3528           "UPDATE items SET itemlost=?,wthdrawn=?,binding=? WHERE itemnumber=?";
3529         my @bind = (
3530             $item->{'itemlost'}, $item->{'wthdrawn'},
3531             $item->{'binding'},  $item->{'itemnumber'}
3532         );
3533         my $sth = $dbh->prepare($query);
3534         $sth->execute(@bind);
3535         $sth->finish;
3536         return undef;
3537     }
3538 ## Now calculate lccalnumber
3539     my ($cutterextra) =
3540       itemcalculator( $dbh, $item->{'bibitemnum'}, $item->{'itemcallnumber'} );
3541
3542     my $query = "UPDATE items SET
3543 barcode=?,itemnotes=?,itemcallnumber=?,notforloan=?,location=?,multivolumepart=?,multivolume=?,stack=?,wthdrawn=?,holdingbranch=?,homebranch=?,cutterextra=?, onloan=?, binding=?";
3544
3545     my @bind = (
3546         $item->{'barcode'},        $item->{'notes'},
3547         $item->{'itemcallnumber'}, $item->{'notforloan'},
3548         $item->{'location'},       $item->{multivolumepart},
3549         $item->{multivolume},      $item->{stack},
3550         $item->{wthdrawn},         $item->{holdingbranch},
3551         $item->{homebranch},       $cutterextra,
3552         $item->{onloan},           $item->{binding}
3553     );
3554     if ( $item->{'lost'} ne '' ) {
3555         $query =
3556 "update items set biblioitemnumber=?,barcode=?,itemnotes=?,homebranch=?,
3557                             itemlost=?,wthdrawn=?,itemcallnumber=?,notforloan=?,
3558                              location=?,multivolumepart=?,multivolume=?,stack=?,wthdrawn=?,holdingbranch=?,cutterextra=?,onloan=?, binding=?";
3559         @bind = (
3560             $item->{'bibitemnum'},     $item->{'barcode'},
3561             $item->{'notes'},          $item->{'homebranch'},
3562             $item->{'lost'},           $item->{'wthdrawn'},
3563             $item->{'itemcallnumber'}, $item->{'notforloan'},
3564             $item->{'location'},       $item->{multivolumepart},
3565             $item->{multivolume},      $item->{stack},
3566             $item->{wthdrawn},         $item->{holdingbranch},
3567             $cutterextra,              $item->{onloan},
3568             $item->{binding}
3569         );
3570         if ( $item->{homebranch} ) {
3571             $query .= ",homebranch=?";
3572             push @bind, $item->{homebranch};
3573         }
3574         if ( $item->{holdingbranch} ) {
3575             $query .= ",holdingbranch=?";
3576             push @bind, $item->{holdingbranch};
3577         }
3578     }
3579     $query .= " where itemnumber=?";
3580     push @bind, $item->{'itemnum'};
3581     if ( $item->{'replacement'} ne '' ) {
3582         $query =~ s/ where/,replacementprice='$item->{'replacement'}' where/;
3583     }
3584     my $sth = $dbh->prepare($query);
3585     $sth->execute(@bind);
3586     $sth->finish;
3587 }
3588
3589 =head2 _koha_delete_biblio
3590
3591 =over 4
3592
3593 $error = _koha_delete_biblio($dbh,$biblionumber);
3594
3595 Internal sub for deleting from biblio table -- also saves to deletedbiblio
3596
3597 C<$dbh> - the database handle
3598 C<$biblionumber> - the biblionumber of the biblio to be deleted
3599
3600 =back
3601
3602 =cut
3603
3604 # FIXME: add error handling
3605
3606 sub _koha_delete_biblio {
3607     my ( $dbh, $biblionumber ) = @_;
3608
3609     # get all the data for this biblio
3610     my $sth = $dbh->prepare("SELECT * FROM biblio WHERE biblionumber=?");
3611     $sth->execute($biblionumber);
3612
3613     if ( my $data = $sth->fetchrow_hashref ) {
3614
3615         # save the record in deletedbiblio
3616         # find the fields to save
3617         my $query = "INSERT INTO deletedbiblio SET ";
3618         my @bind  = ();
3619         foreach my $temp ( keys %$data ) {
3620             $query .= "$temp = ?,";
3621             push( @bind, $data->{$temp} );
3622         }
3623
3624         # replace the last , by ",?)"
3625         $query =~ s/\,$//;
3626         my $bkup_sth = $dbh->prepare($query);
3627         $bkup_sth->execute(@bind);
3628         $bkup_sth->finish;
3629
3630         # delete the biblio
3631         my $del_sth = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
3632         $del_sth->execute($biblionumber);
3633         $del_sth->finish;
3634     }
3635     $sth->finish;
3636     return undef;
3637 }
3638
3639 =head2 _koha_delete_biblioitems
3640
3641 =over 4
3642
3643 $error = _koha_delete_biblioitems($dbh,$biblioitemnumber);
3644
3645 Internal sub for deleting from biblioitems table -- also saves to deletedbiblioitems
3646
3647 C<$dbh> - the database handle
3648 C<$biblionumber> - the biblioitemnumber of the biblioitem to be deleted
3649
3650 =back
3651
3652 =cut
3653
3654 # FIXME: add error handling
3655
3656 sub _koha_delete_biblioitems {
3657     my ( $dbh, $biblioitemnumber ) = @_;
3658
3659     # get all the data for this biblioitem
3660     my $sth =
3661       $dbh->prepare("SELECT * FROM biblioitems WHERE biblioitemnumber=?");
3662     $sth->execute($biblioitemnumber);
3663
3664     if ( my $data = $sth->fetchrow_hashref ) {
3665
3666         # save the record in deletedbiblioitems
3667         # find the fields to save
3668         my $query = "INSERT INTO deletedbiblioitems SET ";
3669         my @bind  = ();
3670         foreach my $temp ( keys %$data ) {
3671             $query .= "$temp = ?,";
3672             push( @bind, $data->{$temp} );
3673         }
3674
3675         # replace the last , by ",?)"
3676         $query =~ s/\,$//;
3677         my $bkup_sth = $dbh->prepare($query);
3678         $bkup_sth->execute(@bind);
3679         $bkup_sth->finish;
3680
3681         # delete the biblioitem
3682         my $del_sth =
3683           $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
3684         $del_sth->execute($biblioitemnumber);
3685         $del_sth->finish;
3686     }
3687     $sth->finish;
3688     return undef;
3689 }
3690
3691 =head2 _koha_delete_item
3692
3693 =over 4
3694
3695 _koha_delete_item( $dbh, $itemnum );
3696
3697 Internal function to delete an item record from the koha tables
3698
3699 =back
3700
3701 =cut
3702
3703 sub _koha_delete_item {
3704     my ( $dbh, $itemnum ) = @_;
3705
3706     my $sth = $dbh->prepare("select * from items where itemnumber=?");
3707     $sth->execute($itemnum);
3708     my $data = $sth->fetchrow_hashref;
3709     $sth->finish;
3710     my $query = "Insert into deleteditems set ";
3711     my @bind  = ();
3712     foreach my $temp ( keys %$data ) {
3713         $query .= "$temp = ?,";
3714         push( @bind, $data->{$temp} );
3715     }
3716     $query =~ s/\,$//;
3717
3718     #  print $query;
3719     $sth = $dbh->prepare($query);
3720     $sth->execute(@bind);
3721     $sth->finish;
3722     $sth = $dbh->prepare("Delete from items where itemnumber=?");
3723     $sth->execute($itemnum);
3724     $sth->finish;
3725 }
3726
3727 =head1 UNEXPORTED FUNCTIONS
3728
3729 =over 4
3730
3731 =head2 calculatelc
3732
3733 $lc = calculatelc($classification);
3734
3735 =back
3736
3737 =cut
3738
3739 sub calculatelc {
3740     my ($classification) = @_;
3741     $classification =~ s/^\s+|\s+$//g;
3742     my $i = 0;
3743     my $lc2;
3744     my $lc1;
3745
3746     for ( $i = 0 ; $i < length($classification) ; $i++ ) {
3747         my $c = ( substr( $classification, $i, 1 ) );
3748         if ( $c ge '0' && $c le '9' ) {
3749
3750             $lc2 = substr( $classification, $i );
3751             last;
3752         }
3753         else {
3754             $lc1 .= substr( $classification, $i, 1 );
3755
3756         }
3757     }    #while
3758
3759     my $other = length($lc1);
3760     if ( !$lc1 ) {
3761         $other = 0;
3762     }
3763
3764     my $extras;
3765     if ( $other < 4 ) {
3766         for ( 1 .. ( 4 - $other ) ) {
3767             $extras .= "0";
3768         }
3769     }
3770     $lc1 .= $extras;
3771     $lc2 =~ s/^ //g;
3772
3773     $lc2 =~ s/ //g;
3774     $extras = "";
3775     ##Find the decimal part of $lc2
3776     my $pos = index( $lc2, "." );
3777     if ( $pos < 0 ) { $pos = length($lc2); }
3778     if ( $pos >= 0 && $pos < 5 ) {
3779         ##Pad lc2 with zeros to create a 5digit decimal needed in marc record to sort as numeric
3780
3781         for ( 1 .. ( 5 - $pos ) ) {
3782             $extras .= "0";
3783         }
3784     }
3785     $lc2 = $extras . $lc2;
3786     return ( $lc1 . $lc2 );
3787 }
3788
3789 =head2 itemcalculator
3790
3791 =over 4
3792
3793 $cutterextra = itemcalculator( $dbh, $biblioitem, $callnumber );
3794
3795 =back
3796
3797 =cut
3798
3799 sub itemcalculator {
3800     my ( $dbh, $biblioitem, $callnumber ) = @_;
3801     my $sth =
3802       $dbh->prepare(
3803 "select classification, subclass from biblioitems where biblioitemnumber=?"
3804       );
3805
3806     $sth->execute($biblioitem);
3807     my ( $classification, $subclass ) = $sth->fetchrow;
3808     my $all         = $classification . " " . $subclass;
3809     my $total       = length($all);
3810     my $cutterextra = substr( $callnumber, $total - 1 );
3811
3812     return $cutterextra;
3813 }
3814
3815 =head2 ModBiblioMarc
3816
3817     &ModBiblioMarc($newrec,$biblionumber,$frameworkcode);
3818
3819     Add MARC data for a biblio to koha
3820
3821     Function exported, but should NOT be used, unless you really know what you're doing
3822
3823 =cut
3824
3825 sub ModBiblioMarc {
3826
3827 # pass the MARC::Record to this function, and it will create the records in the marc field
3828     my ( $record, $biblionumber, $frameworkcode ) = @_;
3829     my $dbh = C4::Context->dbh;
3830     my @fields = $record->fields();
3831     if ( !$frameworkcode ) {
3832         $frameworkcode = "";
3833     }
3834     my $sth =
3835       $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3836     $sth->execute( $frameworkcode, $biblionumber );
3837     $sth->finish;
3838     my $encoding = C4::Context->preference("marcflavour");
3839
3840     # deal with UNIMARC field 100 (encoding) : create it if needed & set encoding to unicode
3841     if ( $encoding eq "UNIMARC" ) {
3842         my $string;
3843         if ( length($record->subfield( 100, "a" )) == 35 ) {
3844             $string = $record->subfield( 100, "a" );
3845             my $f100 = $record->field(100);
3846             $record->delete_field($f100);
3847         }
3848         else {
3849             $string = POSIX::strftime( "%Y%m%d", localtime );
3850             $string =~ s/\-//g;
3851             $string = sprintf( "%-*s", 35, $string );
3852         }
3853         substr( $string, 22, 6, "frey50" );
3854         unless ( $record->subfield( 100, "a" ) ) {
3855             $record->insert_grouped_field(
3856                 MARC::Field->new( 100, "", "", "a" => $string ) );
3857         }
3858     }
3859     ModZebra($biblionumber,"specialUpdate","biblioserver",$record);
3860     $sth =
3861       $dbh->prepare(
3862         "update biblioitems set marc=?,marcxml=?  where biblionumber=?");
3863     $sth->execute( $record->as_usmarc(), $record->as_xml_record(),
3864         $biblionumber );
3865     $sth->finish;
3866     return $biblionumber;
3867 }
3868
3869 =head2 AddItemInMarc
3870
3871 =over 4
3872
3873 $newbiblionumber = AddItemInMarc( $record, $biblionumber, $frameworkcode );
3874
3875 Add an item in a MARC record and save the MARC record
3876
3877 Function exported, but should NOT be used, unless you really know what you're doing
3878
3879 =back
3880
3881 =cut
3882
3883 sub AddItemInMarc {
3884
3885     # pass the MARC::Record to this function, and it will create the records in the marc tables
3886     my ( $record, $biblionumber, $frameworkcode ) = @_;
3887     my $newrec = &GetMarcBiblio($biblionumber);
3888
3889     # create it
3890     my @fields = $record->fields();
3891     foreach my $field (@fields) {
3892         $newrec->append_fields($field);
3893     }
3894
3895     # FIXME: should we be making sure the biblionumbers are the same?
3896     my $newbiblionumber =
3897       &ModBiblioMarc( $newrec, $biblionumber, $frameworkcode );
3898     return $newbiblionumber;
3899 }
3900
3901 =head2 z3950_extended_services
3902
3903 z3950_extended_services($serviceType,$serviceOptions,$record);
3904
3905     z3950_extended_services is used to handle all interactions with Zebra's extended serices package, which is employed to perform all management of the MARC data stored in Zebra.
3906
3907 C<$serviceType> one of: itemorder,create,drop,commit,update,xmlupdate
3908
3909 C<$serviceOptions> a has of key/value pairs. For instance, if service_type is 'update', $service_options should contain:
3910
3911     action => update action, one of specialUpdate, recordInsert, recordReplace, recordDelete, elementUpdate.
3912
3913 and maybe
3914
3915     recordidOpaque => Opaque Record ID (user supplied) or recordidNumber => Record ID number (system number).
3916     syntax => the record syntax (transfer syntax)
3917     databaseName = Database from connection object
3918
3919     To set serviceOptions, call set_service_options($serviceType)
3920
3921 C<$record> the record, if one is needed for the service type
3922
3923     A record should be in XML. You can convert it to XML from MARC by running it through marc2xml().
3924
3925 =cut
3926
3927 sub z3950_extended_services {
3928     my ( $server, $serviceType, $action, $serviceOptions ) = @_;
3929
3930     # get our connection object
3931     my $Zconn = C4::Context->Zconn( $server, 0, 1 );
3932
3933     # create a new package object
3934     my $Zpackage = $Zconn->package();
3935
3936     # set our options
3937     $Zpackage->option( action => $action );
3938
3939     if ( $serviceOptions->{'databaseName'} ) {
3940         $Zpackage->option( databaseName => $serviceOptions->{'databaseName'} );
3941     }
3942     if ( $serviceOptions->{'recordIdNumber'} ) {
3943         $Zpackage->option(
3944             recordIdNumber => $serviceOptions->{'recordIdNumber'} );
3945     }
3946     if ( $serviceOptions->{'recordIdOpaque'} ) {
3947         $Zpackage->option(
3948             recordIdOpaque => $serviceOptions->{'recordIdOpaque'} );
3949     }
3950
3951  # this is an ILL request (Zebra doesn't support it, but Koha could eventually)
3952  #if ($serviceType eq 'itemorder') {
3953  #   $Zpackage->option('contact-name' => $serviceOptions->{'contact-name'});
3954  #   $Zpackage->option('contact-phone' => $serviceOptions->{'contact-phone'});
3955  #   $Zpackage->option('contact-email' => $serviceOptions->{'contact-email'});
3956  #   $Zpackage->option('itemorder-item' => $serviceOptions->{'itemorder-item'});
3957  #}
3958
3959     if ( $serviceOptions->{record} ) {
3960         $Zpackage->option( record => $serviceOptions->{record} );
3961
3962         # can be xml or marc
3963         if ( $serviceOptions->{'syntax'} ) {
3964             $Zpackage->option( syntax => $serviceOptions->{'syntax'} );
3965         }
3966     }
3967
3968     # send the request, handle any exception encountered
3969     eval { $Zpackage->send($serviceType) };
3970     if ( $@ && $@->isa("ZOOM::Exception") ) {
3971         return "error:  " . $@->code() . " " . $@->message() . "\n";
3972     }
3973
3974     # free up package resources
3975     $Zpackage->destroy();
3976 }
3977
3978 =head2 set_service_options
3979
3980 my $serviceOptions = set_service_options($serviceType);
3981
3982 C<$serviceType> itemorder,create,drop,commit,update,xmlupdate
3983
3984 Currently, we only support 'create', 'commit', and 'update'. 'drop' support will be added as soon as Zebra supports it.
3985
3986 =cut
3987
3988 sub set_service_options {
3989     my ($serviceType) = @_;
3990     my $serviceOptions;
3991
3992 # FIXME: This needs to be an OID ... if we ever need 'syntax' this sub will need to change
3993 #   $serviceOptions->{ 'syntax' } = ''; #zebra doesn't support syntaxes other than xml
3994
3995     if ( $serviceType eq 'commit' ) {
3996
3997         # nothing to do
3998     }
3999     if ( $serviceType eq 'create' ) {
4000
4001         # nothing to do
4002     }
4003     if ( $serviceType eq 'drop' ) {
4004         die "ERROR: 'drop' not currently supported (by Zebra)";
4005     }
4006     return $serviceOptions;
4007 }
4008
4009 =head2 GetItemsCount
4010
4011 $count = &GetItemsCount( $biblionumber);
4012 this function return count of item with $biblionumber
4013 =cut
4014
4015 sub GetItemsCount {
4016     my ( $biblionumber ) = @_;
4017     my $dbh = C4::Context->dbh;
4018     my $query = qq|SELECT count(*)
4019                   FROM  items
4020                   WHERE biblionumber=?|;
4021     my $sth = $dbh->prepare($query);
4022     $sth->execute($biblionumber);
4023     my $count = $sth->fetchrow;
4024     $sth->finish;
4025     return ($count);
4026 }
4027
4028 END { }    # module clean-up code here (global destructor)
4029
4030 1;
4031
4032 __END__
4033
4034 =head1 AUTHOR
4035
4036 Koha Developement team <info@koha.org>
4037
4038 Paul POULAIN paul.poulain@free.fr
4039
4040 Joshua Ferraro jmf@liblime.com
4041
4042 =cut
4043
4044 # $Id$
4045 # $Log$
4046 # Revision 1.221  2007/07/31 16:01:11  toins
4047 # Some new functions.
4048 # TransformHTMLtoMarc rewrited.
4049 #
4050 # Revision 1.220  2007/07/20 15:43:16  hdl
4051 # Bug Fixing GetMarcSubjects.
4052 # Links parameters were mixed.
4053 #
4054 # Revision 1.218  2007/07/19 07:40:08  hdl
4055 # Adding selection by location for inventory
4056 #
4057 # Revision 1.217  2007/07/03 13:47:44  tipaul
4058 # fixing some display bugs (itemtype not properly returned and a html table bug that makes items appear strangely
4059 #
4060 # Revision 1.216  2007/07/03 09:40:58  tipaul
4061 # return itemtype description properly
4062 #
4063 # Revision 1.215  2007/07/03 09:33:05  tipaul
4064 # if you just replace su by a space in subjects, you'll replace jesus by je s, which is strange for users. this fix solves the problem and introduces authoritysep systempref as separator of subfields, for a better identification of where the authority starts and end
4065 #
4066 # Revision 1.214  2007/07/02 09:13:22  tipaul
4067 # unimarc bugfix : the encoding is in field 100 in UNIMARC. when TransformHTMLtoXML on an item, you must not automatically add a 100 field in items, otherwise there will be 2 100 fields in the biblio, which is wrong
4068 #
4069 # Revision 1.213  2007/06/25 15:01:45  tipaul
4070 # bugfixes on unimarc 100 handling (the field used for encoding)
4071 #
4072 # Revision 1.212  2007/06/15 13:44:44  tipaul
4073 # some fixes (and only fixes)
4074 #
4075 # Revision 1.211  2007/06/15 09:40:06  toins
4076 # do not get $3 $4 and $5 on GetMarcSubjects GetMarcAuthors on unimarc flavour.
4077 #
4078 # Revision 1.210  2007/06/13 13:03:34  toins
4079 # removing warn compilation.
4080 #
4081 # Revision 1.209  2007/05/23 16:19:40  tipaul
4082 # various bugfixes (minor) and french translation updated
4083 #
4084 # Revision 1.208  2007/05/22 09:13:54  tipaul
4085 # Bugfixes & improvements (various and minor) :
4086 # - updating templates to have tmpl_process3.pl running without any errors
4087 # - adding a drupal-like css for prog templates (with 3 small images)
4088 # - fixing some bugs in circulation & other scripts
4089 # - updating french translation
4090 # - fixing some typos in templates
4091 #
4092 # Revision 1.207  2007/05/22 08:51:19  hdl
4093 # Changing GetMarcStructure signature.
4094 # Deleting first parameter $dbh
4095 #
4096 # Revision 1.206  2007/05/21 08:44:17  btoumi
4097 # add security when u delete biblio :
4098 # u must delete linked items before delete biblio
4099 #
4100 # Revision 1.205  2007/05/11 16:04:03  btoumi
4101 # bug fix:
4102 # problem in  displayed label link  with subject in detail.tmpl
4103 # ex: label random => rdom
4104 #
4105 # Revision 1.204  2007/05/10 14:45:15  tipaul
4106 # Koha NoZebra :
4107 # - support for authorities
4108 # - some bugfixes in ordering and "CCL" parsing
4109 # - support for authorities <=> biblios walking
4110 #
4111 # Seems I can do what I want now, so I consider its done, except for bugfixes that will be needed i m sure !
4112 #
4113 # Revision 1.203  2007/05/03 15:16:02  tipaul
4114 # BUGFIX for : NoZebra
4115 # - NoZebra features : seems they work fine now (adding, modifying, deleting)
4116 # - Biblio edition major bugfix : before this commit editing a biblio resulted in an item removal in marcxml field
4117 #
4118 # Revision 1.202  2007/05/02 16:44:31  tipaul
4119 # NoZebra SQL index management :
4120 # * adding 3 subs in Biblio.pm
4121 # - GetNoZebraIndexes, that get the index structure in a new systempreference (added with this commit)
4122 # - _DelBiblioNoZebra, that retrieve all index entries for a biblio and remove in a variable the biblio reference
4123 # - _AddBiblioNoZebra, that add index entries for a biblio.
4124 # Note that the 2 _Add and _Del subs work only in a hash variable, to speed up things in case of a modif (ie : delete+add). The effective SQL update is done in the ModZebra sub (that existed before, and dealed with zebra index).
4125 # I think the code has to be more deeply tested, but it works at least partially.
4126 #
4127 # Revision 1.201  2007/04/27 14:00:49  hdl
4128 # Removing $dbh from GetMarcFromKohaField (dbh is not used in this function.)
4129 #
4130 # Revision 1.200  2007/04/25 16:26:42  tipaul
4131 # Koha 3.0 nozebra 1st commit : the script misc/migration_tools/rebuild_nozebra.pl build the nozebra table, and, if you set NoZebra to Yes, queries will be done through zebra. TODO :
4132 # - add nozebra table management on biblio editing
4133 # - the index table content is hardcoded. I still have to add some specific systempref to let the library update it
4134 # - manage pagination (next/previous)
4135 # - manage facets
4136 # WHAT works :
4137 # - NZgetRecords : has exactly the same API & returns as zebra getQuery, except that some parameters are unused
4138 # - search & sort works quite good
4139 # - CQL parser is better that what I thought I could do : title="harry and sally" and publicationyear>2000 not itemtype=LIVR should work fine
4140 #
4141 # Revision 1.199  2007/04/24 09:07:53  tipaul
4142 # moving dotransfer to Biblio.pm::ModItemTransfer + some CheckReserves fixes
4143 #
4144 # Revision 1.198  2007/04/23 15:21:17  tipaul
4145 # renaming currenttransfers to transferstoreceive
4146 #
4147 # Revision 1.197  2007/04/18 17:00:14  tipaul
4148 # removing all useless %env / $env
4149 #
4150 # Revision 1.196  2007/04/17 08:48:00  tipaul
4151 # circulation cleaning continued: bufixing
4152 #
4153 # Revision 1.195  2007/04/04 16:46:22  tipaul
4154 # HUGE COMMIT : code cleaning circulation.
4155 #
4156 # some stuff to do, i'll write a mail on koha-devel NOW !
4157 #
4158 # Revision 1.194  2007/03/30 12:00:42  tipaul
4159 # why the hell do we need to explicitly utf8 decode this string ? I really don't know, but it seems it's mandatory, otherwise, tag descriptions are not properly encoded...
4160 #
4161 # Revision 1.193  2007/03/29 16:45:53  tipaul
4162 # Code cleaning of Biblio.pm (continued)
4163 #
4164 # All subs have be cleaned :
4165 # - removed useless
4166 # - merged some
4167 # - reordering Biblio.pm completly
4168 # - using only naming conventions
4169 #
4170 # Seems to have broken nothing, but it still has to be heavily tested.
4171 # Note that Biblio.pm is now much more efficient than previously & probably more reliable as well.
4172 #
4173 # Revision 1.192  2007/03/29 13:30:31  tipaul
4174 # Code cleaning :
4175 # == Biblio.pm cleaning (useless) ==
4176 # * some sub declaration dropped
4177 # * removed modbiblio sub
4178 # * removed moditem sub
4179 # * removed newitems. It was used only in finishrecieve. Replaced by a TransformKohaToMarc+AddItem, that is better.
4180 # * removed MARCkoha2marcItem
4181 # * removed MARCdelsubfield declaration
4182 # * removed MARCkoha2marcBiblio
4183 #
4184 # == Biblio.pm cleaning (naming conventions) ==
4185 # * MARCgettagslib renamed to GetMarcStructure
4186 # * MARCgetitems renamed to GetMarcItem
4187 # * MARCfind_frameworkcode renamed to GetFrameworkCode
4188 # * MARCmarc2koha renamed to TransformMarcToKoha
4189 # * MARChtml2marc renamed to TransformHtmlToMarc
4190 # * MARChtml2xml renamed to TranformeHtmlToXml
4191 # * zebraop renamed to ModZebra
4192 #
4193 # == MARC=OFF ==
4194 # * removing MARC=OFF related scripts (in cataloguing directory)
4195 # * removed checkitems (function related to MARC=off feature, that is completly broken in head. If someone want to reintroduce it, hard work coming...)
4196 # * removed getitemsbybiblioitem (used only by MARC=OFF scripts, that is removed as well)
4197 #
4198 # Revision 1.191  2007/03/29 09:42:13  tipaul
4199 # adding default value new feature into cataloguing. The system (definition) part has already been added by toins
4200 #
4201 # Revision 1.190  2007/03/29 08:45:19  hdl
4202 # Deleting ignore_errors(1) pour MARC::Charset
4203 #
4204 # Revision 1.189  2007/03/28 10:39:16  hdl
4205 # removing $dbh as a parameter in AuthoritiesMarc functions
4206 # And reporting all differences into the scripts taht relies on those functions.