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