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