LocalBibStyle.pm

package LocalBibStyle;
use Data::Dumper;
=head1 NAME

Text::BibTeX::BibStyle - Format Text::BibTeX::Entry items using .bst

=cut

our $VERSION = '0.03';

=head1 DESCRIPTION

C<Text::BibTeX::BibStyle> is a module that can format
C<Text::BibTeX::Entry> objects by interpreting a bibstyle (C<.bst>) file
such as C<ieeetr.bst>.  In this way, Perl can use the same
bibliographic style files that bibtex does.

For a large collection of C<.bst> files, see
http://www.math.utah.edu/pub/tex/bibtex/index.html.

=head1 SYNOPSIS

  $bibstyle = Text::BibTeX::BibStyle->new(%options);

  $ENV{BSTINPUTS} = "my/bstfiles/";
  $bibstyle->read_bibstyle("bibstyle");
       OR
  $bibstyle->replace_bibstyle($bibstyle_def);

  $ENV{BIBINPUTS} = "my/bibfiles/";
  $bibstyle->execute([qw(bibfile1 bibfile2)]);
       OR
  $bibstyle->execute([qw(bibfile1 bibfile2)], \@ref_list);

  @warnings = $bibstyle->warnings;

  $output = $bibstyle->get_output();
  $output = $bibstyle->convert_format(Text::BibTex::BibStyle::html);
       OR
  $output = $bibstyle->get_output(\%options);

=cut

use strict;
use warnings;

use vars qw(@ISA @EXPORT_OK $LATEX $HTML $RST);

use Exporter;
@ISA       = qw( Exporter );
@EXPORT_OK = qw($HTML $LATEX $RST);

use Carp;
use Text::BibTeX qw(:metatypes :subs :joinmethods :macrosubs);
use Text::BibTeX::Name;

=head1 METHODS

=over

=item C<new [(%options])>

Class method.  Creates a new C<Text::BibTeX::BibStyle> object with the
options specified in the optional C<option=>'value'> arguments.The
following options are understood:

=over

=item C<debug>

Turns on debugging messages during execute.

=item C<nowarn>

Turns off warnings from certain sanity checks, such as the existence
of a unique C<ENTRIES> and C<READ> statement within the bibstyle.

=back

=cut

# Exportable output options
$LATEX = { wrap => 1 };
{    # Closure
    my $ASCIIMathML_parser;
    my %Styles = (
        em => 'em',
        bf => 'b',
        it => 'i',
        sl => 'i',
        tt => 'tt'
    );

    $HTML = {
        delete_braces         => 1,
        substitute_newcommand => 1,
        character             => sub {
            my ( $bst, $latex, $unicode, $chars, $accent ) = @_;
            use HTML::Entities;
            return $unicode ? encode_entities($unicode) : $chars;
        },
        command => sub {
            my ( $bst, $cmd, @args ) = @_;
            if ( $cmd =~ /^(begin|end)$/ ) {
                if ( $args[0] eq 'thebibliography' ) {
                    my $slash = $cmd eq 'end' ? '/' : '';
                    my $pre;
                    if ( $cmd eq 'begin' ) {
                        $pre = qq(<h2>References</h2>\n\n);
                    }
                    else {
                        $pre = "</td>";
                    }
                    return "$pre<${slash}table>";
                }
            }
            elsif ( $cmd eq 'bibitem' ) {
                my $key = pop @args;
                $bst->{html}{Bib_count}++;
                my $label = $args[0] || $bst->{html}{Bib_count};
                ( $bst->{html}{Cites}{$key} = $label ) =~
                  s/[{}]//g;    # Remove braces
                my $pre = $bst->{html}{Bib_count} > 1 ? "</td>\n" : '';
                return
qq($pre<tr valign="top"><td><a name="$key">[$label]</a></td><td>);
            }
            elsif ( $cmd eq 'mbox' ) {
                return $args[0];
            }
            elsif ( $cmd eq 'cite' ) {
                return qq(<a href="#$args[0]"><cite>$args[0]</cite></a>);
            }
        },
        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!<cite>(.*?)</cite>![$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</$html_style>"
              : $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;
        },
    };
}

