| [$label] | );
+ }
+ elsif ($cmd eq 'mbox') {
+ return $args[0];
+ }
+ elsif ($cmd eq 'cite') {
+ return qq($args[0]);
+ }
+ },
+ init => sub {
+ my ($bst) = @_;
+
+ # Initialize instance variables
+ $bst->{html} = {Bib_count => 0, Cites => {}};
+ },
+ math => sub {
+ my ($bst, $latex, $math) = @_;
+ use Text::ASCIIMathML;
+ $ASCIIMathML_parser = Text::ASCIIMathML->new() unless $ASCIIMathML_parser;
+ return $ASCIIMathML_parser->TextToMathML($math);
+ },
+ postprocess => sub {
+ my ($bst, $text) = @_;
+
+ # Substitute back any cite tags
+ $text =~ s!(.*?)![$bst->{html}{Cites}{$1}]!g;
+ return $text;
+ },
+ style => sub {
+ my ($bst, $latex, $style, $text) = @_;
+ my $html_style = $Styles{$style};
+ return defined $html_style ? "<$html_style>$text" : $text;
+ },
+ };
}
{ # Closure
- my %Styles = (
- em => '*',
- bf => '**',
- it => '*',
- sl => '*',
- tt => '``'
- );
-
- $RST = {
- delete_braces => 1,
- substitute_newcommand => 1,
-
- # prologue => "",
- character => sub {
- my ( $bst, $latex, $unicode, $chars, $accent ) = @_;
- return $chars if !$unicode;
- my $code = ord $unicode;
- $bst->{rst}{unicode}{$code} = 1;
- return sprintf '\\ |unicode(%x)|\\ ', $code;
- },
- command => sub {
- my ( $bst, $cmd, @args ) = @_;
- if ( $cmd =~ /^(begin|end)$/ ) {
- if ( $args[0] eq 'thebibliography' ) {
- if ( $cmd eq 'begin' ) {
- return qq(**References**\n\n\n);
- }
- }
- }
- elsif ( $cmd eq 'bibitem' ) {
- my $key = pop @args;
- $bst->{rst}{Bib_count}++;
- my $label = $args[0] || $bst->{rst}{Bib_count};
- if ( $args[0] ) {
- my $bst2 = Text::BibTeX::BibStyle->new;
- $label = $bst2->convert_format( $label, $RST );
- }
- $bst->{rst}{Cites}{$key} = $label;
- return ".. [$key] ";
- }
- elsif ( $cmd eq 'mbox' ) {
- return $args[0];
- }
- elsif ( $cmd eq 'cite' ) {
- return "\\ [$args[0]]_";
- }
- },
- init => sub {
- my ($bst) = @_;
-
- # Initialize instance variables
- $bst->{rst} = { Bib_count => 0, Cites => {}, unicode => {} };
- },
- math => sub {
- my ( $bst, $latex, $math ) = @_;
-
- # Latex sometimes starts with ^ or _ for super/subscript
- $math =~ s/^([_^])/{::}$1/;
- $math =~ s/([{}])/\\$1/g;
- $math =~ s/\\/\\\\/g;
- return "\\ :mathml:`$math`\\ ";
- },
- postprocess => sub {
- my ( $bst, $text ) = @_;
-
- # Fix the indentations
- $text =~ s/^[ ]*$//mg;
- $text =~ s/^(?!\A|\.\.|\*\*)[ ]*(.+)/ $1/mg;
- $text =~ s/\\([\\{}])/$1/g;
- foreach my $code ( sort keys %{ $bst->{rst}{unicode} } ) {
- $text .= sprintf ".. |unicode(%x)| unicode:: U+%x\n", $code,
- $code;
- }
- return $text;
- },
- style => sub {
- my ( $bst, $latex, $style, $text ) = @_;
- my $rst_style = $Styles{$style};
- if ($rst_style) {
- my ( $pre, undef, $post ) = $text =~ s/^(\s.)(.*?)(\s.)$/$2/;
- $post ||= '';
- return "$pre$rst_style$text$rst_style$post";
- }
- return $text;
- },
- };
+ my %Styles = (em => '*', bf => '**', it => '*', sl => '*', tt => '``');
+
+ $RST = {
+ delete_braces => 1,
+ substitute_newcommand => 1,
+
+ # prologue => "",
+ character => sub {
+ my ($bst, $latex, $unicode, $chars, $accent) = @_;
+ return $chars if !$unicode;
+ my $code = ord $unicode;
+ $bst->{rst}{unicode}{$code} = 1;
+ return sprintf '\\ |unicode(%x)|\\ ', $code;
+ },
+ command => sub {
+ my ($bst, $cmd, @args) = @_;
+ if ($cmd =~ /^(begin|end)$/) {
+ if ($args[0] eq 'thebibliography') {
+ if ($cmd eq 'begin') {
+ return qq(**References**\n\n\n);
+ }
+ }
+ }
+ elsif ($cmd eq 'bibitem') {
+ my $key = pop @args;
+ $bst->{rst}{Bib_count}++;
+ my $label = $args[0] || $bst->{rst}{Bib_count};
+ if ($args[0]) {
+ my $bst2 = Text::BibTeX::BibStyle->new;
+ $label = $bst2->convert_format($label, $RST);
+ }
+ $bst->{rst}{Cites}{$key} = $label;
+ return ".. [$key] ";
+ }
+ elsif ($cmd eq 'mbox') {
+ return $args[0];
+ }
+ elsif ($cmd eq 'cite') {
+ return "\\ [$args[0]]_";
+ }
+ },
+ init => sub {
+ my ($bst) = @_;
+
+ # Initialize instance variables
+ $bst->{rst} = {Bib_count => 0, Cites => {}, unicode => {}};
+ },
+ math => sub {
+ my ($bst, $latex, $math) = @_;
+
+ # Latex sometimes starts with ^ or _ for super/subscript
+ $math =~ s/^([_^])/{::}$1/;
+ $math =~ s/([{}])/\\$1/g;
+ $math =~ s/\\/\\\\/g;
+ return "\\ :mathml:`$math`\\ ";
+ },
+ postprocess => sub {
+ my ($bst, $text) = @_;
+
+ # Fix the indentations
+ $text =~ s/^[ ]*$//mg;
+ $text =~ s/^(?!\A|\.\.|\*\*)[ ]*(.+)/ $1/mg;
+ $text =~ s/\\([\\{}])/$1/g;
+ foreach my $code (sort keys %{$bst->{rst}{unicode}}) {
+ $text .= sprintf ".. |unicode(%x)| unicode:: U+%x\n", $code, $code;
+ }
+ return $text;
+ },
+ style => sub {
+ my ($bst, $latex, $style, $text) = @_;
+ my $rst_style = $Styles{$style};
+ if ($rst_style) {
+ my ($pre, undef, $post) = $text =~ s/^(\s.)(.*?)(\s.)$/$2/;
+ $post ||= '';
+ return "$pre$rst_style$text$rst_style$post";
+ }
+ return $text;
+ },
+ };
}
sub new {
- my ( $class, %options ) = @_;
+ my ($class, %options) = @_;
- my $self = bless {}, $class;
+ my $self = bless {}, $class;
- $self->{options} = \%options;
+ $self->{options} = \%options;
- return $self;
+ return $self;
}
# A Text::BibTeX::BibStyle hash has the following keys:
@@ -413,60 +396,60 @@ Boolean to force the standard bibtex wrapping on the output.
=cut
{ # Closure
- my $Acc_char = qq([\'\`^\"~=.]);
- my $Acc_let = "[uvHtcdb]";
- my $Acc_sym =
-q(\\\\(?:(?:a[ae]|A[AE]|copyright|dd?ag|[lL]|oe?|OE?|P|pounds|S|ss)\\b)|``|''|\?`|!`|~|---?);
- my $Style = '\\\\(?:[er]m|bf|[it]t|s[lfc])\\b';
-
- sub convert_format : method {
- my ( $self, $text, $opts ) = @_;
-
- $opts->{init}->($self) if $opts->{init};
- $text = _substitute_newcommand($text) if $opts->{substitute_newcommand};
- if ( $opts->{wrap} ) {
- 1 while ( $text =~ s/^(?=.{80})(.{1,79})(\s.*)/$1\n $2/m
- || $text =~ s/^(?=.{80})(.{80,}?)(\s.*)/$1\n $2/m );
- }
- if ( $opts->{prologue} ) {
- my $prologue =
- ref $opts->{prologue}
- ? $opts->{prologue}->($self)
- : $opts->{prologue};
- $text = "$prologue$text";
- }
- if ( $opts->{character} ) {
+ my $Acc_char = qq([\'\`^\"~=.]);
+ my $Acc_let = "[uvHtcdb]";
+ my $Acc_sym
+ = q(\\\\(?:(?:a[ae]|A[AE]|copyright|dd?ag|[lL]|oe?|OE?|P|pounds|S|ss)\\b)|``|''|\?`|!`|~|---?);
+ my $Style = '\\\\(?:[er]m|bf|[it]t|s[lfc])\\b';
+
+ sub convert_format : method {
+ my ($self, $text, $opts) = @_;
+
+ $opts->{init}->($self) if $opts->{init};
+ $text = _substitute_newcommand($text) if $opts->{substitute_newcommand};
+ if ($opts->{wrap}) {
+ 1 while ($text =~ s/^(?=.{80})(.{1,79})(\s.*)/$1\n $2/m
+ || $text =~ s/^(?=.{80})(.{80,}?)(\s.*)/$1\n $2/m);
+ }
+ if ($opts->{prologue}) {
+ my $prologue
+ = ref $opts->{prologue}
+ ? $opts->{prologue}->($self)
+ : $opts->{prologue};
+ $text = "$prologue$text";
+ }
+ if ($opts->{character}) {
- # Handle accents
- $text =~ s/\\i\b/i/g;
- $text =~ s/(\{ \\ ($Acc_char|$Acc_let\b) [ ]* ([a-zA-Z]+) [ ]*
+ # Handle accents
+ $text =~ s/\\i\b/i/g;
+ $text =~ s/(\{ \\ ($Acc_char|$Acc_let\b) [ ]* ([a-zA-Z]+) [ ]*
(?:\}|\Z))/_character($self, $opts, $1, $3, $2)/exog;
- $text =~ s/(\\ ($Acc_char|$Acc_let) [ ]* \{ [ ]* ([a-zA-Z]+) [ ]*
+ $text =~ s/(\\ ($Acc_char|$Acc_let) [ ]* \{ [ ]* ([a-zA-Z]+) [ ]*
(?:\}|\Z))/_character($self, $opts, $1, $3, $2)/exog;
- $text =~ s/($Acc_sym)/_character($self, $opts, $1, $1)/exog;
- $text =~ s/(\\ ([\#\$\%&_]))/_character($self, $opts, $1, $2)/xge;
- $text =~ s!(\\/)!_character($self, $opts, $1, '')!ge;
- }
- if ( $opts->{math} ) {
+ $text =~ s/($Acc_sym)/_character($self, $opts, $1, $1)/exog;
+ $text =~ s/(\\ ([\#\$\%&_]))/_character($self, $opts, $1, $2)/xge;
+ $text =~ s!(\\/)!_character($self, $opts, $1, '')!ge;
+ }
+ if ($opts->{math}) {
- # Handle math mode
- $text =~ s/((\$\$?)(.*?)\2)/$opts->{math}->($self, $1, $3)/sexg;
- $text =~ s/(\\ \( (.*?) \\ \))/$opts->{math}->($self, $1, $2)/sexg;
- $text =~ s/(\\ \[ (.*?) \\ \])/$opts->{math}->($self, $1, $2)/sexg;
- }
- if ( $opts->{style} ) {
+ # Handle math mode
+ $text =~ s/((\$\$?)(.*?)\2)/$opts->{math}->($self, $1, $3)/sexg;
+ $text =~ s/(\\ \( (.*?) \\ \))/$opts->{math}->($self, $1, $2)/sexg;
+ $text =~ s/(\\ \[ (.*?) \\ \])/$opts->{math}->($self, $1, $2)/sexg;
+ }
+ if ($opts->{style}) {
- # Handle text styles
- 1 while $text =~ s/(\{ $Style .*)/do {
+ # Handle text styles
+ 1 while $text =~ s/(\{ $Style .*)/do {
my ($latex, $next) = _remove_matched_brace($1);
(my $text = $latex) =~ s!\{ ($Style) [ ]*(.*) \}$!$2!sx;
my $style = $1;
$style =~ m!([a-z]+)!;
$opts->{style}->($self, $latex, $1, $text) . $next;
}/sexg;
- }
- if ( $opts->{command} ) {
- 1 while $text =~ s/(\A|[^\\])\\([a-z]+)(.*)/do {
+ }
+ if ($opts->{command}) {
+ 1 while $text =~ s/(\A|[^\\])\\([a-z]+)(.*)/do {
my ($pre, $cmd, $next) = ($1, $2, $3);
my @args;
while ($next =~ m!^[\{\[]!) {
@@ -483,22 +466,22 @@ q(\\\\(?:(?:a[ae]|A[AE]|copyright|dd?ag|[lL]|oe?|OE?|P|pounds|S|ss)\\b)|``|''|\?
}
$pre . $opts->{command}->($self, $cmd, @args) . $next;
}/exis;
- }
- if ( $opts->{delete_braces} ) {
-
- # Note: need to do twice to handle {}
- $text =~ s/(\A|.) ([{}])/$1 eq "\\" ? "$1$2" : $1/sexg;
- $text =~ s/(\A|.) ([{}])/$1 eq "\\" ? "$1$2" : $1/sexg;
- }
- if ( $opts->{character} ) {
+ }
+ if ($opts->{delete_braces}) {
- # Handle backslash-quoted braces
- $text =~ s/(\\ ([{}]))/_character($self, $opts, $1, $2)/xge;
- }
- $text = $opts->{postprocess}->( $self, $text ) if $opts->{postprocess};
+ # Note: need to do twice to handle {}
+ $text =~ s/(\A|.) ([{}])/$1 eq "\\" ? "$1$2" : $1/sexg;
+ $text =~ s/(\A|.) ([{}])/$1 eq "\\" ? "$1$2" : $1/sexg;
+ }
+ if ($opts->{character}) {
- return $text;
+ # Handle backslash-quoted braces
+ $text =~ s/(\\ ([{}]))/_character($self, $opts, $1, $2)/xge;
}
+ $text = $opts->{postprocess}->($self, $text) if $opts->{postprocess};
+
+ return $text;
+ }
=item C
@@ -515,91 +498,88 @@ C method.
=cut
- {
- # Closure for local variables
- my %Commands = ( # Info is no. of arguments and subroutine reference
- entry => [ 3, \&_command_entry ],
- execute => [ 1, \&_command_execute ],
- function => [ 2, \&_command_function ],
- integers => [ 1, \&_command_variables ],
- iterate => [ 1, \&_command_iterate ],
- macro => [ 2, \&_command_macro ],
- read => [ 0, \&_command_read ],
- reverse => [ 1, \&_command_iterate ],
- sort => [ 0, \&_command_sort ],
- strings => [ 1, \&_command_variables ],
- );
-
- sub execute : method {
- my ( $self, $bibfiles_ar, $rawbib, $cites_ar ) = @_;
-
- croak
-"No bibstyle interpreter has been defined: call read_bibstyle or replace_bibstyle first"
- unless $self->{interp};
-
- $self->{bibtex} = {
- bibfiles => $bibfiles_ar,
- rawbib => $rawbib,
- bt_entry => undef,
- bt_entries => {},
- cite => undef,
- cites => $cites_ar,
- entries => {},
- format => undef,
- preamble => [],
- };
-
- Text::BibTeX::delete_all_macros();
- my %cmd_count;
- my ( $filename, $lineno );
- my @interp = @{ $self->{interp} };
- while (@interp) {
- my $token = shift @interp;
- if ( $token =~ /^\#line (\d+) (\S+)/ ) {
- ( $lineno, $filename ) = ( $1, $2 );
- next;
- }
- croak "$filename, $lineno: Invalid argument" if ref($token);
- my $lc_token = lc $token;
- croak "$filename, $lineno: Unknown command '$token'"
- unless my $command_ar = $Commands{$lc_token};
-
- my ( $cmd, $cmd_f, $cmd_l ) = ( $token, $filename, $lineno );
- $self->{lineno} = "$filename, $lineno";
-
- # Get the arguments
- my @args;
- while ( @args < $command_ar->[0] ) {
- my $token = shift @interp;
- if ( $token =~ /^\#line (\d+) (\S+)/ ) {
- ( $lineno, $filename ) = ( $1, $2 );
- next;
- }
- last unless ref($token);
- push @args, $token;
- }
- croak
-"$filename, $lineno: Insufficient arguments for command '$cmd' at line $cmd_l"
- if @args < $command_ar->[0];
- if ( ++$cmd_count{$lc_token} > 1
- && $lc_token =~ /^(entry|read)$/ )
- {
- $self->_warning("Duplicate '$token' command ignored");
- next;
- }
- $command_ar->[1]->( $self, $cmd, $cmd_f, $cmd_l, \@args );
- }
- my @missing_cmds = grep !$cmd_count{$_}, qw(entry read);
- $self->_warning(
- sprintf(
- "Need to have one %s command",
- join ' and one ',
- map( uc $_, @missing_cmds )
- )
- ) if @missing_cmds && !$self->{options}{nowarn};
+ {
+ # Closure for local variables
+ my %Commands = ( # Info is no. of arguments and subroutine reference
+ entry => [3, \&_command_entry],
+ execute => [1, \&_command_execute],
+ function => [2, \&_command_function],
+ integers => [1, \&_command_variables],
+ iterate => [1, \&_command_iterate],
+ macro => [2, \&_command_macro],
+ read => [0, \&_command_read],
+ reverse => [1, \&_command_iterate],
+ sort => [0, \&_command_sort],
+ strings => [1, \&_command_variables],
+ );
+
+ sub execute : method {
+ my ($self, $bibfiles_ar, $rawbib, $cites_ar) = @_;
+
+ croak
+ "No bibstyle interpreter has been defined: call read_bibstyle or replace_bibstyle first"
+ unless $self->{interp};
+
+ $self->{bibtex} = {
+ bibfiles => $bibfiles_ar,
+ rawbib => $rawbib,
+ bt_entry => undef,
+ bt_entries => {},
+ cite => undef,
+ cites => $cites_ar,
+ entries => {},
+ format => undef,
+ preamble => [],
+ };
+
+ Text::BibTeX::delete_all_macros();
+ my %cmd_count;
+ my ($filename, $lineno);
+ my @interp = @{$self->{interp}};
+ while (@interp) {
+ my $token = shift @interp;
+ if ($token =~ /^\#line (\d+) (\S+)/) {
+ ($lineno, $filename) = ($1, $2);
+ next;
+ }
+ croak "$filename, $lineno: Invalid argument" if ref($token);
+ my $lc_token = lc $token;
+ croak "$filename, $lineno: Unknown command '$token'"
+ unless my $command_ar = $Commands{$lc_token};
+
+ my ($cmd, $cmd_f, $cmd_l) = ($token, $filename, $lineno);
+ $self->{lineno} = "$filename, $lineno";
+
+ # Get the arguments
+ my @args;
+ while (@args < $command_ar->[0]) {
+ my $token = shift @interp;
+ if ($token =~ /^\#line (\d+) (\S+)/) {
+ ($lineno, $filename) = ($1, $2);
+ next;
+ }
+ last unless ref($token);
+ push @args, $token;
}
+ croak
+ "$filename, $lineno: Insufficient arguments for command '$cmd' at line $cmd_l"
+ if @args < $command_ar->[0];
+ if (++$cmd_count{$lc_token} > 1 && $lc_token =~ /^(entry|read)$/) {
+ $self->_warning("Duplicate '$token' command ignored");
+ next;
+ }
+ $command_ar->[1]->($self, $cmd, $cmd_f, $cmd_l, \@args);
+ }
+ my @missing_cmds = grep !$cmd_count{$_}, qw(entry read);
+ $self->_warning(
+ sprintf(
+ "Need to have one %s command",
+ join ' and one ',
+ map(uc $_, @missing_cmds)
+ )
+ ) if @missing_cmds && !$self->{options}{nowarn};
}
-
+ }
=item C
@@ -609,14 +589,14 @@ which it calls.
=cut
- sub get_output : method {
- my ( $self, $opts ) = @_;
+ sub get_output : method {
+ my ($self, $opts) = @_;
- my $out = join '', @{ $self->{output} };
- $out = $self->convert_format( $out, $opts ) if $opts;
+ my $out = join '', @{$self->{output}};
+ $out = $self->convert_format($out, $opts) if $opts;
- return $out;
- }
+ return $out;
+ }
=item C
@@ -624,11 +604,11 @@ Method. Returns the number of warning messages generated during execution.
=cut
- sub num_warnings : method {
- my ($self) = @_;
+ sub num_warnings : method {
+ my ($self) = @_;
- return 0 + @{ $self->{warnings} };
- }
+ return 0 + @{$self->{warnings}};
+ }
=item C
@@ -639,27 +619,27 @@ defined.
=cut
- sub read_bibstyle : method {
- my ( $self, $bibstyle ) = @_;
+ sub read_bibstyle : method {
+ my ($self, $bibstyle) = @_;
- # my $f = "$bibstyle.bst";
- # my $path = $ENV{BSTINPUTS} || '.';
- # my @path = split /:/, $path;
- # my ($dir) = grep -f "$_/$f", @path;
- # croak("Cannot find $f on path: $path") unless $dir;
- # my $fullfile = "$dir/$f";
+ # my $f = "$bibstyle.bst";
+ # my $path = $ENV{BSTINPUTS} || '.';
+ # my @path = split /:/, $path;
+ # my ($dir) = grep -f "$_/$f", @path;
+ # croak("Cannot find $f on path: $path") unless $dir;
+ # my $fullfile = "$dir/$f";
- my $fullfile = "$bibstyle";
- croak("Cannot find bst file $bibstyle") unless -e $bibstyle;
+ my $fullfile = "$bibstyle";
+ croak("Cannot find bst file $bibstyle") unless -e $bibstyle;
- # Read the file
- open BSTINPUTS, "$fullfile" or croak("$fullfile: $!");
- my @bibstyle = ;
- close BSTINPUTS;
+ # Read the file
+ open BSTINPUTS, "$fullfile" or croak("$fullfile: $!");
+ my @bibstyle = ;
+ close BSTINPUTS;
- my $interp = join '', @bibstyle;
- $self->replace_bibstyle( $interp, $fullfile );
- }
+ my $interp = join '', @bibstyle;
+ $self->replace_bibstyle($interp, $fullfile);
+ }
=item C
@@ -670,115 +650,112 @@ indirectly through the C method.
=cut
- { # Closure for private variables
- my %BuiltIn = (
- '>' => \&_function_arith,
- '<' => \&_function_arith,
- '=' => \&_function_eq,
- '+' => \&_function_arith,
- '-' => \&_function_arith,
- '*' => \&_function_concat,
- ':=' => \&_function_assign,
- 'add.period$' => \&_function_add_period,
- 'call.type$' => \&_function_call_type,
- 'change.case$' => \&_function_change_case,
- 'chr.to.int$' => \&_function_chr_to_int,
- 'cite$' => \&_function_cite,
- 'duplicate$' => \&_function_duplicate,
- 'empty$' => \&_function_empty,
- 'format.name$' => \&_function_format_name,
- 'if$' => \&_function_if,
- 'int.to.chr$' => \&_function_int_to_chr,
- 'int.to.str$' => \&_function_int_to_str,
- 'missing$' => \&_function_missing,
- 'newline$' => \&_function_newline,
- 'num.names$' => \&_function_num_names,
- 'pop$' => sub { my ($self) = @_; $self->_pop; },
- 'preamble$' => \&_function_preamble,
- 'purify$' => \&_function_purify,
- 'quote$' => 1, # Handled as a constant symbol
- 'skip$' => sub { },
- 'stack$' => \&_function_stack,
- 'substring$' => \&_function_substring,
- 'swap$' => \&_function_swap,
- 'text.length$' => \&_function_text_length,
- 'text.prefix$' => \&_function_text_prefix,
- 'top$' => \&_function_top,
- 'type$' => \&_function_type,
- 'warning$' => \&_function_warning,
- 'while$' => \&_function_while,
- 'width$' => \&_function_width,
- 'write$' => \&_function_write,
- );
-
- # Here's where the actual parsing takes place
- sub replace_bibstyle : method {
- my ( $self, $interp, $filename ) = @_;
-
- $filename ||= '';
-
- # Remove comments
- $interp =~ s/(^|[^\\]) \% .*/$1/mgx;
- my @interp = grep $_,
- split( /(\s+)|([{}]|\".*?\"|\#line \d+ .*\n)/, $interp );
-
- # Put '{' .. '}' pairs into array refs
- my @stack;
- my $nest = 0;
- push @stack, [];
- my $lineno = 1;
- push @{ $stack[-1] }, "#line $lineno $filename";
- foreach (@interp) {
- if ( $_ =~ /^\s+$/ ) {
- my $nl = y/\n//;
- if ($nl) {
- $lineno += $nl;
- push @{ $stack[-1] }, "#line $lineno $filename";
- }
- }
- elsif ( $_ eq '{' ) {
- $nest++;
- push @stack, [];
- push @{ $stack[-1] }, "#line $lineno $filename";
- }
- elsif ( $_ eq '}' ) {
- $nest--;
- croak("$filename, $lineno: Unmatched '}'") if $nest < 0;
- push @{ $stack[-2] }, pop(@stack);
- }
- else {
- ( $lineno, $filename ) = ( $1, $2 ) if /^\#line (\d+) (.*)/;
- push @{ $stack[-1] }, $_;
- }
- }
- if ( $nest > 0 ) {
-
- # Find the error line number
- my $errline = 1;
- foreach ( reverse @{ $stack[ $nest - 1 ] } ) {
- if (/^\#line (\d+)/) {
- $errline = $1;
- last;
- }
- }
- croak("$filename, $errline: Unmatched '{'");
- }
+ { # Closure for private variables
+ my %BuiltIn = (
+ '>' => \&_function_arith,
+ '<' => \&_function_arith,
+ '=' => \&_function_eq,
+ '+' => \&_function_arith,
+ '-' => \&_function_arith,
+ '*' => \&_function_concat,
+ ':=' => \&_function_assign,
+ 'add.period$' => \&_function_add_period,
+ 'call.type$' => \&_function_call_type,
+ 'change.case$' => \&_function_change_case,
+ 'chr.to.int$' => \&_function_chr_to_int,
+ 'cite$' => \&_function_cite,
+ 'duplicate$' => \&_function_duplicate,
+ 'empty$' => \&_function_empty,
+ 'format.name$' => \&_function_format_name,
+ 'if$' => \&_function_if,
+ 'int.to.chr$' => \&_function_int_to_chr,
+ 'int.to.str$' => \&_function_int_to_str,
+ 'missing$' => \&_function_missing,
+ 'newline$' => \&_function_newline,
+ 'num.names$' => \&_function_num_names,
+ 'pop$' => sub { my ($self) = @_; $self->_pop; },
+ 'preamble$' => \&_function_preamble,
+ 'purify$' => \&_function_purify,
+ 'quote$' => 1, # Handled as a constant symbol
+ 'skip$' => sub { },
+ 'stack$' => \&_function_stack,
+ 'substring$' => \&_function_substring,
+ 'swap$' => \&_function_swap,
+ 'text.length$' => \&_function_text_length,
+ 'text.prefix$' => \&_function_text_prefix,
+ 'top$' => \&_function_top,
+ 'type$' => \&_function_type,
+ 'warning$' => \&_function_warning,
+ 'while$' => \&_function_while,
+ 'width$' => \&_function_width,
+ 'write$' => \&_function_write,
+ );
- $self->{interp} = $stack[0];
- $self->{output} = [];
- $self->{stack} = [];
- $self->{symbols} = {
- const => { 'quote$' => '"""' },
- entry_str => { 'sort.key$' => undef },
- field => { crossref => undef },
- function => { map( ( $_ => "'$_" ), keys %BuiltIn ) },
- integer => {
- 'entry.max$' => 100,
- 'global.max$' => 1000,
- },
- };
- $self->{warnings} = [];
+ # Here's where the actual parsing takes place
+ sub replace_bibstyle : method {
+ my ($self, $interp, $filename) = @_;
+
+ $filename ||= '';
+
+ # Remove comments
+ $interp =~ s/(^|[^\\]) \% .*/$1/mgx;
+ my @interp = grep $_,
+ split(/(\s+)|([{}]|\".*?\"|\#line \d+ .*\n)/, $interp);
+
+ # Put '{' .. '}' pairs into array refs
+ my @stack;
+ my $nest = 0;
+ push @stack, [];
+ my $lineno = 1;
+ push @{$stack[-1]}, "#line $lineno $filename";
+ foreach (@interp) {
+ if ($_ =~ /^\s+$/) {
+ my $nl = y/\n//;
+ if ($nl) {
+ $lineno += $nl;
+ push @{$stack[-1]}, "#line $lineno $filename";
+ }
+ }
+ elsif ($_ eq '{') {
+ $nest++;
+ push @stack, [];
+ push @{$stack[-1]}, "#line $lineno $filename";
+ }
+ elsif ($_ eq '}') {
+ $nest--;
+ croak("$filename, $lineno: Unmatched '}'") if $nest < 0;
+ push @{$stack[-2]}, pop(@stack);
+ }
+ else {
+ ($lineno, $filename) = ($1, $2) if /^\#line (\d+) (.*)/;
+ push @{$stack[-1]}, $_;
}
+ }
+ if ($nest > 0) {
+
+ # Find the error line number
+ my $errline = 1;
+ foreach (reverse @{$stack[$nest - 1]}) {
+ if (/^\#line (\d+)/) {
+ $errline = $1;
+ last;
+ }
+ }
+ croak("$filename, $errline: Unmatched '{'");
+ }
+
+ $self->{interp} = $stack[0];
+ $self->{output} = [];
+ $self->{stack} = [];
+ $self->{symbols} = {
+ const => {'quote$' => '"""'},
+ entry_str => {'sort.key$' => undef},
+ field => {crossref => undef},
+ function => {map(($_ => "'$_"), keys %BuiltIn)},
+ integer => {'entry.max$' => 100, 'global.max$' => 1000,},
+ };
+ $self->{warnings} = [];
+ }
=item C
@@ -786,11 +763,11 @@ Method. Returns an array of the warning messages generated during execution.
=cut
- sub warnings : method {
- my ($self) = @_;
+ sub warnings : method {
+ my ($self) = @_;
- return @{ $self->{warnings} };
- }
+ return @{$self->{warnings}};
+ }
=back
@@ -842,1157 +819,1113 @@ under the same terms as Perl itself.
################ Internal routines
- # Checks a name to be define to be sure it is valid
- # Arguments: name
- # Returns: name
- sub _check_name : method {
- my ( $self, $name ) = @_;
-
- my $where = $self->{lineno};
- croak "$where: Illegal name '$name'"
- unless $name =~ /^[^\"\#\%\'(),={}\s\d][^\"\#\%\'(),={}\s]*$/;
-
- foreach my $sym (
- qw(const field entry_int entry_str function
- integer string)
- )
- {
- croak "$where: Cannot redefine $sym '$name'"
- if exists $self->{symbols}{$sym}{$name};
- }
-
- return $name;
- }
-
- { # Closure for static variables
- my $Arg_num;
- my $Check_type_warnings;
-
- # Checks the type of an argument
- # Arguments: argument, type(s), token, true if first arg of function
- # The types are a concatenation of
- # i: integer
- # q: quoted value (e.g., 'a)
- # s: string
- # x: expression (array ref)
- sub _check_type : method {
- my ( $self, $arg, $types, $token, $first_arg ) = @_;
-
- $Arg_num = $first_arg ? 1 : $Arg_num + 1;
- $Check_type_warnings = 0 if $first_arg;
- $_ = $arg;
- my $type = (
- !defined $_ || /^\"/ ? 's'
- : ref($_) ? 'x'
- : /^\'/ ? 'q'
- : /^-?\d+$/ ? 'i'
- : croak("$self->{lineno}: value '$_' has unknown type")
- );
- $Check_type_warnings += $self->_warning(
- sprintf "Argument $Arg_num of '$token' has wrong type (%s)",
- $self->_format_token($_)
- ) unless $types =~ /$type/i;
- }
+ # Checks a name to be define to be sure it is valid
+ # Arguments: name
+ # Returns: name
+ sub _check_name : method {
+ my ($self, $name) = @_;
+
+ my $where = $self->{lineno};
+ croak "$where: Illegal name '$name'"
+ unless $name =~ /^[^\"\#\%\'(),={}\s\d][^\"\#\%\'(),={}\s]*$/;
+
+ foreach my $sym (
+ qw(const field entry_int entry_str function
+ integer string)
+ )
+ {
+ croak "$where: Cannot redefine $sym '$name'"
+ if exists $self->{symbols}{$sym}{$name};
+ }
+
+ return $name;
+ }
- # Returns the number of check_type warnings for this function
- sub _check_type_warnings {
- return $Check_type_warnings;
- }
- }
+ { # Closure for static variables
+ my $Arg_num;
+ my $Check_type_warnings;
+
+ # Checks the type of an argument
+ # Arguments: argument, type(s), token, true if first arg of function
+ # The types are a concatenation of
+ # i: integer
+ # q: quoted value (e.g., 'a)
+ # s: string
+ # x: expression (array ref)
+ sub _check_type : method {
+ my ($self, $arg, $types, $token, $first_arg) = @_;
+
+ $Arg_num = $first_arg ? 1 : $Arg_num + 1;
+ $Check_type_warnings = 0 if $first_arg;
+ $_ = $arg;
+ my $type
+ = (!defined $_ || /^\"/ ? 's'
+ : ref($_) ? 'x'
+ : /^\'/ ? 'q'
+ : /^-?\d+$/ ? 'i'
+ : croak("$self->{lineno}: value '$_' has unknown type"));
+ $Check_type_warnings
+ += $self->_warning(
+ sprintf "Argument $Arg_num of '$token' has wrong type (%s)",
+ $self->_format_token($_))
+ unless $types =~ /$type/i;
+ }
+
+ # Returns the number of check_type warnings for this function
+ sub _check_type_warnings {
+ return $Check_type_warnings;
+ }
+ }
# All the _command routines are used to execute a command.
# Inputs: $self, command name, file name, line num, ref to array of arguments
- sub _command_entry {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
-
- $self->{bibtex}{format} = {
- field => [
- 'crossref',
- map( $self->_check_name($_),
- grep !/^\#line/,
- @{ $args_ar->[0] } )
- ],
- integer => [
- map( $self->_check_name($_),
- grep !/^\#line/,
- @{ $args_ar->[1] } )
- ],
- string => [
- 'sort.key$',
- map( $self->_check_name($_),
- grep !/^\#line/,
- @{ $args_ar->[2] } )
- ]
- };
-
- $self->{symbols}{field} =
- { map( ( $_ => undef ), @{ $self->{bibtex}{format}{field} } ) };
- $self->{symbols}{entry_int} =
- { map( ( $_ => "-0" ), @{ $self->{bibtex}{format}{integer} } ) };
- $self->{symbols}{entry_str} =
- { map( ( $_ => undef ), @{ $self->{bibtex}{format}{string} } ) };
-
- 1;
- }
-
- sub _command_execute {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
-
- # print "_command_execute $cmd, $filename, $lineno, $args_ar \n";
-
- my @symbols = grep !/^\#line/, @{ $args_ar->[0] };
- croak
-"$filename, $lineno: first argument to '$cmd' must contain exactly one name"
- unless @symbols == 1;
- my $func_name = $symbols[0];
- my $function = $self->{symbols}{function}{$func_name};
- croak
- "$filename, $lineno: Function '$func_name' has not been defined"
- unless $function;
- $self->{stack} = []; # Start with a new stack
- _evaluate( $self, $function );
- }
+ sub _command_entry {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
+
+ $self->{bibtex}{format} = {
+ field => [
+ 'crossref',
+ map($self->_check_name($_), grep !/^\#line/, @{$args_ar->[0]})
+ ],
+ integer =>
+ [map($self->_check_name($_), grep !/^\#line/, @{$args_ar->[1]})],
+ string => [
+ 'sort.key$',
+ map($self->_check_name($_), grep !/^\#line/, @{$args_ar->[2]})
+ ]
+ };
+
+ $self->{symbols}{field}
+ = {map(($_ => undef), @{$self->{bibtex}{format}{field}})};
+ $self->{symbols}{entry_int}
+ = {map(($_ => "-0"), @{$self->{bibtex}{format}{integer}})};
+ $self->{symbols}{entry_str}
+ = {map(($_ => undef), @{$self->{bibtex}{format}{string}})};
+
+ 1;
+ }
- sub _command_function {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
+ sub _command_execute {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
+
+ # print "_command_execute $cmd, $filename, $lineno, $args_ar \n";
+
+ my @symbols = grep !/^\#line/, @{$args_ar->[0]};
+ croak
+ "$filename, $lineno: first argument to '$cmd' must contain exactly one name"
+ unless @symbols == 1;
+ my $func_name = $symbols[0];
+ my $function = $self->{symbols}{function}{$func_name};
+ croak "$filename, $lineno: Function '$func_name' has not been defined"
+ unless $function;
+ $self->{stack} = []; # Start with a new stack
+ _evaluate($self, $function);
+ }
- my @symbols = grep !/^\#line/, @{ $args_ar->[0] };
- croak
-"$filename, $lineno: first argument to '$cmd' must contain exactly one name"
- unless @symbols == 1;
- my $func_name = $symbols[0];
- $self->_check_name($func_name);
- $self->{symbols}{function}{$func_name} = $args_ar->[1];
- }
+ sub _command_function {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
- sub _command_iterate {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
-
- my @entries = @{ $self->{bibtex}{cites} };
- @entries = reverse @entries if $cmd =~ /reverse/i;
-
- my @symbols = grep !/^\#line/, @{ $args_ar->[0] };
- croak
-"$filename, $lineno: first argument to '$cmd' must contain exactly one name"
- unless @symbols == 1;
- my $func_name = $symbols[0];
- my $function = $self->{symbols}{function}{$func_name};
- croak
- "$filename, $lineno: Function '$func_name' has not been defined"
- unless $function;
-
- foreach my $cite (@entries) {
- $self->{stack} = []; # Start with a new stack
-
- # Initialize the cite, bt_entry, and entry references
- $self->{bibtex}{cite} = $cite;
- $self->{bibtex}{bt_entry} = $self->{bibtex}{bt_entries}{$cite};
- my $entry = $self->{bibtex}{entries}{$cite};
- $self->{symbols}{field} = $entry->{field};
- $self->{symbols}{entry_int} = $entry->{integer};
- $self->{symbols}{entry_str} = $entry->{string};
- _evaluate( $self, $function );
- }
- }
+ my @symbols = grep !/^\#line/, @{$args_ar->[0]};
+ croak
+ "$filename, $lineno: first argument to '$cmd' must contain exactly one name"
+ unless @symbols == 1;
+ my $func_name = $symbols[0];
+ $self->_check_name($func_name);
+ $self->{symbols}{function}{$func_name} = $args_ar->[1];
+ }
- sub _command_macro {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
-
- my @symbols = grep !/^\#line/, @{ $args_ar->[0] };
- croak
-"$filename, $lineno: first argument to '$cmd' must contain exactly one name"
- unless @symbols == 1;
- my @defs = grep !/^\#line/, @{ $args_ar->[1] };
- croak
-"$filename, $lineno: second argument to '$cmd' must contain exactly one string"
- unless @defs == 1 && $defs[0] =~ /^\"(.*)\"$/s;
- my $macro = $symbols[0];
- Text::BibTeX::add_macro_text( $macro, _trim_string( $defs[0] ),
- $filename, $lineno );
-
- # $self->_check_name($macro);
- # $self->{symbols}{macro}{$macro} = $1;
- }
+ sub _command_iterate {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
+
+ my @entries = @{$self->{bibtex}{cites}};
+ @entries = reverse @entries if $cmd =~ /reverse/i;
+
+ my @symbols = grep !/^\#line/, @{$args_ar->[0]};
+ croak
+ "$filename, $lineno: first argument to '$cmd' must contain exactly one name"
+ unless @symbols == 1;
+ my $func_name = $symbols[0];
+ my $function = $self->{symbols}{function}{$func_name};
+ croak "$filename, $lineno: Function '$func_name' has not been defined"
+ unless $function;
+
+ foreach my $cite (@entries) {
+ $self->{stack} = []; # Start with a new stack
+
+ # Initialize the cite, bt_entry, and entry references
+ $self->{bibtex}{cite} = $cite;
+ $self->{bibtex}{bt_entry} = $self->{bibtex}{bt_entries}{$cite};
+ my $entry = $self->{bibtex}{entries}{$cite};
+ $self->{symbols}{field} = $entry->{field};
+ $self->{symbols}{entry_int} = $entry->{integer};
+ $self->{symbols}{entry_str} = $entry->{string};
+ _evaluate($self, $function);
+ }
+ }
- sub _command_read {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
+ sub _command_macro {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
+
+ my @symbols = grep !/^\#line/, @{$args_ar->[0]};
+ croak
+ "$filename, $lineno: first argument to '$cmd' must contain exactly one name"
+ unless @symbols == 1;
+ my @defs = grep !/^\#line/, @{$args_ar->[1]};
+ croak
+ "$filename, $lineno: second argument to '$cmd' must contain exactly one string"
+ unless @defs == 1 && $defs[0] =~ /^\"(.*)\"$/s;
+ my $macro = $symbols[0];
+ Text::BibTeX::add_macro_text($macro, _trim_string($defs[0]),
+ $filename, $lineno);
+
+ # $self->_check_name($macro);
+ # $self->{symbols}{macro}{$macro} = $1;
+ }
- # print "COMMAND_READ $cmd, $filename, $lineno \n";
+ sub _command_read {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
- if( $self->{bibtex}{rawbib} && $self->{bibtex}{rawbib} ne '' ){
- $self->_read_from_raw($cmd, $filename, $lineno, $args_ar);
- }
- else{
- $self->_read_from_files($cmd, $filename, $lineno, $args_ar);
- }
+ # print "COMMAND_READ $cmd, $filename, $lineno \n";
-
+ if ($self->{bibtex}{rawbib} && $self->{bibtex}{rawbib} ne '') {
+ $self->_read_from_raw($cmd, $filename, $lineno, $args_ar);
+ }
+ else {
+ $self->_read_from_files($cmd, $filename, $lineno, $args_ar);
+ }
+ } ##### sub _command_read {
+ sub _read_from_raw {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
+ # print "COMMAND_READ _read_from_raws \n";
- } ##### sub _command_read {
+ croak "$self->{lineno}: I found no rawbib content"
+ unless $self->{bibtex}{rawbib} && $self->{bibtex}{rawbib} ne '';
- sub _read_from_raw {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
- # print "COMMAND_READ _read_from_raws \n";
+ my @cites;
- croak "$self->{lineno}: I found no rawbib content"
- unless $self->{bibtex}{rawbib}
- && $self->{bibtex}{rawbib} ne '';
+ my $bt_entry = new Text::BibTeX::Entry();
+ $bt_entry->parse_s($self->{bibtex}{rawbib});
+ croak "Paring went shitty" unless $bt_entry->parse_ok;
- my @cites;
+ my $metatype = $bt_entry->metatype;
+ if ($metatype == BTE_REGULAR) {
- my $bt_entry = new Text::BibTeX::Entry();
- $bt_entry->parse_s($self->{bibtex}{rawbib});
- croak "Paring went shitty" unless $bt_entry->parse_ok;
+ my $key = $bt_entry->key;
- my $metatype = $bt_entry->metatype;
- if ( $metatype == BTE_REGULAR ) {
+ # print "_read_from_raw: Processing raw Entry metatype $metatype key $key \n";
- my $key = $bt_entry->key;
- # print "_read_from_raw: Processing raw Entry metatype $metatype key $key \n";
+ # next unless $cites{$key} || $cite_all;
+ push @cites, $key; # if $cite_all && !$cited{$key}++;
+ $self->{bibtex}{bt_entries}{$key} = $bt_entry;
+ # Create an entry hash for this entry
+ my $entry = {};
+ $entry->{field}{$_}
+ = $bt_entry->exists($_) ? ('"' . $bt_entry->get($_) . '"') : undef
+ foreach @{$self->{bibtex}{format}{field}};
+ $entry->{field}{crossref} = lc $entry->{field}{crossref}
+ if defined $entry->{field}{crossref};
+ $entry->{integer}{$_} = "-0" # 0?
+ foreach @{$self->{bibtex}{format}{integer}};
+ $entry->{string}{$_} = undef foreach @{$self->{bibtex}{format}{string}};
+ $self->{bibtex}{entries}{$key} = $entry;
+ }
+ elsif ($metatype == BTE_PREAMBLE) {
+ push @{$self->{bibtex}{preamble}}, $bt_entry->value;
+ }
+ elsif ($metatype == BTE_MACRODEF) {
- # next unless $cites{$key} || $cite_all;
- push @cites, $key; # if $cite_all && !$cited{$key}++;
- $self->{bibtex}{bt_entries}{$key} = $bt_entry;
+ # These are handled internally by Text::BibTeX
+ }
+ $self->{bibtex}{cites} = \@cites; # if $cite_all;
+ croak "$self->{lineno} I found no citations"
+ unless @{$self->{bibtex}{cites}};
+ }
- # Create an entry hash for this entry
- my $entry = {};
- $entry->{field}{$_} =
- $bt_entry->exists($_)
- ? ( '"' . $bt_entry->get($_) . '"' )
- : undef foreach @{ $self->{bibtex}{format}{field} };
- $entry->{field}{crossref} = lc $entry->{field}{crossref}
- if defined $entry->{field}{crossref};
- $entry->{integer}{$_} = "-0" # 0?
- foreach @{ $self->{bibtex}{format}{integer} };
- $entry->{string}{$_} = undef
- foreach @{ $self->{bibtex}{format}{string} };
- $self->{bibtex}{entries}{$key} = $entry;
+ sub _read_from_files {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
+
+ # print "COMMAND_READ _read_from_files \n";
+
+ croak "$self->{lineno}: I found no bib files"
+ unless $self->{bibtex}{bibfiles} && @{$self->{bibtex}{bibfiles}};
+
+ my %cited;
+ my @cites;
+
+ my $cite_all = !$self->{bibtex}{cites};
+ $self->{bibtex}{cites} ||= [];
+
+ my %cites; # The refs we want if not $cite_all
+ $cites{$_} = 1 foreach @{$self->{bibtex}{cites}};
+
+ # First read the bibtex files and get entries for each reference
+ foreach my $filename (@{$self->{bibtex}{bibfiles}}) {
+ my $f = "$filename.bib";
+ my $path = $ENV{BIBINPUTS} || '.';
+ my @path = split /:/, $path;
+ my ($dir) = grep -f "$_/$f", @path;
+ die "Cannot find $f on path: $path" unless $dir;
+ my $dirfile = "$dir/$f";
+ my $bibfile = Text::BibTeX::File->new($dirfile) or die "$dirfile: $!\n";
+
+ while (my $bt_entry = new Text::BibTeX::Entry $bibfile) {
+ next unless $bt_entry->parse_ok;
+
+ my $metatype = $bt_entry->metatype;
+ if ($metatype == BTE_REGULAR) {
+
+ # Skip entries that we don't want
+ my $key = $bt_entry->key;
+ next unless $cites{$key} || $cite_all;
+ push @cites, $key if $cite_all && !$cited{$key}++;
+ $self->{bibtex}{bt_entries}{$key} = $bt_entry;
+
+ # Create an entry hash for this entry
+ my $entry = {};
+ $entry->{field}{$_}
+ = $bt_entry->exists($_)
+ ? ('"' . $bt_entry->get($_) . '"')
+ : undef foreach @{$self->{bibtex}{format}{field}};
+ $entry->{field}{crossref} = lc $entry->{field}{crossref}
+ if defined $entry->{field}{crossref};
+ $entry->{integer}{$_} = "-0" # 0?
+ foreach @{$self->{bibtex}{format}{integer}};
+ $entry->{string}{$_} = undef
+ foreach @{$self->{bibtex}{format}{string}};
+ $self->{bibtex}{entries}{$key} = $entry;
}
- elsif ( $metatype == BTE_PREAMBLE ) {
- push @{ $self->{bibtex}{preamble} }, $bt_entry->value;
+ elsif ($metatype == BTE_PREAMBLE) {
+ push @{$self->{bibtex}{preamble}}, $bt_entry->value;
}
- elsif ( $metatype == BTE_MACRODEF ) {
+ elsif ($metatype == BTE_MACRODEF) {
- # These are handled internally by Text::BibTeX
+ # These are handled internally by Text::BibTeX
}
- $self->{bibtex}{cites} = \@cites;# if $cite_all;
- croak "$self->{lineno} I found no citations"
- unless @{ $self->{bibtex}{cites} };
}
+ }
+ $self->{bibtex}{cites} = \@cites if $cite_all;
+ croak "$self->{lineno} I found no citations"
+ unless @{$self->{bibtex}{cites}};
+ }
- sub _read_from_files {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
-
- # print "COMMAND_READ _read_from_files \n";
-
- croak "$self->{lineno}: I found no bib files"
- unless $self->{bibtex}{bibfiles}
- && @{ $self->{bibtex}{bibfiles} };
-
- my %cited;
- my @cites;
-
- my $cite_all = !$self->{bibtex}{cites};
- $self->{bibtex}{cites} ||= [];
-
- my %cites; # The refs we want if not $cite_all
- $cites{$_} = 1 foreach @{ $self->{bibtex}{cites} };
-
- # First read the bibtex files and get entries for each reference
- foreach my $filename ( @{ $self->{bibtex}{bibfiles} } ) {
- my $f = "$filename.bib";
- my $path = $ENV{BIBINPUTS} || '.';
- my @path = split /:/, $path;
- my ($dir) = grep -f "$_/$f", @path;
- die "Cannot find $f on path: $path" unless $dir;
- my $dirfile = "$dir/$f";
- my $bibfile = Text::BibTeX::File->new($dirfile)
- or die "$dirfile: $!\n";
-
- while ( my $bt_entry = new Text::BibTeX::Entry $bibfile) {
- next unless $bt_entry->parse_ok;
-
- my $metatype = $bt_entry->metatype;
- if ( $metatype == BTE_REGULAR ) {
-
- # Skip entries that we don't want
- my $key = $bt_entry->key;
- next unless $cites{$key} || $cite_all;
- push @cites, $key if $cite_all && !$cited{$key}++;
- $self->{bibtex}{bt_entries}{$key} = $bt_entry;
-
- # Create an entry hash for this entry
- my $entry = {};
- $entry->{field}{$_} =
- $bt_entry->exists($_)
- ? ( '"' . $bt_entry->get($_) . '"' )
- : undef foreach @{ $self->{bibtex}{format}{field} };
- $entry->{field}{crossref} = lc $entry->{field}{crossref}
- if defined $entry->{field}{crossref};
- $entry->{integer}{$_} = "-0" # 0?
- foreach @{ $self->{bibtex}{format}{integer} };
- $entry->{string}{$_} = undef
- foreach @{ $self->{bibtex}{format}{string} };
- $self->{bibtex}{entries}{$key} = $entry;
- }
- elsif ( $metatype == BTE_PREAMBLE ) {
- push @{ $self->{bibtex}{preamble} }, $bt_entry->value;
- }
- elsif ( $metatype == BTE_MACRODEF ) {
-
- # These are handled internally by Text::BibTeX
- }
- }
- }
- $self->{bibtex}{cites} = \@cites if $cite_all;
- croak "$self->{lineno} I found no citations"
- unless @{ $self->{bibtex}{cites} };
- }
-
- sub _process_entry {
-
- }
-
-
- sub _command_sort {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
-
- @{ $self->{bibtex}{cites} } =
- sort {
- $self->{bibtex}{entries}{$a}{string}{'sort.key$'}
- cmp $self->{bibtex}{entries}{$b}{string}{'sort.key$'}
- } @{ $self->{bibtex}{cites} };
+ sub _process_entry {
- # croak "$filename, $lineno: Command '$cmd' not implemented yet";
- }
+ }
- sub _command_variables {
- my ( $self, $cmd, $filename, $lineno, $args_ar ) = @_;
+ sub _command_sort {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
- my $init = $cmd =~ /integers/i ? "-0" : undef;
- $cmd =~ s/(.*)s/\L$1/i;
- $self->{symbols}{$cmd}{$_} = $init
- foreach map( $self->_check_name($_),
- grep !/^\#line/, @{ $args_ar->[0] } );
- }
+ @{$self->{bibtex}{cites}} = sort {
+ $self->{bibtex}{entries}{$a}{string}{'sort.key$'}
+ cmp $self->{bibtex}{entries}{$b}{string}{'sort.key$'}
+ } @{$self->{bibtex}{cites}};
- { # Static variables
- my %In_function;
-
- # Evaluates a function
- # Arguments: $self, function definition
- sub _evaluate {
- my ( $self, $function_ar ) = @_;
-
-
-
- $function_ar =~ s/^\'//;
- $function_ar = [$function_ar] unless ref $function_ar;
-
-
-
- local ( $self->{lineno} ) = $self->{lineno};
- my $old_warnings = $self->num_warnings;
- token:
- foreach my $token ( @{$function_ar} ) {
- if ( $token =~ /^\#line (\d+) (.*)/ ) {
- my ( $lineno, $filename ) = ( $1, $2 );
- $self->{lineno} = "$filename, $lineno";
- next token;
- }
- printf STDERR "$self->{lineno}: {%s} %s\n",
- join( ' ',
- map( $self->_format_token($_), @{ $self->{stack} } ) ),
- $self->_format_token($token)
- if $self->{options}{debug};
-
- if ( ref $token ) {
- $self->_push($token);
- next token;
- }
- if ( $token =~ /^\#(-?\d+)/
- || $token =~ /^(\'.*)/
- || $token =~ /^(\".*\")/ )
- {
- $self->_push($1);
- next token;
- }
-
- # Check for constants and variables
- foreach
- my $sym (qw(const entry_int entry_str integer string))
- {
- if ( exists $self->{symbols}{$sym}{$token} ) {
- $self->_push( $self->{symbols}{$sym}{$token} );
- next token;
- }
- }
-
- # Check for fields
- if ( exists $self->{symbols}{field}{$token} ) {
- my $val = $self->{symbols}{field}{$token};
-
- # Supply crossreferenced fields if applicable
- # commented out for performance
- # if (
- # !defined $val
- # && $self->{bibtex}{bt_entry}
- # && ( my $xref =
- # $self->{bibtex}{bt_entry}->get('crossref') )
- # )
- # {
- # my $bt_xref =
- # $self->{bibtex}{bt_entries}{ lc $xref };
- # if ($bt_xref) {
- # $val =
- # $bt_xref->exists($token)
- # ? ( '"' . $bt_xref->get($token) . '"' )
- # : undef;
- # }
- # else {
- # $self->_warning(
- # "Unknown cross reference: $xref");
- # }
- # }
- $self->_push($val);
- next token;
- }
- if ( $BuiltIn{$token} ) {
- $BuiltIn{$token}->( $self, $token );
- next token;
- }
- if ( exists $self->{symbols}{function}{$token} ) {
- if ( $In_function{$token} ) {
- $self->_warning(
- "Recursive call to '$token' ignored");
- }
- else {
- $In_function{$token}++;
- _evaluate( $self,
- $self->{symbols}{function}{$token} );
- $In_function{$token}--;
- }
- next token;
- }
- $self->_warning("Undefined function '$token'");
- }
- return $old_warnings == $self->num_warnings;
- }
- }
+ # croak "$filename, $lineno: Command '$cmd' not implemented yet";
}
- # A subroutine to format a token for printing
- # Arguments: token (popped from stack)
- sub _format_token : method {
- my ( $self, $token ) = @_;
-
- $_ = $token;
- return (
- !defined $_ || $_ eq "-0" ? 'missing'
- : /^-?\d+$/ ? "#$_"
- : ref($_) ? "{"
- . join( ' ', map $self->_format_token($_),
- grep( !/\#line/, @$_ ) )
- . "}"
- : $_
- );
- }
+ sub _command_variables {
+ my ($self, $cmd, $filename, $lineno, $args_ar) = @_;
- # Subroutines for built-in functions
- # All have the same arguments: $self, function token
-
- sub _function_add_period {
- my ( $self, $token ) = @_;
-
- my $arg = $self->_pop( s => $token, 1 );
- $arg =~ s/\"$/.\"/ unless $arg =~ /[.?!]\}*\"$/;
- $self->_push( _check_type_warnings() ? '""' : $arg );
+ my $init = $cmd =~ /integers/i ? "-0" : undef;
+ $cmd =~ s/(.*)s/\L$1/i;
+ $self->{symbols}{$cmd}{$_} = $init
+ foreach map($self->_check_name($_), grep !/^\#line/, @{$args_ar->[0]});
}
- sub _function_arith {
- my ( $self, $token ) = @_;
+ { # Static variables
+ my %In_function;
+
+ # Evaluates a function
+ # Arguments: $self, function definition
+ sub _evaluate {
+ my ($self, $function_ar) = @_;
+
+ $function_ar =~ s/^\'//;
+ $function_ar = [$function_ar] unless ref $function_ar;
+
+ local ($self->{lineno}) = $self->{lineno};
+ my $old_warnings = $self->num_warnings;
+ token:
+ foreach my $token (@{$function_ar}) {
+ if ($token =~ /^\#line (\d+) (.*)/) {
+ my ($lineno, $filename) = ($1, $2);
+ $self->{lineno} = "$filename, $lineno";
+ next token;
+ }
+ printf STDERR "$self->{lineno}: {%s} %s\n",
+ join(' ', map($self->_format_token($_), @{$self->{stack}})),
+ $self->_format_token($token)
+ if $self->{options}{debug};
+
+ if (ref $token) {
+ $self->_push($token);
+ next token;
+ }
+ if ( $token =~ /^\#(-?\d+)/
+ || $token =~ /^(\'.*)/
+ || $token =~ /^(\".*\")/)
+ {
+ $self->_push($1);
+ next token;
+ }
- # We can use builtin eval for these functions
- my $arg1 = $self->_pop( i => $token, 1 );
- my $arg2 = $self->_pop( i => $token );
- $self->_push(
- _check_type_warnings() ? 0 : eval "0+($arg2 $token $arg1)" );
- }
+ # Check for constants and variables
+ foreach my $sym (qw(const entry_int entry_str integer string)) {
+ if (exists $self->{symbols}{$sym}{$token}) {
+ $self->_push($self->{symbols}{$sym}{$token});
+ next token;
+ }
+ }
- sub _function_assign {
- my ( $self, $token ) = @_;
-
- my $sym = $self->_pop( q => $token, 1 );
- my $have_sym if $sym =~ s/^\'//;
- my ($type) = grep( exists $self->{symbols}{$_}{$sym},
- qw(entry_int entry_str integer string) );
- my $val_type = !$have_sym ? 'si' : $type =~ /str/ ? 's' : 'i';
- my $val = $self->_pop( $val_type => $token );
- my $bad_arg = _check_type_warnings();
- return if $bad_arg;
- if ( !$type ) {
- $self->_warning("Undefined variable '$sym'");
- }
- else {
- $self->{symbols}{$type}{$sym} = $val;
+ # Check for fields
+ if (exists $self->{symbols}{field}{$token}) {
+ my $val = $self->{symbols}{field}{$token};
+
+ # Supply crossreferenced fields if applicable
+ # commented out for performance
+ # if (
+ # !defined $val
+ # && $self->{bibtex}{bt_entry}
+ # && ( my $xref =
+ # $self->{bibtex}{bt_entry}->get('crossref') )
+ # )
+ # {
+ # my $bt_xref =
+ # $self->{bibtex}{bt_entries}{ lc $xref };
+ # if ($bt_xref) {
+ # $val =
+ # $bt_xref->exists($token)
+ # ? ( '"' . $bt_xref->get($token) . '"' )
+ # : undef;
+ # }
+ # else {
+ # $self->_warning(
+ # "Unknown cross reference: $xref");
+ # }
+ # }
+ $self->_push($val);
+ next token;
+ }
+ if ($BuiltIn{$token}) {
+ $BuiltIn{$token}->($self, $token);
+ next token;
+ }
+ if (exists $self->{symbols}{function}{$token}) {
+ if ($In_function{$token}) {
+ $self->_warning("Recursive call to '$token' ignored");
+ }
+ else {
+ $In_function{$token}++;
+ _evaluate($self, $self->{symbols}{function}{$token});
+ $In_function{$token}--;
+ }
+ next token;
+ }
+ $self->_warning("Undefined function '$token'");
}
+ return $old_warnings == $self->num_warnings;
+ }
}
-
- sub _function_call_type {
- my ( $self, $token ) = @_;
-
- return $self->_warning("No current entry in function '$token'")
- unless $self->{bibtex}{bt_entry};
- $self->_evaluate( $self->{bibtex}{bt_entry}->type );
+ }
+
+ # A subroutine to format a token for printing
+ # Arguments: token (popped from stack)
+ sub _format_token : method {
+ my ($self, $token) = @_;
+
+ $_ = $token;
+ return (!defined $_ || $_ eq "-0" ? 'missing'
+ : /^-?\d+$/ ? "#$_"
+ : ref($_) ? "{"
+ . join(' ', map $self->_format_token($_), grep(!/\#line/, @$_)) . "}"
+ : $_);
+ }
+
+ # Subroutines for built-in functions
+ # All have the same arguments: $self, function token
+
+ sub _function_add_period {
+ my ($self, $token) = @_;
+
+ my $arg = $self->_pop(s => $token, 1);
+ $arg =~ s/\"$/.\"/ unless $arg =~ /[.?!]\}*\"$/;
+ $self->_push(_check_type_warnings() ? '""' : $arg);
+ }
+
+ sub _function_arith {
+ my ($self, $token) = @_;
+
+ # We can use builtin eval for these functions
+ my $arg1 = $self->_pop(i => $token, 1);
+ my $arg2 = $self->_pop(i => $token);
+ $self->_push(_check_type_warnings() ? 0 : eval "0+($arg2 $token $arg1)");
+ }
+
+ sub _function_assign {
+ my ($self, $token) = @_;
+
+ my $sym = $self->_pop(q => $token, 1);
+ my $have_sym if $sym =~ s/^\'//;
+ my ($type) = grep(exists $self->{symbols}{$_}{$sym},
+ qw(entry_int entry_str integer string));
+ my $val_type = !$have_sym ? 'si' : $type =~ /str/ ? 's' : 'i';
+ my $val = $self->_pop($val_type => $token);
+ my $bad_arg = _check_type_warnings();
+ return if $bad_arg;
+ if (!$type) {
+ $self->_warning("Undefined variable '$sym'");
}
-
- sub _function_change_case {
- my ( $self, $token ) = @_;
-
- my $old_num_warnings = $self->num_warnings;
- my $spec = _trim_string( $self->_pop( s => $token, 1 ) );
- my $str = _trim_string( $self->_pop( s => $token ) );
- return $self->_push('""') if _check_type_warnings();
- if ( $spec !~ /^[tul]$/ ) {
- $self->_warning(
- "Argument 1 of '$token' has illegal specification ($spec)");
- return $self->_push(qq("$str"));
- }
- my $changed;
- $str = _protect($str);
- if ( $spec eq 't' ) {
- my @unchanged = $str =~ /(?:\A|:\s+)([a-z])/ig;
- $changed = lc $str;
- my $cnt = 0;
- $changed =~ s/(\A|:\s+)([a-z])/$1$unchanged[$cnt++]/g;
- }
- else {
- $changed = $spec eq 'u' ? uc $str : lc $str;
- }
-
- # my $changed = Text::BibTeX::change_case($spec, $str);
- $changed = _unprotect($changed);
- $self->_push(qq("$changed"));
+ else {
+ $self->{symbols}{$type}{$sym} = $val;
}
-
- sub _function_chr_to_int {
- my ( $self, $token ) = @_;
-
- my $arg1 = $self->_pop( s => $token, 1 );
- my $bad_arg = _check_type_warnings();
- $self->_warning("Argument 1 to '$token' must be a single character")
- if !$bad_arg && $arg1 !~ /^\"(.)\"$/;
- $self->_push( $bad_arg ? 0 : ord( $1 || '' ) );
+ }
+
+ sub _function_call_type {
+ my ($self, $token) = @_;
+
+ return $self->_warning("No current entry in function '$token'")
+ unless $self->{bibtex}{bt_entry};
+ $self->_evaluate($self->{bibtex}{bt_entry}->type);
+ }
+
+ sub _function_change_case {
+ my ($self, $token) = @_;
+
+ my $old_num_warnings = $self->num_warnings;
+ my $spec = _trim_string($self->_pop(s => $token, 1));
+ my $str = _trim_string($self->_pop(s => $token));
+ return $self->_push('""') if _check_type_warnings();
+ if ($spec !~ /^[tul]$/) {
+ $self->_warning(
+ "Argument 1 of '$token' has illegal specification ($spec)");
+ return $self->_push(qq("$str"));
}
-
- sub _function_cite {
- my ( $self, $token ) = @_;
-
- if ( !$self->{bibtex}{bt_entry} ) {
- $self->_warning("No current entry in function '$token'");
- return $self->_push('""');
- }
- $self->_push( lc qq("$self->{bibtex}{cite}") );
+ my $changed;
+ $str = _protect($str);
+ if ($spec eq 't') {
+ my @unchanged = $str =~ /(?:\A|:\s+)([a-z])/ig;
+ $changed = lc $str;
+ my $cnt = 0;
+ $changed =~ s/(\A|:\s+)([a-z])/$1$unchanged[$cnt++]/g;
}
-
- sub _function_concat {
- my ( $self, $token ) = @_;
-
- my $arg1 = $self->_pop( s => $token, 1 );
- my $arg2 = $self->_pop( s => $token );
- $arg1 = _trim_string($arg1);
- $arg2 = _trim_string($arg2);
- $self->_push(qq("$arg2$arg1"));
+ else {
+ $changed = $spec eq 'u' ? uc $str : lc $str;
}
- sub _function_duplicate {
- my ( $self, $token ) = @_;
+ # my $changed = Text::BibTeX::change_case($spec, $str);
+ $changed = _unprotect($changed);
+ $self->_push(qq("$changed"));
+ }
- my $arg1 = $self->_pop;
- $self->_push($arg1);
- $self->_push($arg1);
- }
+ sub _function_chr_to_int {
+ my ($self, $token) = @_;
- sub _function_empty {
- my ( $self, $token ) = @_;
+ my $arg1 = $self->_pop(s => $token, 1);
+ my $bad_arg = _check_type_warnings();
+ $self->_warning("Argument 1 to '$token' must be a single character")
+ if !$bad_arg && $arg1 !~ /^\"(.)\"$/;
+ $self->_push($bad_arg ? 0 : ord($1 || ''));
+ }
- my $arg1 = $self->_pop( s => $token, 1 );
- $self->_push( 0 + ( !defined $arg1 || $arg1 =~ /^\"\s*\"$/ ) );
- }
-
- sub _function_eq {
- my ( $self, $token ) = @_;
+ sub _function_cite {
+ my ($self, $token) = @_;
- my $arg1 = $self->_pop( is => $token, 1 );
- my $type = $arg1 =~ /^\"/ ? 's' : 'i';
- my $arg2 = $self->_pop( $type => $token );
- my $op = $type eq 's' ? 'eq' : '==';
- $self->_push(
- _check_type_warnings() ? 0 : eval "0+(q($arg2) $op q($arg1))" );
+ if (!$self->{bibtex}{bt_entry}) {
+ $self->_warning("No current entry in function '$token'");
+ return $self->_push('""');
}
-
- sub _function_format_name {
- my ( $self, $token ) = @_;
-
- my $format = $self->_pop( s => $token, 1 );
- my $index = $self->_pop( i => $token );
- my $list = $self->_pop( s => $token );
- return $self->_push('""') if _check_type_warnings();
- $format = _trim_string($format);
- $list = _trim_string($list);
- my @list = Text::BibTeX::split_list( $list, 'and' );
- if ( $index > @list || $index < 1 ) {
- $self->_warning("Index $index is out of range for '$token'");
- return $self->_push('""');
+ $self->_push(lc qq("$self->{bibtex}{cite}"));
+ }
+
+ sub _function_concat {
+ my ($self, $token) = @_;
+
+ my $arg1 = $self->_pop(s => $token, 1);
+ my $arg2 = $self->_pop(s => $token);
+ $arg1 = _trim_string($arg1);
+ $arg2 = _trim_string($arg2);
+ $self->_push(qq("$arg2$arg1"));
+ }
+
+ sub _function_duplicate {
+ my ($self, $token) = @_;
+
+ my $arg1 = $self->_pop;
+ $self->_push($arg1);
+ $self->_push($arg1);
+ }
+
+ sub _function_empty {
+ my ($self, $token) = @_;
+
+ my $arg1 = $self->_pop(s => $token, 1);
+ $self->_push(0 + (!defined $arg1 || $arg1 =~ /^\"\s*\"$/));
+ }
+
+ sub _function_eq {
+ my ($self, $token) = @_;
+
+ my $arg1 = $self->_pop(is => $token, 1);
+ my $type = $arg1 =~ /^\"/ ? 's' : 'i';
+ my $arg2 = $self->_pop($type => $token);
+ my $op = $type eq 's' ? 'eq' : '==';
+ $self->_push(_check_type_warnings() ? 0 : eval "0+(q($arg2) $op q($arg1))");
+ }
+
+ sub _function_format_name {
+ my ($self, $token) = @_;
+
+ my $format = $self->_pop(s => $token, 1);
+ my $index = $self->_pop(i => $token);
+ my $list = $self->_pop(s => $token);
+ return $self->_push('""') if _check_type_warnings();
+ $format = _trim_string($format);
+ $list = _trim_string($list);
+ my @list = Text::BibTeX::split_list($list, 'and');
+ if ($index > @list || $index < 1) {
+ $self->_warning("Index $index is out of range for '$token'");
+ return $self->_push('""');
+ }
+ my $name = $list[$index - 1];
+ my $bt_name = Text::BibTeX::Name->new($name);
+ my %name;
+ @name{qw(f v l j)} = map [$bt_name->part($_)], qw(first von last jr);
+
+ my %parts = (f => 'first', v => 'von', l => 'last', j => 'jr');
+
+ # Parse the format string
+ $format = _protect($format);
+ my @format = split /(PROTECT\(0D\d+\))/, $format;
+ my $output = '';
+ foreach (@format) {
+ if (/^PROTECT/) {
+ my $spec = _unprotect($_);
+ $spec =~ s/^\{(.*)\}/$1/s;
+ my ($pre, $form, $long, $inter, $post, $may_tie, $must_tie)
+ = $spec =~ /(.*?)([fjlv])(\2)?(?:\{(.*)\})?(.*?)?(~)?(~)?$/;
+ if (!defined $form) {
+ $self->_warning("Invalid format specifier '$spec' for '$token'");
+ return $self->_push('""');
}
- my $name = $list[ $index - 1 ];
- my $bt_name = Text::BibTeX::Name->new($name);
- my %name;
- @name{qw(f v l j)} = map [ $bt_name->part($_) ], qw(first von last jr);
-
- my %parts = ( f => 'first', v => 'von', l => 'last', j => 'jr' );
-
- # Parse the format string
- $format = _protect($format);
- my @format = split /(PROTECT\(0D\d+\))/, $format;
- my $output = '';
- foreach (@format) {
- if (/^PROTECT/) {
- my $spec = _unprotect($_);
- $spec =~ s/^\{(.*)\}/$1/s;
- my ( $pre, $form, $long, $inter, $post, $may_tie, $must_tie ) =
- $spec =~ /(.*?)([fjlv])(\2)?(?:\{(.*)\})?(.*?)?(~)?(~)?$/;
- if ( !defined $form ) {
- $self->_warning(
- "Invalid format specifier '$spec' for '$token'");
- return $self->_push('""');
- }
- my $name = $name{$form};
- next unless @$name;
- $pre = ' '
- if $pre eq ''
- && $output ne ''
- && $output !~ /[ ~]$/;
- my $need_tie = 0;
- my @out_names;
- foreach (@$name) {
- my $name = _unprotect($_);
- my $tie = @out_names && $need_tie && $may_tie ? '~' : ' ';
- if ($long) {
- push @out_names, $tie if @out_names;
- push @out_names, $name;
- }
- else {
- # Handle hyphenated names
- my @parts = split /-/, $name;
- my @part_letters;
- foreach my $part (@parts) {
- my ($letter) = $part =~ /^(\{\\[a-z]+|.*?[a-z])/i;
- $letter .= '}'
- while $letter =~ tr/{// > $letter =~ tr/}//;
- push @part_letters, $letter;
- }
- my $join = defined $inter ? "$inter" : '.-';
- $tie = defined $inter ? $inter : ".$tie";
- push @out_names, $tie if @out_names;
- push @out_names, join $join, @part_letters;
-
- # Hyphen counts as a tie
- $tie = '~' if @part_letters > 1 && $tie;
- }
- $need_tie = $tie !~ /~/;
- }
- my $out_tie =
- !$long && ( $must_tie || $may_tie && $need_tie ) ? '~' : '';
- $output .= ( $pre || '' );
- $output .= join( '', @out_names ) if defined $out_names[0];
- $output .= ( $post || '' );
- $output .= $out_tie;
- }
- else {
- $output .= $_;
+ my $name = $name{$form};
+ next unless @$name;
+ $pre = ' ' if $pre eq '' && $output ne '' && $output !~ /[ ~]$/;
+ my $need_tie = 0;
+ my @out_names;
+ foreach (@$name) {
+ my $name = _unprotect($_);
+ my $tie = @out_names && $need_tie && $may_tie ? '~' : ' ';
+ if ($long) {
+ push @out_names, $tie if @out_names;
+ push @out_names, $name;
+ }
+ else {
+ # Handle hyphenated names
+ my @parts = split /-/, $name;
+ my @part_letters;
+ foreach my $part (@parts) {
+ my ($letter) = $part =~ /^(\{\\[a-z]+|.*?[a-z])/i;
+ $letter .= '}' while $letter =~ tr/{// > $letter =~ tr/}//;
+ push @part_letters, $letter;
}
- }
+ my $join = defined $inter ? "$inter" : '.-';
+ $tie = defined $inter ? $inter : ".$tie";
+ push @out_names, $tie if @out_names;
+ push @out_names, join $join, @part_letters;
- $self->_push(qq("$output"));
-
- # my $format = $self->_pop(s => $token, 1);
- # my $index = $self->_pop(i => $token);
- # my $list = $self->_pop(s => $token);
- # return $self->_push('""') if _check_type_warnings();
- # $format = _trim_string($format);
- # $list = _trim_string($list);
- # my @list = split /\s+and\s+/, _protect($list);
- # if ($index > @list || $index < 1) {
- # $self->_warning("Index $index is out of range for '$token'");
- # return $self->_push('""');
- # }
- # # N.B. $name is still protected
- # my $name = $list[$index-1];
- # # Decompose the string into first, von, last, and junior
- # my @names = split /,\s*/, $name;
- # my $von_re = '[a-z](?:PROTECT\(0D\d+\)|\\.|[a-z])*';
- # my %name; # Four keys: f, j, l, v
- # if (@names > 1) { # "von Last, Junior, First" style
- # $name{f} = $names[-1];
- # $name{j} = $names[1] if @names > 2;
- # my @last = split /\s+/, $names[0];
- # my @von;
- # while ($_ = shift @last) {
- # # Get the first letter
- # my $name = _unprotect($_);
- # my ($letter) = $name =~ /([a-z])/i;
- # if ($letter =~ /[a-z]/) {
- # push @von, $_;
- # }
- # else {
- # unshift @last, $_;
- # last;
- # }
- # }
- # $name{v} = join ' ', @von;
- # $name{l} = join ' ', @last;
- # }
- # else {
- # my (@first, @von, @last);
- # @names = split /\s+/, $name;
- # @last = pop @names;
- # while ($_ = shift @names) {
- # # Get the first letter
- # my $name = _unprotect($_);
- # my ($letter) = $name =~ /([a-z])/i;
- # if ($letter =~ /[a-z]/) {
- # push @von, $_;
- # }
- # elsif (@von) {
- # unshift @last, $_;
- # last;
- # }
- # else {
- # push @first, $_;
- # }
- # }
- # $name{f} = join ' ', @first;
- # $name{v} = join ' ', @von;
- # $name{l} = join ' ', @last;
- # }
-
- # # Parse the format string
- # $format = _protect($format);
- # my @format = split /(PROTECT\(0D\d+\))/, $format;
- # my $output = '';
- # foreach (@format) {
- # if (/^PROTECT/) {
- # my $spec = _unprotect($_);
- # $spec =~ s/^\{(.*)\}/$1/s;
- # my ($pre, $form, $long, $inter, $post, $tie, $must_tie) =
- # $spec =~ /(.*?)([fjlv])(\2)?(\{.*\})?(.*?)?(~)?(~)?$/;
- # if (! defined $form) {
- # $self->_warning("Invalid format specifier '$spec' for '$token'");
- # return $self->_push('""');
- # }
- # my $name = $name{$form};
- # next unless defined $name && $name ne '';
- # $inter = $long ? '~' : '.~' unless ($inter || '') ne '';
- # $inter =~ s/^\{(.*)\}$/$1/s;
- # $pre = ' ' if $pre eq '' && $output ne '' &&
- # $output !~ /[ ~]$/;
- # if (! $long) {
- # my @names = split /\s+/, $name;
- # my @inits;
- # foreach (@names) {
- # my $name = _unprotect($_);
- # my ($letter) = $name =~ /^(\{\\[a-z]+|.*?[a-z])/i;
- # $letter .= '}' while $letter =~ tr/{// > $letter =~ tr/}//;
- # push @inits, $letter;
- # }
- # $name = join ' ', @inits;
- # }
- # my @names = split /\s+/, $name;
- # $output .= ($pre || '') . join($inter, @names) . ($post || '') .
- # ($must_tie || '');
- # }
- # else {
- # $output .= $_;
- # }
- # }
- # $output = _unprotect($output);
- # $self->_push(qq("$output"));
+ # Hyphen counts as a tie
+ $tie = '~' if @part_letters > 1 && $tie;
+ }
+ $need_tie = $tie !~ /~/;
+ }
+ my $out_tie = !$long && ($must_tie || $may_tie && $need_tie) ? '~' : '';
+ $output .= ($pre || '');
+ $output .= join('', @out_names) if defined $out_names[0];
+ $output .= ($post || '');
+ $output .= $out_tie;
+ }
+ else {
+ $output .= $_;
+ }
}
- sub _function_if {
- my ( $self, $token ) = @_;
-
- my $else = $self->_pop( qx => $token, 1 );
- my $if = $self->_pop( qx => $token );
- my $cond = $self->_pop( i => $token );
- return if _check_type_warnings();
- my $branch = $cond > 0 ? $if : $else;
- $self->_evaluate($branch);
- }
+ $self->_push(qq("$output"));
+
+ # my $format = $self->_pop(s => $token, 1);
+ # my $index = $self->_pop(i => $token);
+ # my $list = $self->_pop(s => $token);
+ # return $self->_push('""') if _check_type_warnings();
+ # $format = _trim_string($format);
+ # $list = _trim_string($list);
+ # my @list = split /\s+and\s+/, _protect($list);
+ # if ($index > @list || $index < 1) {
+ # $self->_warning("Index $index is out of range for '$token'");
+ # return $self->_push('""');
+ # }
+ # # N.B. $name is still protected
+ # my $name = $list[$index-1];
+ # # Decompose the string into first, von, last, and junior
+ # my @names = split /,\s*/, $name;
+ # my $von_re = '[a-z](?:PROTECT\(0D\d+\)|\\.|[a-z])*';
+ # my %name; # Four keys: f, j, l, v
+ # if (@names > 1) { # "von Last, Junior, First" style
+ # $name{f} = $names[-1];
+ # $name{j} = $names[1] if @names > 2;
+ # my @last = split /\s+/, $names[0];
+ # my @von;
+ # while ($_ = shift @last) {
+ # # Get the first letter
+ # my $name = _unprotect($_);
+ # my ($letter) = $name =~ /([a-z])/i;
+ # if ($letter =~ /[a-z]/) {
+ # push @von, $_;
+ # }
+ # else {
+ # unshift @last, $_;
+ # last;
+ # }
+ # }
+ # $name{v} = join ' ', @von;
+ # $name{l} = join ' ', @last;
+ # }
+ # else {
+ # my (@first, @von, @last);
+ # @names = split /\s+/, $name;
+ # @last = pop @names;
+ # while ($_ = shift @names) {
+ # # Get the first letter
+ # my $name = _unprotect($_);
+ # my ($letter) = $name =~ /([a-z])/i;
+ # if ($letter =~ /[a-z]/) {
+ # push @von, $_;
+ # }
+ # elsif (@von) {
+ # unshift @last, $_;
+ # last;
+ # }
+ # else {
+ # push @first, $_;
+ # }
+ # }
+ # $name{f} = join ' ', @first;
+ # $name{v} = join ' ', @von;
+ # $name{l} = join ' ', @last;
+ # }
+
+ # # Parse the format string
+ # $format = _protect($format);
+ # my @format = split /(PROTECT\(0D\d+\))/, $format;
+ # my $output = '';
+ # foreach (@format) {
+ # if (/^PROTECT/) {
+ # my $spec = _unprotect($_);
+ # $spec =~ s/^\{(.*)\}/$1/s;
+ # my ($pre, $form, $long, $inter, $post, $tie, $must_tie) =
+ # $spec =~ /(.*?)([fjlv])(\2)?(\{.*\})?(.*?)?(~)?(~)?$/;
+ # if (! defined $form) {
+ # $self->_warning("Invalid format specifier '$spec' for '$token'");
+ # return $self->_push('""');
+ # }
+ # my $name = $name{$form};
+ # next unless defined $name && $name ne '';
+ # $inter = $long ? '~' : '.~' unless ($inter || '') ne '';
+ # $inter =~ s/^\{(.*)\}$/$1/s;
+ # $pre = ' ' if $pre eq '' && $output ne '' &&
+ # $output !~ /[ ~]$/;
+ # if (! $long) {
+ # my @names = split /\s+/, $name;
+ # my @inits;
+ # foreach (@names) {
+ # my $name = _unprotect($_);
+ # my ($letter) = $name =~ /^(\{\\[a-z]+|.*?[a-z])/i;
+ # $letter .= '}' while $letter =~ tr/{// > $letter =~ tr/}//;
+ # push @inits, $letter;
+ # }
+ # $name = join ' ', @inits;
+ # }
+ # my @names = split /\s+/, $name;
+ # $output .= ($pre || '') . join($inter, @names) . ($post || '') .
+ # ($must_tie || '');
+ # }
+ # else {
+ # $output .= $_;
+ # }
+ # }
+ # $output = _unprotect($output);
+ # $self->_push(qq("$output"));
+ }
+
+ sub _function_if {
+ my ($self, $token) = @_;
+
+ my $else = $self->_pop(qx => $token, 1);
+ my $if = $self->_pop(qx => $token);
+ my $cond = $self->_pop(i => $token);
+ return if _check_type_warnings();
+ my $branch = $cond > 0 ? $if : $else;
+ $self->_evaluate($branch);
+ }
- sub _function_int_to_chr {
- my ( $self, $token ) = @_;
+ sub _function_int_to_chr {
+ my ($self, $token) = @_;
- my $arg1 = $self->_pop( i => $token, 1 );
- $self->_push( _check_type_warnings() ? '""' : '"' . chr($arg1) . '"' );
- }
+ my $arg1 = $self->_pop(i => $token, 1);
+ $self->_push(_check_type_warnings() ? '""' : '"' . chr($arg1) . '"');
+ }
- sub _function_int_to_str {
- my ( $self, $token ) = @_;
+ sub _function_int_to_str {
+ my ($self, $token) = @_;
- my $arg1 = $self->_pop( i => $token, 1 );
- $self->_push( _check_type_warnings() ? '""' : qq("$arg1") );
- }
+ my $arg1 = $self->_pop(i => $token, 1);
+ $self->_push(_check_type_warnings() ? '""' : qq("$arg1"));
+ }
- sub _function_missing {
- my ( $self, $token ) = @_;
+ sub _function_missing {
+ my ($self, $token) = @_;
- my $arg1 = $self->_pop( s => $token, 1 );
- $self->_push( 0 + ( !defined $arg1 ) );
- }
+ my $arg1 = $self->_pop(s => $token, 1);
+ $self->_push(0 + (!defined $arg1));
+ }
- sub _function_newline {
- my ( $self, $token ) = @_;
+ sub _function_newline {
+ my ($self, $token) = @_;
- push @{ $self->{output} }, "\n";
- }
+ push @{$self->{output}}, "\n";
+ }
- sub _function_num_names {
- my ( $self, $token ) = @_;
+ sub _function_num_names {
+ my ($self, $token) = @_;
- my $arg1 = _trim_string( $self->_pop( s => $token, 1 ) );
- return $self->_push(0) if _check_type_warnings();
- my @split = Text::BibTeX::split_list( $arg1, 'and' );
- $self->_push( 0 + @split );
- }
+ my $arg1 = _trim_string($self->_pop(s => $token, 1));
+ return $self->_push(0) if _check_type_warnings();
+ my @split = Text::BibTeX::split_list($arg1, 'and');
+ $self->_push(0 + @split);
+ }
- sub _function_preamble {
- my ( $self, $token ) = @_;
+ sub _function_preamble {
+ my ($self, $token) = @_;
- $self->_push( sprintf '"%s"',
- join( '', @{ $self->{bibtex}{preamble} } ) );
- }
+ $self->_push(sprintf '"%s"', join('', @{$self->{bibtex}{preamble}}));
+ }
- sub _function_purify {
- my ( $self, $token ) = @_;
+ sub _function_purify {
+ my ($self, $token) = @_;
- my $arg = _trim_string( $self->_pop( s => $token, 1 ) );
- return $self->_push('""') if _check_type_warnings();
+ my $arg = _trim_string($self->_pop(s => $token, 1));
+ return $self->_push('""') if _check_type_warnings();
- # my $pure = Text::BibTeX::purify_string($arg);
- # $self->_push(qq("$pure"));
+ # my $pure = Text::BibTeX::purify_string($arg);
+ # $self->_push(qq("$pure"));
- $arg =~ s/[\s~]+/ /g;
+ $arg =~ s/[\s~]+/ /g;
- # Handle accents
- $arg =~ s/\\i\b/i/g;
- $arg =~ s/\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* ([a-z]+) [ ]*
+ # Handle accents
+ $arg =~ s/\\i\b/i/g;
+ $arg =~ s/\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* ([a-z]+) [ ]*
(?:\}|\Z)/$1/ogix;
- $arg =~ s/\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* ([a-z]+) [ ]*
+ $arg =~ s/\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* ([a-z]+) [ ]*
(?:\}|\Z)/$1/ogix;
- $arg =~ s/($Acc_sym)/(my $v = $1) =~ tr!a-zA-Z!!cd; $v/goxe;
-
- # Remove \latex[options]{commands}
- 1 while $arg =~ s/\\([^\{\[]+)//g;
-
- # Remove braces around only alphanum
- 1 while $arg =~ s/\{([a-z0-9 ]+)\}/$1/gi;
- $arg =~ s/\{[^{}]*\}//g; # Remove all other braces
- $arg =~ tr/a-zA-Z0-9 ~//cd;
- $arg =~ tr/~/ /;
- $arg =~ s/\s+/ /g;
- $self->_push(qq("$arg"));
+ $arg =~ s/($Acc_sym)/(my $v = $1) =~ tr!a-zA-Z!!cd; $v/goxe;
+
+ # Remove \latex[options]{commands}
+ 1 while $arg =~ s/\\([^\{\[]+)//g;
+
+ # Remove braces around only alphanum
+ 1 while $arg =~ s/\{([a-z0-9 ]+)\}/$1/gi;
+ $arg =~ s/\{[^{}]*\}//g; # Remove all other braces
+ $arg =~ tr/a-zA-Z0-9 ~//cd;
+ $arg =~ tr/~/ /;
+ $arg =~ s/\s+/ /g;
+ $self->_push(qq("$arg"));
+ }
+
+ sub _function_stack {
+ my ($self, $token) = @_;
+
+ while (@{$self->{stack}}) {
+ my $val = $self->_pop;
+ $self->_warning($self->_format_token($val), 1);
}
-
- sub _function_stack {
- my ( $self, $token ) = @_;
-
- while ( @{ $self->{stack} } ) {
- my $val = $self->_pop;
- $self->_warning( $self->_format_token($val), 1 );
- }
+ }
+
+ sub _function_substring {
+ my ($self, $token) = @_;
+
+ my $len = $self->_pop(i => $token, 1);
+ my $start = $self->_pop(i => $token);
+ my $string = $self->_pop(s => $token);
+ return $self->_push('""') if _check_type_warnings();
+ if ($start == 0) {
+ $self->_warning("Argument 2 to '$token' cannot be 0");
+ return $self->_push('""');
}
-
- sub _function_substring {
- my ( $self, $token ) = @_;
-
- my $len = $self->_pop( i => $token, 1 );
- my $start = $self->_pop( i => $token );
- my $string = $self->_pop( s => $token );
- return $self->_push('""') if _check_type_warnings();
- if ( $start == 0 ) {
- $self->_warning("Argument 2 to '$token' cannot be 0");
- return $self->_push('""');
- }
- $string = _trim_string($string);
- my $str_len = length $string;
- $start = $start > 0 ? $start - 1 : $str_len + $start - $len + 1;
- if ( $start < 0 ) {
- $len += $start;
- $start = 0;
- }
- $self->_push( sprintf '"%s"', substr( $string, $start, $len ) );
+ $string = _trim_string($string);
+ my $str_len = length $string;
+ $start = $start > 0 ? $start - 1 : $str_len + $start - $len + 1;
+ if ($start < 0) {
+ $len += $start;
+ $start = 0;
}
+ $self->_push(sprintf '"%s"', substr($string, $start, $len));
+ }
- sub _function_swap {
- my ( $self, $token ) = @_;
+ sub _function_swap {
+ my ($self, $token) = @_;
- my ( $arg1, $arg2 ) = ( $self->_pop, $self->_pop );
- $self->_push( $arg1, $arg2 );
- }
+ my ($arg1, $arg2) = ($self->_pop, $self->_pop);
+ $self->_push($arg1, $arg2);
+ }
- sub _function_text_length {
- my ( $self, $token ) = @_;
+ sub _function_text_length {
+ my ($self, $token) = @_;
- my $arg = $self->_pop( s => $token, 1 );
- return $self->_push(0) if _check_type_warnings();
- $arg = _trim_string($arg);
+ my $arg = $self->_pop(s => $token, 1);
+ return $self->_push(0) if _check_type_warnings();
+ $arg = _trim_string($arg);
- # Count the accents
- my $length = $arg =~ s/\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* [a-z]+ [ ]*
+ # Count the accents
+ my $length = $arg =~ s/\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* [a-z]+ [ ]*
(?:\}|\Z)//ogix;
- $length += $arg =~ s/\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* [a-z]+ [ ]*
+ $length += $arg =~ s/\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* [a-z]+ [ ]*
(?:\}|\Z)//ogix;
- $length += $arg =~ s/$Acc_sym//gox;
-
- # Remove any remaining braces
- $arg =~ s/[{}]//g;
-
- # Count whatever's left
- $length += length $arg;
- $self->_push($length);
- }
-
- sub _function_text_prefix {
- my ( $self, $token ) = @_;
-
- my $len = $self->_pop( i => $token, 1 );
- my $str = $self->_pop( s => $token );
- return $self->_push('""') if _check_type_warnings();
- my $answer = '';
- $_ = _trim_string($str);
- while ( $_ && $len ) {
- if (
- s/^(\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* [a-z]+ [ ]*
+ $length += $arg =~ s/$Acc_sym//gox;
+
+ # Remove any remaining braces
+ $arg =~ s/[{}]//g;
+
+ # Count whatever's left
+ $length += length $arg;
+ $self->_push($length);
+ }
+
+ sub _function_text_prefix {
+ my ($self, $token) = @_;
+
+ my $len = $self->_pop(i => $token, 1);
+ my $str = $self->_pop(s => $token);
+ return $self->_push('""') if _check_type_warnings();
+ my $answer = '';
+ $_ = _trim_string($str);
+ while ($_ && $len) {
+ if (
+ s/^(\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* [a-z]+ [ ]*
(?:\}|\Z))//oix
- || s/^(\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* [a-z]+ [ ]*
+ || s/^(\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* [a-z]+ [ ]*
(?:\}|\Z))//oix || s/^($Acc_sym)//o || s/^([^{}])//
- )
- {
- $answer .= $1;
- $len--;
- }
- elsif (/^(\{)/) {
- my $brace;
- ( $brace, $_ ) = _remove_matched_brace($_);
- $answer .= $brace;
- $len--;
- }
- else {
- s/^[{}]//;
- }
- }
- $answer .= '}' while $answer =~ tr/{// > $answer =~ tr/}//;
- $self->_push(qq("$answer"));
+ )
+ {
+ $answer .= $1;
+ $len--;
+ }
+ elsif (/^(\{)/) {
+ my $brace;
+ ($brace, $_) = _remove_matched_brace($_);
+ $answer .= $brace;
+ $len--;
+ }
+ else {
+ s/^[{}]//;
+ }
}
+ $answer .= '}' while $answer =~ tr/{// > $answer =~ tr/}//;
+ $self->_push(qq("$answer"));
+ }
+
+ { # Closure
+ my %Char_widths = (
+ 0040 => 278,
+ 0041 => 278,
+ 0042 => 500,
+ 0043 => 833,
+ 0044 => 500,
+ 0045 => 833,
+ 0046 => 778,
+ 0047 => 278,
+ 0050 => 389,
+ 0051 => 389,
+ 0052 => 500,
+ 0053 => 778,
+ 0054 => 278,
+ 0055 => 333,
+ 0056 => 278,
+ 0057 => 500,
+ 0060 => 500,
+ 0061 => 500,
+ 0062 => 500,
+ 0063 => 500,
+ 0064 => 500,
+ 0065 => 500,
+ 0066 => 500,
+ 0067 => 500,
+ 0070 => 500,
+ 0071 => 500,
+ 0072 => 278,
+ 0073 => 278,
+ 0074 => 278,
+ 0075 => 778,
+ 0076 => 472,
+ 0077 => 472,
+ 0100 => 778,
+
+ # A-Z
+ 0101 => 750,
+ 0102 => 708,
+ 0103 => 722,
+ 0104 => 764,
+ 0105 => 681,
+ 0106 => 653,
+ 0107 => 785,
+ 0110 => 750,
+ 0111 => 361,
+ 0112 => 514,
+ 0113 => 778,
+ 0114 => 625,
+ 0115 => 917,
+ 0116 => 750,
+ 0117 => 778,
+ 0120 => 681,
+ 0121 => 778,
+ 0122 => 736,
+ 0123 => 556,
+ 0124 => 722,
+ 0125 => 750,
+ 0126 => 750,
+ 0127 => 1028,
+ 0130 => 750,
+ 0131 => 750,
+ 0132 => 611,
+
+ 0133 => 278,
+ 0134 => 500,
+ 0135 => 278,
+ 0136 => 500,
+ 0137 => 278,
+ 0140 => 278,
+
+ # a-z
+ 0141 => 500,
+ 0142 => 556,
+ 0143 => 444,
+ 0144 => 556,
+ 0145 => 444,
+ 0146 => 306,
+ 0147 => 500,
+ 0150 => 556,
+ 0151 => 278,
+ 0152 => 306,
+ 0153 => 528,
+ 0154 => 278,
+ 0155 => 833,
+ 0156 => 556,
+ 0157 => 500,
+ 0160 => 556,
+ 0161 => 528,
+ 0162 => 392,
+ 0163 => 394,
+ 0164 => 389,
+ 0165 => 556,
+ 0166 => 528,
+ 0167 => 722,
+ 0170 => 528,
+ 0171 => 528,
+ 0172 => 444,
+ 0173 => 500,
+ 0174 => 1000,
+ 0175 => 500,
+ 0176 => 500,
+
+ aa => 500,
+ AA => 750,
+ o => 500,
+ O => 778,
+ l => 278,
+ L => 625,
+ ss => 500,
+ ae => 722,
+ oe => 778,
+ AE => 903,
+ OE => 1014,
+ '?`' => 472,
+ '!`' => 278,
- { # Closure
- my %Char_widths = (
- 0040 => 278,
- 0041 => 278,
- 0042 => 500,
- 0043 => 833,
- 0044 => 500,
- 0045 => 833,
- 0046 => 778,
- 0047 => 278,
- 0050 => 389,
- 0051 => 389,
- 0052 => 500,
- 0053 => 778,
- 0054 => 278,
- 0055 => 333,
- 0056 => 278,
- 0057 => 500,
- 0060 => 500,
- 0061 => 500,
- 0062 => 500,
- 0063 => 500,
- 0064 => 500,
- 0065 => 500,
- 0066 => 500,
- 0067 => 500,
- 0070 => 500,
- 0071 => 500,
- 0072 => 278,
- 0073 => 278,
- 0074 => 278,
- 0075 => 778,
- 0076 => 472,
- 0077 => 472,
- 0100 => 778,
-
- # A-Z
- 0101 => 750,
- 0102 => 708,
- 0103 => 722,
- 0104 => 764,
- 0105 => 681,
- 0106 => 653,
- 0107 => 785,
- 0110 => 750,
- 0111 => 361,
- 0112 => 514,
- 0113 => 778,
- 0114 => 625,
- 0115 => 917,
- 0116 => 750,
- 0117 => 778,
- 0120 => 681,
- 0121 => 778,
- 0122 => 736,
- 0123 => 556,
- 0124 => 722,
- 0125 => 750,
- 0126 => 750,
- 0127 => 1028,
- 0130 => 750,
- 0131 => 750,
- 0132 => 611,
-
- 0133 => 278,
- 0134 => 500,
- 0135 => 278,
- 0136 => 500,
- 0137 => 278,
- 0140 => 278,
-
- # a-z
- 0141 => 500,
- 0142 => 556,
- 0143 => 444,
- 0144 => 556,
- 0145 => 444,
- 0146 => 306,
- 0147 => 500,
- 0150 => 556,
- 0151 => 278,
- 0152 => 306,
- 0153 => 528,
- 0154 => 278,
- 0155 => 833,
- 0156 => 556,
- 0157 => 500,
- 0160 => 556,
- 0161 => 528,
- 0162 => 392,
- 0163 => 394,
- 0164 => 389,
- 0165 => 556,
- 0166 => 528,
- 0167 => 722,
- 0170 => 528,
- 0171 => 528,
- 0172 => 444,
- 0173 => 500,
- 0174 => 1000,
- 0175 => 500,
- 0176 => 500,
-
- aa => 500,
- AA => 750,
- o => 500,
- O => 778,
- l => 278,
- L => 625,
- ss => 500,
- ae => 722,
- oe => 778,
- AE => 903,
- OE => 1014,
- '?`' => 472,
- '!`' => 278,
-
- );
-
- sub _function_width {
- my ( $self, $token ) = @_;
-
- my $arg = _trim_string( $self->_pop( s => $token, 1 ) );
- return $self->_push(0) if _check_type_warnings();
-
- # Approximate most special characters with their base character
- my $width = 0;
- while (
- $arg =~
- s/^(?:(?:\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* ([a-zA-Z]+) [ ]* |
+ );
+
+ sub _function_width {
+ my ($self, $token) = @_;
+
+ my $arg = _trim_string($self->_pop(s => $token, 1));
+ return $self->_push(0) if _check_type_warnings();
+
+ # Approximate most special characters with their base character
+ my $width = 0;
+ while (
+ $arg =~ s/^(?:(?:\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* ([a-zA-Z]+) [ ]* |
\\ (?:$Acc_char|$Acc_let) [ ]* \{ [ ]* ([a-zA-Z]+) [ ]* |
\{ ($Acc_sym) ) (?:\}|\Z) |
($Acc_sym) |
(.))/($1 || '').($2 || '')/exo
- )
- {
- my ( $symbol, $letter ) = ( $3 || $4, $5 );
- $width += $Char_widths{ ord $letter } || 0 if defined $letter;
- $width += $Char_widths{$symbol} || 0
- if defined $symbol && $symbol =~ s/^\\?//;
- }
- $self->_push($width);
- }
+ )
+ {
+ my ($symbol, $letter) = ($3 || $4, $5);
+ $width += $Char_widths{ord $letter} || 0 if defined $letter;
+ $width += $Char_widths{$symbol} || 0
+ if defined $symbol && $symbol =~ s/^\\?//;
+ }
+ $self->_push($width);
}
+ }
}
sub _function_top {
- my ( $self, $token ) = @_;
+ my ($self, $token) = @_;
- my $arg = $self->_pop;
- $self->_warning( $self->_format_token($arg), 1 );
+ my $arg = $self->_pop;
+ $self->_warning($self->_format_token($arg), 1);
}
sub _function_type {
- my ( $self, $token ) = @_;
+ my ($self, $token) = @_;
- return $self->_push('""') unless my $bt_entry = $self->{bibtex}{bt_entry};
- $self->_push( '"' . ( lc $bt_entry->type ) . '"' );
+ return $self->_push('""') unless my $bt_entry = $self->{bibtex}{bt_entry};
+ $self->_push('"' . (lc $bt_entry->type) . '"');
}
sub _function_warning {
- my ( $self, $token ) = @_;
+ my ($self, $token) = @_;
- my $arg = $self->_pop( s => $token, 1 );
- return if _check_type_warnings();
- $arg = _trim_string($arg);
- $self->_warning( "Warning--$arg", 1 );
+ my $arg = $self->_pop(s => $token, 1);
+ return if _check_type_warnings();
+ $arg = _trim_string($arg);
+ $self->_warning("Warning--$arg", 1);
}
sub _function_while {
- my ( $self, $token ) = @_;
-
- my $do = $self->_pop( qx => $token, 1 );
- my $cont = $self->_pop( qx => $token );
- return if _check_type_warnings();
- my $val;
- while ($self->_evaluate($cont)
- && ( $val = $self->_pop( i => $token ) )
- && !_check_type_warnings() )
- {
- $self->_evaluate($do);
- }
+ my ($self, $token) = @_;
+
+ my $do = $self->_pop(qx => $token, 1);
+ my $cont = $self->_pop(qx => $token);
+ return if _check_type_warnings();
+ my $val;
+ while ($self->_evaluate($cont)
+ && ($val = $self->_pop(i => $token))
+ && !_check_type_warnings())
+ {
+ $self->_evaluate($do);
+ }
}
sub _function_write {
- my ( $self, $token ) = @_;
+ my ($self, $token) = @_;
- my $out = $self->_pop( s => $token, 1 );
- if ( !_check_type_warnings() ) {
- $out = _trim_string($out);
- push @{ $self->{output} }, $out;
- }
+ my $out = $self->_pop(s => $token, 1);
+ if (!_check_type_warnings()) {
+ $out = _trim_string($out);
+ push @{$self->{output}}, $out;
+ }
}
# Pops the top element from the stack, possibly doing type checking.
@@ -2005,310 +1938,305 @@ sub _function_write {
# x: expression (array ref)
# See the description of _check_type for the optional arguments
sub _pop : method {
- my ( $self, $types, $token, $first_arg ) = @_;
+ my ($self, $types, $token, $first_arg) = @_;
- my $where = defined $token ? " on token '$token'" : '';
- return $self->_warning("Stack underflow$where") unless @{ $self->{stack} };
- my $val = pop @{ $self->{stack} };
- $self->_check_type( $val, $types, $token, $first_arg ) if $types;
- return $val;
+ my $where = defined $token ? " on token '$token'" : '';
+ return $self->_warning("Stack underflow$where") unless @{$self->{stack}};
+ my $val = pop @{$self->{stack}};
+ $self->_check_type($val, $types, $token, $first_arg) if $types;
+ return $val;
}
# Pushes some elements on the stack
sub _push : method {
- my $self = shift;
+ my $self = shift;
- push @{ $self->{stack} }, @_;
+ push @{$self->{stack}}, @_;
}
# Removes the outer "s from a string
# Arguments: string to trim
# Returns: trimmed string
sub _trim_string {
- my ($str) = @_;
+ my ($str) = @_;
- $str =~ s/^\"(.*)\"$/$1/s;
- return $str;
+ $str =~ s/^\"(.*)\"$/$1/s;
+ return $str;
}
# Routines to protect and unprotect strings within braces
{
- my %Brackets;
- my $Bracket_cnt = 0;
+ my %Brackets;
+ my $Bracket_cnt = 0;
- # Protects strings within matching { } pairs
- # Arguments
- sub _protect {
- my ($s) = @_;
+ # Protects strings within matching { } pairs
+ # Arguments
+ sub _protect {
+ my ($s) = @_;
- while (
- $s =~ s/\{ ([^{}]*) \}/
+ while (
+ $s =~ s/\{ ([^{}]*) \}/
my $v = sprintf 'PROTECT(0D%d)', $Bracket_cnt++;
$Brackets{$v} = $1; $v/ex
- )
- {
- }
- return $s;
+ )
+ {
}
+ return $s;
+ }
- # Removes a leading left brace to its matching right brace
- # Arguments: string
- # Returns: removed brace, remaining string
- sub _remove_matched_brace {
- my ($str) = @_;
+ # Removes a leading left brace to its matching right brace
+ # Arguments: string
+ # Returns: removed brace, remaining string
+ sub _remove_matched_brace {
+ my ($str) = @_;
- return ( '', $str ) unless $str =~ s/^(\{)//;
+ return ('', $str) unless $str =~ s/^(\{)//;
- # Find the matching brace
- my $nest = 1;
- my @char = ($1);
- 1 while $str =~ s/^(.*?)([{}])/do {
+ # Find the matching brace
+ my $nest = 1;
+ my @char = ($1);
+ 1 while $str =~ s/^(.*?)([{}])/do {
$nest += $2 eq '{' ? 1 : -1;
push @char, $1, $2;
'' } /es && $nest > 0;
- if ( $nest > 0 ) {
- push @char, $str;
- $str = '';
- }
- return ( join( '', @char ), $str );
+ if ($nest > 0) {
+ push @char, $str;
+ $str = '';
}
+ return (join('', @char), $str);
+ }
################# Routines to support output translation
- { # Closure
-
- my %Accents = (
- "'" => {
- A => 193, # capital A, acute accent
- a => 225, # small a, acute accent
- C => 0x106,
- c => 0x107,
- E => 201, # capital E, acute accent
- e => 233, # small e, acute accent
- I => 205, # capital I, acute accent
- i => 237, # small i, acute accent
- L => 0x139,
- l => 0x13a,
- N => 0x143,
- n => 0x144,
- O => 211, # capital O, acute accent
- o => 243, # small o, acute accent
- R => 0x154,
- r => 0x155,
- S => 0x15a,
- s => 0x15b,
- U => 218, # capital U, acute accent
- u => 250, # small u, acute accent
- Y => 221, # capital Y, acute accent
- y => 253, # small y, acute accent
- Z => 0x179,
- z => 0x17a,
- },
- '`' => {
- A => 192, # capital A, grave accent
- a => 224, # small a, grave accent
- E => 200, # capital E, grave accent
- e => 232, # small e, grave accent
- I => 204, # capital I, grave accent
- i => 236, # small i, grave accent
- O => 210, # capital O, grave accent
- o => 242, # small o, grave accent
- U => 217, # capital U, grave accent
- u => 249, # small u, grave accent
- },
- '^' => {
- A => 194, # capital A, circumflex accent
- a => 226, # small a, circumflex accent
- E => 202, # capital E, circumflex accent
- e => 234, # small e, circumflex accent
- G => 0x11c,
- g => 0x11d,
- H => 0x124,
- h => 0x125,
- I => 206, # capital I, circumflex accent
- i => 238, # small i, circumflex accent
- J => 0x134,
- j => 0x135,
- O => 212, # capital O, circumflex accent
- o => 244, # small o, circumflex accent
- S => 0x15c,
- s => 0x15d,
- U => 219, # capital U, circumflex accent
- u => 251, # small u, circumflex accent
- W => 0x174,
- w => 0x175,
- Y => 0x176,
- y => 0x177,
- },
- '"' => {
- A => 196, # capital A, dieresis or umlaut mark
- E => 203, # capital E, dieresis or umlaut mark
- I => 207, # capital I, dieresis or umlaut mark
- O => 214, # capital O, dieresis or umlaut mark
- U => 220, # capital U, dieresis or umlaut mark
- Y => 376,
- a => 228, # small a, dieresis or umlaut mark
- e => 235, # small e, dieresis or umlaut mark
- i => 239, # small i, dieresis or umlaut mark
- o => 246, # small o, dieresis or umlaut mark
- u => 252, # small u, dieresis or umlaut mark
- y => 255, # small y, dieresis or umlaut mark
- },
- '~' => {
- A => 195, # capital A, tilde
- a => 227, # small a, tilde
- I => 0x128,
- i => 0x129,
- N => 209, # capital N, tilde
- n => 241, # small n, tilde
- O => 213, # capital O, tilde
- o => 245, # small o, tilde
- U => 0x168,
- u => 0x169,
- },
- '=' => {
- A => 0x100,
- a => 0x101,
- E => 0x112,
- e => 0x113,
- I => 0x12a,
- i => 0x12b,
- O => 0x14c,
- o => 0x14d,
- U => 0x16a,
- u => 0x16b,
- },
- '.' => {
- C => 0x10a,
- c => 0x10b,
- E => 0x116,
- e => 0x117,
- G => 0x120,
- g => 0x121,
- L => 0x13f,
- l => 0x140,
- Z => 0x17b,
- z => 0x17c,
- },
- c => {
- A => 0x104,
- a => 0x105,
- C => 199, # capital C, cedilla
- c => 231, # small c, cedilla
- E => 0x118,
- e => 0x119,
- G => 0x122,
- g => 0x123,
- I => 0x12e,
- i => 0x12f,
- K => 0x136,
- k => 0x137,
- L => 0x13b,
- l => 0x13c,
- N => 0x145,
- n => 0x146,
- R => 0x156,
- r => 0x157,
- S => 0x15e,
- s => 0x15f,
- T => 0x162,
- t => 0x163,
- U => 0x172,
- u => 0x173,
- },
- H => {
- O => 0x150,
- o => 0x151,
- U => 0x170,
- u => 0x171,
- },
- u => {
- A => 0x102,
- a => 0x103,
- E => 0x114,
- e => 0x115,
- G => 0x11e,
- g => 0x11f,
- I => 0x12c,
- i => 0x12d,
- O => 0x14e,
- o => 0x14f,
- U => 0x16c,
- u => 0x16d,
- },
- v => {
- C => 0x10c,
- c => 0x10d,
- D => 0x10e,
- d => 0x10f,
- E => 0x11a,
- e => 0x11b,
- H => 0x124,
- h => 0x125,
- J => 0x134,
- j => 0x135,
- L => 0x13d,
- l => 0x13e,
- N => 0x147,
- n => 0x148,
- R => 0x158,
- r => 0x159,
- S => 0x160,
- s => 0x161,
- T => 0x164,
- t => 0x165,
- Z => 0x17d,
- z => 0x17e,
- }
- );
-
- my %Chars = (
- '\AA' => 197, # capital A, ring
- '\aa' => 229, # small a, ring
- '\AE' => 198, # capital AE diphthong (ligature)
- '\ae' => 230, # small ae diphthong (ligature)
- '\copyright' => 0xa9,
- '\L' => 0x141,
- '\l' => 0x142,
- '\O' => 216, # capital O, slash
- '\o' => 248, # small o, slash
- '\OE' => 0x152,
- '\oe' => 0x153,
- '\P' => 0xb6,
- '\pounds' => 0xa3,
- '\S' => 0xa7,
- '\ss' => 223, # small sharp s, German (sz ligature)
- '\dag' => 0x2020,
- '\ddag' => 0x2021,
- '!`' => 0xa1,
- '?`' => 0xbf,
- '``' => 0x201c,
- "''" => 0x201d,
- '~' => 160, # non breaking space
- '--' => 0x2013,
- '---' => 0x2014,
- );
+ { # Closure
+
+ my %Accents = (
+ "'" => {
+ A => 193, # capital A, acute accent
+ a => 225, # small a, acute accent
+ C => 0x106,
+ c => 0x107,
+ E => 201, # capital E, acute accent
+ e => 233, # small e, acute accent
+ I => 205, # capital I, acute accent
+ i => 237, # small i, acute accent
+ L => 0x139,
+ l => 0x13a,
+ N => 0x143,
+ n => 0x144,
+ O => 211, # capital O, acute accent
+ o => 243, # small o, acute accent
+ R => 0x154,
+ r => 0x155,
+ S => 0x15a,
+ s => 0x15b,
+ U => 218, # capital U, acute accent
+ u => 250, # small u, acute accent
+ Y => 221, # capital Y, acute accent
+ y => 253, # small y, acute accent
+ Z => 0x179,
+ z => 0x17a,
+ },
+ '`' => {
+ A => 192, # capital A, grave accent
+ a => 224, # small a, grave accent
+ E => 200, # capital E, grave accent
+ e => 232, # small e, grave accent
+ I => 204, # capital I, grave accent
+ i => 236, # small i, grave accent
+ O => 210, # capital O, grave accent
+ o => 242, # small o, grave accent
+ U => 217, # capital U, grave accent
+ u => 249, # small u, grave accent
+ },
+ '^' => {
+ A => 194, # capital A, circumflex accent
+ a => 226, # small a, circumflex accent
+ E => 202, # capital E, circumflex accent
+ e => 234, # small e, circumflex accent
+ G => 0x11c,
+ g => 0x11d,
+ H => 0x124,
+ h => 0x125,
+ I => 206, # capital I, circumflex accent
+ i => 238, # small i, circumflex accent
+ J => 0x134,
+ j => 0x135,
+ O => 212, # capital O, circumflex accent
+ o => 244, # small o, circumflex accent
+ S => 0x15c,
+ s => 0x15d,
+ U => 219, # capital U, circumflex accent
+ u => 251, # small u, circumflex accent
+ W => 0x174,
+ w => 0x175,
+ Y => 0x176,
+ y => 0x177,
+ },
+ '"' => {
+ A => 196, # capital A, dieresis or umlaut mark
+ E => 203, # capital E, dieresis or umlaut mark
+ I => 207, # capital I, dieresis or umlaut mark
+ O => 214, # capital O, dieresis or umlaut mark
+ U => 220, # capital U, dieresis or umlaut mark
+ Y => 376,
+ a => 228, # small a, dieresis or umlaut mark
+ e => 235, # small e, dieresis or umlaut mark
+ i => 239, # small i, dieresis or umlaut mark
+ o => 246, # small o, dieresis or umlaut mark
+ u => 252, # small u, dieresis or umlaut mark
+ y => 255, # small y, dieresis or umlaut mark
+ },
+ '~' => {
+ A => 195, # capital A, tilde
+ a => 227, # small a, tilde
+ I => 0x128,
+ i => 0x129,
+ N => 209, # capital N, tilde
+ n => 241, # small n, tilde
+ O => 213, # capital O, tilde
+ o => 245, # small o, tilde
+ U => 0x168,
+ u => 0x169,
+ },
+ '=' => {
+ A => 0x100,
+ a => 0x101,
+ E => 0x112,
+ e => 0x113,
+ I => 0x12a,
+ i => 0x12b,
+ O => 0x14c,
+ o => 0x14d,
+ U => 0x16a,
+ u => 0x16b,
+ },
+ '.' => {
+ C => 0x10a,
+ c => 0x10b,
+ E => 0x116,
+ e => 0x117,
+ G => 0x120,
+ g => 0x121,
+ L => 0x13f,
+ l => 0x140,
+ Z => 0x17b,
+ z => 0x17c,
+ },
+ c => {
+ A => 0x104,
+ a => 0x105,
+ C => 199, # capital C, cedilla
+ c => 231, # small c, cedilla
+ E => 0x118,
+ e => 0x119,
+ G => 0x122,
+ g => 0x123,
+ I => 0x12e,
+ i => 0x12f,
+ K => 0x136,
+ k => 0x137,
+ L => 0x13b,
+ l => 0x13c,
+ N => 0x145,
+ n => 0x146,
+ R => 0x156,
+ r => 0x157,
+ S => 0x15e,
+ s => 0x15f,
+ T => 0x162,
+ t => 0x163,
+ U => 0x172,
+ u => 0x173,
+ },
+ H => {O => 0x150, o => 0x151, U => 0x170, u => 0x171,},
+ u => {
+ A => 0x102,
+ a => 0x103,
+ E => 0x114,
+ e => 0x115,
+ G => 0x11e,
+ g => 0x11f,
+ I => 0x12c,
+ i => 0x12d,
+ O => 0x14e,
+ o => 0x14f,
+ U => 0x16c,
+ u => 0x16d,
+ },
+ v => {
+ C => 0x10c,
+ c => 0x10d,
+ D => 0x10e,
+ d => 0x10f,
+ E => 0x11a,
+ e => 0x11b,
+ H => 0x124,
+ h => 0x125,
+ J => 0x134,
+ j => 0x135,
+ L => 0x13d,
+ l => 0x13e,
+ N => 0x147,
+ n => 0x148,
+ R => 0x158,
+ r => 0x159,
+ S => 0x160,
+ s => 0x161,
+ T => 0x164,
+ t => 0x165,
+ Z => 0x17d,
+ z => 0x17e,
+ }
+ );
+
+ my %Chars = (
+ '\AA' => 197, # capital A, ring
+ '\aa' => 229, # small a, ring
+ '\AE' => 198, # capital AE diphthong (ligature)
+ '\ae' => 230, # small ae diphthong (ligature)
+ '\copyright' => 0xa9,
+ '\L' => 0x141,
+ '\l' => 0x142,
+ '\O' => 216, # capital O, slash
+ '\o' => 248, # small o, slash
+ '\OE' => 0x152,
+ '\oe' => 0x153,
+ '\P' => 0xb6,
+ '\pounds' => 0xa3,
+ '\S' => 0xa7,
+ '\ss' => 223, # small sharp s, German (sz ligature)
+ '\dag' => 0x2020,
+ '\ddag' => 0x2021,
+ '!`' => 0xa1,
+ '?`' => 0xbf,
+ '``' => 0x201c,
+ "''" => 0x201d,
+ '~' => 160, # non breaking space
+ '--' => 0x2013,
+ '---' => 0x2014,
+ );
# Returns the result of calling the character option subroutine for
# a special character
# Arguments: bst object, Latex string, characters to accent, optional accent
- sub _character {
- my ( $bst, $opts, $latex, $chars, $accent ) = @_;
- my $unicode = $accent ? $Accents{$accent}{$chars} : $Chars{$chars};
- $unicode = chr($unicode) if defined $unicode;
- &{ $opts->{character} }( $bst, $latex, $unicode, $chars, $accent );
- }
+ sub _character {
+ my ($bst, $opts, $latex, $chars, $accent) = @_;
+ my $unicode = $accent ? $Accents{$accent}{$chars} : $Chars{$chars};
+ $unicode = chr($unicode) if defined $unicode;
+ &{$opts->{character}}($bst, $latex, $unicode, $chars, $accent);
}
+ }
- # Takes a string, removes all \newcommand commands from it, and substitutes
- # for all uses of those \newcommand commands.
- # Arguments: string
- # Returns: substituted string
- sub _substitute_newcommand {
- my ($str) = @_;
+ # Takes a string, removes all \newcommand commands from it, and substitutes
+ # for all uses of those \newcommand commands.
+ # Arguments: string
+ # Returns: substituted string
+ sub _substitute_newcommand {
+ my ($str) = @_;
- my %command;
- 1 while $str =~ s/\\newcommand\{ \\([a-z]+) \} \[ (\d+) \](\{.*)/do {
+ my %command;
+ 1 while $str =~ s/\\newcommand\{ \\([a-z]+) \} \[ (\d+) \](\{.*)/do {
my ($cmd, $args, $next, $def) = ($1, $2, $3);
($def, $next) = _remove_matched_brace($next);
$def =~ s!^\{(.*)\}$!sub { qq(\Q$1\E) }!s;
@@ -2319,9 +2247,9 @@ sub _trim_string {
$next;
}/sexi;
- if (%command) {
- my $cmd_re = join '|', keys %command;
- 1 while $str =~ s/\\($cmd_re)(\{.*)/do {
+ if (%command) {
+ my $cmd_re = join '|', keys %command;
+ 1 while $str =~ s/\\($cmd_re)(\{.*)/do {
my ($cmd, $next) = ($1, $2);
my @args;
for (my $i=0; $i < $command{$cmd}{args}; $i++) {
@@ -2332,36 +2260,36 @@ sub _trim_string {
}
&{$command{$cmd}{code}}(@args) . $next;
}/se;
- }
-
- return $str;
}
- sub _unprotect {
- my ($s) = @_;
+ return $str;
+ }
+
+ sub _unprotect {
+ my ($s) = @_;
- return $s unless %Brackets;
- ## fix this later: no warnings 'uninitialized'
- {
- no warnings 'uninitialized';
- my $brack_re = join '|', map( "\Q$_", keys %Brackets );
- while ( $s =~ s/($brack_re)/{$Brackets{uc $1}}/igx ) { }
- return $s;
- }
+ return $s unless %Brackets;
+ ## fix this later: no warnings 'uninitialized'
+ {
+ no warnings 'uninitialized';
+ my $brack_re = join '|', map("\Q$_", keys %Brackets);
+ while ($s =~ s/($brack_re)/{$Brackets{uc $1}}/igx) { }
+ return $s;
}
+ }
}
# Reports a warning
# Arguments: warning string, lineno_suppression
# Rturns: 1
sub _warning : method {
- my ( $self, $warning, $no_lineno ) = @_;
+ my ($self, $warning, $no_lineno) = @_;
- my $lineno = $no_lineno ? '' : "$self->{lineno}: ";
- my $warn = "$lineno$warning";
- push @{ $self->{warnings} }, "$warn\n";
- carp $warn;
- return 1;
+ my $lineno = $no_lineno ? '' : "$self->{lineno}: ";
+ my $warn = "$lineno$warning";
+ push @{$self->{warnings}}, "$warn\n";
+ carp $warn;
+ return 1;
}
1;
diff --git a/lib/redis.pl b/lib/redis.pl
index 5fa1464..03f5f21 100755
--- a/lib/redis.pl
+++ b/lib/redis.pl
@@ -6,34 +6,32 @@
use Mojolicious::Lite;
use Mojo::Redis2;
-helper redis => sub {state $redis = Mojo::Redis2->new()};
+helper redis => sub { state $redis = Mojo::Redis2->new() };
app->redis->subscribe(['long_running_tasks']);
-app->redis->on(message => sub {
+app->redis->on(
+ message => sub {
my ($self, $message, $channel) = @_;
say "$message @ $channel staring...";
- sleep (10);
+ sleep(10);
say "$message @ $channel done!";
-});
+ }
+);
-app->redis->on(error => sub {
+app->redis->on(
+ error => sub {
my ($self, $err) = @_;
say "error $err";
-});
-
+ }
+);
get '/' => sub {
- my $self = shift;
- app->redis->publish("long_running_tasks" => "go");
-
+ my $self = shift;
+ app->redis->publish("long_running_tasks" => "go");
- $self->render(json => {a => 1});
+ $self->render(json => {a => 1});
};
app->start;
-
-
-
-
diff --git a/t/000_prepare.t b/t/000_prepare.t
index 6ed2dad..5ca0d7d 100644
--- a/t/000_prepare.t
+++ b/t/000_prepare.t
@@ -1,6 +1,5 @@
use Mojo::Base -strict;
-
use Test::More;
use Test::Mojo;
use Mojo::IOLoop;
@@ -12,67 +11,57 @@ use BibSpace::Model::Backup;
use BibSpace::Functions::BackupFunctions qw(restore_storable_backup);
use BibSpace::Functions::FDB; # TODO: purge DB etc.
-
`rm log/*.log`;
`rm bibspace.dat`;
my $t_logged_in = Test::Mojo->new('BibSpace');
-
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
my $dbh = $self->app->db;
my $app_config = $t_logged_in->app->config;
-
my $db_host = $ENV{BIBSPACE_DB_HOST} || $self->app->config->{db_host};
my $db_user = $ENV{BIBSPACE_DB_USER} || $self->app->config->{db_user};
my $db_database
- = $ENV{BIBSPACE_DB_DATABASE} || $self->app->config->{db_database};
+ = $ENV{BIBSPACE_DB_DATABASE} || $self->app->config->{db_database};
my $db_pass = $ENV{BIBSPACE_DB_PASS} || $self->app->config->{db_pass};
-
note "Check if we can talk to MySQL and proper database exists.";
-ok( db_connect( $db_host, $db_user, $db_database, $db_pass ),
- "Can connect to database" );
+ok(db_connect($db_host, $db_user, $db_database, $db_pass),
+ "Can connect to database");
$dbh = $self->app->db;
-
my $fixture_file = $self->app->home->rel_file('fixture/bibspace_fixture.dat');
-my $fixture_name = ''.$fixture_file->basename;
-my $fixture_dir = ''.$fixture_file->dirname;
+my $fixture_name = '' . $fixture_file->basename;
+my $fixture_dir = '' . $fixture_file->dirname;
SKIP: {
- note "Drop database and recreate tables";
- skip "System is running in production mode!! Do not test on production!",
- 1
- if $self->mode eq 'production';
- ok( reset_db_data($dbh), "reset_db_data" );
+ note "Drop database and recreate tables";
+ skip "System is running in production mode!! Do not test on production!", 1
+ if $self->mode eq 'production';
+ ok(reset_db_data($dbh), "reset_db_data");
}
-
SKIP: {
- note "============ APPLY DATABASE FIXTURE ============";
- skip "Directory $fixture_dir does not exist", 1
- if !-e $fixture_dir . $fixture_name;
+ note "============ APPLY DATABASE FIXTURE ============";
+ skip "Directory $fixture_dir does not exist", 1
+ if !-e $fixture_dir . $fixture_name;
- note "Find backup file";
- my $fixture
- = Backup->new( dir => $fixture_dir, filename => $fixture_name );
+ note "Find backup file";
+ my $fixture = Backup->new(dir => $fixture_dir, filename => $fixture_name);
- note "restore_storable_backup - read data into all layers";
-
- # this restores data to all layers!
- restore_storable_backup( $fixture, $self->app );
+ note "restore_storable_backup - read data into all layers";
+ # this restores data to all layers!
+ restore_storable_backup($fixture, $self->app);
}
-
ok(1);
done_testing();
diff --git a/t/100-unit/Author.t b/t/100-unit/Author.t
index 4724fef..5a48b5c 100644
--- a/t/100-unit/Author.t
+++ b/t/100-unit/Author.t
@@ -3,56 +3,50 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-
use Data::Dumper;
use Array::Utils qw(:all);
use BibSpace::Model::Author;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
-
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
my $repo = $self->app->repo;
-
-
my @all_authors = $repo->authors_all;
my $limit_test_objects = 30;
-my $other_author = $self->app->entityFactory->new_Author( uid => "Henry");
+my $other_author = $self->app->entityFactory->new_Author(uid => "Henry");
subtest 'Author constructor' => sub {
- is($other_author->master, $other_author->uid, "master name same as uid");
- is($other_author->master_id, $other_author->id, "master_id name same as id");
- is($other_author->masterObj, undef, "masterObj empty");
+ is($other_author->master, $other_author->uid, "master name same as uid");
+ is($other_author->master_id, $other_author->id, "master_id name same as id");
+ is($other_author->masterObj, undef, "masterObj empty");
};
-
+
subtest 'Alone author functions' => sub {
is($other_author->can_be_deleted, 1, "can_be_deleted");
};
-note "============ Testing ".scalar(@all_authors)." Authors ============";
+note "============ Testing " . scalar(@all_authors) . " Authors ============";
-foreach my $author (@all_authors){
+foreach my $author (@all_authors) {
last if $limit_test_objects < 0;
- note "============ Testing Author ID ".$author->id.".";
+ note "============ Testing Author ID " . $author->id . ".";
- ok($author, "author defined");
- ok($author->toString, "author->toString defined");
+ ok($author, "author defined");
+ ok($author->toString, "author->toString defined");
ok($author->get_master, "author->get_master defined");
-
$author->set_master($other_author);
isnt($author->is_master, 1, "isnt master");
- is($author->is_minion, 1, "is minion");
+ is($author->is_minion, 1, "is minion");
is($author->is_minion_of($other_author), 1, "is_minion_of");
isnt($author->is_minion_of($author), 1, "isnt_minion_of");
is($author->get_master, $other_author, "get_master");
@@ -63,27 +57,27 @@ foreach my $author (@all_authors){
ok($author->remove_master, "remove master");
is($author->update_master_name("John"), 1);
is($author->master, "John", "master is John");
- is($author->uid, "John", "uid is John");
+ is($author->uid, "John", "uid is John");
ok($other_author->add_minion($author), "add minion");
isnt($author->is_master, 1, "isnt master");
- is($author->is_minion, 1, "is minion");
+ is($author->is_minion, 1, "is minion");
is($author->is_minion_of($other_author), 1, "is_minion_of");
isnt($author->is_minion_of($author), 1, "isnt_minion_of");
is($author->get_master, $other_author, "get_master");
is($other_author->can_merge_authors($author), 1, "can_merge_authors");
is($author->can_merge_authors($other_author), 1, "can_merge_authors");
- isnt($author->can_merge_authors($author), 1, "can_merge_authors");
+ isnt($author->can_merge_authors($author), 1, "can_merge_authors");
isnt($other_author->can_merge_authors($other_author), 1, "can_merge_authors");
- if($author->is_visible){
+ if ($author->is_visible) {
$author->toggle_visibility;
ok(!$author->is_visible, "is not visible");
$author->toggle_visibility;
ok($author->is_visible, "is visible");
}
- else{
+ else {
$author->toggle_visibility;
ok($author->is_visible, "is visible");
$author->toggle_visibility;
@@ -91,15 +85,14 @@ foreach my $author (@all_authors){
}
my @teams = $author->get_teams;
- foreach my $team (@teams){
+ foreach my $team (@teams) {
ok($author->has_team($team), "has_team");
}
-
- if( $author->get_entries ){
+ if ($author->get_entries) {
my $entry = ($author->get_entries)[0];
- note "Checking entry ".$entry->id;
+ note "Checking entry " . $entry->id;
my $au = Authorship->new(
author => $author,
@@ -108,33 +101,31 @@ foreach my $author (@all_authors){
entry_id => $entry->id
);
- ok( $au->validate, 'validate');
- ok( $au->toString, 'toString');
- ok( $au->equals($au), 'equals');
- ok( $au->equals_id($au), 'equals_id');
- ok( $au->equals_obj($au), 'equals_obj');
+ ok($au->validate, 'validate');
+ ok($au->toString, 'toString');
+ ok($au->equals($au), 'equals');
+ ok($au->equals_id($au), 'equals_id');
+ ok($au->equals_obj($au), 'equals_obj');
- if( !$author->has_authorship($au) ){
- ok( $author->add_authorship($au), 'add_authorship');
+ if (!$author->has_authorship($au)) {
+ ok($author->add_authorship($au), 'add_authorship');
}
- else{
- ok( !$author->add_authorship($au), 'cant add_authorship');
+ else {
+ ok(!$author->add_authorship($au), 'cant add_authorship');
}
- ok( $author->has_entry($entry), 'has_entry');
- ok( $author->has_authorship($au), 'has_authorship');
- is( $author->remove_authorship($au), 1, 'remove authorship');
- ok(!$author->has_authorship($au), 'hasnt authorship');
+ ok($author->has_entry($entry), 'has_entry');
+ ok($author->has_authorship($au), 'has_authorship');
+ is($author->remove_authorship($au), 1, 'remove authorship');
+ ok(!$author->has_authorship($au), 'hasnt authorship');
ok(!$author->remove_authorship($au), 'cant remove authorship');
- ok(!$author->has_authorship($au), 'hasnt authorship');
- ok(!$author->has_entry($entry), "hasn't entry");
-
+ ok(!$author->has_authorship($au), 'hasnt authorship');
+ ok(!$author->has_entry($entry), "hasn't entry");
+
}
-
+
$limit_test_objects--;
}
-
-
ok(1);
done_testing();
diff --git a/t/100-unit/Entry.t b/t/100-unit/Entry.t
index 258608d..90f6625 100644
--- a/t/100-unit/Entry.t
+++ b/t/100-unit/Entry.t
@@ -7,26 +7,23 @@ use Array::Utils qw(:all);
use BibSpace::Model::Entry;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
my $repo = $self->app->repo;
-
my @all_entries = $repo->entries_all;
my $limit_test_entries = 20;
-note "============ Testing ".scalar(@all_entries)." Entries ============";
+note "============ Testing " . scalar(@all_entries) . " Entries ============";
-foreach my $entry(@all_entries){
+foreach my $entry (@all_entries) {
last if $limit_test_entries < 0;
- note ">> Testing Entry ID ".$entry->id.".";
-
+ note ">> Testing Entry ID " . $entry->id . ".";
$entry->make_paper;
ok($entry->is_paper);
@@ -48,51 +45,49 @@ foreach my $entry(@all_entries){
ok($entry->has_bibtex_field("test"));
is($entry->get_bibtex_field_value("test"), "test_value");
- if( $entry->has_bibtex_field('month') ){
- is( $entry->remove_bibtex_fields(['month']), 1, "removed month bibtex field");
- $entry->month(0);
- }
+ if ($entry->has_bibtex_field('month')) {
+ is($entry->remove_bibtex_fields(['month']), 1,
+ "removed month bibtex field");
+ $entry->month(0);
+ }
$entry->add_bibtex_field("month", "April");
- ok( $entry->fix_month, "month fixed");
- is( $entry->month, 4, "month fixed correctly");
+ ok($entry->fix_month, "month fixed");
+ is($entry->month, 4, "month fixed correctly");
- if( $entry->has_bibtex_field('author') or $entry->has_bibtex_field('editor') ){
+ if ($entry->has_bibtex_field('author') or $entry->has_bibtex_field('editor'))
+ {
my @author_names = $entry->author_names_from_bibtex;
- ok( scalar @author_names > 0, "Entry has authors in bibtex");
+ ok(scalar @author_names > 0, "Entry has authors in bibtex");
}
- else{
- $entry->add_bibtex_field("author", "James Bond");
+ else {
+ $entry->add_bibtex_field("author", "James Bond");
my @author_names = $entry->author_names_from_bibtex;
- is( scalar @author_names, 1, "Entry has 1 author in bibtex");
+ is(scalar @author_names, 1, "Entry has 1 author in bibtex");
}
- if( $entry->has_bibtex_field('tags') ){
- is( $entry->remove_bibtex_fields(['tags']), 1, "remove tags bibtex field");
- my @no_tag_names = $entry->tag_names_from_bibtex;
- is( scalar @no_tag_names, 0, "Entry has no tags in bibtex");
- }
+ if ($entry->has_bibtex_field('tags')) {
+ is($entry->remove_bibtex_fields(['tags']), 1, "remove tags bibtex field");
+ my @no_tag_names = $entry->tag_names_from_bibtex;
+ is(scalar @no_tag_names, 0, "Entry has no tags in bibtex");
+ }
$entry->add_bibtex_field("tags", "test_tag");
my @tag_names = $entry->tag_names_from_bibtex;
- is( scalar @tag_names, 1, "Entry has more than one tag in bibtex");
+ is(scalar @tag_names, 1, "Entry has more than one tag in bibtex");
# just call
$entry->get_title;
$self->app->preferences->bibitex_html_converter('BibStyleConverter');
- $entry->regenerate_html( 1, $self->app->bst, $self->app->bibtexConverter );
+ $entry->regenerate_html(1, $self->app->bst, $self->app->bibtexConverter);
$self->app->preferences->bibitex_html_converter('Bibtex2HtmlConverter');
- $entry->regenerate_html( 1, $self->app->bst, $self->app->bibtexConverter );
+ $entry->regenerate_html(1, $self->app->bst, $self->app->bibtexConverter);
$self->app->preferences->bibitex_html_converter('BibStyleConverter');
-
-
- $limit_test_entries = $limit_test_entries -1;
+ $limit_test_entries = $limit_test_entries - 1;
}
-
-my $broken_entry = $self->app->entityFactory->new_Entry( bib => ' ' );
-$broken_entry->regenerate_html( 1, $self->app->bst, $self->app->bibtexConverter );
-
+my $broken_entry = $self->app->entityFactory->new_Entry(bib => ' ');
+$broken_entry->regenerate_html(1, $self->app->bst, $self->app->bibtexConverter);
ok(1);
done_testing();
diff --git a/t/100-unit/Exception.t b/t/100-unit/Exception.t
index d183cdf..9832d93 100644
--- a/t/100-unit/Exception.t
+++ b/t/100-unit/Exception.t
@@ -3,34 +3,36 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-my $repo = $self->app->repo;
+my $repo = $self->app->repo;
my @all_exceptions = $repo->exceptions_all;
-
my $limit_num_tests = 200;
-note "============ Testing ".scalar(@all_exceptions)." entries ============";
+note "============ Testing "
+ . scalar(@all_exceptions)
+ . " entries ============";
foreach my $exception (@all_exceptions) {
last if $limit_num_tests < 0;
- note "============ Testing Exception ID ".$exception->id.".";
+ note "============ Testing Exception ID " . $exception->id . ".";
- ok( $exception->id , "id");
- ok( $exception->toString , "toString");
+ ok($exception->id, "id");
+ ok($exception->toString, "toString");
# lives_ok( sub { $exception->validate }, 'validate expecting to live' );
- lives_ok( sub { $exception->equals($exception) }, 'equals expecting to live' );
- lives_ok( sub { $exception->equals_obj($exception) }, 'equals_obj expecting to live' );
- lives_ok( sub { $exception->equals_id($exception) }, 'equals_id expecting to live' );
- dies_ok( sub { $exception->equals(undef) }, 'equals undef expecting to die' );
+ lives_ok(sub { $exception->equals($exception) }, 'equals expecting to live');
+ lives_ok(sub { $exception->equals_obj($exception) },
+ 'equals_obj expecting to live');
+ lives_ok(sub { $exception->equals_id($exception) },
+ 'equals_id expecting to live');
+ dies_ok(sub { $exception->equals(undef) }, 'equals undef expecting to die');
$limit_num_tests--;
}
diff --git a/t/100-unit/ILogger.t b/t/100-unit/ILogger.t
index 5134bde..0a8070a 100644
--- a/t/100-unit/ILogger.t
+++ b/t/100-unit/ILogger.t
@@ -2,7 +2,6 @@ use Mojo::Base -strict;
use Test::More;
use Test::Mojo;
-
package DummyLogger;
use namespace::autoclean;
@@ -21,6 +20,5 @@ ok($log->info("message"));
ok($log->warn("message"));
ok($log->error("message"));
-
ok(1);
done_testing();
diff --git a/t/100-unit/Labeling.t b/t/100-unit/Labeling.t
index 303721b..8ef2d22 100644
--- a/t/100-unit/Labeling.t
+++ b/t/100-unit/Labeling.t
@@ -3,34 +3,34 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-my $repo = $self->app->repo;
+my $repo = $self->app->repo;
my @all_labelings = $repo->labelings_all;
-
my $limit_num_tests = 200;
-note "============ Testing ".scalar(@all_labelings)." entries ============";
+note "============ Testing " . scalar(@all_labelings) . " entries ============";
foreach my $labeling (@all_labelings) {
last if $limit_num_tests < 0;
- note "============ Testing Labeling ID ".$labeling->id.".";
+ note "============ Testing Labeling ID " . $labeling->id . ".";
- ok( $labeling->id , "id");
- ok( $labeling->toString , "toString");
+ ok($labeling->id, "id");
+ ok($labeling->toString, "toString");
- lives_ok( sub { $labeling->validate }, 'validate expecting to live' );
- lives_ok( sub { $labeling->equals($labeling) }, 'equals expecting to live' );
- lives_ok( sub { $labeling->equals_obj($labeling) }, 'equals_obj expecting to live' );
- lives_ok( sub { $labeling->equals_id($labeling) }, 'equals_id expecting to live' );
- dies_ok( sub { $labeling->equals(undef) }, 'equals undef expecting to die' );
+ lives_ok(sub { $labeling->validate }, 'validate expecting to live');
+ lives_ok(sub { $labeling->equals($labeling) }, 'equals expecting to live');
+ lives_ok(sub { $labeling->equals_obj($labeling) },
+ 'equals_obj expecting to live');
+ lives_ok(sub { $labeling->equals_id($labeling) },
+ 'equals_id expecting to live');
+ dies_ok(sub { $labeling->equals(undef) }, 'equals undef expecting to die');
$limit_num_tests--;
}
diff --git a/t/100-unit/RepositoryFacade.t b/t/100-unit/RepositoryFacade.t
index 277dbae..338e35e 100644
--- a/t/100-unit/RepositoryFacade.t
+++ b/t/100-unit/RepositoryFacade.t
@@ -3,196 +3,191 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-
use Data::Dumper;
use Array::Utils qw(:all);
use feature qw( say );
use BibSpace::Repository::RepositoryFacade;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
-
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
+my $mock_obj_authors = $self->app->entityFactory->new_Author(uid => 'test');
+my $mock_obj_entries = $self->app->entityFactory->new_Entry(bib => 'test');
+my $mock_obj_tags = $self->app->entityFactory->new_Tag(name => 'test');
+my $mock_obj_tagTypes = $self->app->entityFactory->new_TagType(name => 'test');
+my $mock_obj_teams = $self->app->entityFactory->new_Team(name => 'test');
+my $mock_obj_types = $self->app->entityFactory->new_Type(our_type => 'test');
+my $mock_obj_users = $self->app->entityFactory->new_User(
+ login => 'test',
+ email => 'test',
+ pass => 'test',
+ pass2 => 'test'
+);
-
-my $mock_obj_authors = $self->app->entityFactory->new_Author( uid => 'test');
-my $mock_obj_entries = $self->app->entityFactory->new_Entry( bib=> 'test');
-my $mock_obj_tags = $self->app->entityFactory->new_Tag( name => 'test');
-my $mock_obj_tagTypes = $self->app->entityFactory->new_TagType( name => 'test' );
-my $mock_obj_teams = $self->app->entityFactory->new_Team( name => 'test');
-my $mock_obj_types = $self->app->entityFactory->new_Type( our_type=> 'test');
-my $mock_obj_users = $self->app->entityFactory->new_User( login=>'test', email=>'test', pass=>'test', pass2=>'test' );
-
-my $mock_obj_authorships = Authorship->new(
- entry_id => $mock_obj_entries->id,
- entry => $mock_obj_entries,
- author_id =>$mock_obj_authors->id,
- author =>$mock_obj_authors
+my $mock_obj_authorships = Authorship->new(
+ entry_id => $mock_obj_entries->id,
+ entry => $mock_obj_entries,
+ author_id => $mock_obj_authors->id,
+ author => $mock_obj_authors
);
-my $mock_obj_exceptions = Exception->new(
- entry_id => $mock_obj_entries->id,
- entry => $mock_obj_entries,
- team_id =>$mock_obj_teams->id,
- team =>$mock_obj_teams
+my $mock_obj_exceptions = Exception->new(
+ entry_id => $mock_obj_entries->id,
+ entry => $mock_obj_entries,
+ team_id => $mock_obj_teams->id,
+ team => $mock_obj_teams
);
-my $mock_obj_labelings = Labeling->new(
- entry_id => $mock_obj_entries->id,
- entry => $mock_obj_entries,
- tag_id =>$mock_obj_tags->id,
- tag =>$mock_obj_tags
+my $mock_obj_labelings = Labeling->new(
+ entry_id => $mock_obj_entries->id,
+ entry => $mock_obj_entries,
+ tag_id => $mock_obj_tags->id,
+ tag => $mock_obj_tags
);
-my $mock_obj_memberships = Membership->new(
- team_id =>$mock_obj_teams->id,
- team =>$mock_obj_teams,
- author_id =>$mock_obj_authors->id,
- author =>$mock_obj_authors
+my $mock_obj_memberships = Membership->new(
+ team_id => $mock_obj_teams->id,
+ team => $mock_obj_teams,
+ author_id => $mock_obj_authors->id,
+ author => $mock_obj_authors
);
-ok( $mock_obj_authors , "mock_obj_authors: $mock_obj_authors ");
-ok( $mock_obj_authorships , "mock_obj_authorships: $mock_obj_authorships");
-ok( $mock_obj_entries , "mock_obj_entries: $mock_obj_entries ");
-ok( $mock_obj_exceptions , "mock_obj_exceptions: $mock_obj_exceptions ");
-ok( $mock_obj_labelings , "mock_obj_labelings: $mock_obj_labelings ");
-ok( $mock_obj_memberships , "mock_obj_memberships: $mock_obj_memberships");
-ok( $mock_obj_tags , "mock_obj_tags: $mock_obj_tags ");
-ok( $mock_obj_tagTypes , "mock_obj_tagTypes: $mock_obj_tagTypes ");
-ok( $mock_obj_teams , "mock_obj_teams: $mock_obj_teams ");
-ok( $mock_obj_types , "mock_obj_types: $mock_obj_types ");
-ok( $mock_obj_users , "mock_obj_users: $mock_obj_users ");
-
-
+ok($mock_obj_authors, "mock_obj_authors: $mock_obj_authors ");
+ok($mock_obj_authorships, "mock_obj_authorships: $mock_obj_authorships");
+ok($mock_obj_entries, "mock_obj_entries: $mock_obj_entries ");
+ok($mock_obj_exceptions, "mock_obj_exceptions: $mock_obj_exceptions ");
+ok($mock_obj_labelings, "mock_obj_labelings: $mock_obj_labelings ");
+ok($mock_obj_memberships, "mock_obj_memberships: $mock_obj_memberships");
+ok($mock_obj_tags, "mock_obj_tags: $mock_obj_tags ");
+ok($mock_obj_tagTypes, "mock_obj_tagTypes: $mock_obj_tagTypes ");
+ok($mock_obj_teams, "mock_obj_teams: $mock_obj_teams ");
+ok($mock_obj_types, "mock_obj_types: $mock_obj_types ");
+ok($mock_obj_users, "mock_obj_users: $mock_obj_users ");
my @actions0_defined = qw( all count );
-my @actions0_undef = qw( empty );
+my @actions0_undef = qw( empty );
my @actions1 = qw( filter find );
+my @actions2 = qw( save update exists ); # oder important because of exists!
+my @actions2_delete = qw( delete );
-my @actions2 = qw( save update exists ); # oder important because of exists!
-my @actions2_delete = qw( delete );
-
-
-my @objects = qw(authors teams entries tags tagTypes types users);
+my @objects = qw(authors teams entries tags tagTypes types users);
my @relations = qw(authorships exceptions labelings memberships );
-foreach my $obj (@objects){
-
+foreach my $obj (@objects) {
- foreach my $action (@actions0_defined){
+ foreach my $action (@actions0_defined) {
note "================= Testing action $action =================";
- my $code = '$t_anyone->app->repo->'."$obj"."_"."$action;";
- my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ my $code = '$t_anyone->app->repo->' . "$obj" . "_" . "$action;";
+ my $res = eval "$code";
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
}
-
- foreach my $action (@actions0_undef){
+ foreach my $action (@actions0_undef) {
note "================= Testing action $action =================";
- my $code = '$t_anyone->app->repo->'."$obj"."_"."$action;";
- my $res = eval "$code";
- is( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ my $code = '$t_anyone->app->repo->' . "$obj" . "_" . "$action;";
+ my $res = eval "$code";
+ is($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
- }
+ }
- foreach my $action (@actions1){
+ foreach my $action (@actions1) {
note "================= Testing action $action =================";
- my $code = '$t_anyone->app->repo->'."$obj"."_"."$action(sub {defined ".'$_'."} );";
+ my $code = '$t_anyone->app->repo->' . "$obj" . "_"
+ . "$action(sub {defined " . '$_' . "} );";
my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
- }
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
+ }
- foreach my $action (@actions2){
+ foreach my $action (@actions2) {
note "================= Testing action $action =================";
-
- my $element = eval '$mock_obj_'."$obj";
- say "element->id: ".$element->id;
- ok( $element , "element '$element' is defined. Error captured: '$@'." );
- ok(!$@, "eval error empty");
- my $code = 'my $element = '.'$mock_obj_'."$obj".'; ';
- $code .= '$t_anyone->app->repo->'."$obj"."_"."$action( ".'$element'." );";
+ my $element = eval '$mock_obj_' . "$obj";
+ say "element->id: " . $element->id;
+ ok($element, "element '$element' is defined. Error captured: '$@'.");
+ ok(!$@, "eval error empty");
+
+ my $code = 'my $element = ' . '$mock_obj_' . "$obj" . '; ';
+ $code
+ .= '$t_anyone->app->repo->' . "$obj" . "_"
+ . "$action( "
+ . '$element' . " );";
my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
- }
-
+ }
-
}
+foreach my $obj (@relations) {
-foreach my $obj (@relations){
-
-
- foreach my $action (@actions0_defined){
+ foreach my $action (@actions0_defined) {
note "================= Testing action $action =================";
- my $code = '$t_anyone->app->repo->'."$obj"."_"."$action;";
- my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ my $code = '$t_anyone->app->repo->' . "$obj" . "_" . "$action;";
+ my $res = eval "$code";
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
}
-
- foreach my $action (@actions0_undef){
+ foreach my $action (@actions0_undef) {
note "================= Testing action $action =================";
- my $code = '$t_anyone->app->repo->'."$obj"."_"."$action;";
- my $res = eval "$code";
- is( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ my $code = '$t_anyone->app->repo->' . "$obj" . "_" . "$action;";
+ my $res = eval "$code";
+ is($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
- }
-
+ }
- foreach my $action (@actions1){
+ foreach my $action (@actions1) {
note "================= Testing action $action =================";
- my $code = '$t_anyone->app->repo->'."$obj"."_"."$action(sub {defined ".'$_'."} );";
+ my $code = '$t_anyone->app->repo->' . "$obj" . "_"
+ . "$action(sub {defined " . '$_' . "} );";
my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
- }
-
+ }
- foreach my $action (@actions2){
+ foreach my $action (@actions2) {
note "================= Testing action $action =================";
-
- my $element = eval '$mock_obj_'."$obj";
- say "element->id: ".$element->id;
- ok( $element , "element '$element' is defined. Error captured: '$@'." );
- my $code = 'my $element = '.'$mock_obj_'."$obj".'; ';
- $code .= '$t_anyone->app->repo->'."$obj"."_"."$action( ".'$element'." );";
+ my $element = eval '$mock_obj_' . "$obj";
+ say "element->id: " . $element->id;
+ ok($element, "element '$element' is defined. Error captured: '$@'.");
+
+ my $code = 'my $element = ' . '$mock_obj_' . "$obj" . '; ';
+ $code
+ .= '$t_anyone->app->repo->' . "$obj" . "_"
+ . "$action( "
+ . '$element' . " );";
my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
ok(!$@, "eval error empty");
- }
-
+ }
-
}
+foreach my $obj (@objects, @relations) {
-foreach my $obj (@objects, @relations){
-
- foreach my $action (@actions2_delete){
+ foreach my $action (@actions2_delete) {
note "================= Testing action $action =================";
- my $element = eval '$mock_obj_'."$obj";
- say "element->id: ".$element->id;
- ok( $element , "element '$element' is defined. Error captured: '$@'." );
+ my $element = eval '$mock_obj_' . "$obj";
+ say "element->id: " . $element->id;
+ ok($element, "element '$element' is defined. Error captured: '$@'.");
- my $code = 'my $element = '.'$mock_obj_'."$obj".'; ';
- $code .= '$t_anyone->app->repo->'."$obj"."_"."$action( ".'$element'." );";
+ my $code = 'my $element = ' . '$mock_obj_' . "$obj" . '; ';
+ $code
+ .= '$t_anyone->app->repo->' . "$obj" . "_"
+ . "$action( "
+ . '$element' . " );";
my $res = eval "$code";
- isnt( $res, '', "'$code'. Output: '$res'. Error captured: '$@'." );
- }
+ isnt($res, '', "'$code'. Output: '$res'. Error captured: '$@'.");
+ }
}
-
ok(1);
done_testing();
diff --git a/t/100-unit/SmartArray.t b/t/100-unit/SmartArray.t
index 3ceffd1..5ff32be 100644
--- a/t/100-unit/SmartArray.t
+++ b/t/100-unit/SmartArray.t
@@ -1,7 +1,6 @@
use Test::More;
use Test::Exception;
-
use Data::Dumper;
use Array::Utils qw(:all);
use feature qw( say );
@@ -13,52 +12,49 @@ use BibSpace::Util::Thing;
# use Moose;
# has 'str' => ( is => 'rw', isa => 'Str', default => "I am a thing");
-
# package main;
-my $backend = SmartArray->new( logger => SimpleLogger->new() );
+my $backend = SmartArray->new(logger => SimpleLogger->new());
ok($backend);
my $thing1 = Thing->new(id => 1);
my $thing2 = Thing->new(id => 2);
my $thing3 = Thing->new(id => 3);
-my $type = ref($thing1);
-
-
-
-ok( $backend->_init( ref($thing1) ), "init ok");
-ok( $backend->empty($type), "empty ok" );
-ok( !$backend->exists($thing1), "exists ok" );
-ok( $backend->_add($thing1), "add ok" );
-ok( $backend->exists($thing1), "exists ok" );
-ok( $backend->_add(($thing2, $thing3)), "add ok" );
-ok( $backend->all($type), "all ok" );
-is( $backend->count($type), 3, "count ok" );
-ok( !$backend->empty($type), "empty ok" );
-
-
-
-ok( !$backend->find($type, sub{$_->id == 4}), "find ok" );
-ok( $backend->find($type, sub{$_->id == 3}), "find ok" );
-
-is( scalar($backend->filter($type, sub{$_->id < 2}) ), 1, "filter ok" );
-is( scalar($backend->filter($type, sub{$_->id < 3}) ), 2, "filter ok" );
-is( scalar($backend->filter($type, sub{$_->id < 4}) ), 3, "filter ok" );
-is( scalar($backend->filter($type, sub{$_->id < 100}) ), 3, "filter ok" );
+my $type = ref($thing1);
+
+ok($backend->_init(ref($thing1)), "init ok");
+ok($backend->empty($type), "empty ok");
+ok(!$backend->exists($thing1), "exists ok");
+ok($backend->_add($thing1), "add ok");
+ok($backend->exists($thing1), "exists ok");
+ok($backend->_add(($thing2, $thing3)), "add ok");
+ok($backend->all($type), "all ok");
+is($backend->count($type), 3, "count ok");
+ok(!$backend->empty($type), "empty ok");
+
+ok(!$backend->find($type, sub { $_->id == 4 }), "find ok");
+ok($backend->find($type, sub { $_->id == 3 }), "find ok");
+
+is(scalar($backend->filter($type, sub { $_->id < 2 })), 1, "filter ok");
+is(scalar($backend->filter($type, sub { $_->id < 3 })), 2, "filter ok");
+is(scalar($backend->filter($type, sub { $_->id < 4 })), 3, "filter ok");
+is(scalar($backend->filter($type, sub { $_->id < 100 })), 3, "filter ok");
$thing3->str("updated");
-ok( $backend->update($thing3), "update ok" );
-my $found = $backend->find($type, sub{$_->id == 3});
+ok($backend->update($thing3), "update ok");
+my $found = $backend->find($type, sub { $_->id == 3 });
is($found->str, "updated", "found new updated object");
-is( $backend->delete($thing3), 1, "delete ok" );
+is($backend->delete($thing3), 1, "delete ok");
-my $found = $backend->find($type, sub{$_->id == 3});
+my $found = $backend->find($type, sub { $_->id == 3 });
ok(!$found, "not found");
-is( scalar($backend->filter($type, sub{$_->id < 100}) ), 2, "filter after delete ok" );
+is(scalar($backend->filter($type, sub { $_->id < 100 })),
+ 2, "filter after delete ok");
+
+ok($backend->dump, "dump ok");
-ok( $backend->dump, "dump ok" );
# say Dumper $backend;
ok(1);
diff --git a/t/100-unit/SmartHash.t b/t/100-unit/SmartHash.t
index d7f2a1a..189976c 100644
--- a/t/100-unit/SmartHash.t
+++ b/t/100-unit/SmartHash.t
@@ -1,7 +1,6 @@
use Test::More;
use Test::Exception;
-
use Data::Dumper;
use Array::Utils qw(:all);
use feature qw( say );
@@ -13,52 +12,48 @@ use BibSpace::Util::Thing;
# use Moose;
# has 'str' => ( is => 'rw', isa => 'Str', default => "I am a thing");
-
# package main;
-my $backend = SmartHash->new( logger => SimpleLogger->new() );
+my $backend = SmartHash->new(logger => SimpleLogger->new());
ok($backend);
my $thing1 = Thing->new(id => 1);
my $thing2 = Thing->new(id => 2);
my $thing3 = Thing->new(id => 3);
-my $type = ref($thing1);
-
-
-
-ok( $backend->_init( ref($thing1) ), "init ok");
-ok( $backend->empty($type), "empty ok" );
-ok( !$backend->exists($thing1), "exists ok" );
-ok( $backend->_add($thing1), "add ok" );
-ok( $backend->exists($thing1), "exists ok" );
-ok( $backend->_add(($thing2, $thing3)), "add ok" );
-ok( $backend->all($type), "all ok" );
-is( $backend->count($type), 3, "count ok" );
-ok( !$backend->empty($type), "empty ok" );
-
-
-
-ok( !$backend->find($type, sub{$_->id == 4}), "find ok" );
-ok( $backend->find($type, sub{$_->id == 3}), "find ok" );
-
-is( scalar($backend->filter($type, sub{$_->id < 2}) ), 1, "filter ok" );
-is( scalar($backend->filter($type, sub{$_->id < 3}) ), 2, "filter ok" );
-is( scalar($backend->filter($type, sub{$_->id < 4}) ), 3, "filter ok" );
-is( scalar($backend->filter($type, sub{$_->id < 100}) ), 3, "filter ok" );
+my $type = ref($thing1);
+
+ok($backend->_init(ref($thing1)), "init ok");
+ok($backend->empty($type), "empty ok");
+ok(!$backend->exists($thing1), "exists ok");
+ok($backend->_add($thing1), "add ok");
+ok($backend->exists($thing1), "exists ok");
+ok($backend->_add(($thing2, $thing3)), "add ok");
+ok($backend->all($type), "all ok");
+is($backend->count($type), 3, "count ok");
+ok(!$backend->empty($type), "empty ok");
+
+ok(!$backend->find($type, sub { $_->id == 4 }), "find ok");
+ok($backend->find($type, sub { $_->id == 3 }), "find ok");
+
+is(scalar($backend->filter($type, sub { $_->id < 2 })), 1, "filter ok");
+is(scalar($backend->filter($type, sub { $_->id < 3 })), 2, "filter ok");
+is(scalar($backend->filter($type, sub { $_->id < 4 })), 3, "filter ok");
+is(scalar($backend->filter($type, sub { $_->id < 100 })), 3, "filter ok");
$thing3->str("updated");
-ok( $backend->update($thing3), "update ok" );
-my $found = $backend->find($type, sub{$_->id == 3});
+ok($backend->update($thing3), "update ok");
+my $found = $backend->find($type, sub { $_->id == 3 });
is($found->str, "updated");
-is( $backend->delete($thing3), 1, "delete ok" );
-my $found = $backend->find($type, sub{$_->id == 3});
+is($backend->delete($thing3), 1, "delete ok");
+my $found = $backend->find($type, sub { $_->id == 3 });
ok(!$found, "not found");
-is( scalar($backend->filter($type, sub{$_->id < 100}) ), 2, "filter ok" );
+is(scalar($backend->filter($type, sub { $_->id < 100 })), 2, "filter ok");
+
+ok($backend->dump, "dump ok");
-ok( $backend->dump, "dump ok" );
# say Dumper $backend;
ok(1);
diff --git a/t/100-unit/Tag.t b/t/100-unit/Tag.t
index cc9113a..92f2e65 100644
--- a/t/100-unit/Tag.t
+++ b/t/100-unit/Tag.t
@@ -8,7 +8,5 @@ use Test::Mojo;
# use BibSpace::TestManager;
# TestManager->apply_fixture($self->app);
-
-
ok(1);
done_testing();
diff --git a/t/100-unit/TagCloud.t b/t/100-unit/TagCloud.t
index 0e0cfab..68414a8 100644
--- a/t/100-unit/TagCloud.t
+++ b/t/100-unit/TagCloud.t
@@ -6,23 +6,18 @@ use Test::Mojo;
# my $self = $t_anyone->app;
# my $dbh = $t_anyone->app->db;
-
-
use BibSpace::Model::TagCloud;
-use BibSpace::Functions::Core; # for random string
+use BibSpace::Functions::Core; # for random string
use Data::Dumper;
-
-
-
my $random2 = random_string(16);
my $random3 = random_string(16);
my $random4 = random_string(16);
my $tc = TagCloud->new();
-$tc->{name} = $random2;
-$tc->{url} = $random3;
+$tc->{name} = $random2;
+$tc->{url} = $random3;
$tc->{count} = $random4;
my $html = $tc->getHTML();
@@ -31,5 +26,4 @@ like($html, qr/$random2/, "Html should contain $random2");
like($html, qr/$random3/, "Html should contain $random3");
like($html, qr/$random4/, "Html should contain $random4");
-
done_testing();
diff --git a/t/100-unit/TagType.t b/t/100-unit/TagType.t
index 473bf31..fc89829 100644
--- a/t/100-unit/TagType.t
+++ b/t/100-unit/TagType.t
@@ -3,16 +3,11 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-
# my $t_anyone = Test::Mojo->new('BibSpace');
# my $self = $t_anyone->app;
# use BibSpace::TestManager;
# TestManager->apply_fixture($self->app);
-
-
-
-
ok(1);
done_testing();
diff --git a/t/100-unit/Team.t b/t/100-unit/Team.t
index 296df1f..ebdf3c5 100644
--- a/t/100-unit/Team.t
+++ b/t/100-unit/Team.t
@@ -3,40 +3,38 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-my $repo = $self->app->repo;
+my $repo = $self->app->repo;
my @all_teams = $repo->teams_all;
-my $author = ($repo->authors_all)[0];
+my $author = ($repo->authors_all)[0];
my $author2 = ($repo->authors_all)[1];
-my $entry = ($repo->entries_all)[0];
-
+my $entry = ($repo->entries_all)[0];
my $limit_num_tests = 20;
-note "============ Testing ".scalar(@all_teams)." Teams ============";
+note "============ Testing " . scalar(@all_teams) . " Teams ============";
foreach my $team (@all_teams) {
last if $limit_num_tests < 0;
- note "============ Testing Team ID ".$team->id.".";
+ note "============ Testing Team ID " . $team->id . ".";
- ok( $team->toString , "toString");
+ ok($team->toString, "toString");
my $member_author = ($team->get_authors)[0];
- my $non_member = $repo->authors_find( sub{ !$_->has_team($team) } );
+ my $non_member = $repo->authors_find(sub { !$_->has_team($team) });
- if( $member_author ){
+ if ($member_author) {
- isnt( $team->get_membership_end($member_author), -1 );
- isnt( $team->get_membership_beginning($member_author), -1 );
- ok( !$team->can_be_deleted , "can be deleted");
+ isnt($team->get_membership_end($member_author), -1);
+ isnt($team->get_membership_beginning($member_author), -1);
+ ok(!$team->can_be_deleted, "can be deleted");
my $mem = Membership->new(
author => $member_author->get_master,
@@ -52,61 +50,59 @@ foreach my $team (@all_teams) {
team_id => $team->id
);
-
-
## testing membership actually...
- ok( $mem->validate , "mem validate");
- ok( $mem->toString , "mem to string");
- ok( $mem->equals($mem2) , "mem equals");
- ok( $mem->equals_id($mem2) , "mem equals id");
- ok( $mem->equals_obj($mem2) , "mem equals obj");
-
- ok( $member_author->update_membership($team, 0, 0) , "update mem 0 0");
- ok( $member_author->update_membership($team, 100, 200), "update mem 100 200");
-
- dies_ok{ $member_author->update_membership($team, 200, 100) } "update mem bad 200 100";
- dies_ok{ $member_author->update_membership($team, -100, 100) } "update mem bad 100 pne 100";
- dies_ok{ $member_author->update_membership($team, 100, -100) } "update mem bad 100 100 pne";
-
- if( $non_member and !$author->equals($non_member) ){
+ ok($mem->validate, "mem validate");
+ ok($mem->toString, "mem to string");
+ ok($mem->equals($mem2), "mem equals");
+ ok($mem->equals_id($mem2), "mem equals id");
+ ok($mem->equals_obj($mem2), "mem equals obj");
+
+ ok($member_author->update_membership($team, 0, 0), "update mem 0 0");
+ ok($member_author->update_membership($team, 100, 200),
+ "update mem 100 200");
+
+ dies_ok { $member_author->update_membership($team, 200, 100) }
+ "update mem bad 200 100";
+ dies_ok { $member_author->update_membership($team, -100, 100) }
+ "update mem bad 100 pne 100";
+ dies_ok { $member_author->update_membership($team, 100, -100) }
+ "update mem bad 100 100 pne";
+
+ if ($non_member and !$author->equals($non_member)) {
my $mem3 = Membership->new(
author => $non_member->get_master,
team => $team,
author_id => $non_member->get_master->id,
team_id => $team->id
);
- ok( $mem->validate, 'mem validate');
- ok( $mem->toString, 'mem toString');
- ok( !$mem->equals($mem3), '!equals');
- ok( !$mem->equals_id($mem3), '!equals_id');
- ok( !$mem->equals_obj($mem3), '!equals_obj');
+ ok($mem->validate, 'mem validate');
+ ok($mem->toString, 'mem toString');
+ ok(!$mem->equals($mem3), '!equals');
+ ok(!$mem->equals_id($mem3), '!equals_id');
+ ok(!$mem->equals_obj($mem3), '!equals_obj');
- ok( !$team->has_membership($mem3), '!has_membership');
+ ok(!$team->has_membership($mem3), '!has_membership');
}
-
$team->add_membership($mem);
- ok( $team->has_membership($mem) , 'has_membership');
- ok( $team->remove_membership($mem) , 'remove_membership');
- ok( !$team->remove_membership($mem) , '!remove_membership');
-
-
+ ok($team->has_membership($mem), 'has_membership');
+ ok($team->remove_membership($mem), 'remove_membership');
+ ok(!$team->remove_membership($mem), '!remove_membership');
}
- else{
- ok( $team->can_be_deleted , '!can_be_deleted');
+ else {
+ ok($team->can_be_deleted, '!can_be_deleted');
}
- if( $team->tags ){
- ok( $team->tags , 'team has tags');
- ok( $team->get_entries , 'team has entries');
+ if ($team->tags) {
+ ok($team->tags, 'team has tags');
+ ok($team->get_entries, 'team has entries');
}
- if( $team->get_exceptions ){
- ok( $team->get_exceptions , 'team has exceptions');
- ok( $team->get_entries , 'team has entries from exceptions');
+ if ($team->get_exceptions) {
+ ok($team->get_exceptions, 'team has exceptions');
+ ok($team->get_entries, 'team has entries from exceptions');
}
-
$limit_num_tests--;
}
diff --git a/t/100-unit/Type.t b/t/100-unit/Type.t
index 1e1fdb3..57ee5db 100644
--- a/t/100-unit/Type.t
+++ b/t/100-unit/Type.t
@@ -3,59 +3,66 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-my $repo = $self->app->repo;
+my $repo = $self->app->repo;
my @all_types = $repo->types_all;
# my $author = ($repo->authors_all)[0];
# my $author2 = ($repo->authors_all)[1];
# my $entry = ($repo->entries_all)[0];
-
my $limit_num_tests = 20;
-note "============ Testing ".scalar(@all_types)." Types ============";
+note "============ Testing " . scalar(@all_types) . " Types ============";
-foreach my $type (@all_types){
+foreach my $type (@all_types) {
last if $limit_num_tests < 0;
-
- note "============ Testing Type ID ".$type->id.".";
- ok( $type->toString , "toString");
- ok( $type->equals($type) , "equals");
-
- if( $type->bibtexTypes_count == 1){
+ note "============ Testing Type ID " . $type->id . ".";
+
+ ok($type->toString, "toString");
+ ok($type->equals($type), "equals");
+
+ if ($type->bibtexTypes_count == 1) {
- is( $type->num_bibtex_types, 1, "num_bibtex_types is 1");
- ok( $type->get_first_bibtex_type, "get_first_bibtex_type is defined");
+ is($type->num_bibtex_types, 1, "num_bibtex_types is 1");
+ ok($type->get_first_bibtex_type, "get_first_bibtex_type is defined");
- if( $type->get_first_bibtex_type eq $type->our_type ){
- ok( !$type->can_be_deleted, "allowed deletion of custom 1:1 mapping \n\t".$type->toString."\t - should not allow to delete");
+ if ($type->get_first_bibtex_type eq $type->our_type) {
+ ok(!$type->can_be_deleted,
+ "allowed deletion of custom 1:1 mapping \n\t"
+ . $type->toString
+ . "\t - should not allow to delete");
}
- else{
- ok( $type->can_be_deleted, "disalowed deletion of custom 1:1 mapping \n\t".$type->toString."\t - should allow to delete");
+ else {
+ ok($type->can_be_deleted,
+ "disalowed deletion of custom 1:1 mapping \n\t"
+ . $type->toString
+ . "\t - should allow to delete");
}
-
+
}
- elsif( $type->bibtexTypes_count > 1){
+ elsif ($type->bibtexTypes_count > 1) {
+
+ ok($type->num_bibtex_types > 0, "num_bibtex_types");
+ ok($type->get_first_bibtex_type, "get_first_bibtex_type");
+ ok(!$type->can_be_deleted,
+ "allowed deletion of 1:N mapping \n\t"
+ . $type->toString
+ . "\t - should not allow to delete");
- ok( $type->num_bibtex_types > 0 , "num_bibtex_types");
- ok( $type->get_first_bibtex_type, "get_first_bibtex_type");
- ok( !$type->can_be_deleted, "allowed deletion of 1:N mapping \n\t".$type->toString."\t - should not allow to delete");
-
}
- else{
- is( $type->num_bibtex_types, 0 , "num_bibtex_types");
- ok( !$type->get_first_bibtex_type, "get_first_bibtex_type");
- ok( $type->can_be_deleted, "can_be_deleted - zero bibtex types");
+ else {
+ is($type->num_bibtex_types, 0, "num_bibtex_types");
+ ok(!$type->get_first_bibtex_type, "get_first_bibtex_type");
+ ok($type->can_be_deleted, "can_be_deleted - zero bibtex types");
}
-
+
$limit_num_tests--;
}
diff --git a/t/100-unit/User.t b/t/100-unit/User.t
index 8625e22..eb6cc3b 100644
--- a/t/100-unit/User.t
+++ b/t/100-unit/User.t
@@ -3,49 +3,44 @@ use Test::More;
use Test::Mojo;
use Test::Exception;
-my $t_logged_in = Test::Mojo->new('BibSpace');
-my $self = $t_logged_in->app;
+my $t_logged_in = Test::Mojo->new('BibSpace');
+my $self = $t_logged_in->app;
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-my $repo = $self->app->repo;
+my $repo = $self->app->repo;
my @all_users = $repo->users_all;
# my $author = ($repo->authors_all)[0];
# my $author2 = ($repo->authors_all)[1];
# my $entry = ($repo->entries_all)[0];
-
my $limit_num_tests = 20;
-my $me = $repo->users_find(sub { $_->login eq 'pub_admin' } );
+my $me = $repo->users_find(sub { $_->login eq 'pub_admin' });
-note "============ Testing ".scalar(@all_users)." users ============";
+note "============ Testing " . scalar(@all_users) . " users ============";
-foreach my $user (@all_users){
+foreach my $user (@all_users) {
last if $limit_num_tests < 0;
-
- note "============ Testing User ID ".$user->id.".";
-
- ok( $user->toString , "toString");
-
- if( !$user->equals($me) ){
- ok( $user->make_admin, "make_admin");
- ok( $user->make_manager, "make_manager");
- ok( $user->make_user, "make_user");
- ok( $user->make_manager, "make_manager");
- ok( $user->make_admin, "make_admin");
- ok( $user->make_user, "make_user");
- }
+ note "============ Testing User ID " . $user->id . ".";
+ ok($user->toString, "toString");
+
+ if (!$user->equals($me)) {
+ ok($user->make_admin, "make_admin");
+ ok($user->make_manager, "make_manager");
+ ok($user->make_user, "make_user");
+ ok($user->make_manager, "make_manager");
+ ok($user->make_admin, "make_admin");
+ ok($user->make_user, "make_user");
+ }
-
$limit_num_tests--;
}
diff --git a/t/200-controller/Backup.t b/t/200-controller/Backup.t
index 9db9647..f2e2edb 100644
--- a/t/200-controller/Backup.t
+++ b/t/200-controller/Backup.t
@@ -7,8 +7,8 @@ use BibSpace::Functions::BackupFunctions;
my $t_logged_in = Test::Mojo->new('BibSpace');
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
$t_logged_in->ua->max_redirects(5);
@@ -21,72 +21,69 @@ my $page = "";
my $backup_id = 1;
-
####################################################################
subtest 'backup_index' => sub {
- $page = $t_logged_in->app->url_for('backup_index');
- $t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_index');
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
####################################################################
subtest 'backup_do' => sub {
- $page = $t_logged_in->app->url_for('backup_do');
- $t_logged_in->put_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_do');
+ $t_logged_in->put_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
####################################################################
subtest 'backup_do_mysql' => sub {
- $page = $t_logged_in->app->url_for('backup_do_mysql');
- $t_logged_in->put_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_do_mysql');
+ $t_logged_in->put_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
####################################################################
my $backup = do_storable_backup($self->app);
-ok( $backup , "found a backup");
+ok($backup, "found a backup");
$backup_id = $backup->id;
-
####################################################################
subtest 'backup_do_mysql' => sub {
- my @backups = read_backups($self->app->get_backups_dir);
- ok( scalar(@backups) > 0 , "found some backups in ".$self->app->get_backups_dir);
+ my @backups = read_backups($self->app->get_backups_dir);
+ ok(scalar(@backups) > 0,
+ "found some backups in " . $self->app->get_backups_dir);
};
-
####################################################################
subtest 'backup_index again' => sub {
- $page = $t_logged_in->app->url_for('backup_index');
- $t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_index');
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
####################################################################
subtest 'backup_download' => sub {
- $page = $t_logged_in->app->url_for( 'backup_download', id => $backup_id );
- $t_logged_in->get_ok($page)
- ->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_download', id => $backup_id);
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+
+ $page = $t_logged_in->app->url_for('backup_download', id => "xxx");
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
- $page = $t_logged_in->app->url_for( 'backup_download', id => "xxx" );
- $t_logged_in->get_ok($page)
- ->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
- # this should give status 200 but a message that backup does not exist or is not healthy
+# this should give status 200 but a message that backup does not exist or is not healthy
};
####################################################################
subtest 'backup_restore' => sub {
- my @backups = read_backups($self->app->get_backups_dir);
- my $backup = $backups[0];
-
- $page = $t_logged_in->app->url_for('backup_restore', id => $backup->uuid );
- $t_logged_in->put_ok($page)
- ->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
-
- sleep(2);
- # this test sometimes fail without reason. This sleep might help with it
+ my @backups = read_backups($self->app->get_backups_dir);
+ my $backup = $backups[0];
+
+ $page = $t_logged_in->app->url_for('backup_restore', id => $backup->uuid);
+ $t_logged_in->put_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+
+ sleep(2);
+
+ # this test sometimes fail without reason. This sleep might help with it
# ./t/200-controller/Backup.t .................... 8/?
# # Failed test 'Checking: 500 http://127.0.0.1:49271/backups/150102cb-4380-41c4-b94b-9d38d2e232b5'
# # at ./t/200-controller/Backup.t line 84.
@@ -100,38 +97,34 @@ subtest 'backup_restore' => sub {
####################################################################
subtest 'backup_delete' => sub {
- my $page = $t_logged_in->app->url_for( 'backup_delete', id => $backup_id );
+ my $page = $t_logged_in->app->url_for('backup_delete', id => $backup_id);
- $t_logged_in->delete_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $t_logged_in->delete_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
- $page = $t_logged_in->app->url_for( 'backup_delete', id => -222 );
- $t_logged_in->delete_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_delete', id => -222);
+ $t_logged_in->delete_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
-
####################################################################
subtest 'backup_cleanup' => sub {
- $page = $t_logged_in->app->url_for('backup_cleanup');
- $t_logged_in->delete_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('backup_cleanup');
+ $t_logged_in->delete_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
-
-
-
-
####################################################################
subtest 'backup_delete to clean' => sub {
+
# cleanup
- my @backups = read_backups($self->app->get_backups_dir);
+ my @backups = read_backups($self->app->get_backups_dir);
- foreach my $back (@backups){
- my $page = $t_logged_in->app->url_for( 'backup_delete', id => $back->uuid );
- $t_logged_in->delete_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
- }
+ foreach my $back (@backups) {
+ my $page = $t_logged_in->app->url_for('backup_delete', id => $back->uuid);
+ $t_logged_in->delete_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+ }
};
ok(1);
diff --git a/t/200-controller/Display.t b/t/200-controller/Display.t
index 020bc8d..1766350 100644
--- a/t/200-controller/Display.t
+++ b/t/200-controller/Display.t
@@ -6,8 +6,8 @@ use BibSpace::Functions::MySqlBackupFunctions;
my $t_logged_in = Test::Mojo->new('BibSpace');
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
$t_logged_in->ua->max_redirects(5);
@@ -15,39 +15,39 @@ $t_logged_in->ua->max_redirects(5);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
my $page;
####################################################################
subtest 'start' => sub {
- $page = $t_logged_in->app->url_for('start');
- $t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('start');
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
####################################################################
subtest 'show_log' => sub {
- $page = $t_logged_in->app->url_for('show_log', num=>10);
- $t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
-
- $page = $t_logged_in->app->url_for('show_log', num=>-10);
- $t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
-
- $page = $t_logged_in->app->url_for('show_log', num=>10)->query(type => "notexisting");
- $t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $page = $t_logged_in->app->url_for('show_log', num => 10);
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+
+ $page = $t_logged_in->app->url_for('show_log', num => -10);
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+
+ $page = $t_logged_in->app->url_for('show_log', num => 10)
+ ->query(type => "notexisting");
+ $t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
};
####################################################################
$page = $t_logged_in->app->url_for('error500');
-$t_logged_in->get_ok($page)->status_isnt( 404, "Checking: 404 $page" )
- ->status_is( 500, "Checking: 500 $page" );
+$t_logged_in->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_is(500, "Checking: 500 $page");
$page = $t_logged_in->app->url_for('error404');
-$t_logged_in->get_ok($page)->status_is( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+$t_logged_in->get_ok($page)->status_is(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
ok(1);
done_testing();
diff --git a/t/200-controller/Login.t b/t/200-controller/Login.t
index abbdb0e..bdd6d8f 100644
--- a/t/200-controller/Login.t
+++ b/t/200-controller/Login.t
@@ -6,8 +6,8 @@ use BibSpace::Functions::MySqlBackupFunctions;
my $t_logged_in = Test::Mojo->new('BibSpace');
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
$t_logged_in->ua->max_redirects(5);
@@ -15,26 +15,32 @@ $t_logged_in->ua->max_redirects(5);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-$t_logged_in->post_ok('/register' => form => {
+$t_logged_in->post_ok(
+ '/register' => form => {
login => "HenryJohnTester",
name => 'Henry John',
email => 'HenryJohnTester@example.com',
password1 => 'qwerty',
password2 => 'qwerty'
-});
+ }
+);
-$t_logged_in->post_ok('/register' => form => {
+$t_logged_in->post_ok(
+ '/register' => form => {
login => "HenryJohnTester2",
name => 'Henry John2',
email => 'HenryJohnTester2@example.com',
password1 => 'qwerty2',
password2 => 'qwerty2'
-});
+ }
+);
-my $me = $t_logged_in->app->repo->users_find(sub{$_->login eq 'pub_admin'});
-my $user = $t_logged_in->app->repo->users_find(sub{$_->login eq 'HenryJohnTester'});
-my $user2 = $t_logged_in->app->repo->users_find(sub{$_->login eq 'HenryJohnTester2'});
+my $me = $t_logged_in->app->repo->users_find(sub { $_->login eq 'pub_admin' });
+my $user
+ = $t_logged_in->app->repo->users_find(sub { $_->login eq 'HenryJohnTester' });
+my $user2
+ = $t_logged_in->app->repo->users_find(sub { $_->login eq 'HenryJohnTester2' }
+ );
ok($me);
ok($user);
@@ -59,27 +65,27 @@ ok($user2);
# $anyone->get('/logout')->to('login#logout')->name('logout');
my @pages = (
- '/profile',
- $t_logged_in->app->url_for('manage_users'),
- $t_logged_in->app->url_for('show_user_profile', id => $user->id),
- $t_logged_in->app->url_for('show_user_profile', id => $user2->id),
- $t_logged_in->app->url_for('delete_user', id => $user2->id), # delete ok
- $t_logged_in->app->url_for('make_user', id => $user->id),
- $t_logged_in->app->url_for('make_manager', id => $user->id),
- $t_logged_in->app->url_for('make_admin', id => $user->id),
- $t_logged_in->app->url_for('delete_user', id => $user->id), # shall not be deleted - is admin
- $t_logged_in->app->url_for('delete_user', id => $me->id), # shall not be deleted - is me
- $t_logged_in->app->url_for('make_user', id => $me->id), # shall not be degraded - is me & admin
+ '/profile', $t_logged_in->app->url_for('manage_users'),
+ $t_logged_in->app->url_for('show_user_profile', id => $user->id),
+ $t_logged_in->app->url_for('show_user_profile', id => $user2->id),
+ $t_logged_in->app->url_for('delete_user', id => $user2->id), # delete ok
+ $t_logged_in->app->url_for('make_user', id => $user->id),
+ $t_logged_in->app->url_for('make_manager', id => $user->id),
+ $t_logged_in->app->url_for('make_admin', id => $user->id),
+ $t_logged_in->app->url_for('delete_user', id => $user->id)
+ , # shall not be deleted - is admin
+ $t_logged_in->app->url_for('delete_user', id => $me->id)
+ , # shall not be deleted - is me
+ $t_logged_in->app->url_for('make_user', id => $me->id)
+ , # shall not be degraded - is me & admin
);
-
-for my $page (@pages){
+for my $page (@pages) {
note "============ Testing page $page ============";
$t_logged_in->get_ok($page, "Get for page $page")
->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
}
-
ok(1);
done_testing();
diff --git a/t/200-controller/Persistence.t b/t/200-controller/Persistence.t
index 6b94b6f..9296603 100644
--- a/t/200-controller/Persistence.t
+++ b/t/200-controller/Persistence.t
@@ -6,8 +6,8 @@ use BibSpace::Functions::MySqlBackupFunctions;
my $t_logged_in = Test::Mojo->new('BibSpace');
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
$t_logged_in->ua->max_redirects(5);
@@ -16,8 +16,6 @@ $t_logged_in->ua->inactivity_timeout(300);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-
# 'system_status'
# 'load_fixture'
# 'save_fixture'
@@ -30,26 +28,25 @@ TestManager->apply_fixture($self->app);
# 'insert_random_data'
my @pages = (
- $t_logged_in->app->url_for('system_status'),
- $t_logged_in->app->url_for('reset_smart'),
- $t_logged_in->app->url_for('copy_mysql_to_smart'),
- $t_logged_in->app->url_for('reset_mysql'),
- $t_logged_in->app->url_for('copy_smart_to_mysql'),
- $t_logged_in->app->url_for('persistence_status'),
- $t_logged_in->app->url_for('reset_all'),
- $t_logged_in->app->url_for('load_fixture'),
- # $t_logged_in->app->url_for('save_fixture'), # saving test fixture shall not be tested!
- $t_logged_in->app->url_for('insert_random_data', num => 50),
+ $t_logged_in->app->url_for('system_status'),
+ $t_logged_in->app->url_for('reset_smart'),
+ $t_logged_in->app->url_for('copy_mysql_to_smart'),
+ $t_logged_in->app->url_for('reset_mysql'),
+ $t_logged_in->app->url_for('copy_smart_to_mysql'),
+ $t_logged_in->app->url_for('persistence_status'),
+ $t_logged_in->app->url_for('reset_all'),
+ $t_logged_in->app->url_for('load_fixture'),
+
+# $t_logged_in->app->url_for('save_fixture'), # saving test fixture shall not be tested!
+ $t_logged_in->app->url_for('insert_random_data', num => 50),
);
-
-for my $page (@pages){
+for my $page (@pages) {
note "============ Testing page $page ============";
$t_logged_in->get_ok($page, "Get for page $page")
->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
}
-
ok(1);
done_testing();
diff --git a/t/200-controller/Publications.t b/t/200-controller/Publications.t
index 075ebfb..93eaf63 100644
--- a/t/200-controller/Publications.t
+++ b/t/200-controller/Publications.t
@@ -8,49 +8,66 @@ use feature qw( state say );
my $admin_user = Test::Mojo->new('BibSpace');
$admin_user->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
-
-my $self = $admin_user->app;
+my $self = $admin_user->app;
my $app_config = $admin_user->app->config;
$admin_user->ua->max_redirects(3);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
my $test_file = Path::Tiny->new('fixture')->child('test_document.pdf');
-ok( -e $test_file, "test pdf document exists");
+ok(-e $test_file, "test pdf document exists");
+ok(
+ BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(
+ undef, 'ERR_BIBTEX'
+ )
+);
+ok(
+ BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(
+ undef, 'PREVIEW'
+ )
+);
+ok(
+ BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(
+ undef, 'ADD_OK'
+ )
+);
+ok(
+ BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(
+ undef, 'EDIT_OK'
+ )
+);
+ok(
+ BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(
+ undef, 'KEY_OK'
+ )
+);
-ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'ERR_BIBTEX'));
-ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'PREVIEW'));
-ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'ADD_OK'));
-ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'EDIT_OK'));
-ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'KEY_OK'));
# ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'KEY_TAKEN')); # needs a real controller obj
-ok(BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(undef, 'WEIRD_SHIT'));
-
+ok(
+ BibSpace::Controller::Publications::get_adding_editing_message_for_error_code(
+ undef, 'WEIRD_SHIT'
+ )
+);
my @entries = $admin_user->app->repo->entries_all;
my $entry = shift @entries;
my $author = ($admin_user->app->repo->authors_all)[0];
my @teams = $admin_user->app->repo->teams_all;
-my $team = shift @teams;
+my $team = shift @teams;
my @tags = $admin_user->app->repo->tags_all;
-my $tag = shift @tags;
-
-
-
+my $tag = shift @tags;
my $page = $self->url_for('add_publication');
- $admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
-
+$admin_user->get_ok($page, "Get for page $page")
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
####################################################################
subtest 'edit_publication_post' => sub {
@@ -72,131 +89,146 @@ subtest 'edit_publication_post' => sub {
}';
$admin_user->post_ok(
- $self->url_for('edit_publication_post', id=>$entry->id) => form => {new_bib => $bib_content, preview => 1 }
- );
+ $self->url_for('edit_publication_post', id => $entry->id) => form =>
+ {new_bib => $bib_content, preview => 1});
$admin_user->post_ok(
- $self->url_for('edit_publication_post', id=>$entry->id) => form => {new_bib => $bib_content, check_key => 1 }
- );
+ $self->url_for('edit_publication_post', id => $entry->id) => form =>
+ {new_bib => $bib_content, check_key => 1});
$admin_user->post_ok(
- $self->url_for('edit_publication_post', id=>$entry->id) => form => {new_bib => $bib_content, save => 1 }
- );
+ $self->url_for('edit_publication_post', id => $entry->id) => form =>
+ {new_bib => $bib_content, save => 1});
$admin_user->post_ok(
- $self->url_for('edit_publication_post', id=>$entry->id) => form => {new_bib => $bib_content, check_key => 1 }
- );
+ $self->url_for('edit_publication_post', id => $entry->id) => form =>
+ {new_bib => $bib_content, check_key => 1});
};
-
-
-
-
-
my $upload = {
- filetype => 'paper',
- uploaded_file => {
- content => 'test',
- filename => 'test.pdf'
- }
+ filetype => 'paper',
+ uploaded_file => {content => 'test', filename => 'test.pdf'}
};
my $upload_test_file = {
- filetype => 'paper',
- uploaded_file => {
- file => "".$test_file,
- filename => "".$test_file
- }
+ filetype => 'paper',
+ uploaded_file => {file => "" . $test_file, filename => "" . $test_file}
};
my $upload_test_slides = {
- filetype => 'slides',
- uploaded_file => {
- file => "".$test_file,
- filename => "".$test_file
- }
+ filetype => 'slides',
+ uploaded_file => {file => "" . $test_file, filename => "" . $test_file}
};
-
$admin_user->post_ok(
- $self->url_for('post_upload_pdf', id=>$entry->id) => form => $upload,
- "Upload simple file OK"
+ $self->url_for('post_upload_pdf', id => $entry->id) => form => $upload,
+ "Upload simple file OK"
);
-ok( -e $self->app->get_upload_dir."/papers/paper-".$entry->id.".pdf", "uploaded simple file exists");
-
+ok(-e $self->app->get_upload_dir . "/papers/paper-" . $entry->id . ".pdf",
+ "uploaded simple file exists");
-$page = $self->url_for('download_publication_pdf', filetype=>'paper', id=>$entry->id);
+$page = $self->url_for(
+ 'download_publication_pdf',
+ filetype => 'paper',
+ id => $entry->id
+);
$admin_user->get_ok($page, "Download simple file OK: $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
-$page = $self->url_for('publications_remove_attachment', filetype=>'paper', id=>$entry->id);
+$page = $self->url_for(
+ 'publications_remove_attachment',
+ filetype => 'paper',
+ id => $entry->id
+);
$admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
-ok( !-e $self->app->get_upload_dir."/papers/paper-".$entry->id.".pdf", "uploaded file was deleted correctly");
+ok(!-e $self->app->get_upload_dir . "/papers/paper-" . $entry->id . ".pdf",
+ "uploaded file was deleted correctly");
-say "NOW UPLOADING REAL FILE". Dumper $upload_test_file;
+say "NOW UPLOADING REAL FILE" . Dumper $upload_test_file;
$admin_user->post_ok(
- $self->url_for('post_upload_pdf', id=>$entry->id) => form => $upload_test_file,
- "Upload real pdf file OK"
+ $self->url_for('post_upload_pdf', id => $entry->id) => form =>
+ $upload_test_file,
+ "Upload real pdf file OK"
);
$admin_user->post_ok(
- $self->url_for('post_upload_pdf', id=>$entry->id) => form => $upload_test_slides,
- "Upload real pdf with slides file OK"
+ $self->url_for('post_upload_pdf', id => $entry->id) => form =>
+ $upload_test_slides,
+ "Upload real pdf with slides file OK"
);
-
-$page = $self->url_for('download_publication_pdf', filetype=>'paper', id=>$entry->id);
+$page = $self->url_for(
+ 'download_publication_pdf',
+ filetype => 'paper',
+ id => $entry->id
+);
$admin_user->get_ok($page, "Download real file OK: $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
-$page = $self->url_for('download_publication_pdf', filetype=>'slides', id=>$entry->id);
+$page = $self->url_for(
+ 'download_publication_pdf',
+ filetype => 'slides',
+ id => $entry->id
+);
$admin_user->get_ok($page, "Download real file OK: $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
-
-ok( -e $self->app->get_upload_dir."/papers/paper-".$entry->id.".pdf", "file uploaded again exists");
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+ok(-e $self->app->get_upload_dir . "/papers/paper-" . $entry->id . ".pdf",
+ "file uploaded again exists");
-
-my $upload2 = {filetype=>'paper', uploaded_file => {content => 'test2', filename => 'test.docx'} };
+my $upload2 = {
+ filetype => 'paper',
+ uploaded_file => {content => 'test2', filename => 'test.docx'}
+};
$admin_user->post_ok(
- $self->url_for('post_upload_pdf', id=>$entry->id) => form => $upload2
-);
+ $self->url_for('post_upload_pdf', id => $entry->id) => form => $upload2);
-$page = $self->url_for('download_publication', filetype=>'paper', id=>$entry->id);
+$page = $self->url_for('download_publication', filetype => 'paper',
+ id => $entry->id);
$admin_user->get_ok($page, "Get for page $page")
- #->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
-$page = $self->url_for('publications_remove_attachment', filetype=>'paper', id=>$entry->id);
+ #->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+
+$page = $self->url_for(
+ 'publications_remove_attachment',
+ filetype => 'paper',
+ id => $entry->id
+);
$admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
# call twice to remove the non-existing file
-$page = $self->url_for('publications_remove_attachment', filetype=>'paper', id=>$entry->id);
+$page = $self->url_for(
+ 'publications_remove_attachment',
+ filetype => 'paper',
+ id => $entry->id
+);
$admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
-$page = $self->url_for('download_publication', filetype=>'paper', id=>$entry->id);
+$page = $self->url_for('download_publication', filetype => 'paper',
+ id => $entry->id);
$admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(500, "Checking: 500 $page")
- ->status_is(404, "Checking: 404 $page"); # this should give 404, the attachment has been removed
-
-
+ ->status_isnt(500, "Checking: 500 $page")
+ ->status_is(404, "Checking: 404 $page")
+ ; # this should give 404, the attachment has been removed
+
####################################################################
subtest 'add_publication_post' => sub {
my $random_string = random_string(16);
my $bib_content = '
- @article{key_2017_TEST'.$random_string.',
+ @article{key_2017_TEST' . $random_string . ',
author = {Johny Example},
journal = {Journal of Bar},
publisher = {Foo Publishing house},
@@ -206,127 +238,128 @@ subtest 'add_publication_post' => sub {
day = {1--31},
}';
+ $admin_user->post_ok($self->url_for('add_publication_post') => form =>
+ {new_bib => $bib_content, preview => 1});
+ $admin_user->post_ok($self->url_for('add_publication_post') => form =>
+ {new_bib => $bib_content, check_key => 1});
+ $admin_user->post_ok($self->url_for('add_publication_post') => form =>
+ {new_bib => $bib_content, save => 1});
- $admin_user->post_ok(
- $self->url_for('add_publication_post') => form => {new_bib => $bib_content, preview => 1 }
- );
- $admin_user->post_ok(
- $self->url_for('add_publication_post') => form => {new_bib => $bib_content, check_key => 1 }
- );
- $admin_user->post_ok(
- $self->url_for('add_publication_post') => form => {new_bib => $bib_content, save => 1 }
- );
# again to get key conflict
- $admin_user->post_ok(
- $self->url_for('add_publication_post') => form => {new_bib => $bib_content, check_key => 1 }
- );
- $admin_user->post_ok(
- $self->url_for('add_publication_post') => form => {new_bib => $bib_content, save => 1 }
- );
+ $admin_user->post_ok($self->url_for('add_publication_post') => form =>
+ {new_bib => $bib_content, check_key => 1});
+ $admin_user->post_ok($self->url_for('add_publication_post') => form =>
+ {new_bib => $bib_content, save => 1});
- $admin_user->post_ok(
- $self->url_for('add_publication_post') => form => {new_bib => '@bad_content!', save => 1 }
- );
+ $admin_user->post_ok($self->url_for('add_publication_post') => form =>
+ {new_bib => '@bad_content!', save => 1});
};
+# generated with: ./bin/bibspace routes | grep GET | grep -v :
+my @pages = (
+ $self->url_for('publications'), $self->url_for('recently_added', num => 10),
+ $self->url_for('recently_changed', num => 10),
+ $self->url_for('get_single_publication', id => 0),
+ $self->url_for('get_single_publication', id => $entry->id),
+ $self->url_for('toggle_hide_publication', id => $entry->id),
+ $self->url_for('toggle_hide_publication', id => 0),
+ $self->url_for('make_paper', id => $entry->id),
+ $self->url_for('make_talk', id => $entry->id),
-# generated with: ./bin/bibspace routes | grep GET | grep -v :
-my @pages = (
- $self->url_for('publications'),
- $self->url_for('recently_added', num=> 10),
- $self->url_for('recently_changed', num=> 10),
-
- $self->url_for('get_single_publication', id=>0),
- $self->url_for('get_single_publication', id=>$entry->id),
+ $self->url_for('make_paper', id => 0), $self->url_for('make_talk', id => 0),
- $self->url_for('toggle_hide_publication', id=>$entry->id),
- $self->url_for('toggle_hide_publication', id=>0),
+ $self->url_for('edit_publication', id => $entry->id),
+ $self->url_for('edit_publication', id => 0),
- $self->url_for('make_paper', id=>$entry->id),
- $self->url_for('make_talk', id=>$entry->id),
+ $self->url_for('regenerate_publication', id => $entry->id),
+ $self->url_for('regenerate_publication', id => 0),
- $self->url_for('make_paper', id=>0),
- $self->url_for('make_talk', id=>0),
+ $self->url_for('get_untagged_publications', tagtype => 1)
+ ->query(author => $author->id),
+ $self->url_for('get_untagged_publications', tagtype => 1)
+ ->query(author => 'NotExistingAuthor'),
- $self->url_for('edit_publication', id=>$entry->id),
- $self->url_for('edit_publication', id=>0),
+ $self->url_for('discover_attachments', id => $entry->id),
+ $self->url_for('discover_attachments', id => 0),
- $self->url_for('regenerate_publication', id=>$entry->id),
- $self->url_for('regenerate_publication', id=>0),
-
- $self->url_for('get_untagged_publications', tagtype=>1)->query(author=>$author->id),
- $self->url_for('get_untagged_publications', tagtype=>1)->query(author=>'NotExistingAuthor'),
+ "/publications/missing_month", "/publications/candidates_to_delete",
- $self->url_for('discover_attachments', id=>$entry->id),
- $self->url_for('discover_attachments', id=>0),
-
-
- "/publications/missing_month",
- "/publications/candidates_to_delete",
+ $self->url_for('all_orphaned'), $self->url_for('delete_orphaned'),
-
- $self->url_for('all_orphaned'),
- $self->url_for('delete_orphaned'),
-
-
$self->url_for('regenerate_html_for_all'),
- $self->url_for('mark_author_to_regenerate', author_id => $author->id),
- $self->url_for('regenerate_html_in_chunk', chunk_size => 3),
+ $self->url_for('mark_author_to_regenerate', author_id => $author->id),
+ $self->url_for('regenerate_html_in_chunk', chunk_size => 3),
$self->url_for('mark_all_to_regenerate'),
-
- $self->url_for('fix_attachment_urls'),
- $self->url_for('clean_ugly_bibtex'),
+ $self->url_for('fix_attachment_urls'), $self->url_for('clean_ugly_bibtex'),
$self->url_for('fix_all_months'),
- $self->url_for('unrelated_papers_for_team', teamid=>$team->id),
-
- # $self->url_for('download_publication', filetype=>'paper', id=>$entry->id),
- # $self->url_for('publications_remove_attachment', filetype=>'paper', id=>$entry->id),
-
-
- $self->url_for('manage_tags', id=>0),
- $self->url_for('manage_tags', id=>$entry->id),
- $self->url_for('add_tag_to_publication', eid=>$entry->id , tid=>$tag->id),
- $self->url_for('remove_tag_from_publication', eid=>$entry->id , tid=>$tag->id),
-
- $self->url_for('manage_attachments', id=>0),
- $self->url_for('manage_attachments', id=>$entry->id),
-
- $self->url_for('fix_attachment_urls', id=>0),
- $self->url_for('fix_attachment_urls', id=>$entry->id),
-
- $self->url_for('manage_exceptions', id=>0),
- $self->url_for('manage_exceptions', id=>$entry->id),
-
- $self->url_for('add_exception_to_publication', eid=>$entry->id , tid=>$team->id),
- $self->url_for('add_exception_to_publication', eid=>0 , tid=>$team->id),
-
- $self->url_for('remove_exception_from_publication', eid=>$entry->id , tid=>$team->id),
- $self->url_for('remove_exception_from_publication', eid=>$entry->id , tid=>$team->id),
- $self->url_for('remove_exception_from_publication', eid=>0 , tid=>$team->id),
-
- $self->url_for('show_authors_of_entry', id=>0),
- $self->url_for('show_authors_of_entry', id=>$entry->id),
-
- $self->url_for('delete_publication_sure', id=>0),
- $self->url_for('delete_publication_sure', id=>$entry->id),
+ $self->url_for('unrelated_papers_for_team', teamid => $team->id),
+
+# $self->url_for('download_publication', filetype=>'paper', id=>$entry->id),
+# $self->url_for('publications_remove_attachment', filetype=>'paper', id=>$entry->id),
+
+ $self->url_for('manage_tags', id => 0),
+ $self->url_for('manage_tags', id => $entry->id),
+ $self->url_for('add_tag_to_publication', eid => $entry->id, tid => $tag->id),
+ $self->url_for(
+ 'remove_tag_from_publication',
+ eid => $entry->id,
+ tid => $tag->id
+ ),
+
+ $self->url_for('manage_attachments', id => 0),
+ $self->url_for('manage_attachments', id => $entry->id),
+
+ $self->url_for('fix_attachment_urls', id => 0),
+ $self->url_for('fix_attachment_urls', id => $entry->id),
+
+ $self->url_for('manage_exceptions', id => 0),
+ $self->url_for('manage_exceptions', id => $entry->id),
+
+ $self->url_for(
+ 'add_exception_to_publication',
+ eid => $entry->id,
+ tid => $team->id
+ ),
+ $self->url_for('add_exception_to_publication', eid => 0, tid => $team->id),
+
+ $self->url_for(
+ 'remove_exception_from_publication',
+ eid => $entry->id,
+ tid => $team->id
+ ),
+ $self->url_for(
+ 'remove_exception_from_publication',
+ eid => $entry->id,
+ tid => $team->id
+ ),
+ $self->url_for(
+ 'remove_exception_from_publication',
+ eid => 0,
+ tid => $team->id
+ ),
+
+ $self->url_for('show_authors_of_entry', id => 0),
+ $self->url_for('show_authors_of_entry', id => $entry->id),
+
+ $self->url_for('delete_publication_sure', id => 0),
+ $self->url_for('delete_publication_sure', id => $entry->id),
);
####################################################################
# subtest 'loop over pages' => sub {
- for my $page (@pages){
- note "============ Testing page $page ============";
- $admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
- }
-# };
-
+for my $page (@pages) {
+ note "============ Testing page $page ============";
+ $admin_user->get_ok($page, "Get for page $page")
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
+}
+# };
ok(1);
done_testing();
diff --git a/t/200-controller/PublicationsExperimental.t b/t/200-controller/PublicationsExperimental.t
index e69a6d2..ae5f65b 100644
--- a/t/200-controller/PublicationsExperimental.t
+++ b/t/200-controller/PublicationsExperimental.t
@@ -4,30 +4,24 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
my $admin_user = Test::Mojo->new('BibSpace');
$admin_user->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
use BibSpace::TestManager;
TestManager->apply_fixture($admin_user->app);
-my $self = $admin_user->app;
+my $self = $admin_user->app;
my $app_config = $admin_user->app->config;
$admin_user->ua->max_redirects(3);
-
-
-
-
my $page = $self->url_for('add_many_publications');
- $admin_user->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page")->content_like(qr/You operate on an unsaved entry/i);
-
-
+$admin_user->get_ok($page, "Get for page $page")
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page")
+ ->content_like(qr/You operate on an unsaved entry/i);
my $multi_bib1 = '
@article{key-xxx1-2017,
@@ -71,12 +65,10 @@ my $multi_bib2 = '
day = {1--31},
}';
-$admin_user->post_ok(
- $self->url_for('add_many_publications_post') => form => {new_bib => $multi_bib1, preview => 1 }
-);
-$admin_user->post_ok(
- $self->url_for('add_many_publications_post') => form => {new_bib => $multi_bib2, save => 1 }
-);
+$admin_user->post_ok($self->url_for('add_many_publications_post') => form =>
+ {new_bib => $multi_bib1, preview => 1});
+$admin_user->post_ok($self->url_for('add_many_publications_post') => form =>
+ {new_bib => $multi_bib2, save => 1});
ok(1);
diff --git a/t/200-controller/Tags.t b/t/200-controller/Tags.t
index 0af63c7..dcb44a8 100644
--- a/t/200-controller/Tags.t
+++ b/t/200-controller/Tags.t
@@ -4,22 +4,19 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
my $admin_user = Test::Mojo->new('BibSpace');
$admin_user->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
-
-my $self = $admin_user->app;
+my $self = $admin_user->app;
my $app_config = $admin_user->app->config;
$admin_user->ua->max_redirects(3);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
# $logged_user->get('/tags/:type')->to( 'tags#index', type => 1 )->name('all_tags');
# $admin_user->get('/tags/add/:type')->to( 'tags#add', type => 1 )->name('add_tag_get');
# $admin_user->post('/tags/add/:type')->to( 'tags#add_post', type => 1 )->name('add_tag_post');
@@ -32,83 +29,86 @@ my @entries = $admin_user->app->repo->entries_all;
my $entry = shift @entries;
my $author = ($admin_user->app->repo->authors_all)[0];
my @teams = $admin_user->app->repo->teams_all;
-my $team = shift @teams;
+my $team = shift @teams;
my @tags = $admin_user->app->repo->tags_all;
-my $tag = shift @tags;
+my $tag = shift @tags;
-my @tagTypes = $admin_user->app->repo->tagTypes_all;
-my $tagType = shift @tagTypes;
+my @tagTypes = $admin_user->app->repo->tagTypes_all;
+my $tagType = shift @tagTypes;
my $page;
-foreach my $type (@tagTypes){
+foreach my $type (@tagTypes) {
my $typeID = $type->id;
- $page = $self->url_for('all_tags', type=>$typeID);
+ $page = $self->url_for('all_tags', type => $typeID);
note "============ Testing page $page ============";
$admin_user->get_ok($page, "Get for page $page")
->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+ ->status_isnt(500, "Checking: 500 $page");
- $page = $self->url_for('add_tag_get', type=>$typeID);
+ $page = $self->url_for('add_tag_get', type => $typeID);
note "============ Testing page $page ============";
$admin_user->get_ok($page, "Get for page $page")
->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
- # calling this like:
- # $admin_user->post_ok(
- # $self->url_for('add_tag_post', type=>$typeID) => form => {type => $typeID, new_tag => "test_tag_type_$typeID" }
- # );
- # causes to use totally wrong id provider!
+# calling this like:
+# $admin_user->post_ok(
+# $self->url_for('add_tag_post', type=>$typeID) => form => {type => $typeID, new_tag => "test_tag_type_$typeID" }
+# );
+# causes to use totally wrong id provider!
$admin_user->post_ok(
- $self->url_for('add_tag_post', type=>$typeID) => form => {new_tag => "test_tag_type_$typeID" }
- );
+ $self->url_for('add_tag_post', type => $typeID) => form =>
+ {new_tag => "test_tag_type_$typeID"});
$admin_user->post_ok(
- $self->url_for('add_tag_post', type=>$typeID) => form => {new_tag => "zz_$typeID;aa_$typeID;;test_tag2_type_$typeID" }
- );
-
+ $self->url_for('add_tag_post', type => $typeID) => form =>
+ {new_tag => "zz_$typeID;aa_$typeID;;test_tag2_type_$typeID"});
}
+foreach my $tag (@tags) {
-foreach my $tag (@tags){
-
- $page = $self->url_for('get_authors_for_tag', id=>$tag->id, type=>1);
+ $page = $self->url_for('get_authors_for_tag', id => $tag->id, type => 1);
note "============ Testing page $page ============";
$admin_user->get_ok($page, "Get for page $page")
+
# ->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
- $page = $self->url_for('get_authors_for_tag_and_team', tag_id=>$tag->id, team_id=>$team->id, type=>1);
+ $page = $self->url_for(
+ 'get_authors_for_tag_and_team',
+ tag_id => $tag->id,
+ team_id => $team->id,
+ type => 1
+ );
note "============ Testing page $page ============";
$admin_user->get_ok($page, "Get for page $page")
+
# ->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
- $page = $self->url_for('edit_tag', id=>$tag->id);
+ $page = $self->url_for('edit_tag', id => $tag->id);
note "============ Testing page $page ============";
$admin_user->get_ok($page, "Get for page $page")
->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
-
-};
+
+}
my $tag_del = shift @tags;
-$page = $self->url_for('delete_tag', id=>$tag_del->id);
+$page = $self->url_for('delete_tag', id => $tag_del->id);
note "============ Testing page $page ============";
$admin_user->get_ok($page, "Get for page $page")
->status_isnt(404, "Checking: 404 $page")
->status_isnt(500, "Checking: 500 $page");
-
####################################################################
# subtest 'aaa' => sub {
# };
####################################################################
-
ok(1);
done_testing();
diff --git a/t/300-functions/FPublications.t b/t/300-functions/FPublications.t
index 1eaaa6d..fe9b02a 100644
--- a/t/300-functions/FPublications.t
+++ b/t/300-functions/FPublications.t
@@ -4,8 +4,8 @@ use Test::Mojo;
my $t_logged_in = Test::Mojo->new('BibSpace');
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
@@ -14,39 +14,38 @@ TestManager->apply_fixture($self->app);
use BibSpace::Functions::FPublications;
-
####################################################################
subtest 'Fregenerate_html_for_array' => sub {
-
my @all_entries = $t_logged_in->app->repo->entries_all;
- say "There are ".scalar(@all_entries)." entries avaialble.";
+ say "There are " . scalar(@all_entries) . " entries avaialble.";
my $app = $t_logged_in->app;
my @entries = ($all_entries[0]);
- is( Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries), 1, "regen 1 entry ok");
+ is(Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries),
+ 1, "regen 1 entry ok");
- @entries = @all_entries[1..2];
- is( Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries), 2, "regen 2 entries ok");
+ @entries = @all_entries[1 .. 2];
+ is(Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries),
+ 2, "regen 2 entries ok");
- @entries = @all_entries[3..5];
- is( Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries), 3, "regen 3 entries ok");
+ @entries = @all_entries[3 .. 5];
+ is(Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries),
+ 3, "regen 3 entries ok");
@entries = ();
- is( Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries), 0, "regen 0 entries ok");
-
+ is(Fregenerate_html_for_array($app, 1, $app->bibtexConverter, \@entries),
+ 0, "regen 0 entries ok");
};
####################################################################
-
-
$t_logged_in->app->repo->entries_delete($t_logged_in->app->repo->entries_all);
-my @entries = $t_logged_in->app->repo->entries_all;
+my @entries = $t_logged_in->app->repo->entries_all;
my $num_entries = scalar(@entries);
is($num_entries, 0, "Got 0 entries");
@@ -75,19 +74,15 @@ $en4->{bib} = '@mastersthesis{zzzzz2,
$en4->populate_from_bib;
$t_logged_in->app->repo->entries_save($en4);
-
-
-@entries = $t_logged_in->app->repo->entries_all;
+@entries = $t_logged_in->app->repo->entries_all;
$num_entries = scalar(@entries);
my $en = $self->app->entityFactory->new_Entry();
-ok(defined $en, "MEntry initialized correctly");
+ok(defined $en, "MEntry initialized correctly");
ok($num_entries > 0, "Got more than 0 entries");
-
#### START fix months
-
#### single entry
$t_logged_in->app->repo->entries_delete($t_logged_in->app->repo->entries_all);
@@ -116,21 +111,15 @@ $en4->{bib} = '@mastersthesis{xxx2,
}';
$en4->populate_from_bib;
$t_logged_in->app->repo->entries_save($en4);
-@entries = $t_logged_in->app->repo->entries_all;
+@entries = $t_logged_in->app->repo->entries_all;
$num_entries = scalar(@entries);
-
-
-
-
-
-
### this will fail if the user gives a month name with a typo = bad test
-# for my $entry (@entries){
+# for my $entry (@entries){
# if($entry->bibtex_has('month')){
# my $month_bib = $entry->get_bibtex_field_value('month');
# if($month_bib ne ''){
-# my $month_digit = $entry->{month};
+# my $month_digit = $entry->{month};
# if($month_digit == 0){
# say $entry->{bib};
# }
@@ -140,5 +129,4 @@ $num_entries = scalar(@entries);
# }
#### END fix months
-
done_testing();
diff --git a/t/900-frontend/002_basic_gets.t b/t/900-frontend/002_basic_gets.t
index ca4cb64..e8cfa51 100644
--- a/t/900-frontend/002_basic_gets.t
+++ b/t/900-frontend/002_basic_gets.t
@@ -6,99 +6,74 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
my $t_logged_in = Test::Mojo->new('BibSpace');
-my $self = $t_logged_in->app;
+my $self = $t_logged_in->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
-
$self = $t_logged_in->app;
my $app_config = $t_logged_in->app->config;
$t_logged_in->ua->max_redirects(3);
-
my @all_tag_type_objs = $t_logged_in->app->repo->tagTypes_all;
my $some_tag_type_obj = $all_tag_type_objs[0];
-my @tags = $t_logged_in->app->repo->tags_filter(sub{ scalar($_->get_entries)>0 });
+my @tags
+ = $t_logged_in->app->repo->tags_filter(sub { scalar($_->get_entries) > 0 });
my $some_tag = $tags[0];
-my @tags_permalink = $t_logged_in->app->repo->tags_filter(sub{ defined $_->permalink and length($_->permalink)>1 });
+my @tags_permalink = $t_logged_in->app->repo->tags_filter(
+ sub { defined $_->permalink and length($_->permalink) > 1 });
my $some_permalink = $tags_permalink[0];
-my @teams = $t_logged_in->app->repo->teams_all;
+my @teams = $t_logged_in->app->repo->teams_all;
my $some_team = $teams[0];
-my @authors = $t_logged_in->app->repo->authors_filter(sub{ scalar($_->get_entries) > 0});
+my @authors
+ = $t_logged_in->app->repo->authors_filter(sub { scalar($_->get_entries) > 0 }
+ );
my $some_author = $authors[0];
-# generated with: ./bin/bibspace routes | grep GET | grep -v :
+# generated with: ./bin/bibspace routes | grep GET | grep -v :
my @pages = (
- $self->url_for('start'),
- $self->url_for('system_status'),
- "/forgot",
- "/login_form",
- "/youneedtologin",
- "/badpassword",
- "/logout",
- "/register",
- "/log",
-
-
- $self->url_for('add_publication'),
- $self->url_for('add_many_publications'),
- $self->url_for('recently_changed', num=>10),
- $self->url_for('recently_added', num=>10),
-
- $self->url_for('manage_users'),
- $self->url_for('fix_all_months'),
- $self->url_for('fix_attachment_urls'),
- $self->url_for('clean_ugly_bibtex'),
- $self->url_for('regenerate_html_for_all'),
-
- $self->url_for('fix_masters'),
-
- "/profile",
- "/backups",
- "/types",
- "/types/add",
- "/authors",
- "/authors/add",
- "/authors/reassign",
- "/authors/reassign_and_create",
- "/tagtypes",
- "/tagtypes/add",
- "/teams",
- "/teams/add",
- "/publications",
- $self->url_for('all_orphaned'),
- "/publications/candidates_to_delete",
- "/publications/missing_month",
- "/read/publications/meta",
- "/cron",
- "/cron/day",
- "/cron/night",
- "/cron/week",
- "/cron/month",
+ $self->url_for('start'), $self->url_for('system_status'), "/forgot",
+ "/login_form", "/youneedtologin", "/badpassword", "/logout", "/register",
+ "/log",
+
+ $self->url_for('add_publication'), $self->url_for('add_many_publications'),
+ $self->url_for('recently_changed', num => 10),
+ $self->url_for('recently_added', num => 10),
+
+ $self->url_for('manage_users'), $self->url_for('fix_all_months'),
+ $self->url_for('fix_attachment_urls'), $self->url_for('clean_ugly_bibtex'),
+ $self->url_for('regenerate_html_for_all'),
+
+ $self->url_for('fix_masters'),
+
+ "/profile", "/backups", "/types", "/types/add", "/authors", "/authors/add",
+ "/authors/reassign", "/authors/reassign_and_create", "/tagtypes",
+ "/tagtypes/add", "/teams", "/teams/add", "/publications",
+ $self->url_for('all_orphaned'), "/publications/candidates_to_delete",
+ "/publications/missing_month", "/read/publications/meta", "/cron",
+ "/cron/day", "/cron/night", "/cron/week", "/cron/month",
);
my $ws_page;
-$ws_page = $self->url_for('show_stats_websocket', num => 10);
+$ws_page = $self->url_for('show_stats_websocket', num => 10);
$t_logged_in->websocket_ok($ws_page, "Websocket OK for $ws_page");
-$ws_page = $self->url_for('show_log_websocket', num => 10);
+$ws_page = $self->url_for('show_log_websocket', num => 10);
$t_logged_in->websocket_ok($ws_page, "Websocket OK for $ws_page");
-for my $page (@pages){
- note "============ Testing page $page ============";
- $t_logged_in->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+for my $page (@pages) {
+ note "============ Testing page $page ============";
+ $t_logged_in->get_ok($page, "Get for page $page")
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
}
done_testing();
diff --git a/t/900-frontend/003_login.t b/t/900-frontend/003_login.t
index 7b0ca68..f462007 100644
--- a/t/900-frontend/003_login.t
+++ b/t/900-frontend/003_login.t
@@ -6,53 +6,44 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
-
my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $self = $t_anyone->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
####################################################################
subtest 'login: start page asking to login' => sub {
- $t_anyone->get_ok('/')->status_is(200);
- $t_anyone->get_ok('/logout')->status_isnt(404)->status_isnt(500);
- $t_anyone->get_ok('/')->status_is(200)->content_like(qr/Please login or register/i);
+ $t_anyone->get_ok('/')->status_is(200);
+ $t_anyone->get_ok('/logout')->status_isnt(404)->status_isnt(500);
+ $t_anyone->get_ok('/')->status_is(200)
+ ->content_like(qr/Please login or register/i);
};
-
####################################################################
subtest 'login: pub_admin bad password' => sub {
- $t_anyone->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'something_really_wrong' }
- );
+ $t_anyone->post_ok(
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'something_really_wrong'}
+ );
- $t_anyone->get_ok('/')
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Wrong user\s*name or password/i); # accepts username and user name
+ $t_anyone->get_ok('/')->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Wrong user\s*name or password/i)
+ ; # accepts username and user name
};
-
-
####################################################################
subtest 'login: pub_admin login' => sub {
- $t_anyone->ua->max_redirects(10);
- $t_anyone->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
- );
+ $t_anyone->ua->max_redirects(10);
+ $t_anyone->post_ok(
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
+ );
- $t_anyone->get_ok('/')
- ->status_isnt(404)->status_isnt(500)
- ->content_like(qr/Nice to see you here/i);
+ $t_anyone->get_ok('/')->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Nice to see you here/i);
};
-
-
-
done_testing();
diff --git a/t/900-frontend/004_landing_publications.t b/t/900-frontend/004_landing_publications.t
index efdf348..18b645f 100644
--- a/t/900-frontend/004_landing_publications.t
+++ b/t/900-frontend/004_landing_publications.t
@@ -6,93 +6,107 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
my $t_logged_in = Test::Mojo->new('BibSpace');
-my $self = $t_logged_in->app;
+my $self = $t_logged_in->app;
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
-
$self = $t_logged_in->app;
my $app_config = $t_logged_in->app->config;
$t_logged_in->ua->max_redirects(3);
-
my @all_tag_type_objs = $t_logged_in->app->repo->tagTypes_all;
my $some_tag_type_obj = $all_tag_type_objs[0];
-my @tags = $t_logged_in->app->repo->tags_filter(sub{ scalar($_->get_entries)>0 });
+my @tags
+ = $t_logged_in->app->repo->tags_filter(sub { scalar($_->get_entries) > 0 });
my $some_tag = $tags[0];
-my @tags_permalink = $t_logged_in->app->repo->tags_filter(sub{ defined $_->permalink and length($_->permalink)>1 });
+my @tags_permalink = $t_logged_in->app->repo->tags_filter(
+ sub { defined $_->permalink and length($_->permalink) > 1 });
my $some_permalink = $tags_permalink[0];
-my @teams = $t_logged_in->app->repo->teams_all;
+my @teams = $t_logged_in->app->repo->teams_all;
my $some_team = $teams[0];
-my @authors = $t_logged_in->app->repo->authors_filter(sub{ scalar($_->get_entries) > 0});
+my @authors
+ = $t_logged_in->app->repo->authors_filter(sub { scalar($_->get_entries) > 0 }
+ );
my $some_author = $authors[0];
-# generated with: ./bin/bibspace routes | grep GET | grep -v :
+# generated with: ./bin/bibspace routes | grep GET | grep -v :
my @pages = (
- "/read/publications",
- "/r/publications",
- "/r/p",
- "/read/bibtex",
- "/r/bibtex",
- "/r/b",
- $self->url_for('lp'),
- $self->url_for('lp')->query(entry_type => 'paper'),
- $self->url_for('lp')->query(entry_type => 'paper', author => $some_author->uid),
- $self->url_for('lp')->query(entry_type => 'paper', author => $some_author->id),
- $self->url_for('lp')->query(entry_type => 'paper', team => $some_team->name),
- $self->url_for('lp')->query(entry_type => 'paper', team => $some_team->id),
- $self->url_for('lp')->query(entry_type => 'paper', tag => $some_tag->name),
- $self->url_for('lp')->query(entry_type => 'paper', tag => $some_tag->id),
- $self->url_for('lp')->query(entry_type => 'paper', tag => 'not-existing'),
- $self->url_for('lp')->query(entry_type => 'paper', permalink => $some_permalink->name),
- $self->url_for('lp')->query(entry_type => 'paper', permalink => $some_permalink->id),
- $self->url_for('lp')->query(entry_type => 'paper', permalink => 'not-existing'),
- $self->url_for('lp')->query(entry_type => 'paper', bibtex_type => 'inproceedings'),
- $self->url_for('lp')->query(entry_type => 'talk'),
-
- $self->url_for('lyp'),
- $self->url_for('lyp')->query(entry_type => 'paper'),
- $self->url_for('lyp')->query(entry_type => 'paper', author => $some_author->uid),
- $self->url_for('lyp')->query(entry_type => 'paper', author => $some_author->id),
- $self->url_for('lyp')->query(entry_type => 'paper', team => $some_team->name),
- $self->url_for('lyp')->query(entry_type => 'paper', team => $some_team->id),
- $self->url_for('lyp')->query(entry_type => 'paper', tag => $some_tag->name),
- $self->url_for('lyp')->query(entry_type => 'paper', tag => $some_tag->id),
- $self->url_for('lyp')->query(entry_type => 'paper', tag => 'not-existing'),
- $self->url_for('lyp')->query(entry_type => 'paper', permalink => $some_permalink->name),
- $self->url_for('lyp')->query(entry_type => 'paper', permalink => $some_permalink->id),
- $self->url_for('lyp')->query(entry_type => 'paper', permalink => 'not-existing'),
- $self->url_for('lyp')->query(entry_type => 'paper', bibtex_type => 'inproceedings'),
- $self->url_for('lyp')->query(entry_type => 'talk'),
-
-
- $self->url_for('get_authors_for_tag', id=>$some_tag->id, type=>$some_tag_type_obj->id),
- $self->url_for('get_authors_for_tag_and_team', tag_id=>$some_tag->id, team_id=>$some_team->id),
+ "/read/publications", "/r/publications", "/r/p", "/read/bibtex", "/r/bibtex",
+ "/r/b", $self->url_for('lp'),
+ $self->url_for('lp')->query(entry_type => 'paper'),
+ $self->url_for('lp')
+ ->query(entry_type => 'paper', author => $some_author->uid),
+ $self->url_for('lp')
+ ->query(entry_type => 'paper', author => $some_author->id),
+ $self->url_for('lp')->query(entry_type => 'paper', team => $some_team->name),
+ $self->url_for('lp')->query(entry_type => 'paper', team => $some_team->id),
+ $self->url_for('lp')->query(entry_type => 'paper', tag => $some_tag->name),
+ $self->url_for('lp')->query(entry_type => 'paper', tag => $some_tag->id),
+ $self->url_for('lp')->query(entry_type => 'paper', tag => 'not-existing'),
+ $self->url_for('lp')
+ ->query(entry_type => 'paper', permalink => $some_permalink->name),
+ $self->url_for('lp')
+ ->query(entry_type => 'paper', permalink => $some_permalink->id),
+ $self->url_for('lp')
+ ->query(entry_type => 'paper', permalink => 'not-existing'),
+ $self->url_for('lp')
+ ->query(entry_type => 'paper', bibtex_type => 'inproceedings'),
+ $self->url_for('lp')->query(entry_type => 'talk'),
+
+ $self->url_for('lyp'), $self->url_for('lyp')->query(entry_type => 'paper'),
+ $self->url_for('lyp')
+ ->query(entry_type => 'paper', author => $some_author->uid),
+ $self->url_for('lyp')
+ ->query(entry_type => 'paper', author => $some_author->id),
+ $self->url_for('lyp')->query(entry_type => 'paper', team => $some_team->name),
+ $self->url_for('lyp')->query(entry_type => 'paper', team => $some_team->id),
+ $self->url_for('lyp')->query(entry_type => 'paper', tag => $some_tag->name),
+ $self->url_for('lyp')->query(entry_type => 'paper', tag => $some_tag->id),
+ $self->url_for('lyp')->query(entry_type => 'paper', tag => 'not-existing'),
+ $self->url_for('lyp')
+ ->query(entry_type => 'paper', permalink => $some_permalink->name),
+ $self->url_for('lyp')
+ ->query(entry_type => 'paper', permalink => $some_permalink->id),
+ $self->url_for('lyp')
+ ->query(entry_type => 'paper', permalink => 'not-existing'),
+ $self->url_for('lyp')
+ ->query(entry_type => 'paper', bibtex_type => 'inproceedings'),
+ $self->url_for('lyp')->query(entry_type => 'talk'),
+
+ $self->url_for(
+ 'get_authors_for_tag',
+ id => $some_tag->id,
+ type => $some_tag_type_obj->id
+ ),
+ $self->url_for(
+ 'get_authors_for_tag_and_team',
+ tag_id => $some_tag->id,
+ team_id => $some_team->id
+ ),
);
my $ws_page;
-$ws_page = $self->url_for('show_stats_websocket', num => 10);
+$ws_page = $self->url_for('show_stats_websocket', num => 10);
$t_logged_in->websocket_ok($ws_page, "Websocket OK for $ws_page");
-$ws_page = $self->url_for('show_log_websocket', num => 10);
+$ws_page = $self->url_for('show_log_websocket', num => 10);
$t_logged_in->websocket_ok($ws_page, "Websocket OK for $ws_page");
-for my $page (@pages){
- note "============ Testing page $page ============";
- $t_logged_in->get_ok($page, "Get for page $page")
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page");
+for my $page (@pages) {
+ note "============ Testing page $page ============";
+ $t_logged_in->get_ok($page, "Get for page $page")
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
}
done_testing();
diff --git a/t/900-frontend/004_publications_single.t b/t/900-frontend/004_publications_single.t
index caacc68..905b08d 100644
--- a/t/900-frontend/004_publications_single.t
+++ b/t/900-frontend/004_publications_single.t
@@ -11,8 +11,12 @@ my $num_publications_limit = 5;
# plan tests => 1 + 9 * 3 * $num_publications_limit;
my $t_logged_in = Test::Mojo->new('BibSpace');
-$t_logged_in->post_ok( '/do_login' => { Accept => '*/*' }, form => { user => 'pub_admin', pass => 'asdf' } );
+$t_logged_in->post_ok(
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
+);
my $self = $t_logged_in->app;
+
# this is crucial for the test to pass as there are redirects here!
$t_logged_in->ua->max_redirects(3);
$t_logged_in->ua->inactivity_timeout(3600);
@@ -20,38 +24,36 @@ $t_logged_in->ua->inactivity_timeout(3600);
use BibSpace::TestManager;
TestManager->apply_fixture($self->app);
-
-
####################################################################
subtest 'Checking pages for single publication' => sub {
+
# local $TODO = "Testing gets for single publications";
- my @entries = $t_logged_in->app->repo->entries_all;
- my $size = scalar(@entries);
+ my @entries = $t_logged_in->app->repo->entries_all;
+ my $size = scalar(@entries);
$num_publications_limit = $size if $size < $num_publications_limit;
my $num_done = 0;
-
- while ( $num_done < $num_publications_limit ) {
- my $e = $entries[$num_done];
- my $id = $e->id;
+ while ($num_done < $num_publications_limit) {
+ my $e = $entries[$num_done];
+ my $id = $e->id;
my @pages = (
- $self->url_for( 'get_single_publication', id => $id ),
- $self->url_for( 'get_single_publication_read', id => $id ),
- $self->url_for( 'edit_publication', id => $id ),
- $self->url_for( 'regenerate_publication', id => $id ),
- $self->url_for( 'manage_attachments', id => $id ),
- $self->url_for( 'manage_tags', id => $id ),
- $self->url_for( 'manage_exceptions', id => $id ),
- $self->url_for( 'show_authors_of_entry', id => $id ),
- $self->url_for( 'metalist_entry', id => $id ),
+ $self->url_for('get_single_publication', id => $id),
+ $self->url_for('get_single_publication_read', id => $id),
+ $self->url_for('edit_publication', id => $id),
+ $self->url_for('regenerate_publication', id => $id),
+ $self->url_for('manage_attachments', id => $id),
+ $self->url_for('manage_tags', id => $id),
+ $self->url_for('manage_exceptions', id => $id),
+ $self->url_for('show_authors_of_entry', id => $id),
+ $self->url_for('metalist_entry', id => $id),
);
for my $page (@pages) {
note "============ Testing page $page for paper id $id ============";
- $t_logged_in->get_ok( $page, "Checking: OK $page" )
- ->status_isnt( 404, "Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" );
+ $t_logged_in->get_ok($page, "Checking: OK $page")
+ ->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
}
++$num_done;
@@ -61,4 +63,3 @@ subtest 'Checking pages for single publication' => sub {
ok(1);
done_testing();
-
diff --git a/t/900-frontend/005_SEO_public.t b/t/900-frontend/005_SEO_public.t
index 6ac68b5..e6b0f55 100644
--- a/t/900-frontend/005_SEO_public.t
+++ b/t/900-frontend/005_SEO_public.t
@@ -6,7 +6,6 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
my $t_anyone = Test::Mojo->new('BibSpace');
$t_anyone->ua->max_redirects(10);
$t_anyone->ua->inactivity_timeout(3600);
@@ -21,44 +20,41 @@ TestManager->apply_fixture($self->app);
####################################################################
subtest 'PublicationsSEO: public functions' => sub {
- my @entries = $self->app->repo->entries_all;
- my $main_SEOpage = $self->url_for('metalist_all_entries');
- $t_anyone->get_ok($main_SEOpage)
- ->status_isnt( 404, "Checking: 404 $main_SEOpage" )
- ->status_isnt( 500, "Checking: 500 $main_SEOpage" );
-
- for my $e (@entries) {
- note
- "============ Testing SEO page for entry id $e->{id} ============";
- my $entry_id = $e->id;
- my $page = $self->url_for( 'metalist_entry', id => $entry_id );
-
- if ( !$e->is_hidden() ) {
- $t_anyone->get_ok($page)
- ->status_isnt( 404, "HIDDEN==FALSE Checking: 404 $page" )
- ->status_isnt( 500, "Checking: 500 $page" )
- ->status_isnt( 503, "Checking: 503 $page" );
- }
- else {
- $t_anyone->get_ok($page)
- ->status_is( 404, "HIDDEN==TRUE Checking: 404 $page" );
- my $str_that_should_not_be
- = "Paper ID $entry_id: get_ok($main_SEOpage)->status_is(200)
- ->content_unlike(qr/$str_that_should_not_be/i)
- ; ### this is slow!!!
-
- }
+ my @entries = $self->app->repo->entries_all;
+ my $main_SEOpage = $self->url_for('metalist_all_entries');
+ $t_anyone->get_ok($main_SEOpage)
+ ->status_isnt(404, "Checking: 404 $main_SEOpage")
+ ->status_isnt(500, "Checking: 500 $main_SEOpage");
+
+ for my $e (@entries) {
+ note "============ Testing SEO page for entry id $e->{id} ============";
+ my $entry_id = $e->id;
+ my $page = $self->url_for('metalist_entry', id => $entry_id);
+
+ if (!$e->is_hidden()) {
+ $t_anyone->get_ok($page)
+ ->status_isnt(404, "HIDDEN==FALSE Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page")
+ ->status_isnt(503, "Checking: 503 $page");
+ }
+ else {
+ $t_anyone->get_ok($page)
+ ->status_is(404, "HIDDEN==TRUE Checking: 404 $page");
+ my $str_that_should_not_be = "Paper ID $entry_id: get_ok($main_SEOpage)->status_is(200)
+ ->content_unlike(qr/$str_that_should_not_be/i); ### this is slow!!!
}
+
+ }
};
####################################################################
####################################################################
subtest 'PublicationsSEO: check decoding of the list' => sub {
- my $main_page = $self->url_for('metalist_all_entries');
- $t_anyone->get_ok($main_page)->status_is(200)->content_unlike(qr/\{/i);
+ my $main_page = $self->url_for('metalist_all_entries');
+ $t_anyone->get_ok($main_page)->status_is(200)->content_unlike(qr/\{/i);
};
ok(1);
diff --git a/t/900-frontend/006_tag_clouds.t b/t/900-frontend/006_tag_clouds.t
index 759b872..87ea847 100644
--- a/t/900-frontend/006_tag_clouds.t
+++ b/t/900-frontend/006_tag_clouds.t
@@ -6,10 +6,8 @@ use Test::Mojo;
use BibSpace;
use BibSpace::Functions::Core;
-
-
my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $self = $t_anyone->app;
$t_anyone->ua->inactivity_timeout(3600);
$t_anyone->ua->max_redirects(10);
@@ -21,36 +19,30 @@ my @all_teams = $self->app->repo->teams_all;
####################################################################
subtest 'FRONTEND Tag Clouds TEAMS' => sub {
-
- plan 'skip_all' => "There are no teams"
- if scalar @all_teams == 0;
- foreach my $team (@all_teams){
- my $page = $self->url_for('tags_for_team', team_id=>$team->id);
- $t_anyone->get_ok($page)->status_isnt(404, "Checking: 404 $page")->status_isnt(500, "Checking: 500 $page");
+ plan 'skip_all' => "There are no teams" if scalar @all_teams == 0;
+
+ foreach my $team (@all_teams) {
+ my $page = $self->url_for('tags_for_team', team_id => $team->id);
+ $t_anyone->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page");
}
};
-
-
my @all_authors = $self->app->repo->authors_all;
####################################################################
subtest 'FRONTEND Tag Clouds AUTHOR' => sub {
-
- plan 'skip_all' => "There are no authors"
- if scalar @all_authors == 0;
-
- foreach my $author (@all_authors){
- my $page = $self->url_for( 'tags_for_author', author_id=>$author->id );
- $t_anyone->get_ok($page)
- ->status_isnt(404, "Checking: 404 $page")
- ->status_isnt(500, "Checking: 500 $page")
- ->content_unlike(qr/-1/i);
+
+ plan 'skip_all' => "There are no authors" if scalar @all_authors == 0;
+
+ foreach my $author (@all_authors) {
+ my $page = $self->url_for('tags_for_author', author_id => $author->id);
+ $t_anyone->get_ok($page)->status_isnt(404, "Checking: 404 $page")
+ ->status_isnt(500, "Checking: 500 $page")->content_unlike(qr/-1/i);
}
};
-
done_testing();
diff --git a/t/900-frontend/007_user_management_anyone.t b/t/900-frontend/007_user_management_anyone.t
index c7b3bfc..af1bf6b 100644
--- a/t/900-frontend/007_user_management_anyone.t
+++ b/t/900-frontend/007_user_management_anyone.t
@@ -1,6 +1,5 @@
use Mojo::Base -strict;
-
use Test::More;
use Test::Mojo;
@@ -11,17 +10,15 @@ use BibSpace::Model::User;
### Problem with this test suite is that the token for mailgun returns error because it is not correct in the default config
### We need to find a method to test this without providing the real credentials
-
-
# # ############################ PREPARATION
my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
+my $self = $t_anyone->app;
$t_anyone->ua->max_redirects(10);
use BibSpace::TestManager;
TestManager->apply_fixture($t_anyone->app);
-# # ############################ READY FOR TESTING
+# # ############################ READY FOR TESTING
my $token = generate_token();
ok(defined $token);
@@ -29,28 +26,32 @@ is(length($token), 32);
########################################################
-
-
subtest 'Requesting password reset' => sub {
-note "============ FORGOT GEN 1 ============";
-$t_anyone->post_ok('/forgot/gen' => { Accept => '*/*' }, form => { user => 'pub_admin' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Email with password reset instructions has been sent/i, "Filling forgot with login");
-
-note "============ FORGOT GEN 2 ============";
-$t_anyone->post_ok('/forgot/gen' => { Accept => '*/*' }, form => { user => '', email => 'pub_admin@example.com' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Email with password reset instructions has been sent/i, "Filling forgot with email");
-
-note "============ FORGOT GEN 3 ============";
-
-$t_anyone->post_ok('/forgot/gen' => form => { user => 'qwerty1234', email => '' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/User 'qwerty1234' or email '' does not exist. Try again./i, "Filling forgot with bad data");
+ note "============ FORGOT GEN 1 ============";
+ $t_anyone->post_ok(
+ '/forgot/gen' => {Accept => '*/*'},
+ form => {user => 'pub_admin'}
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Email with password reset instructions has been sent/i,
+ "Filling forgot with login");
+
+ note "============ FORGOT GEN 2 ============";
+ $t_anyone->post_ok(
+ '/forgot/gen' => {Accept => '*/*'},
+ form => {user => '', email => 'pub_admin@example.com'}
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Email with password reset instructions has been sent/i,
+ "Filling forgot with email");
+
+ note "============ FORGOT GEN 3 ============";
+
+ $t_anyone->post_ok(
+ '/forgot/gen' => form => {user => 'qwerty1234', email => ''})
+ ->status_isnt(404)->status_isnt(500)
+ ->content_like(
+ qr/User 'qwerty1234' or email '' does not exist. Try again./i,
+ "Filling forgot with bad data");
};
note "============ SET NEW PW ============";
@@ -59,131 +60,140 @@ note "============ SET NEW PW ============";
subtest 'Setting new password' => sub {
- #requesting new token in cas it does not exist
- $t_anyone->post_ok('/forgot/gen' => { Accept => '*/*' }, form => { user => 'pub_admin' });
+ #requesting new token in cas it does not exist
+ $t_anyone->post_ok(
+ '/forgot/gen' => {Accept => '*/*'},
+ form => {user => 'pub_admin'}
+ );
- my $user = $t_anyone->app->repo->users_find(sub{$_->login eq 'pub_admin'});
- my $token2 = $user->forgot_token;
+ my $user = $t_anyone->app->repo->users_find(sub { $_->login eq 'pub_admin' });
+ my $token2 = $user->forgot_token;
- ok($token2, "Checking token exists");
- is(length($token2), 32, "Checking token length");
+ ok($token2, "Checking token exists");
+ is(length($token2), 32, "Checking token length");
- my $page = $t_anyone->app->url_for( 'token_clicked', token => $token2 );
- $t_anyone->get_ok($page)->status_is(200);
+ my $page = $t_anyone->app->url_for('token_clicked', token => $token2);
+ $t_anyone->get_ok($page)->status_is(200);
-
- # not matching passwords
- $t_anyone->post_ok('/forgot/store' => form => { token => $token2, pass1 => 'asdf', pass2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Passwords are not same or do not obey the password policy./i, "Trying with non-matching passwords");
-
- # matching passwords
- $t_anyone->post_ok('/forgot/store' => form => { token => $token2, pass1 => 'asdf', pass2 => 'asdf' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Password change successful. All your password reset tokens have been removed. You may login now./i, "Trying with valid data");
-
- # wrong token
- $t_anyone->post_ok('/forgot/store' => form => { token => 'invalid_token', pass1 => 'asdf', pass2 => 'asdf' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Reset password token is invalid!/i, "Trying invalid token");
+ # not matching passwords
+ $t_anyone->post_ok('/forgot/store' => form =>
+ {token => $token2, pass1 => 'asdf', pass2 => 'qwerty'})->status_isnt(404)
+ ->status_isnt(500)
+ ->content_like(
+ qr/Passwords are not same or do not obey the password policy./i,
+ "Trying with non-matching passwords");
+
+ # matching passwords
+ $t_anyone->post_ok('/forgot/store' => form =>
+ {token => $token2, pass1 => 'asdf', pass2 => 'asdf'})->status_isnt(404)
+ ->status_isnt(500)->content_like(
+ qr/Password change successful. All your password reset tokens have been removed. You may login now./i,
+ "Trying with valid data"
+ );
+
+ # wrong token
+ $t_anyone->post_ok('/forgot/store' => form =>
+ {token => 'invalid_token', pass1 => 'asdf', pass2 => 'asdf'})
+ ->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Reset password token is invalid!/i,
+ "Trying invalid token");
};
########################################################
note "============ Registration anyone ============";
-$t_anyone->get_ok("/noregister")
- ->status_is(200)
- ->content_like(qr/Registration is disabled/i);
-
-
-
+$t_anyone->get_ok("/noregister")->status_is(200)
+ ->content_like(qr/Registration is disabled/i);
####################################################################
subtest 'User management: public registration' => sub {
- if( $t_anyone->app->config->{registration_enabled} == 1){
+ if ($t_anyone->app->config->{registration_enabled} == 1) {
my $token = generate_token;
note "=== Registration anyone: using token $token";
-
- $t_anyone->get_ok("/register")
- ->status_is(200)
- ->content_unlike(qr/Registration is disabled/i)
- ->text_is(label => "Login", "Admin is trying to register a user");
-
-
- $t_anyone->post_ok('/register' => form => {
- login => $token,
- name => 'Henry',
- email => 'h@example.com',
- password1 => 'asdf',
- password2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Passwords don't match!/i, "Trying to register with non-matching passwords");
-
- $t_anyone->post_ok('/register' => form => {
- login => $token,
- name => 'Henry',
- email => 'h@example.com',
- password1 => 'a',
- password2 => 'a' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Password is too short, use minimum 4 symbols/i, "Trying to register with too short password");
-
- $t_anyone->post_ok('/register' => form => {
- login => '',
- name => '',
- email => 'h@example.com',
- password1 => 'a1234',
- password2 => 'a1234' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Login is missing/i, "Trying to register with missing login and email");
-
- $t_anyone->post_ok('/register' => form => {
- login => 'Henry John',
- name => '',
- email => '',
- password1 => 'a1234',
- password2 => 'a1234' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Email is missing/i, "Trying to register with missing login and email");
-
-
- $t_anyone->post_ok('/register' => form => {
- login => $token,
- name => 'Henry John',
- email => $token.'@example.com',
- password1 => 'qwerty',
- password2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/User created successfully! You may now login using login: $token/i, "Trying to register with valid data");
-
- $t_anyone->post_ok('/register' => form => {
- login => 'pub_admin',
- name => 'Henry John',
- email => $token.'@example.com',
- password1 => 'qwerty',
- password2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/This login is already taken/i, "Trying to register pub_admin");
+ $t_anyone->get_ok("/register")->status_is(200)
+ ->content_unlike(qr/Registration is disabled/i)
+ ->text_is(label => "Login", "Admin is trying to register a user");
+
+ $t_anyone->post_ok(
+ '/register' => form => {
+ login => $token,
+ name => 'Henry',
+ email => 'h@example.com',
+ password1 => 'asdf',
+ password2 => 'qwerty'
+ }
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Passwords don't match!/i,
+ "Trying to register with non-matching passwords");
+
+ $t_anyone->post_ok(
+ '/register' => form => {
+ login => $token,
+ name => 'Henry',
+ email => 'h@example.com',
+ password1 => 'a',
+ password2 => 'a'
+ }
+ )->status_isnt(404)->status_isnt(500)->content_like(
+ qr/Password is too short, use minimum 4 symbols/i,
+ "Trying to register with too short password"
+ );
+
+ $t_anyone->post_ok(
+ '/register' => form => {
+ login => '',
+ name => '',
+ email => 'h@example.com',
+ password1 => 'a1234',
+ password2 => 'a1234'
+ }
+ )->status_isnt(404)->status_isnt(500)->content_like(qr/Login is missing/i,
+ "Trying to register with missing login and email");
+
+ $t_anyone->post_ok(
+ '/register' => form => {
+ login => 'Henry John',
+ name => '',
+ email => '',
+ password1 => 'a1234',
+ password2 => 'a1234'
+ }
+ )->status_isnt(404)->status_isnt(500)->content_like(qr/Email is missing/i,
+ "Trying to register with missing login and email");
+
+ $t_anyone->post_ok(
+ '/register' => form => {
+ login => $token,
+ name => 'Henry John',
+ email => $token . '@example.com',
+ password1 => 'qwerty',
+ password2 => 'qwerty'
+ }
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(
+ qr/User created successfully! You may now login using login: $token/i,
+ "Trying to register with valid data");
+
+ $t_anyone->post_ok(
+ '/register' => form => {
+ login => 'pub_admin',
+ name => 'Henry John',
+ email => $token . '@example.com',
+ password1 => 'qwerty',
+ password2 => 'qwerty'
+ }
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/This login is already taken/i,
+ "Trying to register pub_admin");
}
- else{
+ else {
ok(1);
}
};
-
-
ok(1);
-
+
done_testing();
diff --git a/t/900-frontend/008_user_management_logged.t b/t/900-frontend/008_user_management_logged.t
index 2b70600..61d3291 100644
--- a/t/900-frontend/008_user_management_logged.t
+++ b/t/900-frontend/008_user_management_logged.t
@@ -1,6 +1,5 @@
use Mojo::Base -strict;
-
use Test::More;
use Test::Mojo;
@@ -11,21 +10,19 @@ use BibSpace::Model::User;
### Problem with this test suite is that the token for mailgun returns error because it is not correct in the default config
### We need to find a method to test this without providing the real credentials
-
-
# # ############################ PREPARATION
my $t_logged_in = Test::Mojo->new('BibSpace');
$t_logged_in->post_ok(
- '/do_login' => { Accept => '*/*' },
- form => { user => 'pub_admin', pass => 'asdf' }
+ '/do_login' => {Accept => '*/*'},
+ form => {user => 'pub_admin', pass => 'asdf'}
);
my $self = $t_logged_in->app;
$t_logged_in->ua->max_redirects(10);
use BibSpace::TestManager;
TestManager->apply_fixture($t_logged_in->app);
-# # ############################ READY FOR TESTING
+# # ############################ READY FOR TESTING
my $token = generate_token();
ok(defined $token);
@@ -33,80 +30,82 @@ is(length($token), 32);
########################################################
-
-
####################################################################
subtest 'User management: noregister' => sub {
- $t_logged_in->get_ok("/noregister")
- ->status_is(200)
+ $t_logged_in->get_ok("/noregister")->status_is(200)
->content_like(qr/Registration is disabled/i);
};
-
####################################################################
subtest 'User management: admin registration' => sub {
-
- my $token = generate_token;
- note "=== Registration admin: using token $token";
-
- $t_logged_in->get_ok("/register")
- ->status_is(200)
- ->content_unlike(qr/Registration is disabled/i)
- ->text_is(label => "Login", , "Admin is trying to register a user");
-
-
- $t_logged_in->post_ok('/register' => form => {
- login => $token,
- name => 'Henry',
- email => 'h@example.com',
- password1 => 'asdf',
- password2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Passwords don't match!/i, "Trying to register with non-matching passwords");
-
- $t_logged_in->post_ok('/register' => form => {
- login => $token,
- name => 'Henry',
- email => 'h@example.com',
- password1 => 'a',
- password2 => 'a' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Password is too short, use minimum 4 symbols/i, "Trying to register with too short password");
-
- $t_logged_in->post_ok('/register' => form => {
- login => '',
- name => '',
- email => 'h@example.com',
- password1 => 'a1234',
- password2 => 'a1234' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/Login is missing/i, "Trying to register with missing login and email");
-
-
-
- $t_logged_in->post_ok('/register' => form => {
- login => $token,
- name => 'Henry John',
- email => $token.'@example.com',
- password1 => 'qwerty',
- password2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/User created successfully! You may now login using login: $token/i, "Trying to register with valid data");
-
- $t_logged_in->post_ok('/register' => form => {
- login => 'pub_admin',
- name => 'Henry John',
- email => $token.'@example.com',
- password1 => 'qwerty',
- password2 => 'qwerty' })
- ->status_isnt(404)
- ->status_isnt(500)
- ->content_like(qr/This login is already taken/i, "Trying to register pub_admin");
+ my $token = generate_token;
+ note "=== Registration admin: using token $token";
+
+ $t_logged_in->get_ok("/register")->status_is(200)
+ ->content_unlike(qr/Registration is disabled/i)
+ ->text_is(label => "Login", "Admin is trying to register a user");
+
+ $t_logged_in->post_ok(
+ '/register' => form => {
+ login => $token,
+ name => 'Henry',
+ email => 'h@example.com',
+ password1 => 'asdf',
+ password2 => 'qwerty'
+ }
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/Passwords don't match!/i,
+ "Trying to register with non-matching passwords");
+
+ $t_logged_in->post_ok(
+ '/register' => form => {
+ login => $token,
+ name => 'Henry',
+ email => 'h@example.com',
+ password1 => 'a',
+ password2 => 'a'
+ }
+ )->status_isnt(404)->status_isnt(500)->content_like(
+ qr/Password is too short, use minimum 4 symbols/i,
+ "Trying to register with too short password"
+ );
+
+ $t_logged_in->post_ok(
+ '/register' => form => {
+ login => '',
+ name => '',
+ email => 'h@example.com',
+ password1 => 'a1234',
+ password2 => 'a1234'
+ }
+ )->status_isnt(404)->status_isnt(500)->content_like(qr/Login is missing/i,
+ "Trying to register with missing login and email");
+
+ $t_logged_in->post_ok(
+ '/register' => form => {
+ login => $token,
+ name => 'Henry John',
+ email => $token . '@example.com',
+ password1 => 'qwerty',
+ password2 => 'qwerty'
+ }
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(
+ qr/User created successfully! You may now login using login: $token/i,
+ "Trying to register with valid data");
+
+ $t_logged_in->post_ok(
+ '/register' => form => {
+ login => 'pub_admin',
+ name => 'Henry John',
+ email => $token . '@example.com',
+ password1 => 'qwerty',
+ password2 => 'qwerty'
+ }
+ )->status_isnt(404)->status_isnt(500)
+ ->content_like(qr/This login is already taken/i,
+ "Trying to register pub_admin");
};
diff --git a/t/900-frontend/009_cron_and_rest.t b/t/900-frontend/009_cron_and_rest.t
index a4d7fe5..e372c41 100644
--- a/t/900-frontend/009_cron_and_rest.t
+++ b/t/900-frontend/009_cron_and_rest.t
@@ -1,6 +1,5 @@
use Mojo::Base -strict;
-
use Test::More;
use Test::Mojo;
use Mojo::IOLoop;
@@ -9,19 +8,16 @@ use BibSpace;
use BibSpace::Functions::Core;
use BibSpace::Controller::Cron;
-my $t_anyone = Test::Mojo->new('BibSpace');
-my $self = $t_anyone->app;
-
+my $t_anyone = Test::Mojo->new('BibSpace');
+my $self = $t_anyone->app;
$t_anyone->ua->inactivity_timeout(3600);
use BibSpace::TestManager;
TestManager->apply_fixture($t_anyone->app);
-
-$t_anyone->get_ok("/cron/night")
- ->status_isnt( 404, "Checking: 404 /cron/night" )
- ->status_isnt( 500, "Checking: 500 /cron/night" );
+$t_anyone->get_ok("/cron/night")->status_isnt(404, "Checking: 404 /cron/night")
+ ->status_isnt(500, "Checking: 500 /cron/night");
note "============ Testing cron day ============";
BibSpace::Controller::Cron::do_cron_day($self);
@@ -32,9 +28,6 @@ BibSpace::Controller::Cron::do_cron_week($self);
note "============ Testing cron month ============";
BibSpace::Controller::Cron::do_cron_month($self);
-
-
-
note "============ Testing statistics output ============";
ok($self->app->statistics->toLines);
ok($self->app->statistics->toString);
@@ -43,7 +36,8 @@ note "============ Leftovers... ============";
use BibSpace::Util::DummyUidProvider;
-my $duip = DummyUidProvider->new(for_type => 'Dummy', logger => $self->app->logger);
+my $duip
+ = DummyUidProvider->new(for_type => 'Dummy', logger => $self->app->logger);
ok($duip);
ok($duip->reset);
ok($duip->registerUID);
@@ -51,7 +45,10 @@ ok($duip->generateUID);
use BibSpace::Util::SmartUidProvider;
-my $suip = SmartUidProvider->new(idProviderClassName => 'IntegerUidProvider', logger => $self->app->logger);
+my $suip = SmartUidProvider->new(
+ idProviderClassName => 'IntegerUidProvider',
+ logger => $self->app->logger
+);
ok($suip->_init('Entry'));
ok($suip->generateUID('Entry'));
ok($suip->generateUID('Entry'));
diff --git a/t/99_rest.t b/t/99_rest.t
index c2b4937..f60f1b8 100644
--- a/t/99_rest.t
+++ b/t/99_rest.t
@@ -2,18 +2,16 @@ use Mojo::Base -strict;
use Test::More;
use Test::Mojo;
-
`rm test-backups/*sql`;
my $anyone = Test::Mojo->new('BibSpace');
-if($anyone->app->mode ne 'production'){
- `rm backups/*dat`;
- `rm backups/*sql`;
- `rm test-backups/*dat`;
- `rm test-backups/*sql`;
+if ($anyone->app->mode ne 'production') {
+ `rm backups/*dat`;
+ `rm backups/*sql`;
+ `rm test-backups/*dat`;
+ `rm test-backups/*sql`;
}
ok(1);
done_testing();
-
diff --git a/util/ArchitectureGeneratorRepository.pl b/util/ArchitectureGeneratorRepository.pl
index 570482c..e0863e4 100644
--- a/util/ArchitectureGeneratorRepository.pl
+++ b/util/ArchitectureGeneratorRepository.pl
@@ -9,72 +9,76 @@
###################################
package main;
-my $header
- = "# This code was auto-generated using ArchitectureGenerator.pl on "
- . DateTime->now();
+my $header = "# This code was auto-generated using ArchitectureGenerator.pl on "
+ . DateTime->now();
-# Methods:
+# Methods:
# = first layer: all exists filter find count
# == no arg: all count
-# == obj arg: exists
-# == coderef arg: filter find
-# = all layers: save update delete
-# == array arg: save update delete
-
+# == obj arg: exists
+# == coderef arg: filter find
+# = all layers: save update delete
+# == array arg: save update delete
# WARNING: YOU MAY OVERWRITE BIBSPACE::MODEL::REPOSITORY WITH THE GENERATED CODE WITHOUT LOOSING ANYTHING
-# WARNING: YOU MAY __NOT__ OVERWRITE BIBSPACE::MODEL::DAO WITH THE GENERATED CODE.
+# WARNING: YOU MAY __NOT__ OVERWRITE BIBSPACE::MODEL::DAO WITH THE GENERATED CODE.
# IF YOU DO SO, YOU WILL LOOSE THE CODE THAT IS RESPONSIBLE FOR SAVING, READING, .. OF THE BUSINESS ENTITY ENTRIES
# YOU MAY HOWEVER OVERWRITE SELECTED PARTS OF IT (FACTORIES, NEW-BACKEND-RELATED CODE), E.G. IF YOU WANT TO ADD A NEW BACKEND
my %be
- = qw(Entry Entries Author Authors Team Teams Tag Tags TagType TagTypes Authorship Authorships Membership Memberships Labeling Labellings Exception Exceptions);
+ = qw(Entry Entries Author Authors Team Teams Tag Tags TagType TagTypes Authorship Authorships Membership Memberships Labeling Labellings Exception Exceptions);
my $vars = {
- header => $header,
- app_prefix => 'BibSpace::Model::',
- logger_interface => 'ILogger',
- idProvider_interface => 'IUidProvider',
- repo_package_prefix => 'BibSpace::Model::Repository::',
- dao_package_prefix => 'BibSpace::Model::DAO::',
- # plural and singular
- business_entities_hash => \%be,
- methods_all => [qw/all count save update delete exists filter find/],
- # take no arguments, returns
- methods_read => [qw/all count empty/],
- # take object as argument
- methods_check => [qw/exists/],
- # take object or array of objects as argument
- methods_write => [qw/save update delete/],
- # take coderef as argument
- methods_search => [qw/filter find/],
- persistence_backends => [ 'MySQL', 'Redis', 'SmartArray'],
- repository_types => ['Layered'],
+ header => $header,
+ app_prefix => 'BibSpace::Model::',
+ logger_interface => 'ILogger',
+ idProvider_interface => 'IUidProvider',
+ repo_package_prefix => 'BibSpace::Model::Repository::',
+ dao_package_prefix => 'BibSpace::Model::DAO::',
+
+ # plural and singular
+ business_entities_hash => \%be,
+ methods_all => [qw/all count save update delete exists filter find/],
+
+ # take no arguments, returns
+ methods_read => [qw/all count empty/],
+
+ # take object as argument
+ methods_check => [qw/exists/],
+
+ # take object or array of objects as argument
+ methods_write => [qw/save update delete/],
+
+ # take coderef as argument
+ methods_search => [qw/filter find/],
+ persistence_backends => ['MySQL', 'Redis', 'SmartArray'],
+ repository_types => ['Layered'],
};
my $DAOAbstractFactoryPackageName = "DAOFactory";
-my $DAOAbstractFactoryPackagePath = "BibSpace::Model::DAO::$DAOAbstractFactoryPackageName";
+my $DAOAbstractFactoryPackagePath
+ = "BibSpace::Model::DAO::$DAOAbstractFactoryPackageName";
sub printToFile {
- my $package = shift;
- my $template = shift;
- my $vars = shift;
-
- $package =~ s/::/\//g;
- my $file = "./$package";
- my $dir = dirname($file);
- make_path($dir);
- open( my $fh, '>', $file ) or die $_;
- Template->new( { ENCODING => 'utf8', INTERPOLATE => 0 } )
- ->process( \$template, $vars, $fh );
- close $fh;
+ my $package = shift;
+ my $template = shift;
+ my $vars = shift;
+
+ $package =~ s/::/\//g;
+ my $file = "./$package";
+ my $dir = dirname($file);
+ make_path($dir);
+ open(my $fh, '>', $file) or die $_;
+ Template->new({ENCODING => 'utf8', INTERPOLATE => 0})
+ ->process(\$template, $vars, $fh);
+ close $fh;
}
################# DAO ABSTRACT FACTORY
{
-my $package = "DAOFactory";
-my $filePackage = "$vars->{dao_package_prefix}$package";
+ my $package = "DAOFactory";
+ my $filePackage = "$vars->{dao_package_prefix}$package";
-my $absDaoFactory = <{persistence_backends} } ){
- my $package = "$backend"."DAOFactory";
- my $filePackage = "$vars->{dao_package_prefix}$package";
+foreach my $backend (@{$vars->{persistence_backends}}) {
+ my $package = "$backend" . "DAOFactory";
+ my $filePackage = "$vars->{dao_package_prefix}$package";
my $backendDaoFactory = <{persistence_backends} } ){
- foreach my $entity ( keys %{ $vars->{business_entities_hash} } ){
- my $package = "$entity"."$backend"."DAO";
- my $filePackage = "$vars->{dao_package_prefix}$backend"."::$package";
+foreach my $backend (@{$vars->{persistence_backends}}) {
+ foreach my $entity (keys %{$vars->{business_entities_hash}}) {
+ my $package = "$entity" . "$backend" . "DAO";
+ my $filePackage = "$vars->{dao_package_prefix}$backend" . "::$package";
my $entityDaoBackend = <{repository_types} } ) {
- my $package = "$repoType" . "RepositoryFactory";
- my $filePackage = "$vars->{repo_package_prefix}$package";
- my $repoTypeConcreteFactory = <{repository_types}}) {
+ my $package = "$repoType" . "RepositoryFactory";
+ my $filePackage = "$vars->{repo_package_prefix}$package";
+ my $repoTypeConcreteFactory = <{business_entities_hash} } )
+# foreach my $entity ( keys %{ $vars->{business_entities_hash} } )
{
-my $package = "IRepository";
-my $filePackage = "$vars->{repo_package_prefix}Interface::$package";
-my $entityRespositoryInterface = <{repository_types} } ) {
- foreach my $entity ( keys %{ $vars->{business_entities_hash} } ) {
-
- my $package = "$vars->{business_entities_hash}->{$entity}" . "$backend" . "Repository";
- my $filePackage = "$vars->{repo_package_prefix}$backend" . "::". "$package";
- my $entityRepoBackend = <{repository_types}}) {
+ foreach my $entity (keys %{$vars->{business_entities_hash}}) {
+
+ my $package
+ = "$vars->{business_entities_hash}->{$entity}"
+ . "$backend"
+ . "Repository";
+ my $filePackage
+ = "$vars->{repo_package_prefix}$backend" . "::" . "$package";
+ my $entityRepoBackend = < ( is => 'rw', isa => 'Str' );
-has 'year' => ( is => 'rw', isa => 'Int', default => 2017 );
+has 'bib' => (is => 'rw', isa => 'Str');
+has 'year' => (is => 'rw', isa => 'Int', default => 2017);
__PACKAGE__->meta->make_immutable;
no Moose;
###################################
@@ -18,50 +18,55 @@ package BibSpace::Model::ILogger;
use Moose::Role;
use DateTime;
-sub log{
- my $self=shift;
- my $type = shift; # info, warn, error, debug
- my $msg = shift; # text to log
- my $origin = shift // "unknown"; # method from where the msg originates
- my $time = DateTime->now();
- print "\t[$time] $type: $msg (Origin: $origin).\n";
+sub log {
+ my $self = shift;
+ my $type = shift; # info, warn, error, debug
+ my $msg = shift; # text to log
+ my $origin = shift // "unknown"; # method from where the msg originates
+ my $time = DateTime->now();
+ print "\t[$time] $type: $msg (Origin: $origin).\n";
}
-sub debug{
- my $self=shift;
- my $msg = shift;
- my $origin = shift // 'unknown';
- $self->log('debu', $msg, $origin);
+sub debug {
+ my $self = shift;
+ my $msg = shift;
+ my $origin = shift // 'unknown';
+ $self->log('debu', $msg, $origin);
}
-sub entering{
- my $self=shift;
- my $msg = shift;
- my $origin = shift // 'unknown';
- $self->log('ente', $msg, $origin);
+
+sub entering {
+ my $self = shift;
+ my $msg = shift;
+ my $origin = shift // 'unknown';
+ $self->log('ente', $msg, $origin);
}
-sub exiting{
- my $self=shift;
- my $msg = shift;
- my $origin = shift // 'unknown';
- $self->log('exit', $msg, $origin);
+
+sub exiting {
+ my $self = shift;
+ my $msg = shift;
+ my $origin = shift // 'unknown';
+ $self->log('exit', $msg, $origin);
}
-sub info{
- my $self=shift;
- my $msg = shift;
- my $origin = shift // 'unknown';
- $self->log('info', $msg, $origin);
+
+sub info {
+ my $self = shift;
+ my $msg = shift;
+ my $origin = shift // 'unknown';
+ $self->log('info', $msg, $origin);
}
-sub warn{
- my $self=shift;
- my $msg = shift;
- my $origin = shift // 'unknown';
- $self->log('warn', $msg, $origin);
+
+sub warn {
+ my $self = shift;
+ my $msg = shift;
+ my $origin = shift // 'unknown';
+ $self->log('warn', $msg, $origin);
}
-sub error{
- my $self=shift;
- my $msg = shift;
- my $origin = shift // 'unknown';
- $self->log('erro', $msg, $origin);
+
+sub error {
+ my $self = shift;
+ my $msg = shift;
+ my $origin = shift // 'unknown';
+ $self->log('erro', $msg, $origin);
}
no Moose;
@@ -70,11 +75,11 @@ package BibSpace::Model::SimpleLogger;
use Moose;
with 'BibSpace::Model::ILogger';
-sub debug{
- my $self=shift;
- my $msg = shift;
- my $time = DateTime->now();
- print "[$time] DEBU: $msg\n";
+sub debug {
+ my $self = shift;
+ my $msg = shift;
+ my $time = DateTime->now();
+ print "[$time] DEBU: $msg\n";
}
__PACKAGE__->meta->make_immutable;
@@ -84,65 +89,74 @@ sub debug{
###################################
package main;
-
## lets see if this generates properly
use Try::Tiny;
try {
- # use BibSpace::Model::DAO::DAOFactory;
-
- my $dbHandle = "DB stuff"; # DBI->connect(...)
- my $redisHandle = "Redis stuff"; # Redis->connect(...)
-
- my $logger = BibSpace::Model::SimpleLogger->new();
-
- my %backendConfig = (
- backends => [
- { prio => 1, type => 'BibSpace::Model::DAO::ArrayDAOFactory', handle => "NOHANDLE" },
- { prio => 2, type => 'BibSpace::Model::DAO::RedisDAOFactory', handle => $redisHandle },
- { prio => 2, type => 'BibSpace::Model::DAO::MySQLDAOFactory', handle => $dbHandle },
- ]
- );
-
- # use Data::Dumper;
- # print "MAIN: using config: ".Dumper \%backendConfig;
-
- # require BibSpace::Model::Repository::RepositoryFactory;
- # my $factory
- # = BibSpace::Model::Repository::RepositoryFactory->new(logger => $logger)
- # ->getInstance(
- # 'BibSpace::Model::Repository::LayeredRepositoryFactory',
- # \%backendConfig
- # );
-
- # say "######## CALLING 4 times \$factory->getEntriesRepository();";
- # my $erepo = $factory->getEntriesRepository();
- # $factory->getEntriesRepository();
- # $factory->getEntriesRepository();
- # $factory->getEntriesRepository();
- # # there should be only one logger entry on the screen with: DEBU: Initializing filed instanceEntriesRepo in class BibSpace::Model::Repository::LayeredRepositoryFactory
- # say "######## CALLING \$erepo->all();";
-
- # my @allEntries = $erepo->all();
-
- # my $entry = Entry->new( bib => "sth", year => 2012 );
- # my $entry2 = Entry->new( bib => "sth", year => 2011 );
- # my @entries = ( $entry, $entry2 );
- # $erepo->save(@entries);
-
- # my @someEntries = $erepo->filter( sub { $_->year == 2011 } ); #fake!
+ # use BibSpace::Model::DAO::DAOFactory;
+
+ my $dbHandle = "DB stuff"; # DBI->connect(...)
+ my $redisHandle = "Redis stuff"; # Redis->connect(...)
+
+ my $logger = BibSpace::Model::SimpleLogger->new();
+
+ my %backendConfig = (
+ backends => [
+ {
+ prio => 1,
+ type => 'BibSpace::Model::DAO::ArrayDAOFactory',
+ handle => "NOHANDLE"
+ },
+ {
+ prio => 2,
+ type => 'BibSpace::Model::DAO::RedisDAOFactory',
+ handle => $redisHandle
+ },
+ {
+ prio => 2,
+ type => 'BibSpace::Model::DAO::MySQLDAOFactory',
+ handle => $dbHandle
+ },
+ ]
+ );
+
+ # use Data::Dumper;
+ # print "MAIN: using config: ".Dumper \%backendConfig;
+
+ # require BibSpace::Model::Repository::RepositoryFactory;
+ # my $factory
+ # = BibSpace::Model::Repository::RepositoryFactory->new(logger => $logger)
+ # ->getInstance(
+ # 'BibSpace::Model::Repository::LayeredRepositoryFactory',
+ # \%backendConfig
+ # );
+
+# say "######## CALLING 4 times \$factory->getEntriesRepository();";
+# my $erepo = $factory->getEntriesRepository();
+# $factory->getEntriesRepository();
+# $factory->getEntriesRepository();
+# $factory->getEntriesRepository();
+# # there should be only one logger entry on the screen with: DEBU: Initializing filed instanceEntriesRepo in class BibSpace::Model::Repository::LayeredRepositoryFactory
+# say "######## CALLING \$erepo->all();";
+
+ # my @allEntries = $erepo->all();
+
+ # my $entry = Entry->new( bib => "sth", year => 2012 );
+ # my $entry2 = Entry->new( bib => "sth", year => 2011 );
+ # my @entries = ( $entry, $entry2 );
+ # $erepo->save(@entries);
+
+ # my @someEntries = $erepo->filter( sub { $_->year == 2011 } ); #fake!
}
catch {
- say "Caught exception: $_";
+ say "Caught exception: $_";
};
-
-
# Test for DAO only
# try{
-# require BibSpace::Model::DAO::DAOFactory;
+# require BibSpace::Model::DAO::DAOFactory;
# BibSpace::Model::DAO::DAOFactory->import;
# my $dbHandle = "DB stuff"; # DBI->connect(...)
# my $redisHandle = "Redis stuff"; # Redis->connect(...)
@@ -154,7 +168,7 @@ package main;
# my $dao = $daoFactory->getEntryDao();
# # my @entries = $dao->all();
-
+
# my $entry = Entry->new( bib => "sth", year =>2012 );
# my $entry2 = Entry->new( bib => "sth", year => 2011 );
# my @entries = ($entry, $entry2);
|