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