sub new {
    my ( $class, %options ) = @_;

    my $self = bless {}, $class;

    $self->{options} = \%options;

    return $self;
}

# A Text::BibTeX::BibStyle hash has the following keys:
#   bibtex      A reference to a "bibtex" hash
#   interp      Array reference containing the interpreter
#   stack       Reference to array of evaluation stack
#   symbols     Reference to "symbols" hash
#   warnings    Array of warnings produced during execution
#
# "Symbols" hash has the following keys, each of which is a hash reference
# whose key is the symbol name and whose value is its definition:
#   const       Built-in constants
#   field       Reference to hash of field/value pairs for current entry
#   entry_int   Reference to hash of integer/value pairs for current entry
#   entry_str   Reference to hash of string/value pairs for current entry
#   function    Function defined in FUNCTION command or built-in function
#   integer     Integer defined in INTEGERS command
#   string      String defined in STRINGS command
#
# "Bibtex" hash has the following key/value pairs
#   bibfiles    Reference to array of bib file names
#   bt_entry    Reference to the current Text::BibTeX::Entry object
#   bt_entries  Reference to hash whose keys are bibtex keys and whose value
#               is the corresponding Text::BibTeX::Entry for that key
#   cite        Cite key for the current entry
#   cites       Optional reference to array of keys of citations to format
#   entries     Reference to hash whose keys are bibtex keys and whose value
#               is a reference to its entry hash
#   format      Reference to a format hash defined by an ENTRY command
#   preamble    Reference to array of @PREAMBLE items
#
# "Entry" hash has the following keys, each of which is a hash reference
# whose key is the symbol name and whose value is its definition:
#   field       Bibliography field from ENTRY command
#   integer     Entry integer from ENTRY command
#   string      Entry string from ENTRY command
#
# "Format" hash has the following keys, each of which is a reference to
# an array of names that can appear in a corresponding entry hash
#   field       Bibliography fields from ENTRY command
#   integer     Entry integer variables from ENTRY command
#   string      Entry string variables from ENTRY command

=item C<convert_format ($text, \%options)>

Method. Converts a LaTeX bibliography in $text into some other format
using the options specified by C<%options> and returns the result.
This method can also be used to convert a standard BibTeX output to
a different format.

Assuming that C<$text> contains a LaTeX bibliography (e.g., the
contents of a C<.bbl> file), the following option packages may be
useful for the options hash reference:

=over

=item C<$Text::BibTeX::BibStyle::HTML>

Produces HTML code to render the formatted bibliography. Exportable.

=item C<$Text::BibTeX::BibStyle::LATEX>

Outputs LaTeX code identical to bibtex (specifies (wrap => 1)).  Exportable.

=item C<$Text::BibTeX::BibStyle::RST>

Produces reStructuredText code.  Exportable.

=back

The following options are supported, if you want to write your own
translation package:

=over

=item C<character>

Reference to a subroutine to call for special characters.  The
subroutine is called with the arguments C<($bst, $latex, [$unicode],
$char, [$accent])>, where C<$bst> is the Text::BibTeX::BibStyle
object, C<$latex> is the original latex for the special character,
C<$unicode> is the equivalent unicode character (if it exists), $char
is the special character(s), and C<$accent> is the latex accent code
to be applied (if specified).  It should return the string to be
substituted.

=item C<command>

Reference to a subroutine to call for LaTeX commands.  The subroutine
is called with the arguments C<($bst, $cmd, @args)>, where C<$bst> is
the Text::BibTeX::BibStyle object, C<$cmd> is the name of the LaTeX
command and C<@args> is the array of arguments (including optional
arguments) to the command.  At a minimum, the subroutine should handle
the following commands: C<\begin{thebibliography}>,
C<\bibitem[label]{key}>, C<\cite{ref}>, C<\end{thebibliography}>,
C<\mbox{text}>, C<\newblock>. It should return the string to be
substituted.

