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