C4/AuthoritiesMarc.pm

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