=item C<delete_braces>

Boolean to delete from the output any braces that are not
backslash-quoted.

=item C<init>

Reference to a subroutine to call before processing the output.  The
subroutine is called with the argument C<($bst)>, which is the
Text::BibTeX::BibStyle object.

=item C<math>

Reference to a subroutine to call for latex math.  The subroutine is
called with the arguments C<($bst, $latex, $math)>, where C<$bst> is
the Text::BibTeX::BibStyle object, C<$latex> is the original latex and
C<$math> is the part that actually translates to math.  It should
return the string to be substituted.

=item C<postprocess>

Reference to a subroutine to call to post-process the output.  The
subroutine is called with the arguments C<($bst, $text)>, where
C<$bst> is the Text::BibTeX::BibStyle object and C<$text> contains the
text of the entire formatted bibliography.  It should return the final
formatted bibliography.

=item C<prologue>

A string or reference to a subroutine to call to produce any
pre-bibliography definitions needed by the format.

=item C<style>

Reference to a subroutine to call for different font styles.  The
subroutine is called with the arguments C<($bst, $latex, $style,
$text)>, where C<$bst> is the Text::BibTeX::BibStyle object, C<$latex>
is the original latex, C<$style> is one of C<rm>, C<em>, C<bf>, C<it>,
C<sl>, C<sf>, C<sc>, or C<tt> indicating the font style, and C<$text>
is the text to be output in that style.  It should return the string
to be substituted.

=item C<substitute_newcommand>

Boolean to process and do substitutions for any C<\newcommand>
definitions in the output.

=item C<wrap>

Boolean to force the standard bibtex wrapping on the output.

=back

=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} ) {

            # 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]+) [ ]*
	    (?:\}|\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} ) {

            # 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 {
	    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 {
	    my ($pre, $cmd, $next) = ($1, $2, $3);
	    my @args;
	    while ($next =~ m!^[\{\[]!) {
		if ($next =~ m!^\{!) {
		    my $arg;
		    ($arg, $next) = _remove_matched_brace($next);
		    $arg =~ s!^\{ (.*) \}$!$1!sx;
		    push @args, $arg;
		}
		else {
		    $next =~ s!^\[ (.*?) \]!!sx;
		    push @args, $1;
		}
	    }
	    $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} ) {

            # Handle backslash-quoted braces
            $text =~ s/(\\ ([{}]))/_character($self, $opts, $1, $2)/xge;
        }
        $text = $opts->{postprocess}->( $self, $text ) if $opts->{postprocess};

        return $text;
    }

=item C<execute [(\@bibfiles[, \@cites])]>

Method. Executes the current bibstyle interpreter on a set of cited
references passed in C<@cites> looking in a set of C<.bib> files
passed in C<@bibfiles>.  If the C<@cites> argument is undefined, uses
all the references in all the bibfiles.  The files in C<@bibfiles>
should be without the ".bib" extension.  The search path for bibfiles
is taken from the C<BIBINPUTS> environment variables if it is defined.
The C<@bibfiles> argument is not needed if the bibstyle interpreter
does not contain a C<READ> command.  Croaks if a bibstyle interpreter
has not been defined using either the C<read_bibstyle> or
C<replace_bibstyle> 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};
        }
    }


=item C<get_output [(\%options)]>

Method.  Returns the output produced by C<write$> commands in the C<.bst>
file.  The options are listed under the C<convert_format> method,
which it calls.

=cut

    sub get_output : method {
        my ( $self, $opts ) = @_;

        my $out = join '', @{ $self->{output} };
        $out = $self->convert_format( $out, $opts ) if $opts;

        return $out;
    }

=item C<num_warnings>

Method.  Returns the number of warning messages generated during execution.

=cut

    sub num_warnings : method {
        my ($self) = @_;

        return 0 + @{ $self->{warnings} };
    }

=item C<read_bibstyle ($bibstyle)>

