/usr/share/perl5/Locale/Po4a/Sgml.pm

#!/usr/bin/perl -w

# Po4a::Sgml.pm
#
# extract and translate translatable strings from an sgml based document.
#
# This code is an adapted version of sgmlspl (SGML postprocessor for the
#   SGMLS and NSGMLS parsers) which was:
#
# Copyright (c) 1995 by David Megginson <dmeggins@aix1.uottawa.ca>
#
# The adaptation for po4a was done by Denis Barbier <barbier@linuxfr.org>,
# Martin Quinson (mquinson#debian.org) and others.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
#
########################################################################

=encoding UTF-8

=head1 NAME

Locale::Po4a::Sgml - convert SGML documents from/to PO files

=head1 DESCRIPTION

The po4a (PO for anything) project goal is to ease translations (and more
interestingly, the maintenance of translations) using gettext tools on
areas where they were not expected like documentation.

Locale::Po4a::Sgml is a module to help the translation of documentation in
the SGML format into other [human] languages.

This module uses B<onsgmls>(1) to parse the SGML files. Make sure it is
installed.
Also make sure that the DTD of the SGML files are installed in the system.

=head1 OPTIONS ACCEPTED BY THIS MODULE

=over 4

=item B<debug>

Space separated list of keywords indicating which part you want to debug. Possible values are: tag, generic, entities and refs.

=item B<verbose>

Give more information about what's going on.

=item B<translate>

Space separated list of extra tags (beside the DTD provided ones) whose
content should form an extra msgid.

=item B<section>

Space separated list of extra tags (beside the DTD provided ones)
containing other tags, some of them being of category B<translate>.

=item B<indent>

Space separated list of tags which increase the indentation level.

=item B<verbatim>

The layout within those tags should not be changed. The paragraph won't get
wrapped, and no extra indentation space or new line will be added for
cosmetic purpose.

=item B<empty>

Tags not needing to be closed.

=item B<ignore>

Tags ignored and considered as plain char data by po4a. That is to say that
they can be part of an msgid. For example, E<lt>bE<gt> is a good candidate
for this category since putting it in the translate section would create
msgids not being whole sentences, which is bad.

=item B<attributes>

A space separated list of attributes that need to be translated. You can
specify the attributes by their name (for example, "lang"), but you can also
prefix it with a tag hierarchy, to specify that this attribute will only be
translated when it is into the specified tag. For example:
E<lt>bbbE<gt>E<lt>aaaE<gt>lang specifies that the lang attribute will only be
translated if it is in an E<lt>aaaE<gt> tag, which is in a E<lt>bbbE<gt> tag.
The tag names are actually regular expressions so you can also write things
like E<lt>aaa|bbbbE<gt>lang to only translate lang attributes that are in
an E<lt>aaaE<gt> or a E<lt>bbbE<gt> tag.

=item B<qualify>

A space separated list of attributes for which the translation must be
qualified by the attribute name. Note that this setting automatically adds the
given attribute into the 'attributes' list too.

=item B<force>

Proceed even if the DTD is unknown or if onsgmls finds errors in the input
file.

=item B<include-all>

By default, msgids containing only one entity (like '&version;') are skipped
for the translator comfort. Activating this option prevents this
optimisation. It can be useful if the document contains a construction like
"<title>&Aacute;</title>", even if I doubt such things to ever happen...

=item B<ignore-inclusion>

Space separated list of entities that won't be inlined.
Use this option with caution: it may cause onsgmls (used internally) to add
tags and render the output document invalid.

=back

=head1 STATUS OF THIS MODULE

The result is perfect. I.e., the generated documents are exactly the
same. But there are still some problems:

=over 2

=item *

The error output of onsgmls is redirected to /dev/null, which is clearly
bad. I don't know how to avoid that.

The problem is that I have to "protect" the conditional inclusions (i.e. the
C<E<lt>! [ %foo [> and C<]]E<gt>> stuff) from onsgmls. Otherwise
onsgmls eats them, and I don't know how to restore them in the final
document. To prevent that, I rewrite them to C<{PO4A-beg-foo}> and
C<{PO4A-end}>.

The problem with this is that the C<{PO4A-end}> and such I add are invalid in
the document (not in a E<lt>pE<gt> tag or so).

Everything works well with onsgmls's output redirected that way, but it will
prevent us from detecting that the document is badly formatted.

=item *

It does work only with the DebianDoc and DocBook DTD. Adding support for a
new DTD should be very easy. The mechanism is the same for every DTD, you just
have to give a list of the existing tags and some of their characteristics.

I agree, this needs some more documentation, but it is still considered as
beta, and I hate to document stuff which may/will change.

=item *

Warning, support for DTDs is quite experimental. I did not read any
reference manual to find the definition of every tag. I did add tag
definition to the module 'till it works for some documents I found on the
net. If your document use more tags than mine, it won't work. But as I said
above, fixing that should be quite easy.

I did test DocBook against the SAG (System Administrator Guide) only, but
this document is quite big, and should use most of the DocBook
specificities.

For DebianDoc, I tested some of the manuals from the DDP, but not all yet.

=item *

In case of file inclusion, string reference of messages in PO files
(i.e. lines like C<#: en/titletoc.sgml:9460>) will be wrong.

This is because I preprocess the file to protect the conditional inclusion
(i.e. the C<E<lt>! [ %foo [> and C<]]E<gt>> stuff) and some entities (like
&version;) from onsgmls because I want them verbatim to the generated
document. For that, I make a temp copy of the input file and do all the
changes I want to this before passing it to onsgmls for parsing.

So that it works, I replace the entities asking for a file inclusion by the
content of the given file (so that I can protect what needs to be in a subfile
also). But nothing is done so far to correct the references (i.e., filename
and line number) afterward. I'm not sure what the best thing to do is.

=back

=cut

package Locale::Po4a::Sgml;

use 5.006;
use strict;
use warnings;


require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Locale::Po4a::TransTractor);
@EXPORT = qw();

use Locale::Po4a::TransTractor;
use Locale::Po4a::Common;

eval qq{use SGMLS};
if ($@) {
  die wrap_mod("po4a::sgml", dgettext("po4a","The needed module SGMLS.pm was not found and needs to be installed. It can be found on the CPAN, in package libsgmls-perl on debian, etc."));
}

