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