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