use File::Temp;

my %debug=('tag'      => 0,
           'generic'  => 0,
           'entities' => 0,
           'refs'     => 0,
           'onsgmls'   => 0);

my $xmlprolog = undef; # the '<?xml ... ?>' line if existing

sub initialize {
    my $self = shift;
    my %options = @_;

    $self->{options}{'translate'}='';
    $self->{options}{'section'}='';
    $self->{options}{'indent'}='';
    $self->{options}{'empty'}='';
    $self->{options}{'verbatim'}='';
    $self->{options}{'ignore'}='';
    $self->{options}{'ignore-inclusion'}='';

    $self->{options}{'include-all'}='';

    $self->{options}{'force'}='';

    $self->{options}{'verbose'}='';
    $self->{options}{'debug'}='';

    foreach my $opt (keys %options) {
        if ($options{$opt}) {
            die wrap_mod("po4a::sgml", dgettext ("po4a", "Unknown option: %s"), $opt) unless exists $self->{options}{$opt};
            $self->{options}{$opt} = $options{$opt};
        }
    }
    if ($options{'debug'}) {
        foreach (split /\s+/, $options{'debug'}) {
            $debug{$_} = 1;
        }
    }
}

sub read {
    my ($self,$filename)=@_;

    push @{$self->{DOCPOD}{infile}}, $filename;
    $self->Locale::Po4a::TransTractor::read($filename);
}

sub parse {
    my $self=shift;
    map {$self->parse_file($_)} @{$self->{DOCPOD}{infile}};
}

