C4/AuthoritiesMarc.pm

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