koha-dev.rot13.org Git - koha_ffzg/blob - C4/Biblio.pm

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