C4/AuthoritiesMarc.pm

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