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 GetMarcBiblio 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 "
 187                   ;    #Firstinfield Phrase, Right truncated
 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     if (!$authid ) {
 647         $action = 'create';
 648         # Save a blank record, get authid
 649         $dbh->do( "INSERT INTO auth_header (datecreated,marcxml) values (NOW(),?)", undef, '' );
 650         $authid = $dbh->last_insert_id( undef, undef, 'auth_header', 'authid' );
 651         logaction( "AUTHORITIES", "ADD", $authid, "authority" ) if C4::Context->preference("AuthoritiesLog");
 652     } else {
 653         $action = 'modify';
 654     }
 655     # Insert/update the recordID in MARC record
 656     $record->delete_field( $record->field('001') );
 657     $record->insert_fields_ordered( MARC::Field->new( '001', $authid ) );
 658     # Update
 659     $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;
 660
 661     unless ( $skip_record_index ) {
 662         my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::AUTHORITIES_INDEX });
 663         $indexer->index_records( $authid, "specialUpdate", "authorityserver", $record );
 664     }
 665
 666     _after_authority_action_hooks({ action => $action, authority_id => $authid });
 667     return ( $authid );
 668 }
 669
 670 =head2 DelAuthority
 671
 672     DelAuthority({ authid => $authid, [ skip_merge => 1 ] });
 673
 674 Deletes $authid and calls merge to cleanup linked biblio records.
 675 Parameter skip_merge is used in authorities/merge.pl. You should normally not
 676 use it.
 677
 678 skip_record_index will skip the indexation step.
 679
 680 =cut
 681
 682 sub DelAuthority {
 683     my ( $params ) = @_;
 684     my $authid = $params->{authid} || return;
 685     my $skip_merge = $params->{skip_merge};
 686     my $skip_record_index = $params->{skip_record_index} || 0;
 687
 688     my $dbh = C4::Context->dbh;
 689
 690     # Remove older pending merge requests for $authid to itself. (See bug 22437)
 691     my $condition = { authid => $authid, authid_new => [undef, 0, $authid], done => 0 };
 692     Koha::Authority::MergeRequests->search($condition)->delete;
 693
 694     merge({ mergefrom => $authid }) if !$skip_merge;
 695     $dbh->do( "DELETE FROM auth_header WHERE authid=?", undef, $authid );
 696     logaction( "AUTHORITIES", "DELETE", $authid, "authority" ) if C4::Context->preference("AuthoritiesLog");
 697     unless ( $skip_record_index ) {
 698         my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::AUTHORITIES_INDEX });
 699         $indexer->index_records( $authid, "recordDelete", "authorityserver", undef );
 700     }
 701
 702     _after_authority_action_hooks({ action => 'delete', authority_id => $authid });
 703 }
 704
 705 =head2 ModAuthority
 706
 707   $authid= &ModAuthority($authid,$record,$authtypecode, [ { skip_merge => 1 ] )
 708
 709 Modifies authority record, optionally updates attached biblios.
 710 The parameter skip_merge is optional and should be used with care.
 711
 712 skip_record_index will skip the indexation step.
 713
 714 =cut
 715
 716 sub ModAuthority {
 717     my ( $authid, $record, $authtypecode, $params ) = @_;
 718
 719     my $skip_record_index = $params->{skip_record_index} || 0;
 720
 721     my $oldrecord = GetAuthority($authid);
 722     #Now rewrite the $record to table with an add
 723     $authid = AddAuthority($record, $authid, $authtypecode, { skip_record_index => $skip_record_index });
 724     merge({ mergefrom => $authid, MARCfrom => $oldrecord, mergeto => $authid, MARCto => $record }) if !$params->{skip_merge};
 725     logaction( "AUTHORITIES", "MODIFY", $authid, "authority BEFORE=>" . $oldrecord->as_formatted ) if C4::Context->preference("AuthoritiesLog");
 726     return $authid;
 727 }
 728
 729 =head2 GetAuthorityXML
 730
 731   $marcxml= &GetAuthorityXML( $authid)
 732
 733 returns xml form of record $authid
 734
 735 =cut
 736
 737 sub GetAuthorityXML {
 738   # Returns MARC::XML of the authority passed in parameter.
 739   my ( $authid ) = @_;
 740   if (uc(C4::Context->preference('marcflavour')) eq 'UNIMARC') {
 741       my $dbh=C4::Context->dbh;
 742       my $sth = $dbh->prepare("select marcxml from auth_header where authid=? "  );
 743       $sth->execute($authid);
 744       my ($marcxml)=$sth->fetchrow;
 745       return $marcxml;
 746   }
 747   else {
 748       # for MARC21, call GetAuthority instead of
 749       # getting the XML directly since we may
 750       # need to fix up the location of the authority
 751       # code -- note that this is reasonably safe
 752       # because GetAuthorityXML is used only by the
 753       # indexing processes like zebraqueue_start.pl
 754       my $record = GetAuthority($authid);
 755       return $record->as_xml_record('MARC21');
 756   }
 757 }
 758
 759 =head2 GetAuthority
 760
 761   $record= &GetAuthority( $authid)
 762
 763 Returns MARC::Record of the authority passed in parameter.
 764
 765 =cut
 766
 767 sub GetAuthority {
 768     my ($authid)=@_;
 769     my $authority = Koha::MetadataRecord::Authority->get_from_authid($authid);
 770     return unless $authority;
 771     return ($authority->record);
 772 }
 773
 774 =head2 FindDuplicateAuthority
 775
 776   $record= &FindDuplicateAuthority( $record, $authtypecode)
 777
 778 return $authid,Summary if duplicate is found.
 779
 780 Comments : an improvement would be to return All the records that match.
 781
 782 =cut
 783
 784 sub FindDuplicateAuthority {
 785
 786     my ($record,$authtypecode)=@_;
 787 #    warn "IN for ".$record->as_formatted;
 788     my $dbh = C4::Context->dbh;
 789 #    warn "".$record->as_formatted;
 790     my $auth_tag_to_report = Koha::Authority::Types->find($authtypecode)->auth_tag_to_report;
 791 #     warn "record :".$record->as_formatted."  auth_tag_to_report :$auth_tag_to_report";
 792     # build a request for SearchAuthorities
 793     my $op = 'AND';
 794     $authtypecode =~ s#/#\\/#; # GENRE/FORM contains forward slash which is a reserved character
 795     my $query='at:'.$authtypecode.' ';
 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 = $authfrom ? Koha::Authority::Types->find($authfrom->authtypecode) : undef;
1422     my $authtypeto   = $authto ? Koha::Authority::Types->find($authto->authtypecode) : undef;
1423     my $auth_tag_to_report_from = $authtypefrom ? $authtypefrom->auth_tag_to_report : '';
1424     my $auth_tag_to_report_to   = $authtypeto ? $authtypeto->auth_tag_to_report : '';
1425
1426     my @record_to;
1427     @record_to = $MARCto->field($auth_tag_to_report_to)->subfields() if $auth_tag_to_report_to && $MARCto && $MARCto->field($auth_tag_to_report_to);
1428     # Exceptional: If MARCto and authtypeto exist but $auth_tag_to_report_to
1429     # is empty, make sure that $9 and $a remain (instead of clearing the
1430     # reference) in order to allow for data recovery.
1431     # Note: We need $a too, since a single $9 does not pass ModBiblio.
1432     if( $MARCto && $authtypeto && !@record_to  ) {
1433         push @record_to, [ 'a', ' ' ]; # do not remove the space
1434     }
1435
1436     my @record_from;
1437     if( !$authfrom && $MARCfrom && $MARCfrom->field('1..','2..') ) {
1438     # postponed merge, authfrom was deleted and MARCfrom only contains the old reporting tag (and possibly a 100 for UNIMARC)
1439     # 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
1440         @record_from = ( $MARCfrom->field('1..','2..') )[-1]->subfields;
1441     } elsif( $auth_tag_to_report_from && $MARCfrom && $MARCfrom->field($auth_tag_to_report_from) ) {
1442         @record_from = $MARCfrom->field($auth_tag_to_report_from)->subfields;
1443     }
1444
1445     # Get all candidate tags for the change
1446     # (This will reduce the search scope in marc records).
1447     # For a deleted authority record, we scan all auth controlled fields
1448     my $dbh = C4::Context->dbh;
1449     my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
1450     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<>''" );
1451     my $tags_new;
1452     if( $authtypeto && ( !$authtypefrom || $authtypeto->authtypecode ne $authtypefrom->authtypecode )) {
1453         $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypeto->authtypecode ));
1454     }
1455
1456     my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1457     my $skip_subfields = $overwrite
1458         # This hash contains all subfields from the authority report fields
1459         # Including $MARCfrom as well as $MARCto
1460         # We only need it in loose merge mode; replaces the former $exclude
1461         ? {}
1462         : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
1463
1464     my $counteditedbiblio = 0;
1465     foreach my $biblionumber ( @biblionumbers ) {
1466         my $marcrecord = GetMarcBiblio({ biblionumber => $biblionumber });
1467         next if !$marcrecord;
1468         my $update = 0;
1469         foreach my $tagfield (@$tags_using_authtype) {
1470             my $countfrom = 0;    # used in strict mode to remove duplicates
1471             foreach my $field ( $marcrecord->field($tagfield) ) {
1472                 my $auth_number = $field->subfield("9");    # link to authority
1473                 my $tag         = $field->tag();
1474                 next if !defined($auth_number) || $auth_number ne $mergefrom;
1475                 $countfrom++;
1476                 if ( !$mergeto || !@record_to ||
1477                   ( $overwrite && $countfrom > 1 ) ) {
1478                     # !mergeto or !record_to indicates a delete
1479                     # Other condition: remove this duplicate in strict mode
1480                     $marcrecord->delete_field($field);
1481                     $update = 1;
1482                     next;
1483                 }
1484                 my $newtag = $tags_new && @$tags_new
1485                   ? _merge_newtag( $tag, $tags_new )
1486                   : $tag;
1487                 my $controlled_ind = $authto->controlled_indicators({ record => $MARCto, biblio_tag => $newtag });
1488                 my $field_to = MARC::Field->new(
1489                     $newtag,
1490                     $controlled_ind->{ind1} // $field->indicator(1),
1491                     $controlled_ind->{ind2} // $field->indicator(2),
1492                     9 => $mergeto, # Needed to create field, will be moved
1493                 );
1494                 my ( @prefix, @postfix );
1495                 if ( !$overwrite ) {
1496                     # add subfields back in loose mode, check skip_subfields
1497                     # The first extra subfields will be in front of the
1498                     # controlled block, the rest at the end.
1499                     my $prefix_flag = 1;
1500                     foreach my $subfield ( $field->subfields ) {
1501                         next if $subfield->[0] eq '9'; # skip but leave flag
1502                         if ( $skip_subfields->{ $subfield->[0] } ) {
1503                             # This marks the beginning of the controlled block
1504                             $prefix_flag = 0;
1505                             next;
1506                         }
1507                         if ($prefix_flag) {
1508                             push @prefix, [ $subfield->[0], $subfield->[1] ];
1509                         } else {
1510                             push @postfix, [ $subfield->[0], $subfield->[1] ];
1511                         }
1512                     }
1513                 }
1514                 foreach my $subfield ( @prefix, @record_to, @postfix ) {
1515                     $field_to->add_subfields($subfield->[0] => $subfield->[1]);
1516                 }
1517                 if( exists $controlled_ind->{sub2} ) { # thesaurus info
1518                     if( defined $controlled_ind->{sub2} ) {
1519                         # Add or replace
1520                         $field_to->update( 2 => $controlled_ind->{sub2} );
1521                     } else {
1522                         # Key alerts us here to remove $2
1523                         $field_to->delete_subfield( code => '2' );
1524                     }
1525                 }
1526                 # Move $9 to the end
1527                 $field_to->delete_subfield( code => '9' );
1528                 $field_to->add_subfields( 9 => $mergeto );
1529
1530                 if ($tags_new && @$tags_new) {
1531                     $marcrecord->delete_field($field);
1532                     append_fields_ordered( $marcrecord, $field_to );
1533                 } else {
1534                     $field->replace_with($field_to);
1535                 }
1536                 $update = 1;
1537             }
1538         }
1539         next if !$update;
1540         ModBiblio($marcrecord, $biblionumber, GetFrameworkCode($biblionumber));
1541         $counteditedbiblio++;
1542     }
1543     return $counteditedbiblio;
1544 }
1545
1546 sub _merge_newtag {
1547 # Routine is only called for an (exceptional) authtypecode change
1548 # Fixes old behavior of returning the first tag found
1549     my ( $oldtag, $new_tags ) = @_;
1550
1551     # If we e.g. have 650 and 151,651,751 try 651 and check presence
1552     my $prefix = substr( $oldtag, 0, 1 );
1553     my $guess = $prefix . substr( $new_tags->[0], -2 );
1554     if( grep { $_ eq $guess } @$new_tags ) {
1555         return $guess;
1556     }
1557     # Otherwise return one from the same block e.g. 6XX for 650
1558     # If not there too, fall back to first new tag (old behavior!)
1559     my @same_block = grep { /^$prefix/ } @$new_tags;
1560     return @same_block ? $same_block[0] : $new_tags->[0];
1561 }
1562
1563 sub append_fields_ordered {
1564 # while we lack this function in MARC::Record
1565 # we do not want insert_fields_ordered since it inserts before
1566     my ( $record, $field ) = @_;
1567     if( my @flds = $record->field( $field->tag ) ) {
1568         $record->insert_fields_after( pop @flds, $field );
1569     } else { # now fallback to insert_fields_ordered
1570         $record->insert_fields_ordered( $field );
1571     }
1572 }
1573
1574 =head2 get_auth_type_location
1575
1576   my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1577
1578 Get the tag and subfield used to store the heading type
1579 for indexing purposes.  The C<$auth_type> parameter is
1580 optional; if it is not supplied, assume ''.
1581
1582 This routine searches the MARC authority framework
1583 for the tag and subfield whose kohafield is
1584 C<auth_header.authtypecode>; if no such field is
1585 defined in the framework, default to the hardcoded value
1586 specific to the MARC format.
1587
1588 =cut
1589
1590 sub get_auth_type_location {
1591     my $auth_type_code = @_ ? shift : '';
1592
1593     my ($tag, $subfield) = GetAuthMARCFromKohaField('auth_header.authtypecode', $auth_type_code);
1594     if (defined $tag and defined $subfield and $tag != 0 and $subfield ne '' and $subfield ne ' ') {
1595         return ($tag, $subfield);
1596     } else {
1597         if (C4::Context->preference('marcflavour') eq "MARC21")  {
1598             return C4::AuthoritiesMarc::MARC21::default_auth_type_location();
1599         } else {
1600             return C4::AuthoritiesMarc::UNIMARC::default_auth_type_location();
1601         }
1602     }
1603 }
1604
1605 =head2 compare_fields
1606
1607   my match = compare_fields($field1, $field2, 'abcde');
1608
1609 Compares the listed subfields of both fields and return true if they all match
1610
1611 =cut
1612
1613 sub compare_fields {
1614     my ($field1, $field2, $subfields) = @_;
1615
1616     foreach my $subfield (split(//, $subfields)) {
1617         my $subfield1 = $field1->subfield($subfield) // '';
1618         my $subfield2 = $field2->subfield($subfield) // '';
1619         return 0 unless $subfield1 eq $subfield2;
1620     }
1621     return 1;
1622 }
1623
1624
1625 =head2 _after_authority_action_hooks
1626
1627 Helper method that takes care of calling all plugin hooks
1628
1629 =cut
1630
1631 sub _after_authority_action_hooks {
1632     my ( $args ) = @_; # hash keys: action, authority_id
1633     return Koha::Plugins->call( 'after_authority_action', $args );
1634 }
1635
1636 END { }       # module clean-up code here (global destructor)
1637
1638 1;
1639 __END__
1640
1641 =head1 AUTHOR
1642
1643 Koha Development Team <http://koha-community.org/>
1644
1645 Paul POULAIN paul.poulain@free.fr
1646 Ere Maijala ere.maijala@helsinki.fi
1647
1648 =cut
1649