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) = @_;
 549   my $dbh=C4::Context->dbh;
 550         my $leader='     nz  a22     o  4500';#Leader for incomplete MARC21 record
 551
 552 # if authid empty => true add, find a new authid number
 553     my $format;
 554     if (uc(C4::Context->preference('marcflavour')) eq 'UNIMARC') {
 555         $format= 'UNIMARCAUTH';
 556     }
 557     else {
 558         $format= 'MARC21';
 559     }
 560
 561     #update date/time to 005 for marc and unimarc
 562     my $time=POSIX::strftime("%Y%m%d%H%M%S",localtime);
 563     my $f5=$record->field('005');
 564     if (!$f5) {
 565       $record->insert_fields_ordered( MARC::Field->new('005',$time.".0") );
 566     }
 567     else {
 568       $f5->update($time.".0");
 569     }
 570
 571     SetUTF8Flag($record);
 572         if ($format eq "MARC21") {
 573         my $userenv = C4::Context->userenv;
 574         my $library;
 575         my $marcorgcode = C4::Context->preference('MARCOrgCode');
 576         if ( $userenv && $userenv->{'branch'} ) {
 577             $library = Koha::Libraries->find( $userenv->{'branch'} );
 578             # userenv's library could not exist because of a trick in misc/commit_file.pl (see FIXME and set_userenv statement)
 579             $marcorgcode = $library ? $library->get_effective_marcorgcode : $marcorgcode;
 580         }
 581                 if (!$record->leader) {
 582                         $record->leader($leader);
 583                 }
 584                 if (!$record->field('003')) {
 585                         $record->insert_fields_ordered(
 586                 MARC::Field->new('003', $marcorgcode),
 587                         );
 588                 }
 589                 my $date=POSIX::strftime("%y%m%d",localtime);
 590                 if (!$record->field('008')) {
 591             # Get a valid default value for field 008
 592             my $default_008 = C4::Context->preference('MARCAuthorityControlField008');
 593             if(!$default_008 or length($default_008)<34) {
 594                 $default_008 = '|| aca||aabn           | a|a     d';
 595             }
 596             else {
 597                 $default_008 = substr($default_008,0,34);
 598             }
 599
 600             $record->insert_fields_ordered( MARC::Field->new('008',$date.$default_008) );
 601                 }
 602                 if (!$record->field('040')) {
 603                  $record->insert_fields_ordered(
 604         MARC::Field->new('040','','',
 605             'a' => $marcorgcode,
 606             'c' => $marcorgcode,
 607                                 )
 608                         );
 609     }
 610         }
 611
 612   if ($format eq "UNIMARCAUTH") {
 613         $record->leader("     nx  j22             ") unless ($record->leader());
 614         my $date=POSIX::strftime("%Y%m%d",localtime);
 615         my $defaultfield100 = C4::Context->preference('UNIMARCAuthorityField100');
 616     if (my $string=$record->subfield('100',"a")){
 617         $string=~s/fre50/frey50/;
 618         $record->field('100')->update('a'=>$string);
 619     }
 620     elsif ($record->field('100')){
 621           $record->field('100')->update('a'=>$date.$defaultfield100);
 622     } else {
 623         $record->append_fields(
 624         MARC::Field->new('100',' ',' '
 625             ,'a'=>$date.$defaultfield100)
 626         );
 627     }
 628   }
 629   my ($auth_type_tag, $auth_type_subfield) = get_auth_type_location($authtypecode);
 630   if (!$authid and $format eq "MARC21") {
 631     # only need to do this fix when modifying an existing authority
 632     C4::AuthoritiesMarc::MARC21::fix_marc21_auth_type_location($record, $auth_type_tag, $auth_type_subfield);
 633   }
 634   if (my $field=$record->field($auth_type_tag)){
 635     $field->update($auth_type_subfield=>$authtypecode);
 636   }
 637   else {
 638     $record->add_fields($auth_type_tag,'','', $auth_type_subfield=>$authtypecode);
 639   }
 640
 641     # Save record into auth_header, update 001
 642     my $action;
 643     if (!$authid ) {
 644         $action = 'create';
 645         # Save a blank record, get authid
 646         $dbh->do( "INSERT INTO auth_header (datecreated,marcxml) values (NOW(),?)", undef, '' );
 647         $authid = $dbh->last_insert_id( undef, undef, 'auth_header', 'authid' );
 648         logaction( "AUTHORITIES", "ADD", $authid, "authority" ) if C4::Context->preference("AuthoritiesLog");
 649     } else {
 650         $action = 'modify';
 651     }
 652     # Insert/update the recordID in MARC record
 653     $record->delete_field( $record->field('001') );
 654     $record->insert_fields_ordered( MARC::Field->new( '001', $authid ) );
 655     # Update
 656     $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;
 657     my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::AUTHORITIES_INDEX });
 658     $indexer->index_records( $authid, "specialUpdate", "authorityserver", $record );
 659
 660     _after_authority_action_hooks({ action => $action, authority_id => $authid });
 661     return ( $authid );
 662 }
 663
 664 =head2 DelAuthority
 665
 666     DelAuthority({ authid => $authid, [ skip_merge => 1 ] });
 667
 668 Deletes $authid and calls merge to cleanup linked biblio records.
 669 Parameter skip_merge is used in authorities/merge.pl. You should normally not
 670 use it.
 671
 672 skip_record_index will skip the indexation step.
 673
 674 =cut
 675
 676 sub DelAuthority {
 677     my ( $params ) = @_;
 678     my $authid = $params->{authid} || return;
 679     my $skip_merge = $params->{skip_merge};
 680     my $skip_record_index = $params->{skip_record_index} || 0;
 681
 682     my $dbh = C4::Context->dbh;
 683
 684     # Remove older pending merge requests for $authid to itself. (See bug 22437)
 685     my $condition = { authid => $authid, authid_new => [undef, 0, $authid], done => 0 };
 686     Koha::Authority::MergeRequests->search($condition)->delete;
 687
 688     merge({ mergefrom => $authid }) if !$skip_merge;
 689     $dbh->do( "DELETE FROM auth_header WHERE authid=?", undef, $authid );
 690     logaction( "AUTHORITIES", "DELETE", $authid, "authority" ) if C4::Context->preference("AuthoritiesLog");
 691     unless ( $skip_record_index ) {
 692         my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::AUTHORITIES_INDEX });
 693         $indexer->index_records( $authid, "recordDelete", "authorityserver", undef );
 694     }
 695
 696     _after_authority_action_hooks({ action => 'delete', authority_id => $authid });
 697 }
 698
 699 =head2 ModAuthority
 700
 701   $authid= &ModAuthority($authid,$record,$authtypecode, [ { skip_merge => 1 ] )
 702
 703 Modifies authority record, optionally updates attached biblios.
 704 The parameter skip_merge is optional and should be used with care.
 705
 706 =cut
 707
 708 sub ModAuthority {
 709     my ( $authid, $record, $authtypecode, $params ) = @_;
 710     my $oldrecord = GetAuthority($authid);
 711     #Now rewrite the $record to table with an add
 712     $authid = AddAuthority($record, $authid, $authtypecode);
 713     merge({ mergefrom => $authid, MARCfrom => $oldrecord, mergeto => $authid, MARCto => $record }) if !$params->{skip_merge};
 714     logaction( "AUTHORITIES", "MODIFY", $authid, "authority BEFORE=>" . $oldrecord->as_formatted ) if C4::Context->preference("AuthoritiesLog");
 715     return $authid;
 716 }
 717
 718 =head2 GetAuthorityXML
 719
 720   $marcxml= &GetAuthorityXML( $authid)
 721
 722 returns xml form of record $authid
 723
 724 =cut
 725
 726 sub GetAuthorityXML {
 727   # Returns MARC::XML of the authority passed in parameter.
 728   my ( $authid ) = @_;
 729   if (uc(C4::Context->preference('marcflavour')) eq 'UNIMARC') {
 730       my $dbh=C4::Context->dbh;
 731       my $sth = $dbh->prepare("select marcxml from auth_header where authid=? "  );
 732       $sth->execute($authid);
 733       my ($marcxml)=$sth->fetchrow;
 734       return $marcxml;
 735   }
 736   else {
 737       # for MARC21, call GetAuthority instead of
 738       # getting the XML directly since we may
 739       # need to fix up the location of the authority
 740       # code -- note that this is reasonably safe
 741       # because GetAuthorityXML is used only by the
 742       # indexing processes like zebraqueue_start.pl
 743       my $record = GetAuthority($authid);
 744       return $record->as_xml_record('MARC21');
 745   }
 746 }
 747
 748 =head2 GetAuthority
 749
 750   $record= &GetAuthority( $authid)
 751
 752 Returns MARC::Record of the authority passed in parameter.
 753
 754 =cut
 755
 756 sub GetAuthority {
 757     my ($authid)=@_;
 758     my $authority = Koha::MetadataRecord::Authority->get_from_authid($authid);
 759     return unless $authority;
 760     return ($authority->record);
 761 }
 762
 763 =head2 FindDuplicateAuthority
 764
 765   $record= &FindDuplicateAuthority( $record, $authtypecode)
 766
 767 return $authid,Summary if duplicate is found.
 768
 769 Comments : an improvement would be to return All the records that match.
 770
 771 =cut
 772
 773 sub FindDuplicateAuthority {
 774
 775     my ($record,$authtypecode)=@_;
 776 #    warn "IN for ".$record->as_formatted;
 777     my $dbh = C4::Context->dbh;
 778 #    warn "".$record->as_formatted;
 779     my $auth_tag_to_report = Koha::Authority::Types->find($authtypecode)->auth_tag_to_report;
 780 #     warn "record :".$record->as_formatted."  auth_tag_to_report :$auth_tag_to_report";
 781     # build a request for SearchAuthorities
 782     my $op = 'AND';
 783     $authtypecode =~ s#/#\\/#; # GENRE/FORM contains forward slash which is a reserved character
 784     my $query='at:'.$authtypecode.' ';
 785     my $filtervalues=qr([\001-\040\Q!'"`#$%&*+,-./:;<=>?@(){[}_|~\E\]]);
 786     if ($record->field($auth_tag_to_report)) {
 787         foreach ($record->field($auth_tag_to_report)->subfields()) {
 788             $_->[1]=~s/$filtervalues/ /g; $query.= " $op he:\"".$_->[1]."\"" if ($_->[0]=~/[A-z]/);
 789         }
 790     }
 791     my $searcher = Koha::SearchEngine::Search->new({index => $Koha::SearchEngine::AUTHORITIES_INDEX});
 792     my ($error, $results, $total_hits) = $searcher->simple_search_compat( $query, 0, 1, [ 'authorityserver' ] );
 793     # there is at least 1 result => return the 1st one
 794     if (!defined $error && @{$results} ) {
 795         my $marcrecord = C4::Search::new_record_from_zebra(
 796             'authorityserver',
 797             $results->[0]
 798         );
 799         return $marcrecord->field('001')->data,BuildSummary($marcrecord,$marcrecord->field('001')->data,$authtypecode);
 800     }
 801     # no result, returns nothing
 802     return;
 803 }
 804
 805 =head2 BuildSummary
 806
 807   $summary= &BuildSummary( $record, $authid, $authtypecode)
 808
 809 Returns a hashref with a summary of the specified record.
 810
 811 Comment : authtypecode can be inferred from both record and authid.
 812 Moreover, authid can also be inferred from $record.
 813 Would it be interesting to delete those things.
 814
 815 =cut
 816
 817 sub BuildSummary {
 818     ## give this a Marc record to return summary
 819     my ($record,$authid,$authtypecode)=@_;
 820     my $dbh=C4::Context->dbh;
 821     my %summary;
 822     my $summary_template;
 823     # handle $authtypecode is NULL or eq ""
 824     if ($authtypecode) {
 825         my $authref = Koha::Authority::Types->find($authtypecode);
 826         if ( $authref ) {
 827             $summary{authtypecode} = $authref->authtypecode;
 828             $summary{type} = $authref->authtypetext;
 829             $summary_template = $authref->summary;
 830             # for MARC21, the authority type summary displays a label meant for
 831             # display
 832             if (C4::Context->preference('marcflavour') ne 'UNIMARC') {
 833                 $summary{label} = $authref->summary;
 834             } else {
 835                 $summary{summary} = $authref->summary;
 836             }
 837         }
 838     }
 839     my $marc21subfields = 'abcdfghjklmnopqrstuvxyz68';
 840     my %marc21controlrefs = ( 'a' => 'earlier',
 841         'b' => 'later',
 842         'd' => 'acronym',
 843         'f' => 'musical',
 844         'g' => 'broader',
 845         'h' => 'narrower',
 846         'n' => 'notapplicable',
 847         'i' => 'subfi',
 848         't' => 'parent'
 849     );
 850     my %unimarc_relation_from_code = (
 851         g => 'broader',
 852         h => 'narrower',
 853         a => 'seealso',
 854     );
 855     my %thesaurus;
 856     $thesaurus{'1'}="Peuples";
 857     $thesaurus{'2'}="Anthroponymes";
 858     $thesaurus{'3'}="Oeuvres";
 859     $thesaurus{'4'}="Chronologie";
 860     $thesaurus{'5'}="Lieux";
 861     $thesaurus{'6'}="Sujets";
 862     #thesaurus a remplir
 863     my $reported_tag;
 864 # if the library has a summary defined, use it. Otherwise, build a standard one
 865 # FIXME - it appears that the summary field in the authority frameworks
 866 #         can work as a display template.  However, this doesn't
 867 #         suit the MARC21 version, so for now the "templating"
 868 #         feature will be enabled only for UNIMARC for backwards
 869 #         compatibility.
 870     if ($summary{summary} and C4::Context->preference('marcflavour') eq 'UNIMARC') {
 871         my @matches = ($summary{summary} =~ m/\[(.*?)(\d{3})([\*a-z0-9])(.*?)\]/g);
 872         my (@textbefore, @tag, @subtag, @textafter);
 873         for(my $i = 0; $i < scalar @matches; $i++){
 874             push @textbefore, $matches[$i] if($i%4 == 0);
 875             push @tag,        $matches[$i] if($i%4 == 1);
 876             push @subtag,     $matches[$i] if($i%4 == 2);
 877             push @textafter,  $matches[$i] if($i%4 == 3);
 878         }
 879         for(my $i = scalar @tag; $i >= 0; $i--){
 880             my $textbefore = $textbefore[$i] || '';
 881             my $tag = $tag[$i] || '';
 882             my $subtag = $subtag[$i] || '';
 883             my $textafter = $textafter[$i] || '';
 884             my $value = '';
 885             my $field = $record->field($tag);
 886             if ( $field ) {
 887                 if($subtag eq '*') {
 888                     if($tag < 10) {
 889                         $value = $textbefore . $field->data() . $textafter;
 890                     }
 891                 } else {
 892                     my @subfields = $field->subfield($subtag);
 893                     if(@subfields > 0) {
 894                         $value = $textbefore . join (" - ", @subfields) . $textafter;
 895                     }
 896                 }
 897             }
 898             $summary{summary} =~ s/\[\Q$textbefore$tag$subtag$textafter\E\]/$value/;
 899         }
 900         $summary{summary} =~ s/\\n/<br \/>/g;
 901     }
 902     my @authorized;
 903     my @notes;
 904     my @seefrom;
 905     my @seealso;
 906     my @otherscript;
 907     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
 908 # construct UNIMARC summary, that is quite different from MARC21 one
 909 # accepted form
 910         foreach my $field ($record->field('2..')) {
 911             push @authorized, {
 912                 heading => $field->as_string('abcdefghijlmnopqrstuvwxyz'),
 913                 hemain  => ( $field->subfield('a') // undef ),
 914                 field   => $field->tag(),
 915             };
 916         }
 917 # rejected form(s)
 918         foreach my $field ($record->field('3..')) {
 919             push @notes, { note => $field->subfield('a'), field => $field->tag() };
 920         }
 921         foreach my $field ($record->field('4..')) {
 922             my $thesaurus = $field->subfield('2') ? "thes. : ".$thesaurus{"$field->subfield('2')"}." : " : '';
 923             push @seefrom, {
 924                 heading => $thesaurus . $field->as_string('abcdefghijlmnopqrstuvwxyz'),
 925                 hemain  => ( $field->subfield('a') // undef ),
 926                 type    => 'seefrom',
 927                 field   => $field->tag(),
 928             };
 929         }
 930
 931         # see :
 932         @seealso = map {
 933             my $type = $unimarc_relation_from_code{$_->subfield('5') || 'a'};
 934             my $heading = $_->as_string('abcdefgjxyz');
 935             {
 936                 field   => $_->tag,
 937                 type    => $type,
 938                 heading => $heading,
 939                 hemain  => ( $_->subfield('a') // undef ),
 940                 search  => $heading,
 941                 authid  => ( $_->subfield('9') // undef ),
 942             }
 943         } $record->field('5..');
 944
 945         # Other forms
 946         @otherscript = map { {
 947             lang      => length ($_->subfield('8')) == 6 ? substr ($_->subfield('8'), 3, 3) : $_->subfield('8') || '',
 948             term      => $_->subfield('a') . ($_->subfield('b') ? ', ' . $_->subfield('b') : ''),
 949             direction => 'ltr',
 950             field     => $_->tag,
 951         } } $record->field('7..');
 952
 953     } else {
 954 # construct MARC21 summary
 955 # FIXME - looping over 1XX is questionable
 956 # since MARC21 authority should have only one 1XX
 957         use C4::Heading::MARC21;
 958         my $handler = C4::Heading::MARC21->new();
 959         my $subfields_to_report;
 960         foreach my $field ($record->field('1..')) {
 961             my $tag = $field->tag();
 962             next if "152" eq $tag;
 963 # FIXME - 152 is not a good tag to use
 964 # in MARC21 -- purely local tags really ought to be
 965 # 9XX
 966
 967             $subfields_to_report = $handler->get_auth_heading_subfields_to_report($tag);
 968
 969             if ($subfields_to_report) {
 970                 push @authorized, {
 971                     heading => $field->as_string($subfields_to_report),
 972                     hemain  => ( $field->subfield( substr($subfields_to_report, 0, 1) ) // undef ),
 973                     field   => $tag,
 974                 };
 975             } else {
 976                 push @authorized, {
 977                     heading => $field->as_string(),
 978                     hemain  => ( $field->subfield( 'a' ) // undef ),
 979                     field   => $tag,
 980                 };
 981             }
 982         }
 983         foreach my $field ($record->field('4..')) { #See From
 984             my $type = 'seefrom';
 985             $type = ($marc21controlrefs{substr $field->subfield('w'), 0, 1} || '') if ($field->subfield('w'));
 986             if ($type eq 'notapplicable') {
 987                 $type = substr $field->subfield('w'), 2, 1;
 988                 $type = 'earlier' if $type && $type ne 'n';
 989             }
 990             if ($type eq 'subfi') {
 991                 push @seefrom, {
 992                     heading => $field->as_string($marc21subfields),
 993                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 994                     type    => ($field->subfield('i') || ''),
 995                     field   => $field->tag(),
 996                 };
 997             } else {
 998                 push @seefrom, {
 999                     heading => $field->as_string($marc21subfields),
1000                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
1001                     type    => $type,
1002                     field   => $field->tag(),
1003                 };
1004             }
1005         }
1006         foreach my $field ($record->field('5..')) { #See Also
1007             my $type = 'seealso';
1008             $type = ($marc21controlrefs{substr $field->subfield('w'), 0, 1} || '') if ($field->subfield('w'));
1009             if ($type eq 'notapplicable') {
1010                 $type = substr $field->subfield('w'), 2, 1;
1011                 $type = 'earlier' if $type && $type ne 'n';
1012             }
1013             if ($type eq 'subfi') {
1014                 push @seealso, {
1015                     heading => $field->as_string($marc21subfields),
1016                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
1017                     type    => scalar $field->subfield('i'),
1018                     field   => $field->tag(),
1019                     search  => $field->as_string($marc21subfields) || '',
1020                     authid  => $field->subfield('9') || ''
1021                 };
1022             } else {
1023                 push @seealso, {
1024                     heading => $field->as_string($marc21subfields),
1025                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
1026                     type    => $type,
1027                     field   => $field->tag(),
1028                     search  => $field->as_string($marc21subfields) || '',
1029                     authid  => $field->subfield('9') || ''
1030                 };
1031             }
1032         }
1033         foreach my $field ($record->field('6..')) {
1034             push @notes, { note => $field->as_string(), field => $field->tag() };
1035         }
1036         foreach my $field ($record->field('880')) {
1037             my $linkage = $field->subfield('6');
1038             my $category = substr $linkage, 0, 1;
1039             if ($category eq '1') {
1040                 $category = 'preferred';
1041             } elsif ($category eq '4') {
1042                 $category = 'seefrom';
1043             } elsif ($category eq '5') {
1044                 $category = 'seealso';
1045             }
1046             my $type;
1047             if ($field->subfield('w')) {
1048                 $type = $marc21controlrefs{substr $field->subfield('w'), '0'};
1049             } else {
1050                 $type = $category;
1051             }
1052             my $direction = $linkage =~ m#/r$# ? 'rtl' : 'ltr';
1053             push @otherscript, { term => $field->as_string($subfields_to_report), category => $category, type => $type, direction => $direction, linkage => $linkage };
1054         }
1055     }
1056     $summary{mainentry} = $authorized[0]->{heading};
1057     $summary{mainmainentry} = $authorized[0]->{hemain};
1058     $summary{authorized} = \@authorized;
1059     $summary{notes} = \@notes;
1060     $summary{seefrom} = \@seefrom;
1061     $summary{seealso} = \@seealso;
1062     $summary{otherscript} = \@otherscript;
1063     return \%summary;
1064 }
1065
1066 =head2 GetAuthorizedHeading
1067
1068   $heading = &GetAuthorizedHeading({ record => $record, authid => $authid })
1069
1070 Takes a MARC::Record object describing an authority record or an authid, and
1071 returns a string representation of the first authorized heading. This routine
1072 should be considered a temporary shim to ease the future migration of authority
1073 data from C4::AuthoritiesMarc to the object-oriented Koha::*::Authority.
1074
1075 =cut
1076
1077 sub GetAuthorizedHeading {
1078     my $args = shift;
1079     my $record;
1080     unless ($record = $args->{record}) {
1081         return unless $args->{authid};
1082         $record = GetAuthority($args->{authid});
1083     }
1084     return unless (ref $record eq 'MARC::Record');
1085     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1086 # construct UNIMARC summary, that is quite different from MARC21 one
1087 # accepted form
1088         foreach my $field ($record->field('2..')) {
1089             return $field->as_string('abcdefghijlmnopqrstuvwxyz');
1090         }
1091     } else {
1092         use C4::Heading::MARC21;
1093         my $handler = C4::Heading::MARC21->new();
1094
1095         foreach my $field ($record->field('1..')) {
1096             my $subfields = $handler->get_valid_bib_heading_subfields($field->tag());
1097             return $field->as_string($subfields) if ($subfields);
1098         }
1099     }
1100     return;
1101 }
1102
1103 =head2 CompareFieldWithAuthority
1104
1105   $match = &CompareFieldWithAuthority({ field => $field, authid => $authid })
1106
1107 Takes a MARC::Field from a bibliographic record and an authid, and returns true if they match.
1108
1109 =cut
1110
1111 sub CompareFieldWithAuthority {
1112     my $args = shift;
1113
1114     my $record = GetAuthority($args->{authid});
1115     return unless (ref $record eq 'MARC::Record');
1116     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1117         # UNIMARC has same subfields for bibs and authorities
1118         foreach my $field ($record->field('2..')) {
1119             return compare_fields($field, $args->{field}, 'abcdefghijlmnopqrstuvwxyz');
1120         }
1121     } else {
1122         use C4::Heading::MARC21;
1123         my $handler = C4::Heading::MARC21->new();
1124
1125         foreach my $field ($record->field('1..')) {
1126             my $subfields = $handler->get_valid_bib_heading_subfields($field->tag());
1127             return compare_fields($field, $args->{field}, $subfields) if ($subfields);
1128         }
1129     }
1130     return 0;
1131 }
1132
1133 =head2 BuildAuthHierarchies
1134
1135   $text= &BuildAuthHierarchies( $authid, $force)
1136
1137 return text containing trees for hierarchies
1138 for them to be stored in auth_header
1139
1140 Example of text:
1141 122,1314,2452;1324,2342,3,2452
1142
1143 =cut
1144
1145 sub BuildAuthHierarchies{
1146     my $authid = shift @_;
1147 #   warn "authid : $authid";
1148     my $force = shift @_ || (C4::Context->preference('marcflavour') eq 'UNIMARC' ? 0 : 1);
1149     my @globalresult;
1150     my $dbh=C4::Context->dbh;
1151     my $hierarchies;
1152     my $data = GetHeaderAuthority($authid);
1153     if ($data->{'authtrees'} and not $force){
1154         return $data->{'authtrees'};
1155 #  } elsif ($data->{'authtrees'}){
1156 #    $hierarchies=$data->{'authtrees'};
1157     } else {
1158         my $record = GetAuthority($authid);
1159         my $found;
1160         return unless $record;
1161         foreach my $field ($record->field('5..')){
1162             my $broader = 0;
1163             $broader = 1 if (
1164                     (C4::Context->preference('marcflavour') eq 'UNIMARC' && $field->subfield('5') && $field->subfield('5') eq 'g') ||
1165                     (C4::Context->preference('marcflavour') ne 'UNIMARC' && $field->subfield('w') && substr($field->subfield('w'), 0, 1) eq 'g'));
1166             if ($broader) {
1167                 my $subfauthid=_get_authid_subfield($field) || '';
1168                 next if ($subfauthid eq $authid);
1169                 my $parentrecord = GetAuthority($subfauthid);
1170                 next unless $parentrecord;
1171                 my $localresult=$hierarchies;
1172                 my $trees;
1173                 $trees = BuildAuthHierarchies($subfauthid);
1174                 my @trees;
1175                 if ($trees=~/;/){
1176                     @trees = split(/;/,$trees);
1177                 } else {
1178                     push @trees, $trees;
1179                 }
1180                 foreach (@trees){
1181                     $_.= ",$authid";
1182                 }
1183                 @globalresult = (@globalresult,@trees);
1184                 $found=1;
1185             }
1186             $hierarchies=join(";",@globalresult);
1187         }
1188 #Unless there is no ancestor, I am alone.
1189         $hierarchies="$authid" unless ($hierarchies);
1190     }
1191     AddAuthorityTrees($authid,$hierarchies);
1192     return $hierarchies;
1193 }
1194
1195 =head2 BuildAuthHierarchy
1196
1197   $ref= &BuildAuthHierarchy( $record, $class,$authid)
1198
1199 return a hashref in order to display hierarchy for record and final Authid $authid
1200
1201 "loopparents"
1202 "loopchildren"
1203 "class"
1204 "loopauthid"
1205 "current_value"
1206 "value"
1207
1208 =cut
1209
1210 sub BuildAuthHierarchy{
1211     my $record = shift @_;
1212     my $class = shift @_;
1213     my $authid_constructed = shift @_;
1214     return unless ($record && $record->field('001'));
1215     my $authid=$record->field('001')->data();
1216     my %cell;
1217     my $parents=""; my $children="";
1218     my (@loopparents,@loopchildren);
1219     my $marcflavour = C4::Context->preference('marcflavour');
1220     my $relationshipsf = $marcflavour eq 'UNIMARC' ? '5' : 'w';
1221     foreach my $field ($record->field('5..')){
1222         my $subfauthid=_get_authid_subfield($field);
1223         if ($subfauthid && $field->subfield($relationshipsf) && $field->subfield('a')){
1224             my $relationship = substr($field->subfield($relationshipsf), 0, 1);
1225             if ($relationship eq 'h'){
1226                 push @loopchildren, { "authid"=>$subfauthid,"value"=>$field->subfield('a')};
1227             }
1228             elsif ($relationship eq 'g'){
1229                 push @loopparents, { "authid"=>$subfauthid,"value"=>$field->subfield('a')};
1230             }
1231 # brothers could get in there with an else
1232         }
1233     }
1234     $cell{"parents"}=\@loopparents;
1235     $cell{"children"}=\@loopchildren;
1236     $cell{"class"}=$class;
1237     $cell{"authid"}=$authid;
1238     $cell{"current_value"} =1 if ($authid eq $authid_constructed);
1239     $cell{"value"}=C4::Context->preference('marcflavour') eq 'UNIMARC' ? $record->subfield('2..',"a") : $record->subfield('1..', 'a');
1240     return \%cell;
1241 }
1242
1243 =head2 BuildAuthHierarchyBranch
1244
1245   $branch = &BuildAuthHierarchyBranch( $tree, $authid[, $cnt])
1246
1247 Return a data structure representing an authority hierarchy
1248 given a list of authorities representing a single branch in
1249 an authority hierarchy tree. $authid is the current node in
1250 the tree (which may or may not be somewhere in the middle).
1251 $cnt represents the level of the upper-most item, and is only
1252 used when BuildAuthHierarchyBranch is called recursively (i.e.,
1253 don't ever pass in anything but zero to it).
1254
1255 =cut
1256
1257 sub BuildAuthHierarchyBranch {
1258     my ($tree, $authid, $cnt) = @_;
1259     $cnt |= 0;
1260     my $elementdata = GetAuthority(shift @$tree);
1261     my $branch = BuildAuthHierarchy($elementdata,"child".$cnt, $authid);
1262     if (scalar @$tree > 0) {
1263         my $nextBranch = BuildAuthHierarchyBranch($tree, $authid, ++$cnt);
1264         my $nextAuthid = $nextBranch->{authid};
1265         my $found;
1266         # If we already have the next branch listed as a child, let's
1267         # replace the old listing with the new one. If not, we will add
1268         # the branch at the end.
1269         foreach my $cell (@{$branch->{children}}) {
1270             if ($cell->{authid} eq $nextAuthid) {
1271                 $cell = $nextBranch;
1272                 $found = 1;
1273                 last;
1274             }
1275         }
1276         push @{$branch->{children}}, $nextBranch unless $found;
1277     }
1278     return $branch;
1279 }
1280
1281 =head2 GenerateHierarchy
1282
1283   $hierarchy = &GenerateHierarchy($authid);
1284
1285 Return an arrayref holding one or more "trees" representing
1286 authority hierarchies.
1287
1288 =cut
1289
1290 sub GenerateHierarchy {
1291     my ($authid) = @_;
1292     my $trees    = BuildAuthHierarchies($authid);
1293     my @trees    = split /;/,$trees ;
1294     push @trees,$trees unless (@trees);
1295     my @loophierarchies;
1296     foreach my $tree (@trees){
1297         my @tree=split /,/,$tree;
1298         push @tree, $tree unless (@tree);
1299         my $branch = BuildAuthHierarchyBranch(\@tree, $authid);
1300         push @loophierarchies, [ $branch ];
1301     }
1302     return \@loophierarchies;
1303 }
1304
1305 sub _get_authid_subfield{
1306     my ($field)=@_;
1307     return $field->subfield('9')||$field->subfield('3');
1308 }
1309
1310 =head2 GetHeaderAuthority
1311
1312   $ref= &GetHeaderAuthority( $authid)
1313
1314 return a hashref in order auth_header table data
1315
1316 =cut
1317
1318 sub GetHeaderAuthority{
1319   my $authid = shift @_;
1320   my $sql= "SELECT * from auth_header WHERE authid = ?";
1321   my $dbh=C4::Context->dbh;
1322   my $rq= $dbh->prepare($sql);
1323   $rq->execute($authid);
1324   my $data= $rq->fetchrow_hashref;
1325   return $data;
1326 }
1327
1328 =head2 AddAuthorityTrees
1329
1330   $ref= &AddAuthorityTrees( $authid, $trees)
1331
1332 return success or failure
1333
1334 =cut
1335
1336 sub AddAuthorityTrees{
1337   my $authid = shift @_;
1338   my $trees = shift @_;
1339   my $sql= "UPDATE IGNORE auth_header set authtrees=? WHERE authid = ?";
1340   my $dbh=C4::Context->dbh;
1341   my $rq= $dbh->prepare($sql);
1342   return $rq->execute($trees,$authid);
1343 }
1344
1345 =head2 merge
1346
1347     $count = merge({
1348         mergefrom => $mergefrom,
1349         [ MARCfrom => $MARCfrom, ]
1350         [ mergeto => $mergeto, ]
1351         [ MARCto => $MARCto, ]
1352         [ biblionumbers => [ $a, $b, $c ], ]
1353         [ override_limit => 1, ]
1354     });
1355
1356 Merge biblios linked to authority $mergefrom (mandatory parameter).
1357 If $mergeto equals mergefrom, the linked biblio field is updated.
1358 If $mergeto is different, the biblio field will be linked to $mergeto.
1359 If $mergeto is missing, the biblio field is deleted.
1360
1361 MARCfrom is used to determine if a cleared subfield in the authority record
1362 should be removed from a biblio. MARCto is used to populate the biblio
1363 record with the updated values; if you do not pass it, the biblio field
1364 will be deleted (same as missing mergeto).
1365
1366 Normally all biblio records linked to $mergefrom, will be considered. But
1367 you can pass specific numbers via the biblionumbers parameter.
1368
1369 The parameter override_limit is used by the cron job to force larger
1370 postponed merges.
1371
1372 Note: Although $mergefrom and $mergeto will normally be of the same
1373 authority type, merge also supports moving to another authority type.
1374
1375 =cut
1376
1377 sub merge {
1378     my ( $params ) = @_;
1379     my $mergefrom = $params->{mergefrom} || return;
1380     my $MARCfrom = $params->{MARCfrom};
1381     my $mergeto = $params->{mergeto};
1382     my $MARCto = $params->{MARCto};
1383     my $override_limit = $params->{override_limit};
1384
1385     # If we do not have biblionumbers, we get all linked biblios if the
1386     # number of linked records does not exceed the limit UNLESS we override.
1387     my @biblionumbers;
1388     if( $params->{biblionumbers} ) {
1389         @biblionumbers = @{ $params->{biblionumbers} };
1390     } elsif( $override_limit ) {
1391         @biblionumbers = Koha::Authorities->linked_biblionumbers({ authid => $mergefrom });
1392     } else { # now first check number of linked records
1393         my $max = C4::Context->preference('AuthorityMergeLimit') // 0;
1394         my $hits = Koha::Authorities->get_usage_count({ authid => $mergefrom });
1395         if( $hits > 0 && $hits <= $max ) {
1396             @biblionumbers = Koha::Authorities->linked_biblionumbers({ authid => $mergefrom });
1397         } elsif( $hits > $max ) { #postpone this merge to the cron job
1398             Koha::Authority::MergeRequest->new({
1399                 authid => $mergefrom,
1400                 oldrecord => $MARCfrom,
1401                 authid_new => $mergeto,
1402             })->store;
1403         }
1404     }
1405     return 0 if !@biblionumbers;
1406
1407     # Search authtypes and reporting tags
1408     my $authfrom = Koha::Authorities->find($mergefrom);
1409     my $authto = Koha::Authorities->find($mergeto);
1410     my $authtypefrom = $authfrom ? Koha::Authority::Types->find($authfrom->authtypecode) : undef;
1411     my $authtypeto   = $authto ? Koha::Authority::Types->find($authto->authtypecode) : undef;
1412     my $auth_tag_to_report_from = $authtypefrom ? $authtypefrom->auth_tag_to_report : '';
1413     my $auth_tag_to_report_to   = $authtypeto ? $authtypeto->auth_tag_to_report : '';
1414
1415     my @record_to;
1416     @record_to = $MARCto->field($auth_tag_to_report_to)->subfields() if $auth_tag_to_report_to && $MARCto && $MARCto->field($auth_tag_to_report_to);
1417     # Exceptional: If MARCto and authtypeto exist but $auth_tag_to_report_to
1418     # is empty, make sure that $9 and $a remain (instead of clearing the
1419     # reference) in order to allow for data recovery.
1420     # Note: We need $a too, since a single $9 does not pass ModBiblio.
1421     if( $MARCto && $authtypeto && !@record_to  ) {
1422         push @record_to, [ 'a', ' ' ]; # do not remove the space
1423     }
1424
1425     my @record_from;
1426     if( !$authfrom && $MARCfrom && $MARCfrom->field('1..','2..') ) {
1427     # postponed merge, authfrom was deleted and MARCfrom only contains the old reporting tag (and possibly a 100 for UNIMARC)
1428     # 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
1429         @record_from = ( $MARCfrom->field('1..','2..') )[-1]->subfields;
1430     } elsif( $auth_tag_to_report_from && $MARCfrom && $MARCfrom->field($auth_tag_to_report_from) ) {
1431         @record_from = $MARCfrom->field($auth_tag_to_report_from)->subfields;
1432     }
1433
1434     # Get all candidate tags for the change
1435     # (This will reduce the search scope in marc records).
1436     # For a deleted authority record, we scan all auth controlled fields
1437     my $dbh = C4::Context->dbh;
1438     my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
1439     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<>''" );
1440     my $tags_new;
1441     if( $authtypeto && ( !$authtypefrom || $authtypeto->authtypecode ne $authtypefrom->authtypecode )) {
1442         $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypeto->authtypecode ));
1443     }
1444
1445     my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1446     my $skip_subfields = $overwrite
1447         # This hash contains all subfields from the authority report fields
1448         # Including $MARCfrom as well as $MARCto
1449         # We only need it in loose merge mode; replaces the former $exclude
1450         ? {}
1451         : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
1452
1453     my $counteditedbiblio = 0;
1454     foreach my $biblionumber ( @biblionumbers ) {
1455         my $marcrecord = GetMarcBiblio({ biblionumber => $biblionumber });
1456         next if !$marcrecord;
1457         my $update = 0;
1458         foreach my $tagfield (@$tags_using_authtype) {
1459             my $countfrom = 0;    # used in strict mode to remove duplicates
1460             foreach my $field ( $marcrecord->field($tagfield) ) {
1461                 my $auth_number = $field->subfield("9");    # link to authority
1462                 my $tag         = $field->tag();
1463                 next if !defined($auth_number) || $auth_number ne $mergefrom;
1464                 $countfrom++;
1465                 if ( !$mergeto || !@record_to ||
1466                   ( $overwrite && $countfrom > 1 ) ) {
1467                     # !mergeto or !record_to indicates a delete
1468                     # Other condition: remove this duplicate in strict mode
1469                     $marcrecord->delete_field($field);
1470                     $update = 1;
1471                     next;
1472                 }
1473                 my $newtag = $tags_new && @$tags_new
1474                   ? _merge_newtag( $tag, $tags_new )
1475                   : $tag;
1476                 my $controlled_ind = $authto->controlled_indicators({ record => $MARCto, biblio_tag => $newtag });
1477                 my $field_to = MARC::Field->new(
1478                     $newtag,
1479                     $controlled_ind->{ind1} // $field->indicator(1),
1480                     $controlled_ind->{ind2} // $field->indicator(2),
1481                     9 => $mergeto, # Needed to create field, will be moved
1482                 );
1483                 my ( @prefix, @postfix );
1484                 if ( !$overwrite ) {
1485                     # add subfields back in loose mode, check skip_subfields
1486                     # The first extra subfields will be in front of the
1487                     # controlled block, the rest at the end.
1488                     my $prefix_flag = 1;
1489                     foreach my $subfield ( $field->subfields ) {
1490                         next if $subfield->[0] eq '9'; # skip but leave flag
1491                         if ( $skip_subfields->{ $subfield->[0] } ) {
1492                             # This marks the beginning of the controlled block
1493                             $prefix_flag = 0;
1494                             next;
1495                         }
1496                         if ($prefix_flag) {
1497                             push @prefix, [ $subfield->[0], $subfield->[1] ];
1498                         } else {
1499                             push @postfix, [ $subfield->[0], $subfield->[1] ];
1500                         }
1501                     }
1502                 }
1503                 foreach my $subfield ( @prefix, @record_to, @postfix ) {
1504                     $field_to->add_subfields($subfield->[0] => $subfield->[1]);
1505                 }
1506                 if( exists $controlled_ind->{sub2} ) { # thesaurus info
1507                     if( defined $controlled_ind->{sub2} ) {
1508                         # Add or replace
1509                         $field_to->update( 2 => $controlled_ind->{sub2} );
1510                     } else {
1511                         # Key alerts us here to remove $2
1512                         $field_to->delete_subfield( code => '2' );
1513                     }
1514                 }
1515                 # Move $9 to the end
1516                 $field_to->delete_subfield( code => '9' );
1517                 $field_to->add_subfields( 9 => $mergeto );
1518
1519                 if ($tags_new && @$tags_new) {
1520                     $marcrecord->delete_field($field);
1521                     append_fields_ordered( $marcrecord, $field_to );
1522                 } else {
1523                     $field->replace_with($field_to);
1524                 }
1525                 $update = 1;
1526             }
1527         }
1528         next if !$update;
1529         ModBiblio($marcrecord, $biblionumber, GetFrameworkCode($biblionumber));
1530         $counteditedbiblio++;
1531     }
1532     return $counteditedbiblio;
1533 }
1534
1535 sub _merge_newtag {
1536 # Routine is only called for an (exceptional) authtypecode change
1537 # Fixes old behavior of returning the first tag found
1538     my ( $oldtag, $new_tags ) = @_;
1539
1540     # If we e.g. have 650 and 151,651,751 try 651 and check presence
1541     my $prefix = substr( $oldtag, 0, 1 );
1542     my $guess = $prefix . substr( $new_tags->[0], -2 );
1543     if( grep { $_ eq $guess } @$new_tags ) {
1544         return $guess;
1545     }
1546     # Otherwise return one from the same block e.g. 6XX for 650
1547     # If not there too, fall back to first new tag (old behavior!)
1548     my @same_block = grep { /^$prefix/ } @$new_tags;
1549     return @same_block ? $same_block[0] : $new_tags->[0];
1550 }
1551
1552 sub append_fields_ordered {
1553 # while we lack this function in MARC::Record
1554 # we do not want insert_fields_ordered since it inserts before
1555     my ( $record, $field ) = @_;
1556     if( my @flds = $record->field( $field->tag ) ) {
1557         $record->insert_fields_after( pop @flds, $field );
1558     } else { # now fallback to insert_fields_ordered
1559         $record->insert_fields_ordered( $field );
1560     }
1561 }
1562
1563 =head2 get_auth_type_location
1564
1565   my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1566
1567 Get the tag and subfield used to store the heading type
1568 for indexing purposes.  The C<$auth_type> parameter is
1569 optional; if it is not supplied, assume ''.
1570
1571 This routine searches the MARC authority framework
1572 for the tag and subfield whose kohafield is
1573 C<auth_header.authtypecode>; if no such field is
1574 defined in the framework, default to the hardcoded value
1575 specific to the MARC format.
1576
1577 =cut
1578
1579 sub get_auth_type_location {
1580     my $auth_type_code = @_ ? shift : '';
1581
1582     my ($tag, $subfield) = GetAuthMARCFromKohaField('auth_header.authtypecode', $auth_type_code);
1583     if (defined $tag and defined $subfield and $tag != 0 and $subfield ne '' and $subfield ne ' ') {
1584         return ($tag, $subfield);
1585     } else {
1586         if (C4::Context->preference('marcflavour') eq "MARC21")  {
1587             return C4::AuthoritiesMarc::MARC21::default_auth_type_location();
1588         } else {
1589             return C4::AuthoritiesMarc::UNIMARC::default_auth_type_location();
1590         }
1591     }
1592 }
1593
1594 =head2 compare_fields
1595
1596   my match = compare_fields($field1, $field2, 'abcde');
1597
1598 Compares the listed subfields of both fields and return true if they all match
1599
1600 =cut
1601
1602 sub compare_fields {
1603     my ($field1, $field2, $subfields) = @_;
1604
1605     foreach my $subfield (split(//, $subfields)) {
1606         my $subfield1 = $field1->subfield($subfield) // '';
1607         my $subfield2 = $field2->subfield($subfield) // '';
1608         return 0 unless $subfield1 eq $subfield2;
1609     }
1610     return 1;
1611 }
1612
1613
1614 =head2 _after_authority_action_hooks
1615
1616 Helper method that takes care of calling all plugin hooks
1617
1618 =cut
1619
1620 sub _after_authority_action_hooks {
1621     my ( $args ) = @_; # hash keys: action, authority_id
1622     return Koha::Plugins->call( 'after_authority_action', $args );
1623 }
1624
1625 END { }       # module clean-up code here (global destructor)
1626
1627 1;
1628 __END__
1629
1630 =head1 AUTHOR
1631
1632 Koha Development Team <http://koha-community.org/>
1633
1634 Paul POULAIN paul.poulain@free.fr
1635 Ere Maijala ere.maijala@helsinki.fi
1636
1637 =cut
1638