Method.  Replaces the bibstyle interpreter with a new one obtained by
reading the file C<$bibstyle.bst>.  The search path for the bibstyle
file is taken from the C<BSTINPUTS> environment variable if it is
defined.

=cut

    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 $fullfile = "$bibstyle";
        croak("Cannot find bst file $bibstyle") unless -e $bibstyle;

        # Read the file
        open BSTINPUTS, "$fullfile" or croak("$fullfile: $!");
        my @bibstyle = <BSTINPUTS>;
        close BSTINPUTS;

        my $interp = join '', @bibstyle;
        $self->replace_bibstyle( $interp, $fullfile );
    }

=item C<replace_bibstyle ($string[, $filename])>

Method. Replaces the bibstyle interpreter by parsing C<$string>.  The
optional C<$filename> argument is used for warning messages.  Written
primarily for testing purposes; most users will call it only
indirectly through the C<read_bibstyle> 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 ||= '<string>';

            # 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<warnings>

Method. Returns an array of the warning messages generated during execution.

=cut

        sub warnings : method {
            my ($self) = @_;

            return @{ $self->{warnings} };
        }

=back

=head1 ENVIRONMENT

The following environment variables are used:

=over

=item C<BIBINPUTS>

The search path for bibliography (.bib) files.

=item C<BSTINPUTS>

The search path for bibstyle (.bst) files.

=back

=head1 LIMITATIONS

The $Text::BibTeX::BibStyle::HTML output filter has the following
limitations:

=over

=item Math mode

The math mode interpretation depends upon using Text::ASCIIMathML to
convert to MathML.  ASCIIMathML accepts most, but not all, LaTeX
constructs.  In order to render correctly in some browsers, it will
need to use xhtml and put the appropriate MathML entity definitions in
the header.

=item latex2e symbols

Extended symbols defined by latex2e are not supported.

=back

=head1 COPYRIGHT & LICENSE

Copyright 2007 Mark Nodine, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

################ 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;
            }

            # 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_function {
            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 $func_name = $symbols[0];
            $self->_check_name($func_name);
            $self->{symbols}{function}{$func_name} = $args_ar->[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_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_read {
            my ( $self, $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";

        	croak "$self->{lineno}: I found no rawbib content"
              unless $self->{bibtex}{rawbib}
              && $self->{bibtex}{rawbib} ne '';

          my @cites;

        	my $bt_entry = new Text::BibTeX::Entry();
  				$bt_entry->parse_s($self->{bibtex}{rawbib});
  				croak "Paring went shitty" unless $bt_entry->parse_ok;

  				my $metatype = $bt_entry->metatype;
          if ( $metatype == BTE_REGULAR ) {

          	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 ) {

              # 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 _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} };

            #    croak "$filename, $lineno: Command '$cmd' not implemented yet";
        }

        sub _command_variables {
            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] } );
        }

        {    # 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;
            }
        }
    }

    # 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'");
        }
        else {
            $self->{symbols}{$type}{$sym} = $val;
        }
    }

    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"));
        }
        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"));
    }

    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_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}") );
    }

    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 = $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 || '' )
                  . join( '', @out_names )
                  . ( $post || '' )
                  .

                  #		'';
                  $out_tie;
            }
            else {
                $output .= $_;
            }
        }

        $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 ) = @_;

        my $arg1 = $self->_pop( i => $token, 1 );
        $self->_push( _check_type_warnings() ? '""' : '"' . chr($arg1) . '"' );
    }

    sub _function_int_to_str {
        my ( $self, $token ) = @_;

        my $arg1 = $self->_pop( i => $token, 1 );
        $self->_push( _check_type_warnings() ? '""' : qq("$arg1") );
    }

    sub _function_missing {
        my ( $self, $token ) = @_;

        my $arg1 = $self->_pop( s => $token, 1 );
        $self->_push( 0 + ( !defined $arg1 ) );
    }

    sub _function_newline {
        my ( $self, $token ) = @_;

        push @{ $self->{output} }, "\n";
    }

    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 );
    }

    sub _function_preamble {
        my ( $self, $token ) = @_;

        $self->_push( sprintf '"%s"',
            join( '', @{ $self->{bibtex}{preamble} } ) );
    }

    sub _function_purify {
        my ( $self, $token ) = @_;

        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"));

        $arg =~ s/[\s~]+/ /g;

        # 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]+) [ ]*
	(?:\}|\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"));
    }

    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('""');
        }
        $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 ) = @_;

        my ( $arg1, $arg2 ) = ( $self->_pop, $self->_pop );
        $self->_push( $arg1, $arg2 );
    }

    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);

        # Count the accents
        my $length = $arg =~ s/\{ \\ (?:$Acc_char|$Acc_let[ ]) [ ]* [a-z]+ [ ]*
	(?:\}|\Z)//ogix;
        $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]+ [ ]*
		(?:\}|\Z))//oix
                || 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"));
    }

    {    # 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]+) [ ]* |
		  \\ (?:$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);
        }
    }
}

