C4/AuthoritiesMarc.pm

   1 package C4::AuthoritiesMarc;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 # Copyright 2018 The National Library of Finland, University of Helsinki
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 use strict;
  22 use warnings;
  23 use C4::Context;
  24 use C4::Biblio qw( GetFrameworkCode GetMarcBiblio ModBiblio );
  25 use C4::Search qw( FindDuplicate new_record_from_zebra );
  26 use C4::AuthoritiesMarc::MARC21;
  27 use C4::AuthoritiesMarc::UNIMARC;
  28 use C4::Charset qw( SetUTF8Flag );
  29 use C4::Log qw( logaction );
  30 use Koha::MetadataRecord::Authority;
  31 use Koha::Authorities;
  32 use Koha::Authority::MergeRequests;
  33 use Koha::Authority::Types;
  34 use Koha::Authority;
  35 use Koha::Libraries;
  36 use Koha::SearchEngine;
  37 use Koha::SearchEngine::Indexer;
  38 use Koha::SearchEngine::Search;
  39
  40 our (@ISA, @EXPORT_OK);
  41 BEGIN {
  42
  43     require Exporter;
  44     @ISA       = qw(Exporter);
  45     @EXPORT_OK = qw(
  46       GetTagsLabels
  47       GetAuthMARCFromKohaField
  48
  49       AddAuthority
  50       ModAuthority
  51       DelAuthority
  52       GetAuthority
  53       GetAuthorityXML
  54
  55       SearchAuthorities
  56
  57       BuildSummary
  58       BuildAuthHierarchies
  59       BuildAuthHierarchy
  60       GenerateHierarchy
  61       GetHeaderAuthority
  62       AddAuthorityTrees
  63       CompareFieldWithAuthority
  64
  65       merge
  66       FindDuplicateAuthority
  67
  68       GuessAuthTypeCode
  69       GuessAuthId
  70       compare_fields
  71     );
  72 }
  73
  74
  75 =head1 NAME
  76
  77 C4::AuthoritiesMarc
  78
  79 =head2 GetAuthMARCFromKohaField
  80
  81   ( $tag, $subfield ) = &GetAuthMARCFromKohaField ($kohafield,$authtypecode);
  82
  83 returns tag and subfield linked to kohafield
  84
  85 Comment :
  86 Suppose Kohafield is only linked to ONE subfield
  87
  88 =cut
  89
  90 sub GetAuthMARCFromKohaField {
  91 #AUTHfind_marc_from_kohafield
  92   my ( $kohafield,$authtypecode ) = @_;
  93   my $dbh=C4::Context->dbh;
  94   return 0, 0 unless $kohafield;
  95   $authtypecode="" unless $authtypecode;
  96   my $sth = $dbh->prepare("select tagfield,tagsubfield from auth_subfield_structure where kohafield= ? and authtypecode=? ");
  97   $sth->execute($kohafield,$authtypecode);
  98   my ($tagfield,$tagsubfield) = $sth->fetchrow;
  99
 100   return  ($tagfield,$tagsubfield);
 101 }
 102
 103 =head2 SearchAuthorities
 104
 105   (\@finalresult, $nbresults)= &SearchAuthorities($tags, $and_or,
 106      $excluding, $operator, $value, $offset,$length,$authtypecode,
 107      $sortby[, $skipmetadata])
 108
 109 returns ref to array result and count of results returned
 110
 111 =cut
 112
 113 sub SearchAuthorities {
 114     my ($tags, $and_or, $excluding, $operator, $value, $offset,$length,$authtypecode,$sortby,$skipmetadata) = @_;
 115     # warn Dumper($tags, $and_or, $excluding, $operator, $value, $offset,$length,$authtypecode,$sortby);
 116     my $dbh=C4::Context->dbh;
 117     $sortby="" unless $sortby;
 118     my $query;
 119     my $qpquery = '';
 120     my $attr = '';
 121         # the marclist may contain "mainentry". In this case, search the tag_to_report, that depends on
 122         # the authtypecode. Then, search on $a of this tag_to_report
 123         # also store main entry MARC tag, to extract it at end of search
 124     ##first set the authtype search and may be multiple authorities
 125     if ($authtypecode) {
 126         my $n=0;
 127         my @authtypecode;
 128         my @auths=split / /,$authtypecode ;
 129         foreach my  $auth (@auths){
 130             $query .=" \@attr 1=authtype \@attr 5=100 ".$auth; ##No truncation on authtype
 131                 push @authtypecode ,$auth;
 132             $n++;
 133         }
 134         if ($n>1){
 135             while ($n>1){$query= "\@or ".$query;$n--;}
 136         }
 137     }
 138
 139     my $dosearch;
 140     my $and=" \@and " ;
 141     my $q2;
 142     my $attr_cnt = 0;
 143     for ( my $i = 0 ; $i <= $#{$value} ; $i++ ) {
 144         if ( @$value[$i] ) {
 145             if ( @$tags[$i] ) {
 146                 if ( @$tags[$i] eq "mainmainentry" ) {
 147                     $attr = " \@attr 1=Heading-Main ";
 148                 }
 149                 elsif ( @$tags[$i] eq "mainentry" ) {
 150                     $attr = " \@attr 1=Heading ";
 151                 }
 152                 elsif ( @$tags[$i] eq "match" ) {
 153                     $attr = " \@attr 1=Match ";
 154                 }
 155                 elsif ( @$tags[$i] eq "match-heading" ) {
 156                     $attr = " \@attr 1=Match-heading ";
 157                 }
 158                 elsif ( @$tags[$i] eq "see-from" ) {
 159                     $attr = " \@attr 1=Match-heading-see-from ";
 160                 }
 161                 elsif ( @$tags[$i] eq "thesaurus" ) {
 162                     $attr = " \@attr 1=Subject-heading-thesaurus ";
 163                 }
 164                 elsif ( @$tags[$i] eq "all" ) {
 165                     $attr = " \@attr 1=Any ";
 166                 }
 167                 else {    # Use the index passed in params
 168                     $attr = " \@attr 1=" . @$tags[$i] . " ";
 169                 }
 170             }         #if @$tags[$i]
 171             else {    # Assume any if no index was specified
 172                 $attr = " \@attr 1=Any ";
 173             }
 174
 175             my $operator = @$operator[$i];
 176             if ( $operator and $operator eq 'is' ) {
 177                 $attr .= " \@attr 4=1  \@attr 5=100 "
 178                   ;    ##Phrase, No truncation,all of subfield field must match
 179             }
 180             elsif ( $operator and $operator eq "=" ) {
 181                 $attr .= " \@attr 4=107 ";    #Number Exact match
 182             }
 183             elsif ( $operator and $operator eq "start" ) {
 184                 $attr .= " \@attr 3=2 \@attr 4=1 \@attr 5=1 "
 185                   ;    #Firstinfield Phrase, Right truncated
 186             }
 187             elsif ( $operator and $operator eq "exact" ) {
 188                 $attr .= " \@attr 4=1  \@attr 5=100 \@attr 6=3 "
 189                   ;    ##Phrase, No truncation,all of subfield field must match
 190             }
 191             else {
 192                 $attr .= " \@attr 5=1 \@attr 4=6 "
 193                   ;    ## Word list, right truncated, anywhere
 194                 if ( $sortby eq 'Relevance' ) {
 195                     $attr .= "\@attr 2=102 ";
 196                 }
 197             }
 198             @$value[$i] =~
 199               s/"/\\"/g;    # Escape the double-quotes in the search value
 200             $attr = $attr . "\"" . @$value[$i] . "\"";
 201             $q2 .= $attr;
 202             $dosearch = 1;
 203             ++$attr_cnt;
 204         }    #if value
 205     }
 206     ##Add how many queries generated
 207     if (defined $query && $query=~/\S+/){
 208       $query= $and x $attr_cnt . $query . (defined $q2 ? $q2 : '');
 209     } else {
 210       $query= $q2;
 211     }
 212     ## Adding order
 213     #$query=' @or  @attr 7=2 @attr 1=Heading 0 @or  @attr 7=1 @attr 1=Heading 1'.$query if ($sortby eq "HeadingDsc");
 214     my $orderstring;
 215     if ($sortby eq 'HeadingAsc') {
 216         $orderstring = '@attr 7=1 @attr 1=Heading 0';
 217     } elsif ($sortby eq 'HeadingDsc') {
 218         $orderstring = '@attr 7=2 @attr 1=Heading 0';
 219     } elsif ($sortby eq 'AuthidAsc') {
 220         $orderstring = '@attr 7=1 @attr 4=109 @attr 1=Local-Number 0';
 221     } elsif ($sortby eq 'AuthidDsc') {
 222         $orderstring = '@attr 7=2 @attr 4=109 @attr 1=Local-Number 0';
 223     }
 224     $query=($query?$query:"\@attr 1=_ALLRECORDS \@attr 2=103 ''");
 225     $query="\@or $orderstring $query" if $orderstring;
 226
 227     $offset = 0 if not defined $offset or $offset < 0;
 228     my $counter = $offset;
 229     $length=10 unless $length;
 230     my @oAuth;
 231     my $i;
 232     $oAuth[0]=C4::Context->Zconn("authorityserver" , 1);
 233     my $Anewq= ZOOM::Query::PQF->new($query,$oAuth[0]);
 234     my $oAResult;
 235     $oAResult= $oAuth[0]->search($Anewq) ;
 236     while (($i = ZOOM::event(\@oAuth)) != 0) {
 237         my $ev = $oAuth[$i-1]->last_event();
 238         last if $ev == ZOOM::Event::ZEND;
 239     }
 240     my($error, $errmsg, $addinfo, $diagset) = $oAuth[0]->error_x();
 241     if ($error) {
 242         warn  "oAuth error: $errmsg ($error) $addinfo $diagset\n";
 243         goto NOLUCK;
 244     }
 245
 246     my $nbresults;
 247     $nbresults=$oAResult->size();
 248     my $nremains=$nbresults;
 249     my @result = ();
 250     my @finalresult = ();
 251
 252     if ($nbresults>0){
 253
 254     ##Find authid and linkid fields
 255     ##we may be searching multiple authoritytypes.
 256     ## FIXME this assumes that all authid and linkid fields are the same for all authority types
 257     # my ($authidfield,$authidsubfield)=GetAuthMARCFromKohaField($dbh,"auth_header.authid",$authtypecode[0]);
 258     # my ($linkidfield,$linkidsubfield)=GetAuthMARCFromKohaField($dbh,"auth_header.linkid",$authtypecode[0]);
 259         while (($counter < $nbresults) && ($counter < ($offset + $length))) {
 260
 261         ##Here we have to extract MARC record and $authid from ZEBRA AUTHORITIES
 262         my $rec=$oAResult->record($counter);
 263         my $separator=C4::Context->preference('AuthoritySeparator');
 264         my $authrecord = C4::Search::new_record_from_zebra(
 265             'authorityserver',
 266             $rec->raw()
 267         );
 268
 269         if ( !defined $authrecord or !defined $authrecord->field('001') ) {
 270             $counter++;
 271             next;
 272         }
 273
 274         SetUTF8Flag( $authrecord );
 275
 276         my $authid=$authrecord->field('001')->data();
 277         my %newline;
 278         $newline{authid} = $authid;
 279         if ( !$skipmetadata ) {
 280             my $auth_tag_to_report;
 281             $auth_tag_to_report = Koha::Authority::Types->find($authtypecode)->auth_tag_to_report
 282                 if $authtypecode;
 283             my $reported_tag;
 284             my $mainentry = $authrecord->field($auth_tag_to_report);
 285             if ($mainentry) {
 286                 foreach ( $mainentry->subfields() ) {
 287                     $reported_tag .= '$' . $_->[0] . $_->[1];
 288                 }
 289             }
 290
 291             my ( $thisauthtype, $thisauthtypecode );
 292             if ( my $authority = Koha::Authorities->find($authid) ) {
 293                 $thisauthtypecode = $authority->authtypecode;
 294                 $thisauthtype = Koha::Authority::Types->find($thisauthtypecode);
 295             }
 296             unless (defined $thisauthtype) {
 297                 $thisauthtypecode = $authtypecode;
 298                 $thisauthtype = Koha::Authority::Types->find($thisauthtypecode);
 299             }
 300             my $summary = BuildSummary( $authrecord, $authid, $thisauthtypecode );
 301
 302             $newline{authtype}     = defined($thisauthtype) ?
 303                                         $thisauthtype->authtypetext : '';
 304             $newline{summary}      = $summary;
 305             $newline{even}         = $counter % 2;
 306             $newline{reported_tag} = $reported_tag;
 307         }
 308         $counter++;
 309         push @finalresult, \%newline;
 310         }## while counter
 311         ###
 312         if (! $skipmetadata) {
 313             for (my $z=0; $z<@finalresult; $z++){
 314                 my $count = Koha::Authorities->get_usage_count({ authid => $finalresult[$z]{authid} });
 315                 $finalresult[$z]{used}=$count;
 316             }# all $z's
 317         }
 318
 319     }## if nbresult
 320     NOLUCK:
 321     $oAResult->destroy();
 322     # $oAuth[0]->destroy();
 323
 324     return (\@finalresult, $nbresults);
 325 }
 326
 327 =head2 GuessAuthTypeCode
 328
 329   my $authtypecode = GuessAuthTypeCode($record);
 330
 331 Get the record and tries to guess the adequate authtypecode from its content.
 332
 333 =cut
 334
 335 sub GuessAuthTypeCode {
 336     my ($record, $heading_fields) = @_;
 337     return unless defined $record;
 338     $heading_fields //= {
 339     "MARC21"=>{
 340         '100'=>{authtypecode=>'PERSO_NAME'},
 341         '110'=>{authtypecode=>'CORPO_NAME'},
 342         '111'=>{authtypecode=>'MEETI_NAME'},
 343         '130'=>{authtypecode=>'UNIF_TITLE'},
 344         '147'=>{authtypecode=>'NAME_EVENT'},
 345         '148'=>{authtypecode=>'CHRON_TERM'},
 346         '150'=>{authtypecode=>'TOPIC_TERM'},
 347         '151'=>{authtypecode=>'GEOGR_NAME'},
 348         '155'=>{authtypecode=>'GENRE/FORM'},
 349         '162'=>{authtypecode=>'MED_PERFRM'},
 350         '180'=>{authtypecode=>'GEN_SUBDIV'},
 351         '181'=>{authtypecode=>'GEO_SUBDIV'},
 352         '182'=>{authtypecode=>'CHRON_SUBD'},
 353         '185'=>{authtypecode=>'FORM_SUBD'},
 354     },
 355 #200 Personal name      700, 701, 702 4-- with embedded 700, 701, 702 600
 356 #                    604 with embedded 700, 701, 702
 357 #210 Corporate or meeting name  710, 711, 712 4-- with embedded 710, 711, 712 601 604 with embedded 710, 711, 712
 358 #215 Territorial or geographic name     710, 711, 712 4-- with embedded 710, 711, 712 601, 607 604 with embedded 710, 711, 712
 359 #216 Trademark  716 [Reserved for future use]
 360 #220 Family name        720, 721, 722 4-- with embedded 720, 721, 722 602 604 with embedded 720, 721, 722
 361 #230 Title      500 4-- with embedded 500 605
 362 #240 Name and title (embedded 200, 210, 215, or 220 and 230)    4-- with embedded 7-- and 500 7--  604 with embedded 7-- and 500 500
 363 #245 Name and collective title (embedded 200, 210, 215, or 220 and 235)         4-- with embedded 7-- and 501 604 with embedded 7-- and 501 7-- 501
 364 #250 Topical subject    606
 365 #260 Place access       620
 366 #280 Form, genre or physical characteristics    608
 367 #
 368 #
 369 # Could also be represented with :
 370 #leader position 9
 371 #a = personal name entry
 372 #b = corporate name entry
 373 #c = territorial or geographical name
 374 #d = trademark
 375 #e = family name
 376 #f = uniform title
 377 #g = collective uniform title
 378 #h = name/title
 379 #i = name/collective uniform title
 380 #j = topical subject
 381 #k = place access
 382 #l = form, genre or physical characteristics
 383     "UNIMARC"=>{
 384         '200'=>{authtypecode=>'NP'},
 385         '210'=>{authtypecode=>'CO'},
 386         '215'=>{authtypecode=>'SNG'},
 387         '216'=>{authtypecode=>'TM'},
 388         '220'=>{authtypecode=>'FAM'},
 389         '230'=>{authtypecode=>'TU'},
 390         '235'=>{authtypecode=>'CO_UNI_TI'},
 391         '240'=>{authtypecode=>'SAUTTIT'},
 392         '245'=>{authtypecode=>'NAME_COL'},
 393         '250'=>{authtypecode=>'SNC'},
 394         '260'=>{authtypecode=>'PA'},
 395         '280'=>{authtypecode=>'GENRE/FORM'},
 396     }
 397 };
 398     foreach my $field (keys %{$heading_fields->{uc(C4::Context->preference('marcflavour'))} }) {
 399        return $heading_fields->{uc(C4::Context->preference('marcflavour'))}->{$field}->{'authtypecode'} if (defined $record->field($field));
 400     }
 401     return;
 402 }
 403
 404 =head2 GuessAuthId
 405
 406   my $authtid = GuessAuthId($record);
 407
 408 Get the record and tries to guess the adequate authtypecode from its content.
 409
 410 =cut
 411
 412 sub GuessAuthId {
 413     my ($record) = @_;
 414     return unless ($record && $record->field('001'));
 415 #    my $authtypecode=GuessAuthTypeCode($record);
 416 #    my ($tag,$subfield)=GetAuthMARCFromKohaField("auth_header.authid",$authtypecode);
 417 #    if ($tag > 010) {return $record->subfield($tag,$subfield)}
 418 #    else {return $record->field($tag)->data}
 419     return $record->field('001')->data;
 420 }
 421
 422 =head2 GetTagsLabels
 423
 424   $tagslabel= &GetTagsLabels($forlibrarian,$authtypecode)
 425
 426 returns a ref to hashref of authorities tag and subfield structure.
 427
 428 tagslabel usage :
 429
 430   $tagslabel->{$tag}->{$subfield}->{'attribute'}
 431
 432 where attribute takes values in :
 433
 434   lib
 435   tab
 436   mandatory
 437   repeatable
 438   authorised_value
 439   authtypecode
 440   value_builder
 441   kohafield
 442   seealso
 443   hidden
 444   isurl
 445   link
 446
 447 =cut
 448
 449 sub GetTagsLabels {
 450   my ($forlibrarian,$authtypecode)= @_;
 451   my $dbh=C4::Context->dbh;
 452   $authtypecode="" unless $authtypecode;
 453   my $sth;
 454   my $libfield = ($forlibrarian == 1)? 'liblibrarian' : 'libopac';
 455
 456
 457   # check that authority exists
 458   $sth=$dbh->prepare("SELECT count(*) FROM auth_tag_structure WHERE authtypecode=?");
 459   $sth->execute($authtypecode);
 460   my ($total) = $sth->fetchrow;
 461   $authtypecode="" unless ($total >0);
 462   $sth= $dbh->prepare(
 463 "SELECT auth_tag_structure.tagfield,auth_tag_structure.liblibrarian,auth_tag_structure.libopac,auth_tag_structure.mandatory,auth_tag_structure.repeatable
 464  FROM auth_tag_structure
 465  WHERE authtypecode=?
 466  ORDER BY tagfield"
 467     );
 468
 469   $sth->execute($authtypecode);
 470   my ( $liblibrarian, $libopac, $tag, $res, $tab, $mandatory, $repeatable );
 471
 472   while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable ) = $sth->fetchrow ) {
 473         $res->{$tag}->{lib}        = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
 474         $res->{$tag}->{tab}        = " ";            # XXX
 475         $res->{$tag}->{mandatory}  = $mandatory;
 476         $res->{$tag}->{repeatable} = $repeatable;
 477   }
 478   $sth=      $dbh->prepare(
 479 "SELECT tagfield,tagsubfield,liblibrarian,libopac,tab, mandatory, repeatable,authorised_value,frameworkcode as authtypecode,value_builder,kohafield,seealso,hidden,isurl,defaultvalue, display_order
 480 FROM auth_subfield_structure
 481 WHERE authtypecode=?
 482 ORDER BY tagfield, display_order, tagsubfield"
 483     );
 484     $sth->execute($authtypecode);
 485
 486     my $subfield;
 487     my $authorised_value;
 488     my $value_builder;
 489     my $kohafield;
 490     my $seealso;
 491     my $hidden;
 492     my $isurl;
 493     my $defaultvalue;
 494     my $display_order;
 495
 496     while (
 497         ( $tag,         $subfield,   $liblibrarian,   , $libopac,      $tab,
 498         $mandatory,     $repeatable, $authorised_value, $authtypecode,
 499         $value_builder, $kohafield,  $seealso,          $hidden,
 500         $isurl,         $defaultvalue, $display_order )
 501         = $sth->fetchrow
 502       )
 503     {
 504         $res->{$tag}->{$subfield}->{subfield}         = $subfield;
 505         $res->{$tag}->{$subfield}->{lib}              = ($forlibrarian or !$libopac)?$liblibrarian:$libopac;
 506         $res->{$tag}->{$subfield}->{tab}              = $tab;
 507         $res->{$tag}->{$subfield}->{mandatory}        = $mandatory;
 508         $res->{$tag}->{$subfield}->{repeatable}       = $repeatable;
 509         $res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
 510         $res->{$tag}->{$subfield}->{authtypecode}     = $authtypecode;
 511         $res->{$tag}->{$subfield}->{value_builder}    = $value_builder;
 512         $res->{$tag}->{$subfield}->{kohafield}        = $kohafield;
 513         $res->{$tag}->{$subfield}->{seealso}          = $seealso;
 514         $res->{$tag}->{$subfield}->{hidden}           = $hidden;
 515         $res->{$tag}->{$subfield}->{isurl}            = $isurl;
 516         $res->{$tag}->{$subfield}->{defaultvalue}     = $defaultvalue;
 517         $res->{$tag}->{$subfield}->{display_order}    = $display_order;
 518     }
 519
 520     return $res;
 521 }
 522
 523 =head2 AddAuthority
 524
 525   $authid= &AddAuthority($record, $authid,$authtypecode)
 526
 527 Either Create Or Modify existing authority.
 528 returns authid of the newly created authority
 529
 530 =cut
 531
 532 sub AddAuthority {
 533 # pass the MARC::Record to this function, and it will create the records in the authority table
 534   my ($record,$authid,$authtypecode) = @_;
 535   my $dbh=C4::Context->dbh;
 536         my $leader='     nz  a22     o  4500';#Leader for incomplete MARC21 record
 537
 538 # if authid empty => true add, find a new authid number
 539     my $format;
 540     if (uc(C4::Context->preference('marcflavour')) eq 'UNIMARC') {
 541         $format= 'UNIMARCAUTH';
 542     }
 543     else {
 544         $format= 'MARC21';
 545     }
 546
 547     #update date/time to 005 for marc and unimarc
 548     my $time=POSIX::strftime("%Y%m%d%H%M%S",localtime);
 549     my $f5=$record->field('005');
 550     if (!$f5) {
 551       $record->insert_fields_ordered( MARC::Field->new('005',$time.".0") );
 552     }
 553     else {
 554       $f5->update($time.".0");
 555     }
 556
 557     SetUTF8Flag($record);
 558         if ($format eq "MARC21") {
 559         my $userenv = C4::Context->userenv;
 560         my $library;
 561         my $marcorgcode = C4::Context->preference('MARCOrgCode');
 562         if ( $userenv && $userenv->{'branch'} ) {
 563             $library = Koha::Libraries->find( $userenv->{'branch'} );
 564             # userenv's library could not exist because of a trick in misc/commit_file.pl (see FIXME and set_userenv statement)
 565             $marcorgcode = $library ? $library->get_effective_marcorgcode : $marcorgcode;
 566         }
 567                 if (!$record->leader) {
 568                         $record->leader($leader);
 569                 }
 570                 if (!$record->field('003')) {
 571                         $record->insert_fields_ordered(
 572                 MARC::Field->new('003', $marcorgcode),
 573                         );
 574                 }
 575                 my $date=POSIX::strftime("%y%m%d",localtime);
 576                 if (!$record->field('008')) {
 577             # Get a valid default value for field 008
 578             my $default_008 = C4::Context->preference('MARCAuthorityControlField008');
 579             if(!$default_008 or length($default_008)<34) {
 580                 $default_008 = '|| aca||aabn           | a|a     d';
 581             }
 582             else {
 583                 $default_008 = substr($default_008,0,34);
 584             }
 585
 586             $record->insert_fields_ordered( MARC::Field->new('008',$date.$default_008) );
 587                 }
 588                 if (!$record->field('040')) {
 589                  $record->insert_fields_ordered(
 590         MARC::Field->new('040','','',
 591             'a' => $marcorgcode,
 592             'c' => $marcorgcode,
 593                                 )
 594                         );
 595     }
 596         }
 597
 598   if ($format eq "UNIMARCAUTH") {
 599         $record->leader("     nx  j22             ") unless ($record->leader());
 600         my $date=POSIX::strftime("%Y%m%d",localtime);
 601         my $defaultfield100 = C4::Context->preference('UNIMARCAuthorityField100');
 602     if (my $string=$record->subfield('100',"a")){
 603         $string=~s/fre50/frey50/;
 604         $record->field('100')->update('a'=>$string);
 605     }
 606     elsif ($record->field('100')){
 607           $record->field('100')->update('a'=>$date.$defaultfield100);
 608     } else {
 609         $record->append_fields(
 610         MARC::Field->new('100',' ',' '
 611             ,'a'=>$date.$defaultfield100)
 612         );
 613     }
 614   }
 615   my ($auth_type_tag, $auth_type_subfield) = get_auth_type_location($authtypecode);
 616   if (!$authid and $format eq "MARC21") {
 617     # only need to do this fix when modifying an existing authority
 618     C4::AuthoritiesMarc::MARC21::fix_marc21_auth_type_location($record, $auth_type_tag, $auth_type_subfield);
 619   }
 620   if (my $field=$record->field($auth_type_tag)){
 621     $field->update($auth_type_subfield=>$authtypecode);
 622   }
 623   else {
 624     $record->add_fields($auth_type_tag,'','', $auth_type_subfield=>$authtypecode);
 625   }
 626
 627     # Save record into auth_header, update 001
 628     if (!$authid ) {
 629         # Save a blank record, get authid
 630         $dbh->do( "INSERT INTO auth_header (datecreated,marcxml) values (NOW(),?)", undef, '' );
 631         $authid = $dbh->last_insert_id( undef, undef, 'auth_header', 'authid' );
 632         logaction( "AUTHORITIES", "ADD", $authid, "authority" ) if C4::Context->preference("AuthoritiesLog");
 633     }
 634     # Insert/update the recordID in MARC record
 635     $record->delete_field( $record->field('001') );
 636     $record->insert_fields_ordered( MARC::Field->new( '001', $authid ) );
 637     # Update
 638     $dbh->do( "UPDATE auth_header SET authtypecode=?, marc=?, marcxml=? WHERE authid=?", undef, $authtypecode, $record->as_usmarc, $record->as_xml_record($format), $authid ) or die $DBI::errstr;
 639     my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::AUTHORITIES_INDEX });
 640     $indexer->index_records( $authid, "specialUpdate", "authorityserver", $record );
 641
 642     return ( $authid );
 643 }
 644
 645 =head2 DelAuthority
 646
 647     DelAuthority({ authid => $authid, [ skip_merge => 1 ] });
 648
 649 Deletes $authid and calls merge to cleanup linked biblio records.
 650 Parameter skip_merge is used in authorities/merge.pl. You should normally not
 651 use it.
 652
 653 =cut
 654
 655 sub DelAuthority {
 656     my ( $params ) = @_;
 657     my $authid = $params->{authid} || return;
 658     my $skip_merge = $params->{skip_merge};
 659     my $dbh = C4::Context->dbh;
 660
 661     # Remove older pending merge requests for $authid to itself. (See bug 22437)
 662     my $condition = { authid => $authid, authid_new => [undef, 0, $authid], done => 0 };
 663     Koha::Authority::MergeRequests->search($condition)->delete;
 664
 665     merge({ mergefrom => $authid }) if !$skip_merge;
 666     $dbh->do( "DELETE FROM auth_header WHERE authid=?", undef, $authid );
 667     logaction( "AUTHORITIES", "DELETE", $authid, "authority" ) if C4::Context->preference("AuthoritiesLog");
 668     my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::AUTHORITIES_INDEX });
 669     $indexer->index_records( $authid, "recordDelete", "authorityserver", undef );
 670 }
 671
 672 =head2 ModAuthority
 673
 674   $authid= &ModAuthority($authid,$record,$authtypecode, [ { skip_merge => 1 ] )
 675
 676 Modifies authority record, optionally updates attached biblios.
 677 The parameter skip_merge is optional and should be used with care.
 678
 679 =cut
 680
 681 sub ModAuthority {
 682     my ( $authid, $record, $authtypecode, $params ) = @_;
 683     my $oldrecord = GetAuthority($authid);
 684     #Now rewrite the $record to table with an add
 685     $authid = AddAuthority($record, $authid, $authtypecode);
 686     merge({ mergefrom => $authid, MARCfrom => $oldrecord, mergeto => $authid, MARCto => $record }) if !$params->{skip_merge};
 687     logaction( "AUTHORITIES", "MODIFY", $authid, "authority BEFORE=>" . $oldrecord->as_formatted ) if C4::Context->preference("AuthoritiesLog");
 688     return $authid;
 689 }
 690
 691 =head2 GetAuthorityXML
 692
 693   $marcxml= &GetAuthorityXML( $authid)
 694
 695 returns xml form of record $authid
 696
 697 =cut
 698
 699 sub GetAuthorityXML {
 700   # Returns MARC::XML of the authority passed in parameter.
 701   my ( $authid ) = @_;
 702   if (uc(C4::Context->preference('marcflavour')) eq 'UNIMARC') {
 703       my $dbh=C4::Context->dbh;
 704       my $sth = $dbh->prepare("select marcxml from auth_header where authid=? "  );
 705       $sth->execute($authid);
 706       my ($marcxml)=$sth->fetchrow;
 707       return $marcxml;
 708   }
 709   else {
 710       # for MARC21, call GetAuthority instead of
 711       # getting the XML directly since we may
 712       # need to fix up the location of the authority
 713       # code -- note that this is reasonably safe
 714       # because GetAuthorityXML is used only by the
 715       # indexing processes like zebraqueue_start.pl
 716       my $record = GetAuthority($authid);
 717       return $record->as_xml_record('MARC21');
 718   }
 719 }
 720
 721 =head2 GetAuthority
 722
 723   $record= &GetAuthority( $authid)
 724
 725 Returns MARC::Record of the authority passed in parameter.
 726
 727 =cut
 728
 729 sub GetAuthority {
 730     my ($authid)=@_;
 731     my $authority = Koha::MetadataRecord::Authority->get_from_authid($authid);
 732     return unless $authority;
 733     return ($authority->record);
 734 }
 735
 736 =head2 FindDuplicateAuthority
 737
 738   $record= &FindDuplicateAuthority( $record, $authtypecode)
 739
 740 return $authid,Summary if duplicate is found.
 741
 742 Comments : an improvement would be to return All the records that match.
 743
 744 =cut
 745
 746 sub FindDuplicateAuthority {
 747
 748     my ($record,$authtypecode)=@_;
 749 #    warn "IN for ".$record->as_formatted;
 750     my $dbh = C4::Context->dbh;
 751 #    warn "".$record->as_formatted;
 752     my $auth_tag_to_report = Koha::Authority::Types->find($authtypecode)->auth_tag_to_report;
 753 #     warn "record :".$record->as_formatted."  auth_tag_to_report :$auth_tag_to_report";
 754     # build a request for SearchAuthorities
 755     my $op = 'AND';
 756     $authtypecode =~ s#/#\\/#; # GENRE/FORM contains forward slash which is a reserved character
 757     my $query='at:'.$authtypecode.' ';
 758     my $filtervalues=qr([\001-\040\Q!'"`#$%&*+,-./:;<=>?@(){[}_|~\E\]]);
 759     if ($record->field($auth_tag_to_report)) {
 760         foreach ($record->field($auth_tag_to_report)->subfields()) {
 761             $_->[1]=~s/$filtervalues/ /g; $query.= " $op he:\"".$_->[1]."\"" if ($_->[0]=~/[A-z]/);
 762         }
 763     }
 764     my $searcher = Koha::SearchEngine::Search->new({index => $Koha::SearchEngine::AUTHORITIES_INDEX});
 765     my ($error, $results, $total_hits) = $searcher->simple_search_compat( $query, 0, 1, [ 'authorityserver' ] );
 766     # there is at least 1 result => return the 1st one
 767     if (!defined $error && @{$results} ) {
 768         my $marcrecord = C4::Search::new_record_from_zebra(
 769             'authorityserver',
 770             $results->[0]
 771         );
 772         return $marcrecord->field('001')->data,BuildSummary($marcrecord,$marcrecord->field('001')->data,$authtypecode);
 773     }
 774     # no result, returns nothing
 775     return;
 776 }
 777
 778 =head2 BuildSummary
 779
 780   $summary= &BuildSummary( $record, $authid, $authtypecode)
 781
 782 Returns a hashref with a summary of the specified record.
 783
 784 Comment : authtypecode can be inferred from both record and authid.
 785 Moreover, authid can also be inferred from $record.
 786 Would it be interesting to delete those things.
 787
 788 =cut
 789
 790 sub BuildSummary {
 791     ## give this a Marc record to return summary
 792     my ($record,$authid,$authtypecode)=@_;
 793     my $dbh=C4::Context->dbh;
 794     my %summary;
 795     my $summary_template;
 796     # handle $authtypecode is NULL or eq ""
 797     if ($authtypecode) {
 798         my $authref = Koha::Authority::Types->find($authtypecode);
 799         if ( $authref ) {
 800             $summary{authtypecode} = $authref->authtypecode;
 801             $summary{type} = $authref->authtypetext;
 802             $summary_template = $authref->summary;
 803             # for MARC21, the authority type summary displays a label meant for
 804             # display
 805             if (C4::Context->preference('marcflavour') ne 'UNIMARC') {
 806                 $summary{label} = $authref->summary;
 807             } else {
 808                 $summary{summary} = $authref->summary;
 809             }
 810         }
 811     }
 812     my $marc21subfields = 'abcdfghjklmnopqrstuvxyz68';
 813     my %marc21controlrefs = ( 'a' => 'earlier',
 814         'b' => 'later',
 815         'd' => 'acronym',
 816         'f' => 'musical',
 817         'g' => 'broader',
 818         'h' => 'narrower',
 819         'n' => 'notapplicable',
 820         'i' => 'subfi',
 821         't' => 'parent'
 822     );
 823     my %unimarc_relation_from_code = (
 824         g => 'broader',
 825         h => 'narrower',
 826         a => 'seealso',
 827     );
 828     my %thesaurus;
 829     $thesaurus{'1'}="Peuples";
 830     $thesaurus{'2'}="Anthroponymes";
 831     $thesaurus{'3'}="Oeuvres";
 832     $thesaurus{'4'}="Chronologie";
 833     $thesaurus{'5'}="Lieux";
 834     $thesaurus{'6'}="Sujets";
 835     #thesaurus a remplir
 836     my $reported_tag;
 837 # if the library has a summary defined, use it. Otherwise, build a standard one
 838 # FIXME - it appears that the summary field in the authority frameworks
 839 #         can work as a display template.  However, this doesn't
 840 #         suit the MARC21 version, so for now the "templating"
 841 #         feature will be enabled only for UNIMARC for backwards
 842 #         compatibility.
 843     if ($summary{summary} and C4::Context->preference('marcflavour') eq 'UNIMARC') {
 844         my @matches = ($summary{summary} =~ m/\[(.*?)(\d{3})([\*a-z0-9])(.*?)\]/g);
 845         my (@textbefore, @tag, @subtag, @textafter);
 846         for(my $i = 0; $i < scalar @matches; $i++){
 847             push @textbefore, $matches[$i] if($i%4 == 0);
 848             push @tag,        $matches[$i] if($i%4 == 1);
 849             push @subtag,     $matches[$i] if($i%4 == 2);
 850             push @textafter,  $matches[$i] if($i%4 == 3);
 851         }
 852         for(my $i = scalar @tag; $i >= 0; $i--){
 853             my $textbefore = $textbefore[$i] || '';
 854             my $tag = $tag[$i] || '';
 855             my $subtag = $subtag[$i] || '';
 856             my $textafter = $textafter[$i] || '';
 857             my $value = '';
 858             my $field = $record->field($tag);
 859             if ( $field ) {
 860                 if($subtag eq '*') {
 861                     if($tag < 10) {
 862                         $value = $textbefore . $field->data() . $textafter;
 863                     }
 864                 } else {
 865                     my @subfields = $field->subfield($subtag);
 866                     if(@subfields > 0) {
 867                         $value = $textbefore . join (" - ", @subfields) . $textafter;
 868                     }
 869                 }
 870             }
 871             $summary{summary} =~ s/\[\Q$textbefore$tag$subtag$textafter\E\]/$value/;
 872         }
 873         $summary{summary} =~ s/\\n/<br \/>/g;
 874     }
 875     my @authorized;
 876     my @notes;
 877     my @seefrom;
 878     my @seealso;
 879     my @otherscript;
 880     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
 881 # construct UNIMARC summary, that is quite different from MARC21 one
 882 # accepted form
 883         foreach my $field ($record->field('2..')) {
 884             push @authorized, {
 885                 heading => $field->as_string('abcdefghijlmnopqrstuvwxyz'),
 886                 hemain  => ( $field->subfield('a') // undef ),
 887                 field   => $field->tag(),
 888             };
 889         }
 890 # rejected form(s)
 891         foreach my $field ($record->field('3..')) {
 892             push @notes, { note => $field->subfield('a'), field => $field->tag() };
 893         }
 894         foreach my $field ($record->field('4..')) {
 895             my $thesaurus = $field->subfield('2') ? "thes. : ".$thesaurus{"$field->subfield('2')"}." : " : '';
 896             push @seefrom, {
 897                 heading => $thesaurus . $field->as_string('abcdefghijlmnopqrstuvwxyz'),
 898                 hemain  => ( $field->subfield('a') // undef ),
 899                 type    => 'seefrom',
 900                 field   => $field->tag(),
 901             };
 902         }
 903
 904         # see :
 905         @seealso = map {
 906             my $type = $unimarc_relation_from_code{$_->subfield('5') || 'a'};
 907             my $heading = $_->as_string('abcdefgjxyz');
 908             {
 909                 field   => $_->tag,
 910                 type    => $type,
 911                 heading => $heading,
 912                 hemain  => ( $_->subfield('a') // undef ),
 913                 search  => $heading,
 914                 authid  => ( $_->subfield('9') // undef ),
 915             }
 916         } $record->field('5..');
 917
 918         # Other forms
 919         @otherscript = map { {
 920             lang      => length ($_->subfield('8')) == 6 ? substr ($_->subfield('8'), 3, 3) : $_->subfield('8') || '',
 921             term      => $_->subfield('a') . ($_->subfield('b') ? ', ' . $_->subfield('b') : ''),
 922             direction => 'ltr',
 923             field     => $_->tag,
 924         } } $record->field('7..');
 925
 926     } else {
 927 # construct MARC21 summary
 928 # FIXME - looping over 1XX is questionable
 929 # since MARC21 authority should have only one 1XX
 930         use C4::Heading::MARC21;
 931         my $handler = C4::Heading::MARC21->new();
 932         my $subfields_to_report;
 933         foreach my $field ($record->field('1..')) {
 934             my $tag = $field->tag();
 935             next if "152" eq $tag;
 936 # FIXME - 152 is not a good tag to use
 937 # in MARC21 -- purely local tags really ought to be
 938 # 9XX
 939
 940             $subfields_to_report = $handler->get_auth_heading_subfields_to_report($tag);
 941
 942             if ($subfields_to_report) {
 943                 push @authorized, {
 944                     heading => $field->as_string($subfields_to_report),
 945                     hemain  => ( $field->subfield( substr($subfields_to_report, 0, 1) ) // undef ),
 946                     field   => $tag,
 947                 };
 948             } else {
 949                 push @authorized, {
 950                     heading => $field->as_string(),
 951                     hemain  => ( $field->subfield( 'a' ) // undef ),
 952                     field   => $tag,
 953                 };
 954             }
 955         }
 956         foreach my $field ($record->field('4..')) { #See From
 957             my $type = 'seefrom';
 958             $type = ($marc21controlrefs{substr $field->subfield('w'), 0, 1} || '') if ($field->subfield('w'));
 959             if ($type eq 'notapplicable') {
 960                 $type = substr $field->subfield('w'), 2, 1;
 961                 $type = 'earlier' if $type && $type ne 'n';
 962             }
 963             if ($type eq 'subfi') {
 964                 push @seefrom, {
 965                     heading => $field->as_string($marc21subfields),
 966                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 967                     type    => ($field->subfield('i') || ''),
 968                     field   => $field->tag(),
 969                 };
 970             } else {
 971                 push @seefrom, {
 972                     heading => $field->as_string($marc21subfields),
 973                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 974                     type    => $type,
 975                     field   => $field->tag(),
 976                 };
 977             }
 978         }
 979         foreach my $field ($record->field('5..')) { #See Also
 980             my $type = 'seealso';
 981             $type = ($marc21controlrefs{substr $field->subfield('w'), 0, 1} || '') if ($field->subfield('w'));
 982             if ($type eq 'notapplicable') {
 983                 $type = substr $field->subfield('w'), 2, 1;
 984                 $type = 'earlier' if $type && $type ne 'n';
 985             }
 986             if ($type eq 'subfi') {
 987                 push @seealso, {
 988                     heading => $field->as_string($marc21subfields),
 989                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 990                     type    => scalar $field->subfield('i'),
 991                     field   => $field->tag(),
 992                     search  => $field->as_string($marc21subfields) || '',
 993                     authid  => $field->subfield('9') || ''
 994                 };
 995             } else {
 996                 push @seealso, {
 997                     heading => $field->as_string($marc21subfields),
 998                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 999                     type    => $type,
1000                     field   => $field->tag(),
1001                     search  => $field->as_string($marc21subfields) || '',
1002                     authid  => $field->subfield('9') || ''
1003                 };
1004             }
1005         }
1006         foreach my $field ($record->field('6..')) {
1007             push @notes, { note => $field->as_string(), field => $field->tag() };
1008         }
1009         foreach my $field ($record->field('880')) {
1010             my $linkage = $field->subfield('6');
1011             my $category = substr $linkage, 0, 1;
1012             if ($category eq '1') {
1013                 $category = 'preferred';
1014             } elsif ($category eq '4') {
1015                 $category = 'seefrom';
1016             } elsif ($category eq '5') {
1017                 $category = 'seealso';
1018             }
1019             my $type;
1020             if ($field->subfield('w')) {
1021                 $type = $marc21controlrefs{substr $field->subfield('w'), '0'};
1022             } else {
1023                 $type = $category;
1024             }
1025             my $direction = $linkage =~ m#/r$# ? 'rtl' : 'ltr';
1026             push @otherscript, { term => $field->as_string($subfields_to_report), category => $category, type => $type, direction => $direction, linkage => $linkage };
1027         }
1028     }
1029     $summary{mainentry} = $authorized[0]->{heading};
1030     $summary{mainmainentry} = $authorized[0]->{hemain};
1031     $summary{authorized} = \@authorized;
1032     $summary{notes} = \@notes;
1033     $summary{seefrom} = \@seefrom;
1034     $summary{seealso} = \@seealso;
1035     $summary{otherscript} = \@otherscript;
1036     return \%summary;
1037 }
1038
1039 =head2 GetAuthorizedHeading
1040
1041   $heading = &GetAuthorizedHeading({ record => $record, authid => $authid })
1042
1043 Takes a MARC::Record object describing an authority record or an authid, and
1044 returns a string representation of the first authorized heading. This routine
1045 should be considered a temporary shim to ease the future migration of authority
1046 data from C4::AuthoritiesMarc to the object-oriented Koha::*::Authority.
1047
1048 =cut
1049
1050 sub GetAuthorizedHeading {
1051     my $args = shift;
1052     my $record;
1053     unless ($record = $args->{record}) {
1054         return unless $args->{authid};
1055         $record = GetAuthority($args->{authid});
1056     }
1057     return unless (ref $record eq 'MARC::Record');
1058     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1059 # construct UNIMARC summary, that is quite different from MARC21 one
1060 # accepted form
1061         foreach my $field ($record->field('2..')) {
1062             return $field->as_string('abcdefghijlmnopqrstuvwxyz');
1063         }
1064     } else {
1065         use C4::Heading::MARC21;
1066         my $handler = C4::Heading::MARC21->new();
1067
1068         foreach my $field ($record->field('1..')) {
1069             my $subfields = $handler->get_valid_bib_heading_subfields($field->tag());
1070             return $field->as_string($subfields) if ($subfields);
1071         }
1072     }
1073     return;
1074 }
1075
1076 =head2 CompareFieldWithAuthority
1077
1078   $match = &CompareFieldWithAuthority({ field => $field, authid => $authid })
1079
1080 Takes a MARC::Field from a bibliographic record and an authid, and returns true if they match.
1081
1082 =cut
1083
1084 sub CompareFieldWithAuthority {
1085     my $args = shift;
1086
1087     my $record = GetAuthority($args->{authid});
1088     return unless (ref $record eq 'MARC::Record');
1089     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1090         # UNIMARC has same subfields for bibs and authorities
1091         foreach my $field ($record->field('2..')) {
1092             return compare_fields($field, $args->{field}, 'abcdefghijlmnopqrstuvwxyz');
1093         }
1094     } else {
1095         use C4::Heading::MARC21;
1096         my $handler = C4::Heading::MARC21->new();
1097
1098         foreach my $field ($record->field('1..')) {
1099             my $subfields = $handler->get_valid_bib_heading_subfields($field->tag());
1100             return compare_fields($field, $args->{field}, $subfields) if ($subfields);
1101         }
1102     }
1103     return 0;
1104 }
1105
1106 =head2 BuildAuthHierarchies
1107
1108   $text= &BuildAuthHierarchies( $authid, $force)
1109
1110 return text containing trees for hierarchies
1111 for them to be stored in auth_header
1112
1113 Example of text:
1114 122,1314,2452;1324,2342,3,2452
1115
1116 =cut
1117
1118 sub BuildAuthHierarchies{
1119     my $authid = shift @_;
1120 #   warn "authid : $authid";
1121     my $force = shift @_ || (C4::Context->preference('marcflavour') eq 'UNIMARC' ? 0 : 1);
1122     my @globalresult;
1123     my $dbh=C4::Context->dbh;
1124     my $hierarchies;
1125     my $data = GetHeaderAuthority($authid);
1126     if ($data->{'authtrees'} and not $force){
1127         return $data->{'authtrees'};
1128 #  } elsif ($data->{'authtrees'}){
1129 #    $hierarchies=$data->{'authtrees'};
1130     } else {
1131         my $record = GetAuthority($authid);
1132         my $found;
1133         return unless $record;
1134         foreach my $field ($record->field('5..')){
1135             my $broader = 0;
1136             $broader = 1 if (
1137                     (C4::Context->preference('marcflavour') eq 'UNIMARC' && $field->subfield('5') && $field->subfield('5') eq 'g') ||
1138                     (C4::Context->preference('marcflavour') ne 'UNIMARC' && $field->subfield('w') && substr($field->subfield('w'), 0, 1) eq 'g'));
1139             if ($broader) {
1140                 my $subfauthid=_get_authid_subfield($field) || '';
1141                 next if ($subfauthid eq $authid);
1142                 my $parentrecord = GetAuthority($subfauthid);
1143                 next unless $parentrecord;
1144                 my $localresult=$hierarchies;
1145                 my $trees;
1146                 $trees = BuildAuthHierarchies($subfauthid);
1147                 my @trees;
1148                 if ($trees=~/;/){
1149                     @trees = split(/;/,$trees);
1150                 } else {
1151                     push @trees, $trees;
1152                 }
1153                 foreach (@trees){
1154                     $_.= ",$authid";
1155                 }
1156                 @globalresult = (@globalresult,@trees);
1157                 $found=1;
1158             }
1159             $hierarchies=join(";",@globalresult);
1160         }
1161 #Unless there is no ancestor, I am alone.
1162         $hierarchies="$authid" unless ($hierarchies);
1163     }
1164     AddAuthorityTrees($authid,$hierarchies);
1165     return $hierarchies;
1166 }
1167
1168 =head2 BuildAuthHierarchy
1169
1170   $ref= &BuildAuthHierarchy( $record, $class,$authid)
1171
1172 return a hashref in order to display hierarchy for record and final Authid $authid
1173
1174 "loopparents"
1175 "loopchildren"
1176 "class"
1177 "loopauthid"
1178 "current_value"
1179 "value"
1180
1181 =cut
1182
1183 sub BuildAuthHierarchy{
1184     my $record = shift @_;
1185     my $class = shift @_;
1186     my $authid_constructed = shift @_;
1187     return unless ($record && $record->field('001'));
1188     my $authid=$record->field('001')->data();
1189     my %cell;
1190     my $parents=""; my $children="";
1191     my (@loopparents,@loopchildren);
1192     my $marcflavour = C4::Context->preference('marcflavour');
1193     my $relationshipsf = $marcflavour eq 'UNIMARC' ? '5' : 'w';
1194     foreach my $field ($record->field('5..')){
1195         my $subfauthid=_get_authid_subfield($field);
1196         if ($subfauthid && $field->subfield($relationshipsf) && $field->subfield('a')){
1197             my $relationship = substr($field->subfield($relationshipsf), 0, 1);
1198             if ($relationship eq 'h'){
1199                 push @loopchildren, { "authid"=>$subfauthid,"value"=>$field->subfield('a')};
1200             }
1201             elsif ($relationship eq 'g'){
1202                 push @loopparents, { "authid"=>$subfauthid,"value"=>$field->subfield('a')};
1203             }
1204 # brothers could get in there with an else
1205         }
1206     }
1207     $cell{"parents"}=\@loopparents;
1208     $cell{"children"}=\@loopchildren;
1209     $cell{"class"}=$class;
1210     $cell{"authid"}=$authid;
1211     $cell{"current_value"} =1 if ($authid eq $authid_constructed);
1212     $cell{"value"}=C4::Context->preference('marcflavour') eq 'UNIMARC' ? $record->subfield('2..',"a") : $record->subfield('1..', 'a');
1213     return \%cell;
1214 }
1215
1216 =head2 BuildAuthHierarchyBranch
1217
1218   $branch = &BuildAuthHierarchyBranch( $tree, $authid[, $cnt])
1219
1220 Return a data structure representing an authority hierarchy
1221 given a list of authorities representing a single branch in
1222 an authority hierarchy tree. $authid is the current node in
1223 the tree (which may or may not be somewhere in the middle).
1224 $cnt represents the level of the upper-most item, and is only
1225 used when BuildAuthHierarchyBranch is called recursively (i.e.,
1226 don't ever pass in anything but zero to it).
1227
1228 =cut
1229
1230 sub BuildAuthHierarchyBranch {
1231     my ($tree, $authid, $cnt) = @_;
1232     $cnt |= 0;
1233     my $elementdata = GetAuthority(shift @$tree);
1234     my $branch = BuildAuthHierarchy($elementdata,"child".$cnt, $authid);
1235     if (scalar @$tree > 0) {
1236         my $nextBranch = BuildAuthHierarchyBranch($tree, $authid, ++$cnt);
1237         my $nextAuthid = $nextBranch->{authid};
1238         my $found;
1239         # If we already have the next branch listed as a child, let's
1240         # replace the old listing with the new one. If not, we will add
1241         # the branch at the end.
1242         foreach my $cell (@{$branch->{children}}) {
1243             if ($cell->{authid} eq $nextAuthid) {
1244                 $cell = $nextBranch;
1245                 $found = 1;
1246                 last;
1247             }
1248         }
1249         push @{$branch->{children}}, $nextBranch unless $found;
1250     }
1251     return $branch;
1252 }
1253
1254 =head2 GenerateHierarchy
1255
1256   $hierarchy = &GenerateHierarchy($authid);
1257
1258 Return an arrayref holding one or more "trees" representing
1259 authority hierarchies.
1260
1261 =cut
1262
1263 sub GenerateHierarchy {
1264     my ($authid) = @_;
1265     my $trees    = BuildAuthHierarchies($authid);
1266     my @trees    = split /;/,$trees ;
1267     push @trees,$trees unless (@trees);
1268     my @loophierarchies;
1269     foreach my $tree (@trees){
1270         my @tree=split /,/,$tree;
1271         push @tree, $tree unless (@tree);
1272         my $branch = BuildAuthHierarchyBranch(\@tree, $authid);
1273         push @loophierarchies, [ $branch ];
1274     }
1275     return \@loophierarchies;
1276 }
1277
1278 sub _get_authid_subfield{
1279     my ($field)=@_;
1280     return $field->subfield('9')||$field->subfield('3');
1281 }
1282
1283 =head2 GetHeaderAuthority
1284
1285   $ref= &GetHeaderAuthority( $authid)
1286
1287 return a hashref in order auth_header table data
1288
1289 =cut
1290
1291 sub GetHeaderAuthority{
1292   my $authid = shift @_;
1293   my $sql= "SELECT * from auth_header WHERE authid = ?";
1294   my $dbh=C4::Context->dbh;
1295   my $rq= $dbh->prepare($sql);
1296   $rq->execute($authid);
1297   my $data= $rq->fetchrow_hashref;
1298   return $data;
1299 }
1300
1301 =head2 AddAuthorityTrees
1302
1303   $ref= &AddAuthorityTrees( $authid, $trees)
1304
1305 return success or failure
1306
1307 =cut
1308
1309 sub AddAuthorityTrees{
1310   my $authid = shift @_;
1311   my $trees = shift @_;
1312   my $sql= "UPDATE IGNORE auth_header set authtrees=? WHERE authid = ?";
1313   my $dbh=C4::Context->dbh;
1314   my $rq= $dbh->prepare($sql);
1315   return $rq->execute($trees,$authid);
1316 }
1317
1318 =head2 merge
1319
1320     $count = merge({
1321         mergefrom => $mergefrom,
1322         [ MARCfrom => $MARCfrom, ]
1323         [ mergeto => $mergeto, ]
1324         [ MARCto => $MARCto, ]
1325         [ biblionumbers => [ $a, $b, $c ], ]
1326         [ override_limit => 1, ]
1327     });
1328
1329 Merge biblios linked to authority $mergefrom (mandatory parameter).
1330 If $mergeto equals mergefrom, the linked biblio field is updated.
1331 If $mergeto is different, the biblio field will be linked to $mergeto.
1332 If $mergeto is missing, the biblio field is deleted.
1333
1334 MARCfrom is used to determine if a cleared subfield in the authority record
1335 should be removed from a biblio. MARCto is used to populate the biblio
1336 record with the updated values; if you do not pass it, the biblio field
1337 will be deleted (same as missing mergeto).
1338
1339 Normally all biblio records linked to $mergefrom, will be considered. But
1340 you can pass specific numbers via the biblionumbers parameter.
1341
1342 The parameter override_limit is used by the cron job to force larger
1343 postponed merges.
1344
1345 Note: Although $mergefrom and $mergeto will normally be of the same
1346 authority type, merge also supports moving to another authority type.
1347
1348 =cut
1349
1350 sub merge {
1351     my ( $params ) = @_;
1352     my $mergefrom = $params->{mergefrom} || return;
1353     my $MARCfrom = $params->{MARCfrom};
1354     my $mergeto = $params->{mergeto};
1355     my $MARCto = $params->{MARCto};
1356     my $override_limit = $params->{override_limit};
1357
1358     # If we do not have biblionumbers, we get all linked biblios if the
1359     # number of linked records does not exceed the limit UNLESS we override.
1360     my @biblionumbers;
1361     if( $params->{biblionumbers} ) {
1362         @biblionumbers = @{ $params->{biblionumbers} };
1363     } elsif( $override_limit ) {
1364         @biblionumbers = Koha::Authorities->linked_biblionumbers({ authid => $mergefrom });
1365     } else { # now first check number of linked records
1366         my $max = C4::Context->preference('AuthorityMergeLimit') // 0;
1367         my $hits = Koha::Authorities->get_usage_count({ authid => $mergefrom });
1368         if( $hits > 0 && $hits <= $max ) {
1369             @biblionumbers = Koha::Authorities->linked_biblionumbers({ authid => $mergefrom });
1370         } elsif( $hits > $max ) { #postpone this merge to the cron job
1371             Koha::Authority::MergeRequest->new({
1372                 authid => $mergefrom,
1373                 oldrecord => $MARCfrom,
1374                 authid_new => $mergeto,
1375             })->store;
1376         }
1377     }
1378     return 0 if !@biblionumbers;
1379
1380     # Search authtypes and reporting tags
1381     my $authfrom = Koha::Authorities->find($mergefrom);
1382     my $authto = Koha::Authorities->find($mergeto);
1383     my $authtypefrom = $authfrom ? Koha::Authority::Types->find($authfrom->authtypecode) : undef;
1384     my $authtypeto   = $authto ? Koha::Authority::Types->find($authto->authtypecode) : undef;
1385     my $auth_tag_to_report_from = $authtypefrom ? $authtypefrom->auth_tag_to_report : '';
1386     my $auth_tag_to_report_to   = $authtypeto ? $authtypeto->auth_tag_to_report : '';
1387
1388     my @record_to;
1389     @record_to = $MARCto->field($auth_tag_to_report_to)->subfields() if $auth_tag_to_report_to && $MARCto && $MARCto->field($auth_tag_to_report_to);
1390     # Exceptional: If MARCto and authtypeto exist but $auth_tag_to_report_to
1391     # is empty, make sure that $9 and $a remain (instead of clearing the
1392     # reference) in order to allow for data recovery.
1393     # Note: We need $a too, since a single $9 does not pass ModBiblio.
1394     if( $MARCto && $authtypeto && !@record_to  ) {
1395         push @record_to, [ 'a', ' ' ]; # do not remove the space
1396     }
1397
1398     my @record_from;
1399     if( !$authfrom && $MARCfrom && $MARCfrom->field('1..','2..') ) {
1400     # postponed merge, authfrom was deleted and MARCfrom only contains the old reporting tag (and possibly a 100 for UNIMARC)
1401     # 2XX is for UNIMARC; we use -1 in order to skip 100 in UNIMARC; this will not impact MARC21, since there is only one tag
1402         @record_from = ( $MARCfrom->field('1..','2..') )[-1]->subfields;
1403     } elsif( $auth_tag_to_report_from && $MARCfrom && $MARCfrom->field($auth_tag_to_report_from) ) {
1404         @record_from = $MARCfrom->field($auth_tag_to_report_from)->subfields;
1405     }
1406
1407     # Get all candidate tags for the change
1408     # (This will reduce the search scope in marc records).
1409     # For a deleted authority record, we scan all auth controlled fields
1410     my $dbh = C4::Context->dbh;
1411     my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
1412     my $tags_using_authtype = $authtypefrom && $authtypefrom->authtypecode ? $dbh->selectcol_arrayref( $sql, undef, ( $authtypefrom->authtypecode )) : $dbh->selectcol_arrayref( "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode IS NOT NULL AND authtypecode<>''" );
1413     my $tags_new;
1414     if( $authtypeto && ( !$authtypefrom || $authtypeto->authtypecode ne $authtypefrom->authtypecode )) {
1415         $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypeto->authtypecode ));
1416     }
1417
1418     my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1419     my $skip_subfields = $overwrite
1420         # This hash contains all subfields from the authority report fields
1421         # Including $MARCfrom as well as $MARCto
1422         # We only need it in loose merge mode; replaces the former $exclude
1423         ? {}
1424         : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
1425
1426     my $counteditedbiblio = 0;
1427     foreach my $biblionumber ( @biblionumbers ) {
1428         my $marcrecord = GetMarcBiblio({ biblionumber => $biblionumber });
1429         next if !$marcrecord;
1430         my $update = 0;
1431         foreach my $tagfield (@$tags_using_authtype) {
1432             my $countfrom = 0;    # used in strict mode to remove duplicates
1433             foreach my $field ( $marcrecord->field($tagfield) ) {
1434                 my $auth_number = $field->subfield("9");    # link to authority
1435                 my $tag         = $field->tag();
1436                 next if !defined($auth_number) || $auth_number ne $mergefrom;
1437                 $countfrom++;
1438                 if ( !$mergeto || !@record_to ||
1439                   ( $overwrite && $countfrom > 1 ) ) {
1440                     # !mergeto or !record_to indicates a delete
1441                     # Other condition: remove this duplicate in strict mode
1442                     $marcrecord->delete_field($field);
1443                     $update = 1;
1444                     next;
1445                 }
1446                 my $newtag = $tags_new && @$tags_new
1447                   ? _merge_newtag( $tag, $tags_new )
1448                   : $tag;
1449                 my $controlled_ind = $authto->controlled_indicators({ record => $MARCto, biblio_tag => $newtag });
1450                 my $field_to = MARC::Field->new(
1451                     $newtag,
1452                     $controlled_ind->{ind1} // $field->indicator(1),
1453                     $controlled_ind->{ind2} // $field->indicator(2),
1454                     9 => $mergeto, # Needed to create field, will be moved
1455                 );
1456                 my ( @prefix, @postfix );
1457                 if ( !$overwrite ) {
1458                     # add subfields back in loose mode, check skip_subfields
1459                     # The first extra subfields will be in front of the
1460                     # controlled block, the rest at the end.
1461                     my $prefix_flag = 1;
1462                     foreach my $subfield ( $field->subfields ) {
1463                         next if $subfield->[0] eq '9'; # skip but leave flag
1464                         if ( $skip_subfields->{ $subfield->[0] } ) {
1465                             # This marks the beginning of the controlled block
1466                             $prefix_flag = 0;
1467                             next;
1468                         }
1469                         if ($prefix_flag) {
1470                             push @prefix, [ $subfield->[0], $subfield->[1] ];
1471                         } else {
1472                             push @postfix, [ $subfield->[0], $subfield->[1] ];
1473                         }
1474                     }
1475                 }
1476                 foreach my $subfield ( @prefix, @record_to, @postfix ) {
1477                     $field_to->add_subfields($subfield->[0] => $subfield->[1]);
1478                 }
1479                 if( exists $controlled_ind->{sub2} ) { # thesaurus info
1480                     if( defined $controlled_ind->{sub2} ) {
1481                         # Add or replace
1482                         $field_to->update( 2 => $controlled_ind->{sub2} );
1483                     } else {
1484                         # Key alerts us here to remove $2
1485                         $field_to->delete_subfield( code => '2' );
1486                     }
1487                 }
1488                 # Move $9 to the end
1489                 $field_to->delete_subfield( code => '9' );
1490                 $field_to->add_subfields( 9 => $mergeto );
1491
1492                 if ($tags_new && @$tags_new) {
1493                     $marcrecord->delete_field($field);
1494                     append_fields_ordered( $marcrecord, $field_to );
1495                 } else {
1496                     $field->replace_with($field_to);
1497                 }
1498                 $update = 1;
1499             }
1500         }
1501         next if !$update;
1502         ModBiblio($marcrecord, $biblionumber, GetFrameworkCode($biblionumber));
1503         $counteditedbiblio++;
1504     }
1505     return $counteditedbiblio;
1506 }
1507
1508 sub _merge_newtag {
1509 # Routine is only called for an (exceptional) authtypecode change
1510 # Fixes old behavior of returning the first tag found
1511     my ( $oldtag, $new_tags ) = @_;
1512
1513     # If we e.g. have 650 and 151,651,751 try 651 and check presence
1514     my $prefix = substr( $oldtag, 0, 1 );
1515     my $guess = $prefix . substr( $new_tags->[0], -2 );
1516     if( grep { $_ eq $guess } @$new_tags ) {
1517         return $guess;
1518     }
1519     # Otherwise return one from the same block e.g. 6XX for 650
1520     # If not there too, fall back to first new tag (old behavior!)
1521     my @same_block = grep { /^$prefix/ } @$new_tags;
1522     return @same_block ? $same_block[0] : $new_tags->[0];
1523 }
1524
1525 sub append_fields_ordered {
1526 # while we lack this function in MARC::Record
1527 # we do not want insert_fields_ordered since it inserts before
1528     my ( $record, $field ) = @_;
1529     if( my @flds = $record->field( $field->tag ) ) {
1530         $record->insert_fields_after( pop @flds, $field );
1531     } else { # now fallback to insert_fields_ordered
1532         $record->insert_fields_ordered( $field );
1533     }
1534 }
1535
1536 =head2 get_auth_type_location
1537
1538   my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1539
1540 Get the tag and subfield used to store the heading type
1541 for indexing purposes.  The C<$auth_type> parameter is
1542 optional; if it is not supplied, assume ''.
1543
1544 This routine searches the MARC authority framework
1545 for the tag and subfield whose kohafield is
1546 C<auth_header.authtypecode>; if no such field is
1547 defined in the framework, default to the hardcoded value
1548 specific to the MARC format.
1549
1550 =cut
1551
1552 sub get_auth_type_location {
1553     my $auth_type_code = @_ ? shift : '';
1554
1555     my ($tag, $subfield) = GetAuthMARCFromKohaField('auth_header.authtypecode', $auth_type_code);
1556     if (defined $tag and defined $subfield and $tag != 0 and $subfield ne '' and $subfield ne ' ') {
1557         return ($tag, $subfield);
1558     } else {
1559         if (C4::Context->preference('marcflavour') eq "MARC21")  {
1560             return C4::AuthoritiesMarc::MARC21::default_auth_type_location();
1561         } else {
1562             return C4::AuthoritiesMarc::UNIMARC::default_auth_type_location();
1563         }
1564     }
1565 }
1566
1567 =head2 compare_fields
1568
1569   my match = compare_fields($field1, $field2, 'abcde');
1570
1571 Compares the listed subfields of both fields and return true if they all match
1572
1573 =cut
1574
1575 sub compare_fields {
1576     my ($field1, $field2, $subfields) = @_;
1577
1578     foreach my $subfield (split(//, $subfields)) {
1579         my $subfield1 = $field1->subfield($subfield) // '';
1580         my $subfield2 = $field2->subfield($subfield) // '';
1581         return 0 unless $subfield1 eq $subfield2;
1582     }
1583     return 1;
1584 }
1585
1586
1587 END { }       # module clean-up code here (global destructor)
1588
1589 1;
1590 __END__
1591
1592 =head1 AUTHOR
1593
1594 Koha Development Team <http://koha-community.org/>
1595
1596 Paul POULAIN paul.poulain@free.fr
1597 Ere Maijala ere.maijala@helsinki.fi
1598
1599 =cut
1600