#
# Filter out some uninteresting strings for translation
#
sub translate {
    my ($self)=(shift);
    my ($string,$ref,$type)=(shift,shift,shift);
    my (%options)=@_;

    # don't translate entries composed of one entity
    if ( (($string =~ /^&[^;]*;$/) || ($options{'wrap'} && $string =~ /^\s*&[^;]*;\s*$/))
         && !($self->{options}{'include-all'}) ){
        warn wrap_mod("po4a::sgml", dgettext("po4a", "msgid skipped to help translators (contains only an entity)"), $string)
            unless $self->verbose() <= 0;
        return $string.($options{'wrap'}?"\n":"");
    }
    # don't translate entries composed of tags only
    if ( $string =~ /^(((<[^>]*>)|\s)*)$/
         && !($self->{options}{'include-all'}) ) {
        warn wrap_mod("po4a::sgml", dgettext("po4a", "msgid skipped to help translators (contains only tags)"), $string)
               unless $self->verbose() <= 0;
        return $string.($options{'wrap'}?"\n":"");
    }

    # don't translate entries composed of marked section tags only
    if (   ($string =~ /^(?:<!\s*\[\s*[^\[]+\s*\[|\]\s*]\s*>|\s)*$/)
        && !($self->{options}{'include-all'})) {
        warn wrap_mod("po4a::sgml", dgettext("po4a", "msgid skipped to ".
                      "help translators (contains only opening or closing ".
                      "tags of marked sections)"), $string)
               unless $self->verbose() <= 0;
        return $string.($options{'wrap'}?"\n":"");
    }

    $string = $self->SUPER::translate($string,$ref,$type,%options);

    $string = $self->post_trans($string,$ref,$type);

    return $string;
}

sub post_trans {
    my ($self,$str,$ref,$type)=@_;

    # Change ascii non-breaking space to an &nbsp;
    my $nbs_out = "\xA0";
    my $enc_length = Encode::from_to($nbs_out, "latin1",
                                               $self->get_out_charset);
    $str =~ s/\Q$nbs_out/&nbsp;/g if defined $enc_length;

    return $str;
}

#
# Make sure our cruft is removed from the file
#
sub pushline {
    my ($self,$line)=@_;
    $line =~ s/{PO4A-amp}/&/g;
    $self->SUPER::pushline($line);
}

sub set_tags_kind {
    my $self=shift;
    my (%kinds)=@_;

    foreach (qw(translate empty section verbatim ignore attributes qualify)) {
        $self->{SGML}->{k}{$_} = $self->{options}{$_} ? $self->{options}{$_}.' ' : '';
        # Remove the default behavior for the tags defined with the
        # options.
        foreach my $k (keys %kinds) {
            foreach my $t (split(" ", $self->{SGML}->{k}{$_})) {
                $kinds{$k} =~ s/\b$t\b//;
            }
        }
    }

    foreach (keys %kinds) {
        die "po4a::sgml: internal error: set_tags_kind called with unrecognized arg $_"
            if ($_ !~ /^(translate|empty|verbatim|ignore|indent|attributes|qualify)$/);

        $self->{SGML}->{k}{$_} .= $kinds{$_};
    }
}

#
# Do the actual work, using the SGMLS package and settings done elsewhere.
#
sub parse_file {
    my ($self,$mastername)=@_;
    my ($prolog);

    # Rewrite the file to:
    #   - protect optional inclusion marker (i.e. "<![ %str [" and "]]>")
    #   - protect entities from expansion (ie "&release;")
    my $origfile="";
    my $i=0;
    while ($i < @{$self->{TT}{doc_in}}) {
        $origfile .= ${$self->{TT}{doc_in}}[$i];
        $i+=2;
    }

    unless ($self->{options}{'force'}) {
        # Detect if we can find the DTD
        my ($tmpfh,$tmpfile)=File::Temp::tempfile("po4a-XXXX",
                                                  SUFFIX => ".sgml",
                                                  DIR    => $ENV{TMPDIR} || "/tmp",
                                                  UNLINK => 0);
        print $tmpfh $origfile;
        close $tmpfh
            or die wrap_mod("po4a::sgml",
                            dgettext("po4a", "Can't close tempfile: %s"), $!);
        if (system("onsgmls -p < $tmpfile")) {
            unlink ($tmpfile);
            die wrap_mod("po4a::sgml",
                         dgettext("po4a", "Error while running onsgmls -p.  ".
                                          "Please check if onsgmls and the ".
                                          "DTD are installed."));
        }
        unlink ($tmpfile);
    }
    # Detect the XML pre-prolog
    if ($origfile =~ s/^(\s*<\?xml[^?]*\?>)//) {
        warn wrap_mod("po4a::sgml", dgettext("po4a",
                "Trying to handle a XML document as a SGML one. ".
                "Feel lucky if it works, help us implementing a proper XML backend if it does not."), $mastername)
          unless $self->verbose() <= 0;
        $xmlprolog=$1;
    }
    # Get the prolog
    {
        $prolog=$origfile;
        my $lvl;    # number of '<' seen without matching '>'
        my $pos = 0;  # where in the document (in chars) while detecting prolog boundaries

        unless ($prolog =~ s/^(.*<!DOCTYPE).*$/$1/is) {
            die wrap_mod("po4a::sgml", dgettext("po4a",
                "This file is not a master SGML document (no DOCTYPE). ".
                "It may be a file to be included by another one, in which case it should not be passed to po4a directly. Text from included files is extracted/translated when handling the master file including them."));
        }
        $pos += length($prolog);
        $lvl=1;
        while ($lvl != 0) {
            # Eat comments in the prolog, since there may be some '>' or '<' in them.
            if ($origfile =~ m/^.{$pos}(<!--.*?-->)/s) {
                print "Found a comment in the prolog: $1\n" if ($debug{'generic'});
                $pos += length($1);
                # take care of the line numbers
                my @a = split(/\n/,$1);
                shift @a; # nb line - 1
                while (defined(shift @a)) {
                    $prolog .= "\n";
                }
                next;
            }
            # Search the closing '>'
            my ($c)=substr($origfile,$pos,1);
            $lvl++ if ($c eq '<');
            $lvl-- if ($c eq '>');
            $prolog = "$prolog$c";
            $pos++;
        }
    }

    # Add the definition of new tags that will be used for the
    # conditionnal inclusions
    if ($origfile =~ /^.*<!DOCTYPE[^[>]*\[/is) {
        $origfile =~ s/^(.*<!DOCTYPE[^[>]*\[)/$1 <!ELEMENT PO4ABEG - o empty> <!ATTLIST PO4ABEG name CDATA #REQUIRED> <!ELEMENT PO4AEND - o empty>/is;
    }

    print STDERR "PROLOG=$prolog\n------------\n" if ($debug{'generic'});

    # Configure the tags for this dtd
    if ($prolog =~ /debiandoc/i) {
        $self->set_tags_kind("translate" => "author version abstract title".
                                            "date copyrightsummary heading p ".
                                            "example tag title",
                             "empty"     => "date ref manref url toc",
                             "verbatim"  => "example",
                             "ignore"    => "package prgn file tt em var ".
                                            "name email footnote po4aend po4abeg ".
                                            "strong ftpsite ftppath qref",
                             "indent"    => "appendix ".
                                            "book ".
                                            "chapt copyright ".
                                            "debiandoc ".
                                            "enumlist ".
                                            "item ".
                                            "list ".
                                            "sect sect1 sect2 sect3 sect4 ".
                                            "tag taglist titlepag toc");

    } elsif ($prolog =~ /docbook/i) {
        $self->set_tags_kind("translate" => "abbrev appendixinfo artheader attribution ".
                                            "biblioentry biblioset ".
                                            "chapterinfo collab collabname confdates confgroup conftitle ".
                                            "date ".
                                            "edition editor entry example ".
                                            "figure ".
                                            "glosssee glossseealso glossterm ".
                                            "holder ".
                                            "member msgaud msglevel msgorig ".
                                            "orgdiv orgname othername ".
                                            "pagenums para phrase pubdate publishername primary ".
                                            "refclass refdescriptor refentrytitle refmiscinfo refname refpurpose releaseinfo remark revnumber revremark ".
                                            "screeninfo seg secondary see seealso segtitle simpara substeps subtitle synopfragmentref synopsis ".
                                            "term tertiary title titleabbrev ".
                                            "contrib epigraph",
                             "empty"     => "audiodata colspec graphic imagedata textdata sbr spanspec videodata xref",
                             "indent"    => "abstract answer appendix article articleinfo audioobject author authorgroup ".
                                            "bibliodiv bibliography blockquote blockinfo book bookinfo bridgehead ".
                                            "callout calloutlist caption caution chapter copyright ".
                                            "dedication docinfo ".
                                            "entry ".
                                            "formalpara ".
                                            "glossary glossdef glossdiv glossentry glosslist group ".
                                            "imageobject important index indexterm informaltable itemizedlist ".
                                            "keyword keywordset ".
                                            "legalnotice listitem lot ".
                                            "mediaobject msg msgentry msginfo msgexplan msgmain msgrel msgsub msgtext ".
                                            "note ".
                                            "objectinfo orderedlist ".
                                            "part partintro preface procedure publisher ".
                                            "qandadiv qandaentry qandaset question ".
                                            "reference refentry refentryinfo refmeta refnamediv refsect1 refsect1info refsect2 refsect2info refsect3 refsect3info refsection refsectioninfo refsynopsisdiv refsynopsisdivinfo revision revdescription row ".
                                            "screenshot sect1 sect1info sect2 sect2info sect3 sect3info sect4 sect4info sect5 sect5info section sectioninfo seglistitem segmentedlist set setindex setinfo shortcut simplelist simplemsgentry simplesect step synopfragment ".
                                            "table tbody textobject tgroup thead tip toc ".
                                            "variablelist varlistentry videoobject ".
                                            "warning",
                             "verbatim"  => "address cmdsynopsis holder literallayout programlisting ".
                                            "refentrytitle refname refpurpose screen term title",
                             "ignore"    => "acronym action affiliation anchor application arg author authorinitials ".
                                            "city citation citerefentry citetitle classname co command computeroutput constant corpauthor country ".
                                            "database po4abeg po4aend ".
                                            "email emphasis envar errorcode errorname errortext errortype exceptionname ".
                                            "filename firstname firstterm footnote footnoteref foreignphrase function ".
                                            "glossterm guibutton guiicon guilabel guimenu guimenuitem guisubmenu ".
                                            "hardware ".
                                            "indexterm informalexample inlineequation inlinegraphic inlinemediaobject interface interfacename isbn ".
                                            "keycap keycode keycombo keysym ".
                                            "link lineannotation literal ".
                                            "manvolnum markup medialabel menuchoice methodname modespec mousebutton ".
                                            "nonterminal ".
                                            "olink ooclass ooexception oointerface option optional othercredit ".
                                            "parameter personname phrase productname productnumber prompt property pubsnumber ".
                                            "quote ".
                                            "remark replaceable returnvalue revhistory ".
                                            "sgmltag sidebar structfield structname subscript superscript surname symbol systemitem ".
                                            "token trademark type ".
                                            "ulink userinput ".
                                            "varname volumenum ".
                                            "wordasword ".
                                            "xref ".
                                            "year",
                             "attributes" =>"<(article|book)>lang");

    } else {
        if ($self->{options}{'force'}) {
            warn wrap_mod("po4a::sgml", dgettext("po4a", "DTD of this file is unknown, but proceeding as requested."));
            $self->set_tags_kind();
        } else {
            die wrap_mod("po4a::sgml", dgettext("po4a",
                "DTD of this file is unknown. (supported: DebianDoc, DocBook). The prolog follows:")."\n$prolog");
        }
    }

    # Hash of the file entities that won't be included
    my %ignored_inclusion = ();
    foreach (split / /,$self->{options}{'ignore-inclusion'}) {
        $ignored_inclusion{$_} = 1;
    }

    # Prepare the reference indirection stuff
    my @refs;
    my $length = ($origfile =~ tr/\n/\n/);
    print "XX Prepare reference indirection stuff\n" if $debug{'refs'};
    for (my $i=1; $i<=$length; $i++) {
        push @refs,"$mastername:$i";
        print "$mastername:$i\n" if $debug{'refs'};
    }

    # protect the conditional inclusions in the file
    $origfile =~ s/<!\[\s*IGNORE\s*\[/{PO4A-beg-IGNORE}/g; # cond. incl. starts
    $origfile =~ s/<!\[\s*CDATA\s*\[/{PO4A-beg-CDATA}/g; # cond. incl. starts
    $origfile =~ s/<!\[\s*RCDATA\s*\[/{PO4A-beg-RCDATA}/g; # cond. incl. starts
    $origfile =~ s/<!\[\s*([^\[\s]+)\s*\[/<po4abeg name="$1">/g; # cond. incl. starts
    $origfile =~ s/\]\]>/<po4aend>/g;                # cond. incl. end

    # Remove <![ IGNORE [ sections
    # FIXME: we don't support included PO4A-beg-
    my $tmp1 = $origfile;
    while ($tmp1 =~ m/^(.*?)({PO4A-beg-\s*IGNORE\s*}(?:.+?)<po4aend>)(.*)$/s)
    {
        my ($begin,$ignored,$end) = ($1, $2, $3);
        my @begin   = split(/\n/, $begin);
        my @ignored = split(/\n/, $ignored);
        my $pre = scalar @begin;
        my $len = (scalar @ignored) -1;
        $pre++ if ($begin =~ /\n$/s);
        $len++ if ($end   =~ /^\n/s);
        # remove the references of the ignored lines
        splice @refs, $pre+1, $len-1;
        # remove the lines
        $tmp1 = $begin.$end;
    }
    $origfile = $tmp1;
    # The <, >, and & in a CDATA must be escaped because they do not
    # correspond to tags or entities delimiters.
    $tmp1 = $origfile;
    $origfile = "";
    while ($tmp1 =~ m/^(.*?{PO4A-beg-\s*(?:CDATA|RCDATA)\s*})(.+?)(<po4aend>.*)$/s) {
        my ($begin, $tmp) = ($1, $2);
        $tmp1 = $3;
        $tmp =~ s/</{PO4A-lt}/gs;
        $tmp =~ s/>/{PO4A-gt}/gs;
        $tmp =~ s/&/{PO4A-amp}/gs;
        $origfile .= $begin.$tmp;
    }
    $origfile .= $tmp1;

    # Deal with the %entities; in the prolog. God damn it, this code is gross!
    # Try hard not to change the number of lines to not fuck up the references
    my %prologentincl;
    my $moretodo=1;
    PROLOGENTITY: while ($moretodo) { # non trivial loop to deal with recursive inclusion
        $moretodo = 0;
        # Unprotect not yet defined inclusions
        $prolog =~ s/{PO4A-percent}/%/sg;
        print STDERR "prolog=>>>>$prolog<<<<\n"
              if ($debug{'entities'});
        while ($prolog =~ /(.*?)<!ENTITY\s*%\s*(\S*)\s+SYSTEM\s*"([^>"]*)"\s*>(.*)$/is) {  #})"{ (Stupid editor)
            print STDERR "Seen the definition entity of prolog inclusion '$2' (=$3)\n"
              if ($debug{'entities'});
            # Preload the content of the entity.
            my $key = $2;
            my $filename=$3;
            my $origfilename = $filename;
            my ($begin, $end) = ($1, $4);
            if ($filename !~ m%^/% && $mastername =~ m%/%) {
                my $dir=$mastername;
                $dir =~ s%/[^/]*$%%;
                $filename="$dir/$filename";
                # origfile also needs to be fixed otherwise onsgmls won't
                # find the file.
                $origfile =~ s/(<!ENTITY\s*%\s*\Q$key\E\s+SYSTEM\s*")\Q$origfilename\E("\s*>)/$1$filename$2/gsi;
            }
            if (defined $ignored_inclusion{$key} or !-e $filename) {
                # We won't expand this entity.
                # And we avoid onsgmls to do so.
                $prolog = "$begin<!--{PO4A-ent-beg-$key}$filename".
                          "{PO4A-ent-end}-->$end";
            } else {
            $prolog = $begin.$end;
            (-e $filename && open IN,"<$filename")  ||
              die wrap_mod("po4a::sgml",
                           dgettext("po4a",
                               "Can't open %s (content of entity %s%s;): %s"),
                           $filename, '%', $key, $!);
            local $/ = undef;
            $prologentincl{$key} = <IN>;
            close IN;
            print STDERR "Content of \%$key; is $filename (".
                         ($prologentincl{$key} =~ tr/\n/\n/).
                         " lines long)\n"
              if ($debug{'entities'});
            print STDERR "content: ".$prologentincl{$key}."\n"
              if ($debug{'entities'});
            $moretodo = 1;
            next PROLOGENTITY;
            }
        }
        while ($prolog =~ /(.*?)<!ENTITY\s*%\s*(\S*)\s*"([^>"]*)"\s*>(.*)$/is) {  #})"{ (Stupid editor)
            print STDERR "Seen the definition entity of prolog definition '$2' (=$3)\n"
              if ($debug{'entities'});
            # Preload the content of the entity.
            my $key = $2;
            $prolog = $1.$4;
            $prologentincl{$key} = $3;
            print STDERR "content: ".$prologentincl{$key}."\n"
              if ($debug{'entities'});
            $moretodo = 1;
            next PROLOGENTITY;
        }
        while ($prolog =~ /^(.*?)%([^;\s]*);(.*)$/s) {
            my ($pre,$ent,$post) = ($1,$2,$3);
            # Yeah, right, the content of the entity can be defined in a not yet loaded entity
            # It's easy to build a weird case where all that shit collapses poorly. But why the
            # hell are you using those strange constructs in your document, damn it?
            print STDERR "Seen prolog inclusion $ent\n" if ($debug{'entities'});
            if (defined ($prologentincl{$ent})) {
                $prolog = $pre.$prologentincl{$ent}.$post;
                print STDERR "Change \%$ent; to its content in the prolog\n"
                  if $debug{'entities'};
                $moretodo = 1;
            } else {
                # AAAARGH stupid document using %bla; and having then defined in another inclusion!
                # Protect it for this pass, and unprotect it on next one
                print STDERR "entity $ent not defined yet ?!\n"
                  if $debug{'entities'};
                $prolog = "$pre".'{PO4A-percent}'."$ent;$post";
            }
        }
    }
    $prolog =~ s/<!--\{PO4A-ent-beg-(.*?)\}(.*?)\{PO4A-ent-end\}-->/<!ENTITY % $1 SYSTEM "$2">/g;
    # Unprotect undefined inclusions, and die of them
    $prolog =~ s/\{PO4A-percent\}/%/sg;
    if ($prolog =~ /%([^;\s]*);/) {
        die wrap_mod("po4a::sgml",
                     dgettext("po4a",
                              "unrecognized prolog inclusion entity: %%%s;"),
                     $1)
           unless ($ignored_inclusion{$1});
    }
    # Protect &entities; (all but the ones asking for a file inclusion)
    #   search the file inclusion entities
    my %entincl;
    my $searchprolog=$prolog;
    while ($searchprolog =~ /(.*?)<!ENTITY\s+(\S*)\s+SYSTEM\s*"([^>"]*)"\s*>(.*)$/is) {  #})"{
        print STDERR "Seen the entity of inclusion $2 (=$3)\n"
          if ($debug{'entities'});
        my $key = $2;
        my $filename = $3;
        my $origfilename = $filename;
        $searchprolog = $4;
        if ($filename !~ m%^/% && $mastername =~ m%/%) {
            my $dir=$mastername;
            $dir =~ s%/[^/]*$%%;
            $filename="$dir/$filename";
            # origfile also needs to be fixed otherwise onsgmls won't find
            # the file.
            $origfile =~ s/(<!ENTITY\s+$key\s+SYSTEM\s*")\Q$origfilename\E("\s*>)/$1$filename$2/gsi;
        }
        if ((not defined $ignored_inclusion{$2}) and (-e $filename)) {
            $entincl{$key}{'filename'}=$filename;
            # Preload the content of the entity
            (-e $filename && open IN,"<$filename")  ||
                die wrap_mod("po4a::sgml",
                       dgettext("po4a",
                                "Can't open %s (content of entity %s%s;): %s"),
                                $filename, '&', $key, $!);
            local $/ = undef;
            $entincl{$key}{'content'} = <IN>;
            close IN;
            $entincl{$key}{'length'} = ($entincl{$key}{'content'} =~ tr/\n/\n/);
            print STDERR "read $filename (content of \&$key;, $entincl{$key}{'length'} lines long)\n"
                if ($debug{'entities'});
        }
    }

    #   Change the entities including files in the document
    my $dosubstitution = 1;
    while ($dosubstitution) {
        $dosubstitution = 0;
        foreach my $key (keys %entincl) {
            # The external entity can be referenced as &key; or &key
            # In the second case, we must differentiate &key and &key2
            while ($origfile =~/^(.*?)&$key(;.*$|[^-_:.A-Za-z0-9].*$|$)/s) {
                # Since we will include a new file, we
                # must do a new round of substitutions.
                $dosubstitution = 1;
                my ($begin,$end)=($1,$2);
                $end = "" unless (defined $end);
                $end =~ s/^;//s;

                if ($begin =~ m/.*<!--(.*?)$/s and $1 !~ m/-->/s) {
                    # This entity is commented. Just remove it.
                    $origfile = $begin.$end;
                    next;
                }

                # add the refs
                my $len  = $entincl{$key}{'length'}; # number added by the inclusion
                my $pre  = ($begin =~ tr/\n/\n/); # number of \n
                my $post = ($end =~ tr/\n/\n/);
                print "XX Add a ref. pre=$pre; len=$len; post=$post\n"
                    if $debug{'refs'};
                # Keep a reference of inclusion position in main file
                my $main = $refs[$pre];

                # Remove the references for the lines after the inclusion
                # point.
                my @endrefs = splice @refs, $pre+1;

                # Add the references of the added lines
                my $i;
                for ($i=0; $i<$len; $i++) {
                    $refs[$i+$pre] = "$main $entincl{$key}{'filename'}:".($i+1);
                }

                if ($begin !~ m/\n[ \t]*$/s) {
                    if ($entincl{$key}{'content'} =~ m/^[ \t]*\n/s) {
                        # There is nothing in the first line of the
                        # included file, and something on the line before
                        # the inclusion The line reference will be more
                        # informative like this:
                        $refs[$pre] = $main;
                    }
                }
                if ($end !~ s/^[ \t]*\n//s) {
                    if ($entincl{$key}{'content'} =~ m/\n[ \t]*$/s) {
                        # There is something on the line after the
                        # inclusion, and there is an end of line at the
                        # end of the included file. We must add the line
                        # reference of the remainder on the line:
                        push @refs, $main;
                    }
                }
                # Append the references removed earlier (lines after the
                # inclusion point).
                push @refs, @endrefs;

                # Do the substitution
                $origfile = "$begin".$entincl{$key}{'content'}."$end";
                print STDERR "substitute $key\n" if ($debug{'entities'});
            }
        }
    }
    $origfile=~s/\G(.*?)&([A-Za-z_:][-_:.A-Za-z0-9]*|#[0-9]+|#x[0-9a-fA-F]+)\b/$1\{PO4A-amp\}$2/gs;
    if (defined($xmlprolog) && length($xmlprolog)) {
        $origfile=~s/\/>/\{PO4A-close\}>/gs;
    }

    if ($debug{'refs'}) {
        print "XX Resulting shifts\n";
        for (my $i=0; $i<scalar @refs; $i++) {
            print "$mastername:".($i+1)." -> $refs[$i]\n";
        }
    }

    my ($tmpfh,$tmpfile)=File::Temp::tempfile("po4a-XXXX",
                                              SUFFIX => ".sgml",
                                              DIR    => $ENV{TMPDIR} || "/tmp",
                                              UNLINK => 0);
    print $tmpfh $origfile;
    close $tmpfh or die wrap_mod("po4a::sgml", dgettext("po4a", "Can't close tempfile: %s"), $!);

    my $cmd="onsgmls -l -E 0 -wno-valid < $tmpfile".
            ($debug{'onsgmls'}?"":" 2>/dev/null")." |";
    print STDERR "CMD=$cmd\n" if ($debug{'generic'} or $debug{'onsgmls'});

    open (IN,$cmd) || die wrap_mod("po4a::sgml", dgettext("po4a", "Can't run onsgmls: %s"), $!);

    # The kind of tags
    my (%translate,%empty,%verbatim,%indent,%exist,%attribute,%qualify);
    foreach (split(/ /, ($self->{SGML}->{k}{'translate'}||'') )) {
        $translate{uc $_} = 1;
        $indent{uc $_} = 1;
        $exist{uc $_} = 1;
    }
    foreach (split(/ /, ($self->{SGML}->{k}{'empty'}||'') )) {
        $empty{uc $_} = 1;
        $exist{uc $_} = 1;
    }
    foreach (split(/ /, ($self->{SGML}->{k}{'verbatim'}||'') )) {
        $translate{uc $_} = 1;
        $verbatim{uc $_} = 1;
        $exist{uc $_} = 1;
    }
    foreach (split(/ /, ($self->{SGML}->{k}{'indent'}||'') )) {
        $translate{uc $_} = 1;
        $indent{uc $_} = 1;
        $exist{uc $_} = 1;
    }
    foreach (split(/ /, ($self->{SGML}->{k}{'ignore'}) || '')) {
        $exist{uc $_} = 1;
    }
    foreach (split(/ /, ($self->{SGML}->{k}{'attributes'} || ''))) {
        my ($attr, $tags);
        if (m/(^.*>)(\w+)/) {
            $attr=uc $2;
            $tags=$1;
        } else {
            $attr=uc $_;
            $tags=".*";
        }
        if (exists $attribute{$attr}) {
            $attribute{$attr}.="|$tags";
        } else {
            $attribute{$attr} = $tags;
        }
    }
    foreach (split(/ /, ($self->{SGML}->{k}{'qualify'}) || '')) {
        $qualify{uc $_} = 1;
        $attribute{uc $_} = '.*' unless exists $attribute{uc $_};
    }


    # What to do before parsing

    # push the XML prolog if existing
    $self->pushline($xmlprolog."\n") if (defined($xmlprolog) && length($xmlprolog));

    # Put the prolog into the file, allowing for entity definition translation
    #  <!ENTITY myentity "definition_of_my_entity">
    # and push("<!ENTITY myentity \"".$self->translate("definition_of_my_entity")
    if ($prolog =~ m/(.*?\[)(.*)(\]>)/s) {
        warn "Pre=~~$1~~;Post=~~$3~~\n" if ($debug{'entities'});
        $self->pushline($1."\n") if (length($1));
        $prolog=$2;
        my ($post) = $3;
        while ($prolog =~ m/^(.*?)<!ENTITY\s+(\S*)\s+"([^"]*)"\s*>(.*)$/is) { #" ){
           $self->pushline($1) if length($1);
           $self->pushline("<!ENTITY $2 \"".$self->translate($3,"","definition of entity \&$2;")."\">");
           warn "Seen text entity $2\n" if ($debug{'entities'});
           $prolog = $4;
        }
        $prolog .= $post;
        $self->pushline($prolog."\n") if (length($prolog));
    } else {
        warn "No entity declaration detected in ~~$prolog~~...\n" if ($debug{'entities'});
        $self->pushline($prolog) if length($prolog);
    }

    # The parse object.
    # Damn SGMLS. It makes me do crude things.
    no strict "subs";
    my $parse= new SGMLS(IN);
    use strict;

    # Some values for the parsing
    my @open=(); # opened translation container tags
    my $verb=0;  # can we wrap or not
    my $verb_last_ref;
    my $seenfootnote=0;
    my $indent=0; # indent level
    my $lastchar = ''; #
    my $buffer= ""; # what we will soon handle

    # Keep a reference to the last line indicated by onsgmls
    my $line=0;
    # Unfortunately, onsgmls do not mention all the line changes.  We have
    # to keep track of the number of lines seen in the "record ends".
    my $adds=0;
    # If the last line received contains only spaces, do not take it into
    # account for the line reference of the paragraph.
    my $empty_last_cdata=0;
    # run the appropriate handler for each event
    EVENT: while (my $event = $parse->next_event) {
        # get the line reference to build po entries
        if ($line != $parse->line) {
            # onsgmls informs us of that the line changed. Reset $adds and
            # $empty_last_cdata
            $adds = 0;
            $empty_last_cdata = 0;
            $line = $parse->line;
        }
        my $ref=$refs[$parse->line-1 + $adds - $empty_last_cdata];
        # In verbatim mode, keep the current line reference.
        if ($verb) {
            $ref=$refs[$parse->line-1];
        }
        my $type;

        if ($event->type eq 'start_element') {
            die wrap_ref_mod($ref, "po4a::sgml",
                             dgettext("po4a", "Unknown tag %s"),
                             $event->data->name)
                unless $exist{$event->data->name};

            $lastchar = ">";

            # Which tag did we see?
            my $tag='';
            $tag .= '<'.lc($event->data->name());
            while (my ($attr, $val) = each %{$event->data->attributes()}) {
                my $value = $val->value();
#                if ($val->type() eq 'IMPLIED') {
#                    $tag .= ' '.lc($attr).'="'.lc($attr).'"';
#                } els
                if ($val->type() eq 'CDATA' ||
                    $val->type() eq 'IMPLIED') {
                    if (defined $value && length($value)) {
                        my $lattr=lc $attr;
                        my $uattr=uc $attr;
                        if (exists $attribute{$uattr}) {
                            my $context="";
                            foreach my $o (@open) {
                                next if (!defined $o or $o =~ m%^</%);
                                $o =~ s/ .*/>/;
                                $context.=$o;
                            }
                            $context=join("", $context,
                                          "<", lc($event->data->name()), ">");
                            if ($context =~ /^($attribute{$uattr})$/) {
                                if ($qualify{$uattr}) {
                                    my $translated = $self->translate("$lattr=$value", $ref, "attribute $context$lattr");
                                    if ($translated =~ s/^$lattr=//) {
                                        $value=$translated;
                                    } else {
                                        die wrap_mod("po4a::sgml", dgettext("po4a", "bad translation '%s' for '%s' in '%s'"), $translated, $context.$lattr, $ref);
                                    }
                                } else {
                                    $value = $self->translate($value, $ref, "attribute $context$lattr");
                                }
                            }
                        }
                        if ($value =~ m/\"/) {
                            $value = "'".$value."'";
                        } else {
                            $value = '"'.$value.'"';
                        }
                        $tag .= " $lattr=$value";
                    }
                } elsif ($val->type() eq 'NOTATION') {
                } else {
                    $tag .= ' '.lc($attr).'="'.lc($value).'"'
                        if (defined $value && length($value));
                }
            }
            $tag .= '>';


            # debug
            print STDERR "Seen $tag, open level=".(scalar @open).", verb=$verb\n"
                if ($debug{'tag'});

            if ($event->data->name() eq 'FOOTNOTE') {
                # we want to put the <para> inside the <footnote> in the same msgid
                $seenfootnote = 1;
            }

            if ($seenfootnote) {
                $buffer .= $tag;
                next EVENT;
            }
            if ($translate{$event->data->name()}) {
                # Build the type
                if (scalar @open > 0) {
                    $type=$open[$#open] . $tag;
                } else {
                    $type=$tag;
                }

                # do the job
                if (@open > 0) {
                    $self->end_paragraph($buffer,$ref,$type,$verb,$indent,
                                         @open);
                } else {
                    $self->pushline($buffer) if $buffer;
                }
                $buffer="";
                push @open,$tag;
            } elsif ($indent{$event->data->name()}) {
                die wrap_ref_mod($ref, "po4a::sgml", dgettext("po4a",
                    "Closing tag for a translation container missing before %s"),$tag)
                    if (scalar @open);
            }

            if ($verbatim{$event->data->name()}) {
                $verb++;
                # Keep a reference to the line that openned the verbatim
                # section. This is needed to check if its data starts on
                # the same line.
                $verb_last_ref = $ref;
            }
            if ($verb) {
                # Tag in a verbatim section. Check if it appeared at
                # the same line than the previous data. If not, it
                # means that an end of line must be added to the
                # buffer.
                if ($ref ne $verb_last_ref) {
                    # FIXME: Does it work if $verb > 1
                    $buffer .= "\n";
                    $verb_last_ref = $ref;
                }
            }

            if ($indent{$event->data->name()}) {
                # push the indenting space only if not in verb before that tag
                # push trailing "\n" only if not in verbose afterward
                $self->pushline( ($verb>1?"": (" " x $indent)).$tag.($verb?"":"\n"));
                $indent ++ unless $empty{$event->data->name()} ;
            }  else {
                $tag =~ s/<po4abeg name="([^"]+)">/<![ $1 [/; #"; Stupid emacs
                $tag =~ s/<po4aend>/]]>/;
                $buffer .= $tag;
            }
        } # end of type eq 'start_element'

        elsif ($event->type eq 'end_element') {
            my $tag = ($empty{$event->data->name()}
                           ?
                       ''
                           :
                       '</'.lc($event->data->name()).'>');

            if ($verb) {
                # Tag in a verbatim section. Check if it appeared at
                # the same line than the previous data. If not, it
                # means that an end of line must be added to the
                # buffer.
                if ($ref ne $verb_last_ref) {
                    # FIXME: Does it work if $verb > 1
                    $buffer .= "\n";
                    $verb_last_ref = $ref;
                }
            }
            print STDERR "Seen $tag, level=".(scalar @open).", verb=$verb\n"
                if ($debug{'tag'});

            $lastchar = ">";

            if ($event->data->name() eq 'FOOTNOTE') {
                # we want to put the <para> inside the <footnote> in the same msgid
                $seenfootnote = 0;
            }

            if ($seenfootnote) {
                $buffer .= $tag;
                next EVENT;
            }
            if ($translate{$event->data->name()}) {
                $type = $open[$#open] . $tag;
                $self->end_paragraph($buffer,$ref,$type,$verb,$indent,@open);
                $buffer = "";
                pop @open;
                if (@open > 0) {
                    pop @open;
                    push @open,$tag;
                }
            } elsif ($indent{$event->data->name()}) {
                die wrap_ref_mod($ref, "po4a::sgml", dgettext("po4a",
           "Closing tag for a translation container missing before %s"), $tag)
                    if (scalar @open);
            }

            unless ($event->data->name() =~ m/^(PO4ABEG|PO4AEND)$/si) {
                if ($indent{$event->data->name()}) {
                    $indent -- ;
                    # add indenting space only when not in verbatim
                    # add the tailing \n only if out of verbatim after that tag
                    $self->pushline(($verb?"":(" " x $indent)).$tag.($verb>1?"":"\n"));
                }  else {
                    $buffer .= $tag;
                }
                $verb-- if $verbatim{$event->data->name()};
            }
        } # end of type eq 'end_element'

        elsif ($event->type eq 'cdata') {
            my $cdata = $event->data;
            $empty_last_cdata=($cdata =~ m/^\s*$/);
            $cdata =~ s/{PO4A-lt}/</g;
            $cdata =~ s/{PO4A-gt}/>/g;
            $cdata =~ s/{PO4A-amp}/&/g;
            $cdata =~ s/{PO4A-end}/\]\]>/g;
            $cdata =~ s/{PO4A-beg-([^\}]+)}/<!\[$1\[/g;
            if ($verb) {
                # Check if this line of data appear on the same line
                # than the previous tag. If not, append an end of line
                # to the buffer.
                if ($ref ne $verb_last_ref) {
                    $buffer .= "\n";
                    $verb_last_ref = $ref;
                }
            } else {
                $cdata =~ s/\\t/ /g;
                $cdata =~ s/\s+/ /g;
                $cdata =~ s/^\s//s if $lastchar eq ' ';
            }
            $lastchar = substr($cdata, -1, 1);
            $buffer .= $cdata;
            if (defined($xmlprolog) && length($xmlprolog)) {
                $buffer =~ s/>PO4A-close\}>/\/>/sg;
                $buffer =~ s/PO4A-close\}>//sg; # This should not be necessary
            }
        } # end of type eq 'cdata'

        elsif ($event->type eq 'sdata') {
            my $sdata = $event->data;
            $sdata =~ s/^\[//;
            $sdata =~ s/\s*\]$//;
            $lastchar = substr($sdata, -1, 1);
            $buffer .= '&'.$sdata.';';
        } # end of type eq 'sdata'

        elsif ($event->type eq 're') {
            # End of record, the line reference shall be incremented.
            $adds +=1;
            if ($verb) {
                # Check if this line of data appear on the same line
                # than the previous tag. If not, append an end of line
                # to the buffer.
                if ($ref ne $verb_last_ref) {
                    $buffer .= "\n";
                    $verb_last_ref = $ref;
                }
                $buffer .= "\n";
            } elsif ($lastchar ne ' ') {
                $buffer .= " ";
            }
            $lastchar = ' ';
        } #end of type eq 're'

        elsif ($event->type eq 'conforming') {

        }

        elsif ($event->type eq 'pi') {
            my $pi = $event->data;
            $buffer .= "<?$pi>";
        }

        else {
            die wrap_ref_mod($refs[$parse->line], "po4a::sgml",
                             dgettext("po4a","Unknown SGML event type: %s"),
                             $event->type);
        }
    }

    # What to do after parsing
    $self->pushline($buffer);
    close(IN);
    warn wrap_mod("po4a::sgml",
                  dgettext("po4a","Warning: onsgmls produced some errors.  ".
                  "This is usually caused by po4a, which modifies the input ".
                  "and restores it afterwards, causing the input of onsgmls ".
                  "to be invalid.  This is usually safe, but you may wish ".
                  "to verify the generated document with onsgmls -wno-valid.  ".
                  "Continuing..."))
        if ($? != 0 and $self->verbose() > 0);
    unlink ($tmpfile) unless ($debug{'refs'} or $debug{'onsgmls'});
}

sub end_paragraph {
    my ($self, $para,$ref, $type,$verb,$indent)=
        (shift,shift,shift,shift,shift,shift);
    my (@open)=@_;
    die "Internal error: no paragraph to end here!!"
        unless scalar @open;

    return unless defined($para) && length($para);

    if (($para =~ m/^\s*$/s) and (not $verb)) {
        # In non-verbatim environments, a paragraph with only spaces is
        # like an empty paragraph
        return;
    }

    # unprotect &entities;
    $para =~ s/{PO4A-amp}/&/g;
    # remove the name"\|\|" onsgmls added as attributes
    $para =~ s/ name=\"\\\|\\\|\"//g;
    $para =~ s/ moreinfo=\"none\"//g;

    # Extract the leading and trailing spaces. They will be restored only
    # in verbatim environments.
    my ($leading_spaces, $trailing_spaces) = ("", "");
    if ($verb) {
        # In the verbatim mode, we can ignore empty lines, but not the
        # leading spaces or tabulations. Otherwise, the PO will look
        # weird.
        if ($para =~ m/^(\s*\n)(.*?)(\s*)$/s) {
            $leading_spaces = $1;
            $para = $2;
            $trailing_spaces = $3;
        }
    } else {
        if ($para =~ m/^(\s*)(.*?)(\s*)$/s) {
            $leading_spaces = $1;
            $para = $2;
            $trailing_spaces = $3;
        }
    }

    $para = $self->translate($para,$ref,$type,
                             'wrap' => ! $verb,
                             'wrapcol' => (75 - $indent));

    if ($verb) {
        $para = $leading_spaces.$para.$trailing_spaces;
    } else {
        $para =~ s/^\s+//s;
        my $toadd=" " x ($indent+1);
        $para =~ s/^/$toadd/mg;
        $para .= "\n";
    }

    $self->pushline( $para );
}

1;

=head1 AUTHORS

This module is an adapted version of sgmlspl (SGML postprocessor for the
ONSGMLS parser) which was:

 Copyright (c) 1995 by David Megginson <dmeggins@aix1.uottawa.ca>

The adaptation for po4a was done by:

 Denis Barbier <barbier@linuxfr.org>
 Martin Quinson (mquinson#debian.org)

=head1 COPYRIGHT AND LICENSE

 Copyright (c) 1995 by David Megginson <dmeggins@aix1.uottawa.ca>
 Copyright 2002, 2003, 2004, 2005 by SPI, inc.

This program is free software; you may redistribute it and/or modify it
under the terms of GPL (see the COPYING file).
po4a 0.47-2 / usr / share / perl5 / Locale / Po4a / Sgml.pm
