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 #    warn "IN for ".$record->as_formatted;
 759     my $dbh = C4::Context->dbh;
 760 #    warn "".$record->as_formatted;
 761     my $auth_tag_to_report = Koha::Authority::Types->find($authtypecode)->auth_tag_to_report;
 762 #     warn "record :".$record->as_formatted."  auth_tag_to_report :$auth_tag_to_report";
 763     # build a request for SearchAuthorities
 764     my $op = 'AND';
 765     $authtypecode =~ s#/#\\/#; # GENRE/FORM contains forward slash which is a reserved character
 766     my $query='at:'.$authtypecode.' ';
 767     my $filtervalues=qr([\001-\040\Q!'"`#$%&*+,-./:;<=>?@(){[}_|~\E\]]);
 768     if ($record->field($auth_tag_to_report)) {
 769         foreach ($record->field($auth_tag_to_report)->subfields()) {
 770             $_->[1]=~s/$filtervalues/ /g; $query.= " $op he:\"".$_->[1]."\"" if ($_->[0]=~/[A-z]/);
 771         }
 772     }
 773     my $searcher = Koha::SearchEngine::Search->new({index => $Koha::SearchEngine::AUTHORITIES_INDEX});
 774     my ($error, $results, $total_hits) = $searcher->simple_search_compat( $query, 0, 1, [ 'authorityserver' ] );
 775     # there is at least 1 result => return the 1st one
 776     if (!defined $error && @{$results} ) {
 777         my $marcrecord = C4::Search::new_record_from_zebra(
 778             'authorityserver',
 779             $results->[0]
 780         );
 781         return $marcrecord->field('001')->data,BuildSummary($marcrecord,$marcrecord->field('001')->data,$authtypecode);
 782     }
 783     # no result, returns nothing
 784     return;
 785 }
 786
 787 =head2 BuildSummary
 788
 789   $summary= &BuildSummary( $record, $authid, $authtypecode)
 790
 791 Returns a hashref with a summary of the specified record.
 792
 793 Comment : authtypecode can be inferred from both record and authid.
 794 Moreover, authid can also be inferred from $record.
 795 Would it be interesting to delete those things.
 796
 797 =cut
 798
 799 sub BuildSummary {
 800     ## give this a Marc record to return summary
 801     my ($record,$authid,$authtypecode)=@_;
 802     my $dbh=C4::Context->dbh;
 803     my %summary;
 804     my $summary_template;
 805     # handle $authtypecode is NULL or eq ""
 806     if ($authtypecode) {
 807         my $authref = Koha::Authority::Types->find($authtypecode);
 808         if ( $authref ) {
 809             $summary{authtypecode} = $authref->authtypecode;
 810             $summary{type} = $authref->authtypetext;
 811             $summary_template = $authref->summary;
 812             # for MARC21, the authority type summary displays a label meant for
 813             # display
 814             if (C4::Context->preference('marcflavour') ne 'UNIMARC') {
 815                 $summary{label} = $authref->summary;
 816             } else {
 817                 $summary{summary} = $authref->summary;
 818             }
 819         }
 820     }
 821     my $marc21subfields = 'abcdfghjklmnopqrstuvxyz68';
 822     my %marc21controlrefs = ( 'a' => 'earlier',
 823         'b' => 'later',
 824         'd' => 'acronym',
 825         'f' => 'musical',
 826         'g' => 'broader',
 827         'h' => 'narrower',
 828         'n' => 'notapplicable',
 829         'i' => 'subfi',
 830         't' => 'parent'
 831     );
 832     my %unimarc_relation_from_code = (
 833         g => 'broader',
 834         h => 'narrower',
 835         a => 'seealso',
 836     );
 837     my %thesaurus;
 838     $thesaurus{'1'}="Peuples";
 839     $thesaurus{'2'}="Anthroponymes";
 840     $thesaurus{'3'}="Oeuvres";
 841     $thesaurus{'4'}="Chronologie";
 842     $thesaurus{'5'}="Lieux";
 843     $thesaurus{'6'}="Sujets";
 844     #thesaurus a remplir
 845     my $reported_tag;
 846 # if the library has a summary defined, use it. Otherwise, build a standard one
 847 # FIXME - it appears that the summary field in the authority frameworks
 848 #         can work as a display template.  However, this doesn't
 849 #         suit the MARC21 version, so for now the "templating"
 850 #         feature will be enabled only for UNIMARC for backwards
 851 #         compatibility.
 852     if ($summary{summary} and C4::Context->preference('marcflavour') eq 'UNIMARC') {
 853         my @matches = ($summary{summary} =~ m/\[(.*?)(\d{3})([\*a-z0-9])(.*?)\]/g);
 854         my (@textbefore, @tag, @subtag, @textafter);
 855         for(my $i = 0; $i < scalar @matches; $i++){
 856             push @textbefore, $matches[$i] if($i%4 == 0);
 857             push @tag,        $matches[$i] if($i%4 == 1);
 858             push @subtag,     $matches[$i] if($i%4 == 2);
 859             push @textafter,  $matches[$i] if($i%4 == 3);
 860         }
 861         for(my $i = scalar @tag; $i >= 0; $i--){
 862             my $textbefore = $textbefore[$i] || '';
 863             my $tag = $tag[$i] || '';
 864             my $subtag = $subtag[$i] || '';
 865             my $textafter = $textafter[$i] || '';
 866             my $value = '';
 867             my $field = $record->field($tag);
 868             if ( $field ) {
 869                 if($subtag eq '*') {
 870                     if($tag < 10) {
 871                         $value = $textbefore . $field->data() . $textafter;
 872                     }
 873                 } else {
 874                     my @subfields = $field->subfield($subtag);
 875                     if(@subfields > 0) {
 876                         $value = $textbefore . join (" - ", @subfields) . $textafter;
 877                     }
 878                 }
 879             }
 880             $summary{summary} =~ s/\[\Q$textbefore$tag$subtag$textafter\E\]/$value/;
 881         }
 882         $summary{summary} =~ s/\\n/<br \/>/g;
 883     }
 884     my @authorized;
 885     my @notes;
 886     my @seefrom;
 887     my @seealso;
 888     my @otherscript;
 889     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
 890 # construct UNIMARC summary, that is quite different from MARC21 one
 891 # accepted form
 892         foreach my $field ($record->field('2..')) {
 893             push @authorized, {
 894                 heading => $field->as_string('abcdefghijlmnopqrstuvwxyz'),
 895                 hemain  => ( $field->subfield('a') // undef ),
 896                 field   => $field->tag(),
 897             };
 898         }
 899 # rejected form(s)
 900         foreach my $field ($record->field('3..')) {
 901             push @notes, { note => $field->subfield('a'), field => $field->tag() };
 902         }
 903         foreach my $field ($record->field('4..')) {
 904             my $thesaurus = $field->subfield('2') ? "thes. : ".$thesaurus{"$field->subfield('2')"}." : " : '';
 905             push @seefrom, {
 906                 heading => $thesaurus . $field->as_string('abcdefghijlmnopqrstuvwxyz'),
 907                 hemain  => ( $field->subfield('a') // undef ),
 908                 type    => 'seefrom',
 909                 field   => $field->tag(),
 910             };
 911         }
 912
 913         # see :
 914         @seealso = map {
 915             my $type = $unimarc_relation_from_code{$_->subfield('5') || 'a'};
 916             my $heading = $_->as_string('abcdefgjxyz');
 917             {
 918                 field   => $_->tag,
 919                 type    => $type,
 920                 heading => $heading,
 921                 hemain  => ( $_->subfield('a') // undef ),
 922                 search  => $heading,
 923                 authid  => ( $_->subfield('9') // undef ),
 924             }
 925         } $record->field('5..');
 926
 927         # Other forms
 928         @otherscript = map { {
 929             lang      => length ($_->subfield('8')) == 6 ? substr ($_->subfield('8'), 3, 3) : $_->subfield('8') || '',
 930             term      => $_->subfield('a') . ($_->subfield('b') ? ', ' . $_->subfield('b') : ''),
 931             direction => 'ltr',
 932             field     => $_->tag,
 933         } } $record->field('7..');
 934
 935     } else {
 936 # construct MARC21 summary
 937 # FIXME - looping over 1XX is questionable
 938 # since MARC21 authority should have only one 1XX
 939         use C4::Heading::MARC21;
 940         my $handler = C4::Heading::MARC21->new();
 941         my $subfields_to_report;
 942         foreach my $field ($record->field('1..')) {
 943             my $tag = $field->tag();
 944             next if "152" eq $tag;
 945 # FIXME - 152 is not a good tag to use
 946 # in MARC21 -- purely local tags really ought to be
 947 # 9XX
 948
 949             $subfields_to_report = $handler->get_auth_heading_subfields_to_report($tag);
 950
 951             if ($subfields_to_report) {
 952                 push @authorized, {
 953                     heading => $field->as_string($subfields_to_report),
 954                     hemain  => ( $field->subfield( substr($subfields_to_report, 0, 1) ) // undef ),
 955                     field   => $tag,
 956                 };
 957             } else {
 958                 push @authorized, {
 959                     heading => $field->as_string(),
 960                     hemain  => ( $field->subfield( 'a' ) // undef ),
 961                     field   => $tag,
 962                 };
 963             }
 964         }
 965         foreach my $field ($record->field('4..')) { #See From
 966             my $type = 'seefrom';
 967             $type = ($marc21controlrefs{substr $field->subfield('w'), 0, 1} || '') if ($field->subfield('w'));
 968             if ($type eq 'notapplicable') {
 969                 $type = substr $field->subfield('w'), 2, 1;
 970                 $type = 'earlier' if $type && $type ne 'n';
 971             }
 972             if ($type eq 'subfi') {
 973                 push @seefrom, {
 974                     heading => $field->as_string($marc21subfields),
 975                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 976                     type    => ($field->subfield('i') || ''),
 977                     field   => $field->tag(),
 978                 };
 979             } else {
 980                 push @seefrom, {
 981                     heading => $field->as_string($marc21subfields),
 982                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 983                     type    => $type,
 984                     field   => $field->tag(),
 985                 };
 986             }
 987         }
 988         foreach my $field ($record->field('5..')) { #See Also
 989             my $type = 'seealso';
 990             $type = ($marc21controlrefs{substr $field->subfield('w'), 0, 1} || '') if ($field->subfield('w'));
 991             if ($type eq 'notapplicable') {
 992                 $type = substr $field->subfield('w'), 2, 1;
 993                 $type = 'earlier' if $type && $type ne 'n';
 994             }
 995             if ($type eq 'subfi') {
 996                 push @seealso, {
 997                     heading => $field->as_string($marc21subfields),
 998                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
 999                     type    => scalar $field->subfield('i'),
1000                     field   => $field->tag(),
1001                     search  => $field->as_string($marc21subfields) || '',
1002                     authid  => $field->subfield('9') || ''
1003                 };
1004             } else {
1005                 push @seealso, {
1006                     heading => $field->as_string($marc21subfields),
1007                     hemain  => scalar $field->subfield( substr($marc21subfields, 0, 1) ),
1008                     type    => $type,
1009                     field   => $field->tag(),
1010                     search  => $field->as_string($marc21subfields) || '',
1011                     authid  => $field->subfield('9') || ''
1012                 };
1013             }
1014         }
1015         foreach my $field ($record->field('6..')) {
1016             push @notes, { note => $field->as_string(), field => $field->tag() };
1017         }
1018         foreach my $field ($record->field('880')) {
1019             my $linkage = $field->subfield('6');
1020             my $category = substr $linkage, 0, 1;
1021             if ($category eq '1') {
1022                 $category = 'preferred';
1023             } elsif ($category eq '4') {
1024                 $category = 'seefrom';
1025             } elsif ($category eq '5') {
1026                 $category = 'seealso';
1027             }
1028             my $type;
1029             if ($field->subfield('w')) {
1030                 $type = $marc21controlrefs{substr $field->subfield('w'), '0'};
1031             } else {
1032                 $type = $category;
1033             }
1034             my $direction = $linkage =~ m#/r$# ? 'rtl' : 'ltr';
1035             push @otherscript, { term => $field->as_string($subfields_to_report), category => $category, type => $type, direction => $direction, linkage => $linkage };
1036         }
1037     }
1038     $summary{mainentry} = $authorized[0]->{heading};
1039     $summary{mainmainentry} = $authorized[0]->{hemain};
1040     $summary{authorized} = \@authorized;
1041     $summary{notes} = \@notes;
1042     $summary{seefrom} = \@seefrom;
1043     $summary{seealso} = \@seealso;
1044     $summary{otherscript} = \@otherscript;
1045     return \%summary;
1046 }
1047
1048 =head2 GetAuthorizedHeading
1049
1050   $heading = &GetAuthorizedHeading({ record => $record, authid => $authid })
1051
1052 Takes a MARC::Record object describing an authority record or an authid, and
1053 returns a string representation of the first authorized heading. This routine
1054 should be considered a temporary shim to ease the future migration of authority
1055 data from C4::AuthoritiesMarc to the object-oriented Koha::*::Authority.
1056
1057 =cut
1058
1059 sub GetAuthorizedHeading {
1060     my $args = shift;
1061     my $record;
1062     unless ($record = $args->{record}) {
1063         return unless $args->{authid};
1064         $record = GetAuthority($args->{authid});
1065     }
1066     return unless (ref $record eq 'MARC::Record');
1067     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1068 # construct UNIMARC summary, that is quite different from MARC21 one
1069 # accepted form
1070         foreach my $field ($record->field('2..')) {
1071             return $field->as_string('abcdefghijlmnopqrstuvwxyz');
1072         }
1073     } else {
1074         use C4::Heading::MARC21;
1075         my $handler = C4::Heading::MARC21->new();
1076
1077         foreach my $field ($record->field('1..')) {
1078             my $subfields = $handler->get_valid_bib_heading_subfields($field->tag());
1079             return $field->as_string($subfields) if ($subfields);
1080         }
1081     }
1082     return;
1083 }
1084
1085 =head2 CompareFieldWithAuthority
1086
1087   $match = &CompareFieldWithAuthority({ field => $field, authid => $authid })
1088
1089 Takes a MARC::Field from a bibliographic record and an authid, and returns true if they match.
1090
1091 =cut
1092
1093 sub CompareFieldWithAuthority {
1094     my $args = shift;
1095
1096     my $record = GetAuthority($args->{authid});
1097     return unless (ref $record eq 'MARC::Record');
1098     if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1099         # UNIMARC has same subfields for bibs and authorities
1100         foreach my $field ($record->field('2..')) {
1101             return compare_fields($field, $args->{field}, 'abcdefghijlmnopqrstuvwxyz');
1102         }
1103     } else {
1104         use C4::Heading::MARC21;
1105         my $handler = C4::Heading::MARC21->new();
1106
1107         foreach my $field ($record->field('1..')) {
1108             my $subfields = $handler->get_valid_bib_heading_subfields($field->tag());
1109             return compare_fields($field, $args->{field}, $subfields) if ($subfields);
1110         }
1111     }
1112     return 0;
1113 }
1114
1115 =head2 BuildAuthHierarchies
1116
1117   $text= &BuildAuthHierarchies( $authid, $force)
1118
1119 return text containing trees for hierarchies
1120 for them to be stored in auth_header
1121
1122 Example of text:
1123 122,1314,2452;1324,2342,3,2452
1124
1125 =cut
1126
1127 sub BuildAuthHierarchies{
1128     my $authid = shift @_;
1129 #   warn "authid : $authid";
1130     my $force = shift @_ || (C4::Context->preference('marcflavour') eq 'UNIMARC' ? 0 : 1);
1131     my @globalresult;
1132     my $dbh=C4::Context->dbh;
1133     my $hierarchies;
1134     my $data = GetHeaderAuthority($authid);
1135     if ($data->{'authtrees'} and not $force){
1136         return $data->{'authtrees'};
1137 #  } elsif ($data->{'authtrees'}){
1138 #    $hierarchies=$data->{'authtrees'};
1139     } else {
1140         my $record = GetAuthority($authid);
1141         my $found;
1142         return unless $record;
1143         foreach my $field ($record->field('5..')){
1144             my $broader = 0;
1145             $broader = 1 if (
1146                     (C4::Context->preference('marcflavour') eq 'UNIMARC' && $field->subfield('5') && $field->subfield('5') eq 'g') ||
1147                     (C4::Context->preference('marcflavour') ne 'UNIMARC' && $field->subfield('w') && substr($field->subfield('w'), 0, 1) eq 'g'));
1148             if ($broader) {
1149                 my $subfauthid=_get_authid_subfield($field) || '';
1150                 next if ($subfauthid eq $authid);
1151                 my $parentrecord = GetAuthority($subfauthid);
1152                 next unless $parentrecord;
1153                 my $localresult=$hierarchies;
1154                 my $trees;
1155                 $trees = BuildAuthHierarchies($subfauthid);
1156                 my @trees;
1157                 if ($trees=~/;/){
1158                     @trees = split(/;/,$trees);
1159                 } else {
1160                     push @trees, $trees;
1161                 }
1162                 foreach (@trees){
1163                     $_.= ",$authid";
1164                 }
1165                 @globalresult = (@globalresult,@trees);
1166                 $found=1;
1167             }
1168             $hierarchies=join(";",@globalresult);
1169         }
1170 #Unless there is no ancestor, I am alone.
1171         $hierarchies="$authid" unless ($hierarchies);
1172     }
1173     AddAuthorityTrees($authid,$hierarchies);
1174     return $hierarchies;
1175 }
1176
1177 =head2 BuildAuthHierarchy
1178
1179   $ref= &BuildAuthHierarchy( $record, $class,$authid)
1180
1181 return a hashref in order to display hierarchy for record and final Authid $authid
1182
1183 "loopparents"
1184 "loopchildren"
1185 "class"
1186 "loopauthid"
1187 "current_value"
1188 "value"
1189
1190 =cut
1191
1192 sub BuildAuthHierarchy{
1193     my $record = shift @_;
1194     my $class = shift @_;
1195     my $authid_constructed = shift @_;
1196     return unless ($record && $record->field('001'));
1197     my $authid=$record->field('001')->data();
1198     my %cell;
1199     my $parents=""; my $children="";
1200     my (@loopparents,@loopchildren);
1201     my $marcflavour = C4::Context->preference('marcflavour');
1202     my $relationshipsf = $marcflavour eq 'UNIMARC' ? '5' : 'w';
1203     foreach my $field ($record->field('5..')){
1204         my $subfauthid=_get_authid_subfield($field);
1205         if ($subfauthid && $field->subfield($relationshipsf) && $field->subfield('a')){
1206             my $relationship = substr($field->subfield($relationshipsf), 0, 1);
1207             if ($relationship eq 'h'){
1208                 push @loopchildren, { "authid"=>$subfauthid,"value"=>$field->subfield('a')};
1209             }
1210             elsif ($relationship eq 'g'){
1211                 push @loopparents, { "authid"=>$subfauthid,"value"=>$field->subfield('a')};
1212             }
1213 # brothers could get in there with an else
1214         }
1215     }
1216     $cell{"parents"}=\@loopparents;
1217     $cell{"children"}=\@loopchildren;
1218     $cell{"class"}=$class;
1219     $cell{"authid"}=$authid;
1220     $cell{"current_value"} =1 if ($authid eq $authid_constructed);
1221     $cell{"value"}=C4::Context->preference('marcflavour') eq 'UNIMARC' ? $record->subfield('2..',"a") : $record->subfield('1..', 'a');
1222     return \%cell;
1223 }
1224
1225 =head2 BuildAuthHierarchyBranch
1226
1227   $branch = &BuildAuthHierarchyBranch( $tree, $authid[, $cnt])
1228
1229 Return a data structure representing an authority hierarchy
1230 given a list of authorities representing a single branch in
1231 an authority hierarchy tree. $authid is the current node in
1232 the tree (which may or may not be somewhere in the middle).
1233 $cnt represents the level of the upper-most item, and is only
1234 used when BuildAuthHierarchyBranch is called recursively (i.e.,
1235 don't ever pass in anything but zero to it).
1236
1237 =cut
1238
1239 sub BuildAuthHierarchyBranch {
1240     my ($tree, $authid, $cnt) = @_;
1241     $cnt |= 0;
1242     my $elementdata = GetAuthority(shift @$tree);
1243     my $branch = BuildAuthHierarchy($elementdata,"child".$cnt, $authid);
1244     if (scalar @$tree > 0) {
1245         my $nextBranch = BuildAuthHierarchyBranch($tree, $authid, ++$cnt);
1246         my $nextAuthid = $nextBranch->{authid};
1247         my $found;
1248         # If we already have the next branch listed as a child, let's
1249         # replace the old listing with the new one. If not, we will add
1250         # the branch at the end.
1251         foreach my $cell (@{$branch->{children}}) {
1252             if ($cell->{authid} eq $nextAuthid) {
1253                 $cell = $nextBranch;
1254                 $found = 1;
1255                 last;
1256             }
1257         }
1258         push @{$branch->{children}}, $nextBranch unless $found;
1259     }
1260     return $branch;
1261 }
1262
1263 =head2 GenerateHierarchy
1264
1265   $hierarchy = &GenerateHierarchy($authid);
1266
1267 Return an arrayref holding one or more "trees" representing
1268 authority hierarchies.
1269
1270 =cut
1271
1272 sub GenerateHierarchy {
1273     my ($authid) = @_;
1274     my $trees    = BuildAuthHierarchies($authid);
1275     my @trees    = split /;/,$trees ;
1276     push @trees,$trees unless (@trees);
1277     my @loophierarchies;
1278     foreach my $tree (@trees){
1279         my @tree=split /,/,$tree;
1280         push @tree, $tree unless (@tree);
1281         my $branch = BuildAuthHierarchyBranch(\@tree, $authid);
1282         push @loophierarchies, [ $branch ];
1283     }
1284     return \@loophierarchies;
1285 }
1286
1287 sub _get_authid_subfield{
1288     my ($field)=@_;
1289     return $field->subfield('9')||$field->subfield('3');
1290 }
1291
1292 =head2 GetHeaderAuthority
1293
1294   $ref= &GetHeaderAuthority( $authid)
1295
1296 return a hashref in order auth_header table data
1297
1298 =cut
1299
1300 sub GetHeaderAuthority{
1301   my $authid = shift @_;
1302   my $sql= "SELECT * from auth_header WHERE authid = ?";
1303   my $dbh=C4::Context->dbh;
1304   my $rq= $dbh->prepare($sql);
1305   $rq->execute($authid);
1306   my $data= $rq->fetchrow_hashref;
1307   return $data;
1308 }
1309
1310 =head2 AddAuthorityTrees
1311
1312   $ref= &AddAuthorityTrees( $authid, $trees)
1313
1314 return success or failure
1315
1316 =cut
1317
1318 sub AddAuthorityTrees{
1319   my $authid = shift @_;
1320   my $trees = shift @_;
1321   my $sql= "UPDATE IGNORE auth_header set authtrees=? WHERE authid = ?";
1322   my $dbh=C4::Context->dbh;
1323   my $rq= $dbh->prepare($sql);
1324   return $rq->execute($trees,$authid);
1325 }
1326
1327 =head2 merge
1328
1329     $count = merge({
1330         mergefrom => $mergefrom,
1331         [ MARCfrom => $MARCfrom, ]
1332         [ mergeto => $mergeto, ]
1333         [ MARCto => $MARCto, ]
1334         [ biblionumbers => [ $a, $b, $c ], ]
1335         [ override_limit => 1, ]
1336     });
1337
1338 Merge biblios linked to authority $mergefrom (mandatory parameter).
1339 If $mergeto equals mergefrom, the linked biblio field is updated.
1340 If $mergeto is different, the biblio field will be linked to $mergeto.
1341 If $mergeto is missing, the biblio field is deleted.
1342
1343 MARCfrom is used to determine if a cleared subfield in the authority record
1344 should be removed from a biblio. MARCto is used to populate the biblio
1345 record with the updated values; if you do not pass it, the biblio field
1346 will be deleted (same as missing mergeto).
1347
1348 Normally all biblio records linked to $mergefrom, will be considered. But
1349 you can pass specific numbers via the biblionumbers parameter.
1350
1351 The parameter override_limit is used by the cron job to force larger
1352 postponed merges.
1353
1354 Note: Although $mergefrom and $mergeto will normally be of the same
1355 authority type, merge also supports moving to another authority type.
1356
1357 =cut
1358
1359 sub merge {
1360     my ( $params ) = @_;
1361     my $mergefrom = $params->{mergefrom} || return;
1362     my $MARCfrom = $params->{MARCfrom};
1363     my $mergeto = $params->{mergeto};
1364     my $MARCto = $params->{MARCto};
1365     my $override_limit = $params->{override_limit};
1366
1367     # If we do not have biblionumbers, we get all linked biblios if the
1368     # number of linked records does not exceed the limit UNLESS we override.
1369     my @biblionumbers;
1370     if( $params->{biblionumbers} ) {
1371         @biblionumbers = @{ $params->{biblionumbers} };
1372     } elsif( $override_limit ) {
1373         @biblionumbers = Koha::Authorities->linked_biblionumbers({ authid => $mergefrom });
1374     } else { # now first check number of linked records
1375         my $max = C4::Context->preference('AuthorityMergeLimit') // 0;
1376         my $hits = Koha::Authorities->get_usage_count({ authid => $mergefrom });
1377         if( $hits > 0 && $hits <= $max ) {
1378             @biblionumbers = Koha::Authorities->linked_biblionumbers({ authid => $mergefrom });
1379         } elsif( $hits > $max ) { #postpone this merge to the cron job
1380             Koha::Authority::MergeRequest->new({
1381                 authid => $mergefrom,
1382                 oldrecord => $MARCfrom,
1383                 authid_new => $mergeto,
1384             })->store;
1385         }
1386     }
1387     return 0 if !@biblionumbers;
1388
1389     # Search authtypes and reporting tags
1390     my $authfrom = Koha::Authorities->find($mergefrom);
1391     my $authto = Koha::Authorities->find($mergeto);
1392     my $authtypefrom = $authfrom ? Koha::Authority::Types->find($authfrom->authtypecode) : undef;
1393     my $authtypeto   = $authto ? Koha::Authority::Types->find($authto->authtypecode) : undef;
1394     my $auth_tag_to_report_from = $authtypefrom ? $authtypefrom->auth_tag_to_report : '';
1395     my $auth_tag_to_report_to   = $authtypeto ? $authtypeto->auth_tag_to_report : '';
1396
1397     my @record_to;
1398     @record_to = $MARCto->field($auth_tag_to_report_to)->subfields() if $auth_tag_to_report_to && $MARCto && $MARCto->field($auth_tag_to_report_to);
1399     # Exceptional: If MARCto and authtypeto exist but $auth_tag_to_report_to
1400     # is empty, make sure that $9 and $a remain (instead of clearing the
1401     # reference) in order to allow for data recovery.
1402     # Note: We need $a too, since a single $9 does not pass ModBiblio.
1403     if( $MARCto && $authtypeto && !@record_to  ) {
1404         push @record_to, [ 'a', ' ' ]; # do not remove the space
1405     }
1406
1407     my @record_from;
1408     if( !$authfrom && $MARCfrom && $MARCfrom->field('1..','2..') ) {
1409     # postponed merge, authfrom was deleted and MARCfrom only contains the old reporting tag (and possibly a 100 for UNIMARC)
1410     # 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
1411         @record_from = ( $MARCfrom->field('1..','2..') )[-1]->subfields;
1412     } elsif( $auth_tag_to_report_from && $MARCfrom && $MARCfrom->field($auth_tag_to_report_from) ) {
1413         @record_from = $MARCfrom->field($auth_tag_to_report_from)->subfields;
1414     }
1415
1416     # Get all candidate tags for the change
1417     # (This will reduce the search scope in marc records).
1418     # For a deleted authority record, we scan all auth controlled fields
1419     my $dbh = C4::Context->dbh;
1420     my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
1421     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<>''" );
1422     my $tags_new;
1423     if( $authtypeto && ( !$authtypefrom || $authtypeto->authtypecode ne $authtypefrom->authtypecode )) {
1424         $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypeto->authtypecode ));
1425     }
1426
1427     my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1428     my $skip_subfields = $overwrite
1429         # This hash contains all subfields from the authority report fields
1430         # Including $MARCfrom as well as $MARCto
1431         # We only need it in loose merge mode; replaces the former $exclude
1432         ? {}
1433         : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
1434
1435     my $counteditedbiblio = 0;
1436     foreach my $biblionumber ( @biblionumbers ) {
1437         my $marcrecord = GetMarcBiblio({ biblionumber => $biblionumber });
1438         next if !$marcrecord;
1439         my $update = 0;
1440         foreach my $tagfield (@$tags_using_authtype) {
1441             my $countfrom = 0;    # used in strict mode to remove duplicates
1442             foreach my $field ( $marcrecord->field($tagfield) ) {
1443                 my $auth_number = $field->subfield("9");    # link to authority
1444                 my $tag         = $field->tag();
1445                 next if !defined($auth_number) || $auth_number ne $mergefrom;
1446                 $countfrom++;
1447                 if ( !$mergeto || !@record_to ||
1448                   ( $overwrite && $countfrom > 1 ) ) {
1449                     # !mergeto or !record_to indicates a delete
1450                     # Other condition: remove this duplicate in strict mode
1451                     $marcrecord->delete_field($field);
1452                     $update = 1;
1453                     next;
1454                 }
1455                 my $newtag = $tags_new && @$tags_new
1456                   ? _merge_newtag( $tag, $tags_new )
1457                   : $tag;
1458                 my $controlled_ind = $authto->controlled_indicators({ record => $MARCto, biblio_tag => $newtag });
1459                 my $field_to = MARC::Field->new(
1460                     $newtag,
1461                     $controlled_ind->{ind1} // $field->indicator(1),
1462                     $controlled_ind->{ind2} // $field->indicator(2),
1463                     9 => $mergeto, # Needed to create field, will be moved
1464                 );
1465                 my ( @prefix, @postfix );
1466                 if ( !$overwrite ) {
1467                     # add subfields back in loose mode, check skip_subfields
1468                     # The first extra subfields will be in front of the
1469                     # controlled block, the rest at the end.
1470                     my $prefix_flag = 1;
1471                     foreach my $subfield ( $field->subfields ) {
1472                         next if $subfield->[0] eq '9'; # skip but leave flag
1473                         if ( $skip_subfields->{ $subfield->[0] } ) {
1474                             # This marks the beginning of the controlled block
1475                             $prefix_flag = 0;
1476                             next;
1477                         }
1478                         if ($prefix_flag) {
1479                             push @prefix, [ $subfield->[0], $subfield->[1] ];
1480                         } else {
1481                             push @postfix, [ $subfield->[0], $subfield->[1] ];
1482                         }
1483                     }
1484                 }
1485                 foreach my $subfield ( @prefix, @record_to, @postfix ) {
1486                     $field_to->add_subfields($subfield->[0] => $subfield->[1]);
1487                 }
1488                 if( exists $controlled_ind->{sub2} ) { # thesaurus info
1489                     if( defined $controlled_ind->{sub2} ) {
1490                         # Add or replace
1491                         $field_to->update( 2 => $controlled_ind->{sub2} );
1492                     } else {
1493                         # Key alerts us here to remove $2
1494                         $field_to->delete_subfield( code => '2' );
1495                     }
1496                 }
1497                 # Move $9 to the end
1498                 $field_to->delete_subfield( code => '9' );
1499                 $field_to->add_subfields( 9 => $mergeto );
1500
1501                 if ($tags_new && @$tags_new) {
1502                     $marcrecord->delete_field($field);
1503                     append_fields_ordered( $marcrecord, $field_to );
1504                 } else {
1505                     $field->replace_with($field_to);
1506                 }
1507                 $update = 1;
1508             }
1509         }
1510         next if !$update;
1511         ModBiblio($marcrecord, $biblionumber, GetFrameworkCode($biblionumber));
1512         $counteditedbiblio++;
1513     }
1514     return $counteditedbiblio;
1515 }
1516
1517 sub _merge_newtag {
1518 # Routine is only called for an (exceptional) authtypecode change
1519 # Fixes old behavior of returning the first tag found
1520     my ( $oldtag, $new_tags ) = @_;
1521
1522     # If we e.g. have 650 and 151,651,751 try 651 and check presence
1523     my $prefix = substr( $oldtag, 0, 1 );
1524     my $guess = $prefix . substr( $new_tags->[0], -2 );
1525     if( grep { $_ eq $guess } @$new_tags ) {
1526         return $guess;
1527     }
1528     # Otherwise return one from the same block e.g. 6XX for 650
1529     # If not there too, fall back to first new tag (old behavior!)
1530     my @same_block = grep { /^$prefix/ } @$new_tags;
1531     return @same_block ? $same_block[0] : $new_tags->[0];
1532 }
1533
1534 sub append_fields_ordered {
1535 # while we lack this function in MARC::Record
1536 # we do not want insert_fields_ordered since it inserts before
1537     my ( $record, $field ) = @_;
1538     if( my @flds = $record->field( $field->tag ) ) {
1539         $record->insert_fields_after( pop @flds, $field );
1540     } else { # now fallback to insert_fields_ordered
1541         $record->insert_fields_ordered( $field );
1542     }
1543 }
1544
1545 =head2 get_auth_type_location
1546
1547   my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1548
1549 Get the tag and subfield used to store the heading type
1550 for indexing purposes.  The C<$auth_type> parameter is
1551 optional; if it is not supplied, assume ''.
1552
1553 This routine searches the MARC authority framework
1554 for the tag and subfield whose kohafield is
1555 C<auth_header.authtypecode>; if no such field is
1556 defined in the framework, default to the hardcoded value
1557 specific to the MARC format.
1558
1559 =cut
1560
1561 sub get_auth_type_location {
1562     my $auth_type_code = @_ ? shift : '';
1563
1564     my ($tag, $subfield) = GetAuthMARCFromKohaField('auth_header.authtypecode', $auth_type_code);
1565     if (defined $tag and defined $subfield and $tag != 0 and $subfield ne '' and $subfield ne ' ') {
1566         return ($tag, $subfield);
1567     } else {
1568         if (C4::Context->preference('marcflavour') eq "MARC21")  {
1569             return C4::AuthoritiesMarc::MARC21::default_auth_type_location();
1570         } else {
1571             return C4::AuthoritiesMarc::UNIMARC::default_auth_type_location();
1572         }
1573     }
1574 }
1575
1576 =head2 compare_fields
1577
1578   my match = compare_fields($field1, $field2, 'abcde');
1579
1580 Compares the listed subfields of both fields and return true if they all match
1581
1582 =cut
1583
1584 sub compare_fields {
1585     my ($field1, $field2, $subfields) = @_;
1586
1587     foreach my $subfield (split(//, $subfields)) {
1588         my $subfield1 = $field1->subfield($subfield) // '';
1589         my $subfield2 = $field2->subfield($subfield) // '';
1590         return 0 unless $subfield1 eq $subfield2;
1591     }
1592     return 1;
1593 }
1594
1595
1596 =head2 _after_authority_action_hooks
1597
1598 Helper method that takes care of calling all plugin hooks
1599
1600 =cut
1601
1602 sub _after_authority_action_hooks {
1603     my ( $args ) = @_; # hash keys: action, authority_id
1604     return Koha::Plugins->call( 'after_authority_action', $args );
1605 }
1606
1607 END { }       # module clean-up code here (global destructor)
1608
1609 1;
1610 __END__
1611
1612 =head1 AUTHOR
1613
1614 Koha Development Team <http://koha-community.org/>
1615
1616 Paul POULAIN paul.poulain@free.fr
1617 Ere Maijala ere.maijala@helsinki.fi
1618
1619 =cut
1620