summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/source/bibtex/biber/lib/Biber/Utils.pm
diff options
context:
space:
mode:
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.pm564
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: