1package Biber::Config; 2use v5.16; 3 4use Biber; 5use Biber::Constants; 6use Biber::Utils; 7use IPC::Cmd qw( can_run ); 8use IPC::Run3; # This works with PAR::Packer and Windows. IPC::Run doesn't 9use Cwd qw( abs_path ); 10use Data::Compare; 11use Data::Dump; 12use Encode; 13use File::Slurp; 14use File::Spec; 15use Carp; 16use List::AllUtils qw(first max); 17use Log::Log4perl qw( :no_extra_logdie_message ); # To keep PAR::Packer happy, explicitly load these 18use Log::Log4perl::Appender::Screen; 19use Log::Log4perl::Appender::File; 20use Log::Log4perl::Layout::SimpleLayout; 21use Log::Log4perl::Layout::PatternLayout; 22use Unicode::Normalize; 23 24our $VERSION = '2.1'; 25our $BETA_VERSION = 0; # Is this a beta version? 26 27our $logger = Log::Log4perl::get_logger('main'); 28our $screen = Log::Log4perl::get_logger('screen'); 29our $logfile = Log::Log4perl::get_logger('logfile'); 30 31=encoding utf-8 32 33 34=head1 NAME 35 36Biber::Config - Configuration items which need to be saved across the 37 lifetime of a Biber object 38 39 This class contains a static object and static methods to access 40 configuration and state data. There are several classes of data in here 41 which have separate accessors: 42 43 * Biber options 44 * Biblatex options 45 * State information used by Biber as it processes entries 46 * displaymode date 47 48=cut 49 50 51# Static (class) data 52our $CONFIG; 53$CONFIG->{state}{crossrefkeys} = {}; 54$CONFIG->{state}{seenwork} = {}; 55 56# Set tracking, parent->child and child->parent 57$CONFIG->{state}{set}{pc} = {}; 58$CONFIG->{state}{set}{cp} = {}; 59 60# Citekeys which refer to the same entry 61$CONFIG->{state}{citkey_aliases} = {}; 62 63# Disambiguation data for labelalpha. Used for labelalphatemplate autoinc method 64$CONFIG->{state}{ladisambiguation} = {}; 65 66# Record of which entries have inherited from other fields. Used for loop detection. 67$CONFIG->{state}{crossref} = []; 68$CONFIG->{state}{xdata} = []; 69 70# Record of which entries have inherited what from whom, with the fields inherited. 71# Used for generating inheritance trees 72$CONFIG->{state}{graph} = {}; 73 74# For the uniquelist feature. Records the number of times a name list occurs in all entries 75$CONFIG->{state}{uniquelistcount} = {}; 76 77# Boolean to say whether uniquename/uniquelist information has changed 78# Default is true so that uniquename/uniquelist processing starts 79$CONFIG->{state}{unulchanged} = 1; 80 81# uniquenamecount holds a hash of lastnames and lastname/initials 82$CONFIG->{state}{uniquenamecount} = {}; 83# Same as uniquenamecount but for all names, regardless of visibility. Needed to track 84# uniquelist 85$CONFIG->{state}{uniquenamecount_all} = {}; 86# Counter for tracking name/year combinations for extrayear 87$CONFIG->{state}{seen_nameyear} = {}; 88# Counter for the actual extrayear value 89$CONFIG->{state}{seen_extrayear} = {}; 90 91# Counter for tracking name/title combinations for extratitle 92$CONFIG->{state}{seen_nametitle} = {}; 93# Counter for the actual extratitle value 94$CONFIG->{state}{seen_extratitle} = {}; 95 96# Counter for tracking title/year combinations for extratitleyear 97$CONFIG->{state}{seen_titleyear} = {}; 98# Counter for the actual extratitleyear value 99$CONFIG->{state}{seen_extratitleyear} = {}; 100 101# Counter for the actual extraalpha value 102$CONFIG->{state}{seen_extraalpha} = {}; 103$CONFIG->{state}{seenkeys} = {}; 104 105# Track the order of keys as cited. Keys cited in the same \cite*{} get the same order 106# Used for sorting schemes which use \citeorder 107$CONFIG->{state}{keyorder} = {}; 108 109# Location of the control file 110$CONFIG->{state}{control_file_location} = ''; 111 112# Data files per section being used by biber 113$CONFIG->{state}{datafiles} = []; 114 115=head2 _init 116 117 Reset internal hashes to defaults. 118 119=cut 120 121sub _init { 122 $CONFIG->{options}{biblatex}{PER_ENTRY} = {}; 123 $CONFIG->{state}{unulchanged} = 1; 124 $CONFIG->{state}{control_file_location} = ''; 125 $CONFIG->{state}{seenwork} = {}; 126 $CONFIG->{state}{crossrefkeys} = {}; 127 $CONFIG->{state}{ladisambiguation} = {}; 128 $CONFIG->{state}{uniquenamecount} = {}; 129 $CONFIG->{state}{uniquenamecount_all} = {}; 130 $CONFIG->{state}{uniquelistcount} = {}; 131 $CONFIG->{state}{seen_nameyear} = {}; 132 $CONFIG->{state}{seen_extrayear} = {}; 133 $CONFIG->{state}{seen_nametitle} = {}; 134 $CONFIG->{state}{seen_extratitle} = {}; 135 $CONFIG->{state}{seen_titleyear} = {}; 136 $CONFIG->{state}{seen_extratitleyear} = {}; 137 $CONFIG->{state}{seen_extrayearalpha} = {}; 138 $CONFIG->{state}{seenkeys} = {}; 139 $CONFIG->{state}{datafiles} = []; 140 $CONFIG->{state}{crossref} = []; 141 $CONFIG->{state}{xdata} = []; 142 $CONFIG->{state}{set}{pc} = {}; 143 $CONFIG->{state}{set}{cp} = {}; 144 145 return; 146} 147 148=head2 _initopts 149 150 Initialise default options, optionally with config file as argument 151 152=cut 153 154sub _initopts { 155 shift; # class method so don't care about class name 156 my $opts = shift; 157 my $userconf; 158 159 # For testing, need to be able to force ignore of conf file in case user 160 # already has one which interferes with test settings. 161 unless (defined($opts->{noconf})) { 162 # if a config file was given as cmd-line arg, it overrides all other 163 # config file locations 164 unless ( defined($opts->{configfile}) and -f $opts->{configfile} ) { 165 $opts->{configfile} = config_file(); 166 } 167 } 168 169 # Set hard-coded biber option defaults 170 while (my ($k, $v) = each %$CONFIG_DEFAULT_BIBER) { 171 if (exists($v->{content})) { # simple option 172 Biber::Config->setoption($k, $v->{content}); 173 } 174 # mildly complex options 175 elsif (lc($k) eq 'dot_include' or 176 lc($k) eq 'collate_options' or 177 lc($k) eq 'nosort' or 178 lc($k) eq 'noinit' ) { 179 Biber::Config->setoption($k, $v->{option}); 180 } 181 } 182 183 # There is a special default config file for tool mode 184 # Referring to as yet unprocessed cmd-line tool option as it isn't processed until below 185 if ($opts->{tool}) { 186 (my $vol, my $dir, undef) = File::Spec->splitpath( $INC{"Biber/Config.pm"} ); 187 $dir =~ s/\/$//; # splitpath sometimes leaves a trailing '/' 188 _config_file_set(File::Spec->catpath($vol, "$dir", 'biber-tool.conf')); 189 } 190 191 # Normal user config file - overrides tool mode defaults, if any 192 _config_file_set($opts->{configfile}); 193 194 # Set hard-coded biblatex option defaults 195 # This has to go after _config_file_set() as this is what defines option scope 196 # in tool mode (from the .conf file) 197 foreach (keys %CONFIG_DEFAULT_BIBLATEX) { 198 Biber::Config->setblxoption($_, $CONFIG_DEFAULT_BIBLATEX{$_}); 199 } 200 201 # Command-line overrides everything else 202 foreach my $copt (keys %$opts) { 203 # This is a tricky option as we need to keep non-overriden defaults 204 # If we don't we can get errors when contructing the sorting call to eval() later 205 if (lc($copt) eq 'collate_options') { 206 my $collopts = Biber::Config->getoption('collate_options'); 207 my $copt_h = eval "{ $opts->{$copt} }" or croak('Bad command-line collation options'); 208 # Override defaults with any cmdline settings 209 foreach my $co (keys %$copt_h) { 210 $collopts->{$co} = $copt_h->{$co}; 211 } 212 Biber::Config->setconfigfileoption('collate_options', $collopts); 213 } 214 else { 215 Biber::Config->setcmdlineoption($copt, $opts->{$copt}); 216 } 217 } 218 219 # Set control file name. In a conditional as @ARGV might not be set in tests 220 if (my $bcf = $ARGV[0]) { # ARGV is ok even in a module 221 $bcf .= '.bcf' unless $bcf =~ m/\.bcf$/; 222 Biber::Config->setoption('bcf', $bcf); # only referenced in biber program 223 } 224 225 # Set log file name 226 my $biberlog; 227 if (my $log = Biber::Config->getoption('logfile')) { # user specified logfile name 228 # Sanitise user-specified log name 229 $log =~ s/\.blg\z//xms; 230 $biberlog = $log . '.blg'; 231 } 232 elsif (not @ARGV) { # default if no .bcf file specified - mainly in tests 233 Biber::Config->setoption('nolog', 1); 234 } 235 else { # set log to \jobname.blg 236 my $bcf = $ARGV[0]; # ARGV is ok even in a module 237 # Sanitise control file name 238 $bcf =~ s/\.bcf\z//xms; 239 $biberlog = $bcf . '.blg'; 240 } 241 242 # prepend output directory for log, if specified 243 if (my $outdir = Biber::Config->getoption('output_directory')) { 244 $biberlog = File::Spec->catfile($outdir, $biberlog); 245 } 246 247 # Setting up Log::Log4perl 248 my $LOGLEVEL; 249 if (Biber::Config->getoption('trace')) { 250 $LOGLEVEL = 'TRACE' 251 } 252 elsif (Biber::Config->getoption('debug')) { 253 $LOGLEVEL = 'DEBUG' 254 } 255 elsif (Biber::Config->getoption('quiet') == 1) { 256 $LOGLEVEL = 'ERROR' 257 } 258 elsif (Biber::Config->getoption('quiet') > 1) { 259 $LOGLEVEL = 'FATAL' 260 } 261 else { 262 $LOGLEVEL = 'INFO' 263 } 264 265 my $LOGLEVEL_F; 266 my $LOG_MAIN; 267 if (Biber::Config->getoption('nolog')) { 268 $LOG_MAIN = 'Screen'; 269 $LOGLEVEL_F = 'OFF' 270 } 271 else { 272 $LOG_MAIN = 'Logfile, Screen'; 273 $LOGLEVEL_F = $LOGLEVEL 274 } 275 276 my $LOGLEVEL_S; 277 if (Biber::Config->getoption('onlylog')) { 278 $LOGLEVEL_S = 'OFF' 279 } 280 else { 281 # Max screen loglevel is INFO 282 if (Biber::Config->getoption('quiet') == 1) { 283 $LOGLEVEL_S = 'ERROR'; 284 } 285 elsif (Biber::Config->getoption('quiet') > 1) { 286 $LOGLEVEL_S = 'FATAL' 287 } 288 else { 289 $LOGLEVEL_S = 'INFO'; 290 } 291 } 292 293 # configuration "file" for Log::Log4perl 294 my $l4pconf = qq| 295 log4perl.category.main = $LOGLEVEL, $LOG_MAIN 296 log4perl.category.screen = $LOGLEVEL_S, Screen 297 298 log4perl.appender.Screen = Log::Log4perl::Appender::Screen 299 log4perl.appender.Screen.utf8 = 1 300 log4perl.appender.Screen.Threshold = $LOGLEVEL_S 301 log4perl.appender.Screen.stderr = 0 302 log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout 303|; 304 305 # Only want a logfile appender if --nolog isn't set 306 if ($LOGLEVEL_F ne 'OFF') { 307 $l4pconf .= qq| 308 log4perl.category.logfile = $LOGLEVEL_F, Logfile 309 log4perl.appender.Logfile = Log::Log4perl::Appender::File 310 log4perl.appender.Logfile.utf8 = 1 311 log4perl.appender.Logfile.Threshold = $LOGLEVEL_F 312 log4perl.appender.Logfile.filename = $biberlog 313 log4perl.appender.Logfile.mode = clobber 314 log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout 315 log4perl.appender.Logfile.layout.ConversionPattern = [%r] %F{1}:%L> %p - %m%n 316|; 317 } 318 319 Log::Log4perl->init(\$l4pconf); 320 321 my $vn = $VERSION; 322 $vn .= ' (beta)' if $BETA_VERSION; 323 my $tool = ' running in TOOL mode' if Biber::Config->getoption('tool'); 324 325 $logger->info("This is Biber $vn$tool") unless Biber::Config->getoption('nolog'); 326 327 $logger->info("Config file is '" . $opts->{configfile} . "'") if $opts->{configfile}; 328 $logger->info("Logfile is '$biberlog'") unless Biber::Config->getoption('nolog'); 329 330 if (Biber::Config->getoption('debug')) { 331 $screen->info("DEBUG mode: all messages are logged to '$biberlog'") 332 } 333 334 return; 335} 336 337# read a config file and set options from it 338sub _config_file_set { 339 my $conf = shift; 340 my $userconf; 341 342 # Can't use logcroak here because logging isn't initialised yet 343 if (defined($conf)) { 344 require XML::LibXML::Simple; 345 346 my $buf = File::Slurp::read_file($conf); 347 $buf = NFD(decode('UTF-8', $buf));# Unicode NFD boundary 348 349 $userconf = XML::LibXML::Simple::XMLin($buf, 350 'ForceContent' => 1, 351 'ForceArray' => [ 352 qr/\Aoption\z/, 353 qr/\Amaps\z/, 354 qr/\Amap\z/, 355 qr/\Amap_step\z/, 356 qr/\Aper_type\z/, 357 qr/\Aper_datasource\z/, 358 qr/\Atype_pair\z/, 359 qr/\Ainherit\z/, 360 qr/\Afieldor\z/, 361 qr/\Afieldxor\z/, 362 qr/\Afield\z/, 363 qr/\Aalias\z/, 364 qr/\Aalsoset\z/, 365 qr/\Aconstraints\z/, 366 qr/\Aconstraint\z/, 367 qr/\Aentrytype\z/, 368 qr/\Adatetype\z/, 369 qr/\Acondition\z/, 370 qr/\A(?:or)?filter\z/, 371 qr/\Asortexclusion\z/, 372 qr/\Aexclusion\z/, 373 qr/\Asort\z/, 374 qr/\Asortitem\z/, 375 qr/\Apresort\z/, 376 qr/\Aoptionscope\z/, 377 ], 378 'NsStrip' => 1, 379 'KeyAttr' => []) or 380 croak("Failed to read biber config file '$conf'\n $@"); 381 } 382 # Option scope has to be set first 383 foreach my $bcfscopeopts (@{$userconf->{optionscope}}) { 384 my $type = $bcfscopeopts->{type}; 385 foreach my $bcfscopeopt (@{$bcfscopeopts->{option}}) { 386 $CONFIG_SCOPE_BIBLATEX{$bcfscopeopt->{content}}{$type} = 1; 387 } 388 } 389 delete $userconf->{optionscope}; 390 391 # Set options from config file 392 while (my ($k, $v) = each %$userconf) { 393 if (exists($v->{content})) { # simple option 394 Biber::Config->setconfigfileoption($k, $v->{content}); 395 } 396 # mildly complex options - nosort/collate_options 397 elsif (lc($k) eq 'nosort' or 398 lc($k) eq 'noinit' ) { 399 Biber::Config->setconfigfileoption($k, $v->{option}); 400 } 401 # rather complex options 402 elsif (lc($k) eq 'collate_options') { 403 my $collopts = Biber::Config->getoption('collate_options'); 404 # Override defaults with any user settings 405 foreach my $co (@{$v->{option}}) { 406 $collopts->{$co->{name}} = $co->{value}; 407 } 408 Biber::Config->setconfigfileoption($k, $collopts); 409 } 410 elsif (lc($k) eq 'sourcemap') { 411 my $sms; 412 foreach my $sm (@{$v->{maps}}) { 413 if (defined($sm->{level}) and $sm->{level} eq 'driver') { 414 carp("You can't set driver level sourcemaps via biber - use \\DeclareDriverSourcemap in biblatex. Ignoring map."); 415 } 416 elsif (defined($sm->{level}) and $sm->{level} eq 'style') { 417 carp("You can't set style level sourcemaps via biber - use \\DeclareStyleSourcemap in biblatex. Ignoring map."); 418 } 419 else { 420 push @$sms, $sm; 421 } 422 } 423 Biber::Config->setconfigfileoption($k, $sms); 424 } 425 elsif (lc($k) eq 'inheritance') {# This is a biblatex option 426 Biber::Config->setblxoption($k, $v); 427 } 428 elsif (lc($k) eq 'sorting') {# This is a biblatex option 429 # sorting excludes 430 foreach my $sex (@{$v->{sortexclusion}}) { 431 my $excludes; 432 foreach my $ex (@{$sex->{exclusion}}) { 433 $excludes->{$ex->{content}} = 1; 434 } 435 Biber::Config->setblxoption('sortexclusion', 436 $excludes, 437 'PER_TYPE', 438 $sex->{type}); 439 } 440 441 # presort defaults 442 foreach my $presort (@{$v->{presort}}) { 443 # Global presort default 444 unless (exists($presort->{type})) { 445 Biber::Config->setblxoption('presort', $presort->{content}); 446 } 447 # Per-type default 448 else { 449 Biber::Config->setblxoption('presort', 450 $presort->{content}, 451 'PER_TYPE', 452 $presort->{type}); 453 } 454 } 455 Biber::Config->setblxoption('sorting', Biber::_parse_sort($v)); 456 } 457 elsif (lc($k) eq 'datamodel') {# This is a biblatex option 458 Biber::Config->setblxoption('datamodel', $v); 459 } 460 } 461} 462 463=head2 config_file 464 465Returns the full path of the B<Biber> configuration file. 466If returns the first file found among: 467 468=over 4 469 470=item * C<biber.conf> in the current directory 471 472=item * C<$HOME/.biber.conf> 473 474=item * C<$ENV{XDG_CONFIG_HOME}/biber/biber.conf> 475 476=item * C<$HOME/Library/biber/biber.conf> (Mac OSX only) 477 478=item * C<$ENV{APPDATA}/biber.conf> (Windows only) 479 480=item * the output of C<kpsewhich biber.conf> (if available on the system). 481 482=back 483 484If no file is found, it returns C<undef>. 485 486=cut 487 488sub config_file { 489 my $biberconf; 490 491 if ( -f $BIBER_CONF_NAME ) { 492 $biberconf = abs_path($BIBER_CONF_NAME); 493 } 494 elsif ( -f File::Spec->catfile($ENV{HOME}, ".$BIBER_CONF_NAME" ) ) { 495 $biberconf = File::Spec->catfile($ENV{HOME}, ".$BIBER_CONF_NAME" ); 496 } 497 elsif ( defined $ENV{XDG_CONFIG_HOME} and 498 -f File::Spec->catfile($ENV{XDG_CONFIG_HOME}, "biber", $BIBER_CONF_NAME) ) { 499 $biberconf = File::Spec->catfile($ENV{XDG_CONFIG_HOME}, "biber", $BIBER_CONF_NAME); 500 } 501 elsif ( $^O =~ /(?:Mac|darwin)/ and 502 -f File::Spec->catfile($ENV{HOME}, "Library", "biber", $BIBER_CONF_NAME) ) { 503 $biberconf = File::Spec->catfile($ENV{HOME}, "Library", "biber", $BIBER_CONF_NAME); 504 } 505 elsif ( $^O =~ /Win/ and 506 defined $ENV{APPDATA} and 507 -f File::Spec->catfile($ENV{APPDATA}, "biber", $BIBER_CONF_NAME) ) { 508 $biberconf = File::Spec->catfile($ENV{APPDATA}, "biber", $BIBER_CONF_NAME); 509 } 510 elsif ( can_run('kpsewhich') ) { 511 my $err; 512 run3 [ 'kpsewhich', $BIBER_CONF_NAME ], \undef, \$biberconf, \$err, { return_if_system_error => 1}; 513 if ($? == -1) { 514 biber_error("Error running kpsewhich to look for config file: $err"); 515 } 516 517 chomp $biberconf; 518 $biberconf =~ s/\cM\z//xms; # kpsewhich in cygwin sometimes returns ^M at the end 519 $biberconf = undef unless $biberconf; # sanitise just in case it's an empty string 520 } 521 else { 522 $biberconf = undef; 523 } 524 525 return $biberconf; 526} 527 528############################## 529# Biber options static methods 530############################## 531 532=head2 get_unul_done 533 534 Return a boolean saying whether uniquenename+uniquelist processing is finished 535 536=cut 537 538sub get_unul_done { 539 shift; # class method so don't care about class name 540 return $CONFIG->{state}{unulchanged} ? 0 : 1; 541} 542 543=head2 set_unul_changed 544 545 Set a boolean saying whether uniquename+uniquelist has changed 546 547=cut 548 549sub set_unul_changed { 550 shift; # class method so don't care about class name 551 my $val = shift; 552 $CONFIG->{state}{unulchanged} = $val; 553 return; 554} 555 556=head2 postprocess_biber_opts 557 558 Place to postprocess biber options when they have been 559 gathered from all the possible places that set them 560 561=cut 562 563sub postprocess_biber_opts { 564 shift; # class method so don't care about class name 565 # Turn sortcase, sortupper, sortfirstinits into booleans if they are not already 566 # They are not booleans on the command-line/config file so that they 567 # mirror biblatex option syntax for users, for example 568 569 foreach my $opt ('sortfirstinits', 'sortcase', 'sortupper') { 570 if (exists($CONFIG->{options}{biber}{$opt})) { 571 if ($CONFIG->{options}{biber}{$opt} eq 'true') { 572 $CONFIG->{options}{biber}{$opt} = 1; 573 } 574 elsif ($CONFIG->{options}{biber}{$opt} eq 'false') { 575 $CONFIG->{options}{biber}{$opt} = 0; 576 } 577 unless ($CONFIG->{options}{biber}{$opt} eq '1' or 578 $CONFIG->{options}{biber}{$opt} eq '0') { 579 Biber::Utils::biber_error("Invalid value for option '$opt'"); 580 } 581 } 582 } 583} 584 585=head2 set_dm 586 587 Sets the data model information object 588 589=cut 590 591sub set_dm { 592 shift; 593 my $obj = shift; 594 $CONFIG->{dm} = $obj; 595 return; 596} 597 598=head2 get_dm 599 600 Gets the data model information object 601 602=cut 603 604sub get_dm { 605 shift; 606 return $CONFIG->{dm}; 607} 608 609=head2 set_ctrlfile_path 610 611 Stores the path to the control file 612 613=cut 614 615sub set_ctrlfile_path { 616 shift; 617 $CONFIG->{control_file_location} = shift; 618 return; 619} 620 621=head2 get_ctrlfile_path 622 623 Retrieved the path to the control file 624 625=cut 626 627sub get_ctrlfile_path { 628 shift; 629 return $CONFIG->{control_file_location}; 630} 631 632=head2 setoption 633 634 Store a Biber config option 635 636=cut 637 638sub setoption { 639 shift; # class method so don't care about class name 640 my ($opt, $val) = @_; 641 $CONFIG->{options}{biber}{$opt} = $val; 642 return; 643} 644 645=head2 getoption 646 647 Get a Biber option 648 649=cut 650 651sub getoption { 652 shift; # class method so don't care about class name 653 my $opt = shift; 654 return $CONFIG->{options}{biber}{$opt}; 655} 656 657=head2 setcmdlineoption 658 659 Store a Biber command-line option 660 661=cut 662 663sub setcmdlineoption { 664 shift; # class method so don't care about class name 665 my ($opt, $val) = @_; 666 # Command line options are also options ... 667 $CONFIG->{options}{biber}{$opt} = $CONFIG->{cmdlineoptions}{$opt} = $val; 668 return; 669} 670 671=head2 setconfigfileoption 672 673 Store a Biber config-file option 674 675=cut 676 677sub setconfigfileoption { 678 shift; # class method so don't care about class name 679 my ($opt, $val) = @_; 680 # Config file options are also options ... 681 $CONFIG->{options}{biber}{$opt} = $CONFIG->{configfileoptions}{$opt} = $val; 682 return; 683} 684 685 686=head2 iscmdlineoption 687 688 Check if an option is explicitly set by user on the command 689 line 690 691=cut 692 693sub iscmdlineoption { 694 shift; # class method so don't care about class name 695 my $opt = shift; 696 return 1 if defined($CONFIG->{cmdlineoptions}{$opt}); 697 return 0; 698} 699 700=head2 isconfigfileoption 701 702 Check if an option is explicitly set by user in their 703 config file 704 705=cut 706 707sub isconfigfileoption { 708 shift; # class method so don't care about class name 709 my $opt = shift; 710 return 1 if defined($CONFIG->{configfileoptions}{$opt}); 711 return 0; 712} 713 714=head2 isexplicitoption 715 716 Check if an option is explicitly set by user on the command 717 line or in the config file 718 719=cut 720 721sub isexplicitoption { 722 my $self = shift; 723 my $opt = shift; 724 return 1 if ($self->iscmdlineoption($opt) || $self->isconfigfileoption($opt)); 725 return 0; 726} 727 728 729################################# 730# BibLaTeX options static methods 731################################# 732 733 734=head2 setblxoption 735 736 Set a biblatex option on the appropriate scope 737 738=cut 739 740sub setblxoption { 741 shift; # class method so don't care about class name 742 my ($opt, $val, $scope, $scopeval) = @_; 743 if (not defined($scope)) { # global is the default 744 if ($CONFIG_SCOPE_BIBLATEX{$opt}->{GLOBAL}) { 745 $CONFIG->{options}{biblatex}{GLOBAL}{$opt} = $val; 746 } 747 } 748 else { # Per-type/entry options need to specify type/entry too 749 if ($CONFIG_SCOPE_BIBLATEX{$opt}->{$scope}) { 750 $CONFIG->{options}{biblatex}{$scope}{$scopeval}{$opt} = $val; 751 } 752 } 753 return; 754} 755 756=head2 getblxoption 757 758 Get a biblatex option from the global or per entry-type scope 759 760 getblxoption('option', ['entrytype'], ['citekey']) 761 762 Returns the value of option. In order of decreasing preference, returns: 763 1. Biblatex option defined for entry 764 2. Biblatex option defined for entry type 765 3. Biblatex option defined globally 766 767=cut 768 769sub getblxoption { 770 shift; # class method so don't care about class name 771 my ($opt, $entrytype, $citekey) = @_; 772 if ( defined($citekey) and 773 $CONFIG_SCOPE_BIBLATEX{$opt}->{PER_ENTRY} and 774 defined $CONFIG->{options}{biblatex}{PER_ENTRY}{$citekey} and 775 defined $CONFIG->{options}{biblatex}{PER_ENTRY}{$citekey}{$opt}) { 776 return $CONFIG->{options}{biblatex}{PER_ENTRY}{$citekey}{$opt}; 777 } 778 elsif (defined($entrytype) and 779 $CONFIG_SCOPE_BIBLATEX{$opt}->{PER_TYPE} and 780 defined $CONFIG->{options}{biblatex}{PER_TYPE}{lc($entrytype)} and 781 defined $CONFIG->{options}{biblatex}{PER_TYPE}{lc($entrytype)}{$opt}) { 782 return $CONFIG->{options}{biblatex}{PER_TYPE}{lc($entrytype)}{$opt}; 783 } 784 elsif ($CONFIG_SCOPE_BIBLATEX{$opt}->{GLOBAL}) { 785 return $CONFIG->{options}{biblatex}{GLOBAL}{$opt}; 786 } 787} 788 789 790 791############################## 792# Inheritance state methods 793############################## 794 795=head2 set_graph 796 797 Record node and arc connection types for .dot output 798 799=cut 800 801sub set_graph { 802 shift; # class method so don't care about class name 803 my $type = shift; 804 if ($type eq 'set') { 805 my ($source_key, $target_key) = @_; 806 $logger->debug("Saving DOT graph information type 'set' with SOURCEKEY=$source_key, TARGETKEY=$target_key"); 807 $CONFIG->{state}{graph}{$type}{settomem}{$source_key}{$target_key} = 1; 808 $CONFIG->{state}{graph}{$type}{memtoset}{$target_key} = $source_key; 809 } 810 elsif ($type eq 'xref') { 811 my ($source_key, $target_key) = @_; 812 $logger->debug("Saving DOT graph information type 'xref' with SOURCEKEY=$source_key, TARGETKEY=$target_key"); 813 $CONFIG->{state}{graph}{$type}{$source_key} = $target_key; 814 } 815 elsif ($type eq 'related') { 816 my ($clone_key, $related_key, $target_key) = @_; 817 $logger->debug("Saving DOT graph information type 'related' with CLONEKEY=$clone_key, RELATEDKEY=$related_key, TARGETKEY=$target_key"); 818 $CONFIG->{state}{graph}{$type}{reltoclone}{$related_key}{$clone_key} = 1; 819 $CONFIG->{state}{graph}{$type}{clonetotarget}{$clone_key}{$target_key} = 1; 820 } 821 else { 822 my ($source_key, $target_key, $source_field, $target_field) = @_; 823 $logger->debug("Saving DOT graph information type '$type' with SOURCEKEY=$source_key, TARGETKEY=$target_key, SOURCEFIELD=$source_field, TARGETFIELD=$target_field"); 824 $CONFIG->{state}{graph}{$type}{$source_key}{$source_field}{$target_key} = $target_field; 825 } 826 return; 827} 828 829=head2 get_graph 830 831 Return an inheritance graph data structure for an inheritance type 832 833=cut 834 835sub get_graph { 836 shift; # class method so don't care about class name 837 my $type = shift; 838 return $CONFIG->{state}{graph}{$type}; 839} 840 841=head2 set_set_pc 842 843 Record a parent->child set relationship 844 845=cut 846 847sub set_set_pc { 848 shift; # class method so don't care about class name 849 my ($parent, $child) = @_; 850 $CONFIG->{state}{set}{pc}{$parent}{$child} = 1; 851 return; 852} 853 854=head2 set_set_cp 855 856 Record a child->parent set relationship 857 858=cut 859 860sub set_set_cp { 861 shift; # class method so don't care about class name 862 my ($child, $parent) = @_; 863 $CONFIG->{state}{set}{cp}{$child}{$parent} = 1; 864 return; 865} 866 867=head2 get_set_pc 868 869 Return a boolean saying if there is a parent->child set relationship 870 871=cut 872 873sub get_set_pc { 874 shift; # class method so don't care about class name 875 my ($parent, $child) = @_; 876 return exists($CONFIG->{state}{set}{pc}{$parent}{$child}) ? 1 : 0; 877} 878 879=head2 get_set_cp 880 881 Return a boolean saying if there is a child->parent set relationship 882 883=cut 884 885sub get_set_cp { 886 shift; # class method so don't care about class name 887 my ($child, $parent) = @_; 888 return exists($CONFIG->{state}{set}{cp}{$child}{$parent}) ? 1 : 0; 889} 890 891=head2 get_set_children 892 893 Return a list of children for a parent set 894 895=cut 896 897sub get_set_children { 898 shift; # class method so don't care about class name 899 my $parent = shift; 900 if (exists($CONFIG->{state}{set}{pc}{$parent})) { 901 return (keys %{$CONFIG->{state}{set}{pc}{$parent}}); 902 } 903 else { 904 return (); 905 } 906} 907 908=head2 get_set_parents 909 910 Return a list of parents for a child of a set 911 912=cut 913 914sub get_set_parents { 915 shift; # class method so don't care about class name 916 my $child = shift; 917 if (exists($CONFIG->{state}{set}{cp}{$child})) { 918 return (keys %{$CONFIG->{state}{set}{cp}{$child}}); 919 } 920 else { 921 return (); 922 } 923} 924 925 926=head2 set_inheritance 927 928 Record that $target inherited information from $source 929 Can be used for crossrefs and xdata. This just records that an entry 930 inherited from another entry, for loop detection. 931 932=cut 933 934sub set_inheritance { 935 shift; # class method so don't care about class name 936 my ($type, $source, $target) = @_; 937 push @{$CONFIG->{state}{$type}}, {s => $source, t => $target}; 938 return; 939} 940 941 942=head2 get_inheritance 943 944 Check if $target directly inherited information from $source 945 Can be used for crossrefs and xdata 946 947=cut 948 949sub get_inheritance { 950 shift; # class method so don't care about class name 951 my ($type, $source, $target) = @_; 952 return first {$_->{s} eq $source and $_->{t} eq $target} @{$CONFIG->{state}{$type}}; 953} 954 955=head2 is_inheritance_path 956 957 Checks for an inheritance path from entry $e1 to $e2 958 Can be used for crossrefs and xdata 959 960[ 961 {s => 'A', 962 t => 'B'}, 963 {s => 'A', 964 t => 'E'}, 965 {s => 'B', 966 t => 'C'}, 967 {s => 'C', 968 t => 'D'} 969]; 970 971=cut 972 973sub is_inheritance_path { 974 my ($self, $type, $e1, $e2) = @_; 975 foreach my $dps (grep {$_->{s} eq $e1} @{$CONFIG->{state}{$type}}) { 976 return 1 if $dps->{t} eq $e2; 977 return 1 if is_inheritance_path($self, $type, $dps->{t}, $e2); 978 } 979 return 0; 980} 981 982 983=head1 labelalpha disambiguation 984 985=head2 incr_la_disambiguation 986 987 Increment a counter to say we have seen this labelalpha 988 989=cut 990 991sub incr_la_disambiguation { 992 shift; # class method so don't care about class name 993 my $la = shift; 994 $CONFIG->{state}{ladisambiguation}{$la}++; 995 return; 996} 997 998 999=head2 get_la_disambiguation 1000 1001 Get the disambiguation counter for this labelalpha. 1002 Return a 0 for undefs to avoid spurious errors. 1003 1004=cut 1005 1006sub get_la_disambiguation { 1007 shift; # class method so don't care about class name 1008 my $la = shift; 1009 return $CONFIG->{state}{ladisambiguation}{$la} // 0; 1010} 1011 1012=head1 keyorder 1013 1014=head2 set_keyorder 1015 1016 Set some key order information 1017 1018=cut 1019 1020sub set_keyorder { 1021 shift; # class method so don't care about class name 1022 my ($section, $key, $keyorder) = @_; 1023 $CONFIG->{state}{keyorder}{$section}{$key} = $keyorder; 1024 return; 1025} 1026 1027=head2 get_keyorder 1028 1029 Get some key order information 1030 1031=cut 1032 1033sub get_keyorder { 1034 shift; # class method so don't care about class name 1035 my ($section, $key) = @_; 1036 return $CONFIG->{state}{keyorder}{$section}{$key}; 1037} 1038 1039 1040=head2 get_keyorder_max 1041 1042 Get maximum key order number for a section 1043 1044=cut 1045 1046sub get_keyorder_max { 1047 shift; # class method so don't care about class name 1048 my $section = shift; 1049 return (max values %{$CONFIG->{state}{keyorder}{$section}}) || 0; 1050} 1051 1052=head2 reset_keyorder 1053 1054 Reset keyorder - for use in tests where we switch to allkeys 1055 1056=cut 1057 1058sub reset_keyorder { 1059 shift; # class method so don't care about class name 1060 my $section = shift; 1061 delete $CONFIG->{state}{keyorder}{$section}; 1062 return; 1063} 1064 1065 1066=head1 seenkey 1067 1068=head2 get_seenkey 1069 1070 Get the count of a key 1071 1072=cut 1073 1074sub get_seenkey { 1075 shift; # class method so don't care about class name 1076 my $key = shift; 1077 my $section = shift; # If passed, return count for just this section 1078 if (defined($section)) { 1079 return $CONFIG->{state}{seenkeys}{$section}{$key}; 1080 } 1081 else { 1082 my $count; 1083 foreach my $section (keys %{$CONFIG->{state}{seenkeys}}) { 1084 $count += $CONFIG->{state}{seenkeys}{$section}{$key}; 1085 } 1086 return $count; 1087 } 1088} 1089 1090 1091=head2 incr_seenkey 1092 1093 Increment the seen count of a key 1094 1095=cut 1096 1097sub incr_seenkey { 1098 shift; # class method so don't care about class name 1099 my $key = shift; 1100 my $section = shift; 1101 $CONFIG->{state}{seenkeys}{$section}{$key}++; 1102 return; 1103} 1104 1105=head2 get_seenwork 1106 1107 Get the count of occurences of a labelname or labeltitle 1108 1109=cut 1110 1111sub get_seenwork { 1112 shift; # class method so don't care about class name 1113 my $identifier = shift; 1114 return $CONFIG->{state}{seenwork}{$identifier}; 1115} 1116 1117=head2 incr_seenwork 1118 1119 Increment the count of occurences of a labelname or labeltitle 1120 1121=cut 1122 1123sub incr_seenwork { 1124 shift; # class method so don't care about class name 1125 my $identifier = shift; 1126 $CONFIG->{state}{seenwork}{$identifier}++; 1127 return; 1128} 1129 1130 1131 1132=head2 reset_seen_extra 1133 1134 Reset the counters for extra* 1135 1136=cut 1137 1138sub reset_seen_extra { 1139 shift; # class method so don't care about class name 1140 my $ay = shift; 1141 $CONFIG->{state}{seen_extrayear} = {}; 1142 $CONFIG->{state}{seen_extratitle} = {}; 1143 $CONFIG->{state}{seen_extratitleyear} = {}; 1144 $CONFIG->{state}{seen_extraalpha} = {}; 1145 return; 1146} 1147 1148 1149=head2 incr_seen_extrayear 1150 1151 Increment and return the counter for extrayear 1152 1153=cut 1154 1155sub incr_seen_extrayear { 1156 shift; # class method so don't care about class name 1157 my $ey = shift; 1158 return ++$CONFIG->{state}{seen_extrayear}{$ey}; 1159} 1160 1161=head2 incr_seen_extratitle 1162 1163 Increment and return the counter for extratitle 1164 1165=cut 1166 1167sub incr_seen_extratitle { 1168 shift; # class method so don't care about class name 1169 my $et = shift; 1170 return ++$CONFIG->{state}{seen_extratitle}{$et}; 1171} 1172 1173=head2 incr_seen_extratitleyear 1174 1175 Increment and return the counter for extratitleyear 1176 1177=cut 1178 1179sub incr_seen_extratitleyear { 1180 shift; # class method so don't care about class name 1181 my $ety = shift; 1182 return ++$CONFIG->{state}{seen_extratitleyear}{$ety}; 1183} 1184 1185 1186=head2 incr_seen_extraalpha 1187 1188 Increment and return the counter for extraalpha 1189 1190=cut 1191 1192sub incr_seen_extraalpha { 1193 shift; # class method so don't care about class name 1194 my $ea = shift; 1195 return ++$CONFIG->{state}{seen_extraalpha}{$ea}; 1196} 1197 1198 1199=head2 get_seen_nameyear 1200 1201 Get the count of an labelname/labelyear combination for tracking 1202 extrayear. It uses labelyear plus name as we need to disambiguate 1203 entries with different labelyear (like differentiating 1984--1986 from 1204 just 1984) 1205 1206=cut 1207 1208sub get_seen_nameyear { 1209 shift; # class method so don't care about class name 1210 my $ny = shift; 1211 return $CONFIG->{state}{seen_nameyear}{$ny}; 1212} 1213 1214=head2 incr_seen_nameyear 1215 1216 Increment the count of an labelname/labelyear combination for extrayear 1217 1218 We pass in the name and year strings seperately as we have to 1219 be careful and only increment this counter beyond 1 if there is 1220 a name component. Otherwise, extrayear gets defined for all 1221 entries with no name but the same year etc. 1222 1223=cut 1224 1225sub incr_seen_nameyear { 1226 shift; # class method so don't care about class name 1227 my ($ns, $ys) = @_; 1228 my $tmp = "$ns,$ys"; 1229 # We can always increment this to 1 1230 unless ($CONFIG->{state}{seen_nameyear}{$tmp}) { 1231 $CONFIG->{state}{seen_nameyear}{$tmp}++; 1232 } 1233 # But beyond that only if we have a labelname in the entry since 1234 # this counter is used to create extrayear which doesn't mean anything for 1235 # entries with no name 1236 # We allow empty year so that we generate extrayear for the same name with no year 1237 # so we can do things like "n.d.-a", "n.d.-b" etc. 1238 else { 1239 if ($ns) { 1240 $CONFIG->{state}{seen_nameyear}{$tmp}++; 1241 } 1242 } 1243 return; 1244} 1245 1246 1247=head2 get_seen_nametitle 1248 1249 Get the count of an labelname/labeltitle combination for tracking 1250 extratitle. 1251 1252=cut 1253 1254sub get_seen_nametitle { 1255 shift; # class method so don't care about class name 1256 my $nt = shift; 1257 return $CONFIG->{state}{seen_nametitle}{$nt}; 1258} 1259 1260=head2 incr_seen_nametitle 1261 1262 Increment the count of an labelname/labeltitle combination for extratitle 1263 1264 We pass in the name and year strings seperately as we have to 1265 be careful and only increment this counter beyond 1 if there is 1266 a title component. Otherwise, extratitle gets defined for all 1267 entries with no title. 1268 1269=cut 1270 1271sub incr_seen_nametitle { 1272 shift; # class method so don't care about class name 1273 my ($ns, $ts) = @_; 1274 my $tmp = "$ns,$ts"; 1275 # We can always increment this to 1 1276 unless ($CONFIG->{state}{seen_nametitle}{$tmp}) { 1277 $CONFIG->{state}{seen_nametitle}{$tmp}++; 1278 } 1279 # But beyond that only if we have a labeltitle in the entry since 1280 # this counter is used to create extratitle which doesn't mean anything for 1281 # entries with no title 1282 else { 1283 if ($ts) { 1284 $CONFIG->{state}{seen_nametitle}{$tmp}++; 1285 } 1286 } 1287 return; 1288} 1289 1290 1291=head2 get_seen_titleyear 1292 1293 Get the count of an labeltitle/labelyear combination for tracking 1294 extratitleyear 1295 1296=cut 1297 1298sub get_seen_titleyear { 1299 shift; # class method so don't care about class name 1300 my $ty = shift; 1301 return $CONFIG->{state}{seen_titleyear}{$ty}; 1302} 1303 1304=head2 incr_seen_titleyear 1305 1306 Increment the count of an labeltitle/labelyear combination for extratitleyear 1307 1308 We pass in the title and year strings seperately as we have to 1309 be careful and only increment this counter beyond 1 if there is 1310 a title component. Otherwise, extratitleyear gets defined for all 1311 entries with no title. 1312 1313=cut 1314 1315sub incr_seen_titleyear { 1316 shift; # class method so don't care about class name 1317 my ($ts, $ys) = @_; 1318 my $tmp = "$ts,$ys"; 1319 # We can always increment this to 1 1320 unless ($CONFIG->{state}{seen_titleyear}{$tmp}) { 1321 $CONFIG->{state}{seen_titleyear}{$tmp}++; 1322 } 1323 # But beyond that only if we have a labeltitle in the entry since 1324 # this counter is used to create extratitleyear which doesn't mean anything for 1325 # entries with no title 1326 else { 1327 if ($ts) { 1328 $CONFIG->{state}{seen_titleyear}{$tmp}++; 1329 } 1330 } 1331 return; 1332} 1333 1334 1335 1336=head1 uniquelistcount 1337 1338=head2 get_uniquelistcount 1339 1340 Get the number of uniquelist entries for a (possibly partial) list 1341 1342=cut 1343 1344sub get_uniquelistcount { 1345 shift; # class method so don't care about class name 1346 my $namelist = shift; 1347 return $CONFIG->{state}{uniquelistcount}{global}{join("\x{10FFFD}", @$namelist)}; 1348} 1349 1350=head2 add_uniquelistcount 1351 1352 Incremenent the count for a list part to the data for a name 1353 1354=cut 1355 1356sub add_uniquelistcount { 1357 shift; # class method so don't care about class name 1358 my $namelist = shift; 1359 $CONFIG->{state}{uniquelistcount}{global}{join("\x{10FFFD}", @$namelist)}++; 1360 return; 1361} 1362 1363=head2 add_uniquelistcount_final 1364 1365 Incremenent the count for a complete list to the data for a name 1366 1367=cut 1368 1369sub add_uniquelistcount_final { 1370 shift; # class method so don't care about class name 1371 my $namelist = shift; 1372 $CONFIG->{state}{uniquelistcount}{global}{final}{join("\x{10FFFD}", @$namelist)}++; 1373 return; 1374} 1375 1376 1377=head2 add_uniquelistcount_minyear 1378 1379 Incremenent the count for a list and year to the data for a name 1380 Used to track uniquelist = minyear 1381 1382=cut 1383 1384sub add_uniquelistcount_minyear { 1385 shift; # class method so don't care about class name 1386 my ($minyearnamelist, $year, $namelist) = @_; 1387 # Allow year a default in case labelname is undef 1388 $CONFIG->{state}{uniquelistcount}{minyear}{join("\x{10FFFD}", @$minyearnamelist)}{$year // '0'}{join("\x{10FFFD}", @$namelist)}++; 1389 return; 1390} 1391 1392=head2 get_uniquelistcount_minyear 1393 1394 Get the count for a list and year to the data for a name 1395 Used to track uniquelist = minyear 1396 1397=cut 1398 1399sub get_uniquelistcount_minyear { 1400 shift; # class method so don't care about class name 1401 my ($minyearnamelist, $year) = @_; 1402 return scalar keys %{$CONFIG->{state}{uniquelistcount}{minyear}{join("\x{10FFFD}", @$minyearnamelist)}{$year}}; 1403} 1404 1405 1406 1407=head2 get_uniquelistcount_final 1408 1409 Get the number of uniquelist entries for a full list 1410 1411=cut 1412 1413sub get_uniquelistcount_final { 1414 shift; # class method so don't care about class name 1415 my $namelist = shift; 1416 my $c = $CONFIG->{state}{uniquelistcount}{global}{final}{join("\x{10FFFD}", @$namelist)}; 1417 return $c // 0; 1418} 1419 1420 1421=head2 reset_uniquelistcount 1422 1423 Reset the count for list parts and complete lists 1424 1425=cut 1426 1427sub reset_uniquelistcount { 1428 shift; # class method so don't care about class name 1429 $CONFIG->{state}{uniquelistcount} = {}; 1430 return; 1431} 1432 1433=head2 list_differs_nth 1434 1435 Returns true if some other list differs at passed nth place 1436 and is at least as long 1437 1438 list_differs_nth([a, b, c, d, e], 3) = 1 1439 1440 if there is another list like any of these: 1441 1442 [a, b, d, e, f] 1443 [a, b, e, z, z, y] 1444 1445=cut 1446 1447sub list_differs_nth { 1448 shift; # class method so don't care about class name 1449 my ($list, $n) = @_; 1450 my @list_one = @$list; 1451 # Loop over all final lists, looking for ones which match: 1452 # * up to n - 1 1453 # * differ at $n 1454 # * are at least as long 1455 foreach my $l_s (keys %{$CONFIG->{state}{uniquelistcount}{global}{final}}) { 1456 my @l = split("\x{10FFFD}", $l_s); 1457 # If list is shorter than the list we are checking, it's irrelevant 1458 next unless $#l >= $#$list; 1459 # If list matches at $n, it's irrelevant; 1460 next if ($list_one[$n-1] eq $l[$n-1]); 1461 # If list doesn't match up to $n - 1, it's irrelevant 1462 next unless Compare([@list_one[0 .. $n-2]], [@l[0 .. $n-2]]); 1463 $logger->trace("list_differs_nth() returning true: " . join(',', @list_one) . " vs " . join(',', @l)); 1464 return 1; 1465 } 1466 return 0; 1467} 1468 1469 1470 1471=head2 list_differs_last 1472 1473 Returns true if some list differs from passed list in its last place 1474 1475 list_differs_last([a, b, c]) = 1 1476 1477 if there is another list like any of these: 1478 1479 [a, b, d] 1480 [a, b, d, e] 1481 1482=cut 1483 1484sub list_differs_last { 1485 shift; # class method so don't care about class name 1486 my $list = shift; 1487 my @list_one = @$list; 1488 my $list_last = pop @list_one; 1489 1490 # Loop over all final lists, looking for ones which match up to 1491 # length of list to check minus 1 but which differ in the last place of the 1492 # list to check. 1493 foreach my $l_s (keys %{$CONFIG->{state}{uniquelistcount}{global}{final}}) { 1494 my @l = split("\x{10FFFD}", $l_s); 1495 # If list is shorter than the list we are checking, it's irrelevant 1496 next unless $#l >= $#$list; 1497 # get the list elements up to length of the list we are checking 1498 my @ln = @l[0 .. $#$list]; 1499 # pop off the last element which is the potential point of difference 1500 my $ln_last = pop @ln; 1501 if (Compare(\@list_one, \@ln) and ($list_last ne $ln_last)) { 1502 $logger->trace("list_differs_last() returning true: (" . join(',', @list_one) . " vs " . join(',', @ln) . " -> $list_last vs $ln_last)"); 1503 return 1; 1504 } 1505 } 1506 return 0; 1507} 1508 1509=head2 list_differs_superset 1510 1511 Returns true if some list differs from passed list by being 1512 identical to the list up to the end of the list but also 1513 by having extra elements after this 1514 1515 list_differs_superset([a, b, c]) = 1 1516 1517 if there is another list like any of these: 1518 1519 [a, b, c, d] 1520 [a, b, c, d, e] 1521 1522=cut 1523 1524sub list_differs_superset { 1525 shift; # class method so don't care about class name 1526 my $list = shift; 1527 # Loop over all final lists, looking for ones which match up to 1528 # length of list to check but which differ after this length 1529 foreach my $l_s (keys %{$CONFIG->{state}{uniquelistcount}{global}{final}}) { 1530 my @l = split("\x{10FFFD}", $l_s); 1531 # If list is not longer than the list we are checking, it's irrelevant 1532 next unless $#l > $#$list; 1533 # get the list elements up to length of the list we are checking 1534 my @ln = @l[0 .. $#$list]; 1535 if (Compare($list, \@ln)) { 1536 $logger->trace("list_differs_superset() returning true: (" . join(',', @$list) . " vs " . join(',', @l) . ")"); 1537 return 1; 1538 } 1539 } 1540 return 0; 1541} 1542 1543 1544=head1 uniquenamecount 1545 1546=head2 get_numofuniquenames 1547 1548 Get the number of uniquenames entries for a visible name 1549 1550=cut 1551 1552sub get_numofuniquenames { 1553 shift; # class method so don't care about class name 1554 my ($name, $namecontext) = @_; 1555 my $return = scalar keys %{$CONFIG->{state}{uniquenamecount}{$name}{$namecontext}}; 1556 $logger->trace("get_numofuniquenames() returning $return for NAME='$name' and NAMECONTEXT='$namecontext'"); 1557 return $return; 1558} 1559 1560=head2 get_numofuniquenames_all 1561 1562 Get the number of uniquenames entries for a name 1563 1564=cut 1565 1566sub get_numofuniquenames_all { 1567 shift; # class method so don't care about class name 1568 my ($name, $namecontext) = @_; 1569 my $return = scalar keys %{$CONFIG->{state}{uniquenamecount_all}{$name}{$namecontext}}; 1570 $logger->trace("get_numofuniquenames_all() returning $return for NAME='$name' and NAMECONTEXT='$namecontext'"); 1571 return $return; 1572} 1573 1574 1575=head2 add_uniquenamecount 1576 1577 Add a name to the list of name contexts which have the name in it 1578 (only called for visible names) 1579 1580=cut 1581 1582sub add_uniquenamecount { 1583 shift; # class method so don't care about class name 1584 my ($name, $namecontext, $key) = @_; 1585 $CONFIG->{state}{uniquenamecount}{$name}{$namecontext}{$key}++; 1586 return; 1587} 1588 1589=head2 add_uniquenamecount_all 1590 1591 Add a name to the list of name contexts which have the name in it 1592 (called for all names) 1593 1594=cut 1595 1596sub add_uniquenamecount_all { 1597 shift; # class method so don't care about class name 1598 my ($name, $namecontext, $key) = @_; 1599 $CONFIG->{state}{uniquenamecount_all}{$name}{$namecontext}{$key}++; 1600 return; 1601} 1602 1603=head2 reset_uniquenamecount 1604 1605 Reset the list of names which have the name part in it 1606 1607=cut 1608 1609sub reset_uniquenamecount { 1610 shift; # class method so don't care about class name 1611 $CONFIG->{state}{uniquenamecount} = {}; 1612 $CONFIG->{state}{uniquenamecount_all} = {}; 1613 return; 1614} 1615 1616=head2 _get_uniquename 1617 1618 Get the list of name contexts which contain a name 1619 Mainly for use in tests 1620 1621=cut 1622 1623sub _get_uniquename { 1624 shift; # class method so don't care about class name 1625 my ($name, $namecontext) = @_; 1626 my @list = sort keys %{$CONFIG->{state}{uniquenamecount}{$name}{$namecontext}}; 1627 return \@list; 1628} 1629 1630=head1 crossrefkeys 1631 1632=head2 get_crossrefkeys 1633 1634 Return ref to array of keys which are crossref targets 1635 1636=cut 1637 1638sub get_crossrefkeys { 1639 shift; # class method so don't care about class name 1640 return [ keys %{$CONFIG->{state}{crossrefkeys}} ]; 1641} 1642 1643=head2 get_crossrefkey 1644 1645 Return an integer representing the number of times a 1646 crossref target key has been ref'ed 1647 1648=cut 1649 1650sub get_crossrefkey { 1651 shift; # class method so don't care about class name 1652 my $k = shift; 1653 return $CONFIG->{state}{crossrefkeys}{$k}; 1654} 1655 1656=head2 del_crossrefkey 1657 1658 Remove a crossref target key from the crossrefkeys state 1659 1660=cut 1661 1662sub del_crossrefkey { 1663 shift; # class method so don't care about class name 1664 my $k = shift; 1665 if (exists($CONFIG->{state}{crossrefkeys}{$k})) { 1666 delete $CONFIG->{state}{crossrefkeys}{$k}; 1667 } 1668 return; 1669} 1670 1671=head2 incr_crossrefkey 1672 1673 Increment the crossreferences count for a target crossref key 1674 1675=cut 1676 1677sub incr_crossrefkey { 1678 shift; # class method so don't care about class name 1679 my $k = shift; 1680 $CONFIG->{state}{crossrefkeys}{$k}++; 1681 return; 1682} 1683 1684 1685############################ 1686# Displaymode static methods 1687############################ 1688 1689=head2 set_displaymode 1690 1691 Set the display mode for a field. 1692 setdisplaymode(['entrytype'], ['field'], ['citekey'], $value) 1693 1694 This sets the desired displaymode to use for some data in the bib. 1695 Of course, this is entirey seperate semantically from the 1696 displaymodes *defined* in the bib which just tell you what to return 1697 for a particular displaymode request for some data. 1698 1699=cut 1700 1701sub set_displaymode { 1702 shift; # class method so don't care about class name 1703 my ($val, $entrytype, $fieldtype, $citekey) = @_; 1704 if ($citekey) { 1705 if ($fieldtype) { 1706 $CONFIG->{displaymodes}{PER_FIELD}{$citekey}{$fieldtype} = $val; 1707 } 1708 else { 1709 $CONFIG->{displaymodes}{PER_ENTRY}{$citekey} = $val; 1710 } 1711 } 1712 elsif ($fieldtype) { 1713 $CONFIG->{displaymodes}{PER_FIELDTYPE}{$fieldtype} = $val; 1714 } 1715 elsif ($entrytype) { 1716 $CONFIG->{displaymodes}{PER_ENTRYTYPE}{$entrytype} = $val; 1717 } 1718 else { 1719 $CONFIG->{displaymodes}{GLOBAL} = $val ; 1720 } 1721} 1722 1723=head2 get_displaymode 1724 1725 Get the display mode for a field. 1726 getdisplaymode(['entrytype'], ['field'], ['citekey']) 1727 1728 Returns the displaymode. In order of decreasing preference, returns: 1729 1. Mode defined for a specific field in a specific citekey 1730 2. Mode defined for a citekey 1731 3. Mode defined for a fieldtype (any citekey) 1732 4. Mode defined for an entrytype (any citekey) 1733 5. Mode defined globally (any citekey) 1734 1735=cut 1736 1737sub get_displaymode { 1738 shift; # class method so don't care about class name 1739 my ($entrytype, $fieldtype, $citekey) = @_; 1740 my $dm; 1741 if ($citekey) { 1742 if ($fieldtype and 1743 defined($CONFIG->{displaymodes}{PER_FIELD}) and 1744 defined($CONFIG->{displaymodes}{PER_FIELD}{$citekey}) and 1745 defined($CONFIG->{displaymodes}{PER_FIELD}{$citekey}{$fieldtype})) { 1746 $dm = $CONFIG->{displaymodes}{PER_FIELD}{$citekey}{$fieldtype}; 1747 } 1748 elsif (defined($CONFIG->{displaymodes}{PER_ENTRY}) and 1749 defined($CONFIG->{displaymodes}{PER_ENTRY}{$citekey})) { 1750 $dm = $CONFIG->{displaymodes}{PER_ENTRY}{$citekey}; 1751 } 1752 } 1753 elsif ($fieldtype and 1754 defined($CONFIG->{displaymodes}{PER_FIELDTYPE}) and 1755 defined($CONFIG->{displaymodes}{PER_FIELDTYPE}{$fieldtype})) { 1756 $dm = $CONFIG->{displaymodes}{PER_FIELDTYPE}{$fieldtype}; 1757 } 1758 elsif ($entrytype and 1759 defined($CONFIG->{displaymodes}{PER_ENTRYTYPE}) and 1760 defined($CONFIG->{displaymodes}{PER_ENTRYTYPE}{$entrytype})) { 1761 $dm = $CONFIG->{displaymodes}{PER_ENTRYTYPE}{$entrytype}; 1762 } 1763 $dm = $CONFIG->{displaymodes}{'*'} unless $dm; # Global if nothing else; 1764 return $dm; 1765} 1766 1767=head2 dump 1768 1769 Dump config information (for debugging) 1770 1771=cut 1772 1773sub dump { 1774 shift; # class method so don't care about class name 1775 dd($CONFIG); 1776} 1777 17781; 1779 1780__END__ 1781 1782=head1 AUTHORS 1783 1784François Charette, C<< <firmicus at ankabut.net> >> 1785Philip Kime C<< <philip at kime.org.uk> >> 1786 1787=head1 BUGS 1788 1789Please report any bugs or feature requests on our Github tracker at 1790L<https://github.com/plk/biber/issues>. 1791 1792=head1 COPYRIGHT & LICENSE 1793 1794Copyright 2009-2015 François Charette and Philip Kime, all rights reserved. 1795 1796This module is free software. You can redistribute it and/or 1797modify it under the terms of the Artistic License 2.0. 1798 1799This program is distributed in the hope that it will be useful, 1800but without any warranty; without even the implied warranty of 1801merchantability or fitness for a particular purpose. 1802 1803=cut 1804