diff options
Diffstat (limited to 'Master/texmf-dist/source/bibtex/biber/lib/Biber/Utils.pm')
-rw-r--r-- | Master/texmf-dist/source/bibtex/biber/lib/Biber/Utils.pm | 564 |
1 files changed, 564 insertions, 0 deletions
diff --git a/Master/texmf-dist/source/bibtex/biber/lib/Biber/Utils.pm b/Master/texmf-dist/source/bibtex/biber/lib/Biber/Utils.pm new file mode 100644 index 00000000000..d4b9f85f3a1 --- /dev/null +++ b/Master/texmf-dist/source/bibtex/biber/lib/Biber/Utils.pm @@ -0,0 +1,564 @@ +package Biber::Utils; +#use feature 'unicode_strings'; + +use strict; +use warnings; +use Carp; +use Encode; +use File::Find; +use File::Spec; +use IPC::Cmd qw( can_run run ); +use List::Util qw( first ); +use Biber::Constants; +use Biber::LaTeX::Recode; +use Biber::Entry::Name; +use Regexp::Common qw( balanced ); +use re 'eval'; +use base 'Exporter'; +use Log::Log4perl qw(:no_extra_logdie_message); + +my $logger = Log::Log4perl::get_logger('main'); + +=encoding utf-8 + +=head1 NAME + +Biber::Utils - Various utility subs used in Biber + +=cut + +=head1 EXPORT + +All functions are exported by default. + +=cut + +our @EXPORT = qw{ locate_biber_file makenameid stringify_hash + normalise_string normalise_string_lite normalise_string_underscore normalise_string_sort + reduce_array remove_outer add_outer ucinit strip_nosort + is_def is_undef is_def_and_notnull is_def_and_null + is_undef_or_null is_notnull is_null normalise_utf8}; + +=head1 FUNCTIONS + +=head2 locate_biber_file + + Searches for a file by + + For the exact path if the filename is absolute + In the output_directory, if defined + Relative to the current directory + In the same directory as the control file + Using kpsewhich, if available + +=cut + +sub locate_biber_file { + my $filename = shift; + my $filenamepath = $filename; # default if nothing else below applies + my $outfile; + # If output_directory is set, perhaps the file can be found there so + # construct a path to test later + if (my $outdir = Biber::Config->getoption('output_directory')) { + $outfile = File::Spec->catfile($outdir, $filename); + } + + # Filename is absolute + if (File::Spec->file_name_is_absolute($filename) and -e $filename) { + return $filename; + } + + # File is output_directory + if (defined($outfile) and -e $outfile) { + return $outfile; + } + + # File is relative to cwd + if (-e $filename) { + return $filename; + } + + # File is where control file lives + if (my $cfp = Biber::Config->get_ctrlfile_path) { + my ($ctlvolume, $ctldir, undef) = File::Spec->splitpath($cfp); + if ($ctlvolume) { # add vol sep for windows if volume is set and there isn't one + $ctlvolume .= ':' unless $ctlvolume =~ /:\z/; + } + if ($ctldir) { # add path sep if there isn't one + $ctldir .= '/' unless $ctldir =~ /\/\z/; + } + + my $path = "$ctlvolume$ctldir$filename"; + + return $path if -e $path; + } + + # File is in kpse path + if (can_run('kpsewhich')) { + my $found; + scalar run( command => [ 'kpsewhich', $filename ], + verbose => 0, + buffer => \$found ); + if ($found) { + chomp $found; + # filename can be UTF-8 and run() isn't clever with UTF-8 + return decode_utf8($found); + } + } + return undef; +} + +=head2 makenameid + +Given a Biber::Names object, return an underscore normalised +concatenation of all of the full name strings. + +=cut + +sub makenameid { + my $names = shift; + my @namestrings; + foreach my $name (@{$names->names}) { + push @namestrings, $name->get_namestring; + } + my $tmp = join ' ', @namestrings; + return normalise_string_underscore($tmp); +} + +=head2 latex_recode_output + + Tries to convert UTF-8 to TeX macros in passes string + +=cut + +sub latex_recode_output { + my $string = shift; + $logger->info('Converting UTF-8 to TeX macros on output to .bbl'); + require Biber::LaTeX::Recode; + return Biber::LaTeX::Recode::latex_encode($string, + scheme => Biber::Config->getoption('bblsafecharsset')); +}; + +=head2 strip_nosort + +Removes elements which are not to be used in sorting a name from a string + +=cut + +sub strip_nosort { + my $string = shift; + my $fieldname = shift; + return '' unless $string; # Sanitise missing data + my $nosort = Biber::Config->getoption('nosort'); + # Strip user-defined REs from string + my $restrings; + # Specific fieldnames override types + if (exists($nosort->{$fieldname})) { + $restrings = $nosort->{$fieldname}; + } + else { # types + foreach my $ns (keys %$nosort) { + next unless $ns =~ /\Atype_/xms; + if ($NOSORT_TYPES{$ns}{$fieldname}) { + $restrings = $nosort->{$ns}; + } + } + } + # If no nosort to do, just return string + return $string unless $restrings; + # Config::General can't force arrays per option and don't want to set this globally + $restrings = [ $restrings ] unless ref($restrings) eq 'ARRAY'; + foreach my $re (@$restrings) { + $re = qr/$re/; + $string =~ s/$re//gxms; + } + return $string; +} + +=head2 normalise_string_sort + +Removes LaTeX macros, and all punctuation, symbols, separators and control characters, +as well as leading and trailing whitespace for sorting strings. +It also decodes LaTeX character macros into Unicode as this is always safe when +normalising strings for sorting since they don't appear in the output. + +=cut + +sub normalise_string_sort { + my $str = shift; + my $fieldname = shift; + return '' unless $str; # Sanitise missing data + # First strip nosort REs + $str = strip_nosort($str, $fieldname); + # First replace ties with spaces or they will be lost + $str =~ s/([^\\])~/$1 /g; # Foo~Bar -> Foo Bar + # Replace LaTeX chars by Unicode for sorting + # Don't bother if output is UTF-8 as in this case, we've already decoded everthing + # before we read the file (see Biber.pm) + unless (Biber::Config->getoption('bblencoding') eq 'UTF-8') { + $str = latex_decode($str, strip_outer_braces => 1, + scheme => Biber::Config->getoption('decodecharsset')); + } + return normalise_string_common($str); +} + +=head2 normalise_string + +Removes LaTeX macros, and all punctuation, symbols, separators and control characters, +as well as leading and trailing whitespace for sorting strings. +Only decodes LaTeX character macros into Unicode if output is UTF-8 + +=cut + +sub normalise_string { + my $str = shift; + return '' unless $str; # Sanitise missing data + # First replace ties with spaces or they will be lost + $str =~ s/([^\\])~/$1 /g; # Foo~Bar -> Foo Bar + if (Biber::Config->getoption('bblencoding') eq 'UTF-8') { + $str = latex_decode($str, strip_outer_braces => 1, + scheme => Biber::Config->getoption('decodecharsset')); + } + return normalise_string_common($str); +} + +=head2 normalise_string_common + + Common bit for normalisation + +=cut + +sub normalise_string_common { + my $str = shift; + $str =~ s/\\[A-Za-z]+//g; # remove latex macros (assuming they have only ASCII letters) + $str =~ s/[\p{P}\p{S}\p{C}]+//g; # remove punctuation, symbols, separator and control + $str =~ s/^\s+//; # Remove leading spaces + $str =~ s/\s+$//; # Remove trailing spaces + $str =~ s/\s+/ /g; # collapse spaces + return $str; +} + +=head2 normalise_string_lite + + Removes LaTeX macros + +=cut + +sub normalise_string_lite { + my $str = shift; + return '' unless $str; # Sanitise missing data + # First replace ties with spaces or they will be lost + $str =~ s/\\\p{L}+\s*//g; # remove tex macros + $str =~ s/\\[^\p{L}]+\s*//g; # remove accent macros like \"a + $str =~ s/[{}]//g; # Remove any brackets left + $str =~ s/~//g; + $str =~ s/\.//g; + $str =~ s/\s+//g; + return $str; +} + +=head2 normalise_string_underscore + +Like normalise_string, but also substitutes ~ and whitespace with underscore. + +=cut + +sub normalise_string_underscore { + my $str = shift; + return '' unless $str; # Sanitise missing data + $str =~ s/([^\\])~/$1 /g; # Foo~Bar -> Foo Bar + $str = normalise_string($str); + $str =~ s/\s+/_/g; + return $str; +} + +=head2 reduce_array + +reduce_array(\@a, \@b) returns all elements in @a that are not in @b + +=cut + +sub reduce_array { + my ($a, $b) = @_; + my %countb = (); + foreach my $elem (@$b) { + $countb{$elem}++; + } + my @result; + foreach my $elem (@$a) { + push @result, $elem unless $countb{$elem}; + } + return @result; +} + +=head2 remove_outer + + Remove surrounding curly brackets: + '{string}' -> 'string' + +=cut + +sub remove_outer { + my $str = shift; + $str =~ s/^{(.+)}$/$1/; + return $str; +} + +=head2 add_outer + + Add surrounding curly brackets: + 'string' -> '{string}' + +=cut + +sub add_outer { + my $str = shift; + return '{' . $str . '}'; +} + + +=head2 ucinit + + upper case of initial letters in a string + +=cut + +sub ucinit { + my $str = shift; + $str = lc($str); + $str =~ s/\b(\p{Ll})/\u$1/g; + return $str; +} + +=head2 is_undef + + Checks for undefness of arbitrary things, including + composite method chain calls which don't reliably work + with defined() (see perldoc for defined()) + This works because we are just testing the value passed + to this sub. So, for example, this is randomly unreliable + even if the resulting value of the arg to defined() is "undef": + + defined($thing->method($arg)->method) + + wheras: + + is_undef($thing->method($arg)->method) + + works since we only test the return value of all the methods + with defined() + +=cut + +sub is_undef { + my $val = shift; + return defined($val) ? 0 : 1; +} + +=head2 is_def + + Checks for definedness in the same way as is_undef() + +=cut + +sub is_def { + my $val = shift; + return defined($val) ? 1 : 0; +} + +=head2 is_undef_or_null + + Checks for undef or nullness (see is_undef() above) + +=cut + +sub is_undef_or_null { + my $val = shift; + return 1 if is_undef($val); + return $val ? 0 : 1; +} + +=head2 is_def_and_notnull + + Checks for def and unnullness (see is_undef() above) + +=cut + +sub is_def_and_notnull { + my $arg = shift; + if (defined($arg) and is_notnull($arg)) { + return 1; + } + else { + return 0; + } +} + +=head2 is_def_and_null + + Checks for def and nullness (see is_undef() above) + +=cut + +sub is_def_and_null { + my $arg = shift; + if (defined($arg) and is_null($arg)) { + return 1; + } + else { + return 0; + } +} + +=head2 is_null + + Checks for nullness + +=cut + +sub is_null { + my $arg = shift; + return is_notnull($arg) ? 0 : 1; +} + +=head2 is_notnull + + Checks for notnullness + +=cut + +sub is_notnull { + my $arg = shift; + return undef unless defined($arg); + my $st = is_notnull_scalar($arg); + if (defined($st) and $st) { return 1; } + my $at = is_notnull_array($arg); + if (defined($at) and $at) { return 1; } + my $ht = is_notnull_hash($arg); + if (defined($ht) and $ht) { return 1; } + my $ot = is_notnull_object($arg); + if (defined($ot) and $ot) { return 1; } + return 0; +} + +=head2 is_notnull_scalar + + Checks for notnullness of a scalar + +=cut + +sub is_notnull_scalar { + my $arg = shift; + unless (ref \$arg eq 'SCALAR') { + return undef; + } + return $arg ne '' ? 1 : 0; +} + +=head2 is_notnull_array + + Checks for notnullness of an array (passed by ref) + +=cut + +sub is_notnull_array { + my $arg = shift; + unless (ref $arg eq 'ARRAY') { + return undef; + } + my @arr = @$arg; + return $#arr > -1 ? 1 : 0; +} + +=head2 is_notnull_hash + + Checks for notnullness of an hash (passed by ref) + +=cut + +sub is_notnull_hash { + my $arg = shift; + unless (ref $arg eq 'HASH') { + return undef; + } + my @arr = keys %$arg; + return $#arr > -1 ? 1 : 0; +} + +=head2 is_notnull_object + + Checks for notnullness of an object (passed by ref) + +=cut + +sub is_notnull_object { + my $arg = shift; + unless (ref($arg) =~ m/\ABiber::/xms) { + return undef; + } + return $arg->notnull ? 1 : 0; +} + + +=head2 stringify_hash + + Turns a hash into a string of keys and values + +=cut + +sub stringify_hash { + my $hashref = shift; + my $string; + while (my ($k,$v) = each %{$hashref}) { + $string .= "$k => $v, "; + } + # Take off the trailing comma and space + chop $string; + chop $string; + return $string; +} + +=head2 normalise_utf8 + + Normalise any UTF-8 encoding string immediately to exactly what we want + We want the strict perl utf8 "UTF-8" + +=cut + +sub normalise_utf8 { + if (defined(Biber::Config->getoption('bibencoding')) and + Biber::Config->getoption('bibencoding') =~ m/\Autf-?8\z/xmsi) { + Biber::Config->setoption('bibencoding', 'UTF-8'); + } + if (defined(Biber::Config->getoption('bblencoding')) and + Biber::Config->getoption('bblencoding') =~ m/\Autf-?8\z/xmsi) { + Biber::Config->setoption('bblencoding', 'UTF-8'); + } +} + +=head1 AUTHOR + +François Charette, C<< <firmicus at gmx.net> >> +Philip Kime C<< <philip at kime.org.uk> >> + +=head1 BUGS + +Please report any bugs or feature requests on our sourceforge tracker at +L<https://sourceforge.net/tracker2/?func=browse&group_id=228270>. + +=head1 COPYRIGHT & LICENSE + +Copyright 2009-2011 François Charette and Philip Kime, all rights reserved. + +This module is free software. You can redistribute it and/or +modify it under the terms of the Artistic License 2.0. + +This program is distributed in the hope that it will be useful, +but without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=cut + +1; + +# vim: set tabstop=2 shiftwidth=2 expandtab: |