sub _function_top {
    my ( $self, $token ) = @_;

    my $arg = $self->_pop;
    $self->_warning( $self->_format_token($arg), 1 );
}

sub _function_type {
    my ( $self, $token ) = @_;

    return $self->_push('""') unless my $bt_entry = $self->{bibtex}{bt_entry};
    $self->_push( '"' . ( lc $bt_entry->type ) . '"' );
}

sub _function_warning {
    my ( $self, $token ) = @_;

    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);
    }
}

sub _function_write {
    my ( $self, $token ) = @_;

    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.
# If one argument is present, all must be
# Arguments: optional (type(s), token, first_arg)
# The types are a concatenation of
#   i: integer
#   q: quoted value (e.g., 'a)
#   s: string
#   x: expression (array ref)
# See the description of _check_type for the optional arguments
sub _pop : method {
    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;
}

# Pushes some elements on the stack
sub _push : method {
    my $self = shift;

    push @{ $self->{stack} }, @_;
}

# Removes the outer "s from a string
# Arguments: string to trim
# Returns:   trimmed string
sub _trim_string {
    my ($str) = @_;

    $str =~ s/^\"(.*)\"$/$1/s;
    return $str;
}

# Routines to protect and unprotect strings within braces
{
    my %Brackets;
    my $Bracket_cnt = 0;

    # Protects strings within matching { } pairs
    # Arguments
    sub _protect {
        my ($s) = @_;

        while (
            $s =~ s/\{ ([^{}]*) \}/
	   my $v = sprintf 'PROTECT(0D%d)', $Bracket_cnt++;
	   $Brackets{$v} = $1; $v/ex
          )
        {
        }
        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) = @_;

        return ( '', $str ) unless $str =~ s/^(\{)//;

        # 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 );
    }

################# 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,
        );

    # 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 );
        }
    }

    # 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 ($cmd, $args, $next, $def) = ($1, $2, $3);
	($def, $next) = _remove_matched_brace($next);
	$def =~ s!^\{(.*)\}$!sub { qq(\Q$1\E) }!s;
	$def =~ s!\\\#(\d+)!\$_[@{[$1-1]}]!g;
	my $sub = eval("$def");
	die "Internal error: $@" if $@;
	$command{$cmd} = { args => $args, def => $def, code => $sub };
	$next;
    }/sexi;

        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++) {
		my ($arg, $next_) = _remove_matched_brace($next);
		$arg =~ s!^\{(.*)\}$!$1!s;
		push @args, $arg;
		$next = $next_;
	    }
	    &{$command{$cmd}{code}}(@args) . $next;
 	}/se;
        }

        return $str;
    }

    sub _unprotect {
        my ($s) = @_;

        return $s unless %Brackets;
        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 $lineno = $no_lineno ? '' : "$self->{lineno}: ";
    my $warn = "$lineno$warning";
    push @{ $self->{warnings} }, "$warn\n";
    carp $warn;
    return 1;
}

1;