#!/usr/bin/perl -w

# = HISTORY SECTION =====================================================================

# ---------------------------------------------------------------------------------------
# version | date   | author   | changes
# ---------------------------------------------------------------------------------------
# 0.02    |16.08.01| JSTENZEL | fixed call of <parser>->run() by adapting it to new tag
#         |        |          | declarations finally (but the bug caused no error);
# 0.01    |16.06.01| JSTENZEL | derived from my pp2sdf.
# ---------------------------------------------------------------------------------------

# = POD SECTION =========================================================================

=head1 NAME

B<pp2cppp> - translates PerlPoint to Clinton Pierce's Perl Projector

=head1 VERSION

This manual describes version B<0.02>.

=head1 DESCRIPTION

This is a demonstration application of the PerlPoint package. It
translates PerlPoint into Clinton Pierce's Perl Projector format
(see ). In this documentation, I call this format "CPPP".

=head1 SYNOPSIS

pp2cppp [<options>] <PerlPoint sources>

=head2 Options

All options can be abbreviated uniqly.

=over 4

=item -activeContents

PerlPoint sources can embed Perl code which is evaluated while the source is parsed. For
reasons of security this feature is deactivated by default. Set this option to active
it. You can use I<-safeOpcode> to fine tune which operations shall be permitted.

=item -cache

parsing of one and the same document several times can be accelerated by activating the
PerlPoint parser cache by this option. The performance boost depends on your document
structure.

Cache files are written besides the source and named ".<source file>.ppcache".

It can be useful to (temporarily) deactivate the cache to get correct line numbers in
parser error messages (currently numbers cannot always reported correctly with activated
cache because of a special perl behaviour).

=item -cacheCleanup

PerlPoint parser cache files grow (with every modified version of a source parsed)
because they store expressions for every parsed variant of a paragraph. This is usually
uncritical but you may wish to clean up the cache occasionally. Use this option to
perform the task (or remove the cache file manually).

=item -help

displays an online help and terminates the script.

=item -nocopyright

suppresses the copyright message;

=item -noinfo

supresses runtime informations;

=item -nowarn

supresses warnings;

=item -quiet

a shortcut for "-nocopyright -noinfo -nowarn": all non critical runtime messages are suppressed;

=item -safeOpcode <opcode>

If active contents is enabled (I<-activeContents>), Perl code embedded into the translated PerlPoint
sources will be evaluated. To keep security this is done via an object of class B<Safe> which restricts
code to permitted operations. By this option you can declare which opcode (or opcode tag) is permitted.
Please see the B<Safe> and B<Opcode> manual pages for further details. (These modules come with perl.)

Pass C<ALL> to allow I<everything>.

This option can be used multiply.

You may want to store these options in default option files, see below for details.


=item -set <flag>

This option allows you to pass certain settings - of your choice - to active contents
(like conditions) where it can be accessed via the $PerlPoint hash reference. For
example, your PerlPoint code could contain a condition like

  ? $PerlPoint->{userSettings}{special}

  Special part.

  ? 1

. The special part enclosed by the two conditions would then be processed I<only> if you
call B<pp2cppp> with

  -set special

- and if active contents was enabled by I<-active>, of course.

This option can be used multiply.

=item -trace [<level>]

activates traces of the specified level. You may use the environment variable SCRIPTDEBUG
alternatively (but an option overwrites environment settings). The following levels are
defined  (use the I<numeric> values) - if a description sounds cryptic to you, just ignore
the setting:

=over 4

=item zero (0)

same as omitting the option: all traces are suppressed.

=item one (1)

paragraph detection,

=item two (2)

lexer traces,

=item four (4)

parsing,

=item eight (8)

semantic actions embedded into parsing,

=item sixteen (16)

active contents,

=item thirtytwo (32)

backend traces.

=back

Using different levels may cause unexpected results.

Several levels are combined by addition.

 # activate lexer and parser traces
 -trace 6

=back

=head2 Option files

Options may be loaded from files where they are stored exactly as you write them in the
command line, but may be spread to several lines and extended by comment lines which start
with a "#" character. To mark an option file in the commandline, simply enter its (path and)
name prededed by a "@" character, for example

  pp2cppp @myOptions ppfile

  where the file myOptions could look like

  # suppress infos
  -noinfo

Option files may be nested. To avoid endless recursion, every option file is resolved only
the first time it is detected.

  # this is an option file which
  # refers to another option file
  -noinfo @moreOptions

The script also takes care of I<default option files> which means that usual options can
be stored in files named C<.pp2cppp>. If such a file is placed in the directory where the script itself
resides, options in the file are read in automatically by all pp2cppp calls. These are global
settings. If you place such a file in your home directory, it is read automatically as well
but only if pp2cppp is called under your account, so this is for personal preferences.

A personal default option file overwrites global settings, and all default options are
overwritten by options passed to the script call.


=head1 SUPPORTED TAGS

All supported tags are declared by B<PerlPoint::Tags::CPPP>. Please see there for a
complete list.

B<pp2cppp> supports several foreign tags initially introduced by C<pp2html>.
Support means that they are handled, but possibly different to the original
handling:

=over 4

=item L

The tag body becomes plain text, followed by the URL in paranthesis.
Any other options besides C<url> are ignored.

 Example:

  \L{url=link}<Look there!> becomes "Look there! (link)".

=item U

Marks the body to be underlined

 Example:

  \U<text> becomes "u<text>".


=back


=head1 EMBEDDING TARGET CODE

There may be things you want to see in the target document but find no way to express
them in PerlPoint. Well, PerlPoint lets you embed target code very easily directly into
the PerlPoint script. Nevertheless, it is recommended to use native PerlPoint wherever
possible ;-).

Please note that embedded target code intended for certain translators like B<pp2cppp>
may be B<I<ignored>> if the PerlPoint document is processed by I<other> translators.
pp2html, for example, accepts embedded HTML but ignores embedded CPPP.

=head2 Embedding CPPP

Just use the B<\EMBED> and B<\END_EMBED> tags to place native CPPP if really
necessary:

  This is \I<PerlPoint> with embedded
  \EMBED{lang=cppp}{{B:CPPP}}\END_EMBED.

  \EMBED{lang=cppp}

  =t An CPPP chapter

  =comment A CPPP comment.

  \END_EMBED

You may as well I<include> complete CPPP files by B<\INCLUDE>.

  \INLUDE{type=cppp file="snippet.cppp"}


=head2 Embedding other languages

B<pp2cppp> will ignore any other embedded or included target language than CPPP.


=head1 PREDECLARED VARIABLES

B<pp2cppp> predeclares several variables which can be used like any user defined PerlPoint
variable.

=over 4

=item CONVERTER_NAME

The name of the converter currently processing the document ("pp2cppp").

=item CONVERTER_VERSION

The version of the running converter.

=back


=head1 FILES

=head1 ENVIRONMENT

=over 4

=item SCRIPTDEBUG

may be set to a numeric value to activate certain trace levels. You can use option I<-trace>
alternatively (note that a used option overwrites an environment setting). The several levels
are described with this option.

=back

=head1 NOTES

PerlPoint allows to process a document by all of its converters. Nevertheless,
possibly several foreign tags might produce unexpected results.


=head1 FILES

B<pp2cppp> activates the PerlPoint parser cache to accelerate repeated translations.
Because of this the usual PerlPoint parser cache files will be written next the
parsed sources (as ".<source file name>.ppcache" in the source directory).

=head1 SEE ALSO

The Perl Projector homepage.

PerlPoint::Tags::CPPP

PerlPoint::Parser

PerlPoint::Backend

=head1 AUTHOR

Copyright (c) Jochen Stenzel (perl@jochen-stenzel.de), 2000, 2001. All rights reserved.

This script is free software, you can redistribute it and/or modify it
under the terms of the Artistic License distributed with Perl version
5.003 or (at your option) any later version. Please refer to the
Artistic License that came with your Perl distribution for more
details.

The Artistic License should have been included in your distribution of
Perl. It resides in the file named "Artistic" at the top-level of the
Perl source tree (where Perl was downloaded/unpacked - ask your
system administrator if you dont know where this is).  Alternatively,
the current version of the Artistic License distributed with Perl can
be viewed on-line on the World-Wide Web (WWW) from the following URL:
http://www.perl.com/perl/misc/Artistic.html


=head1 DISCLAIMER

This software is distributed in the hope that it will be useful, but
is provided "AS IS" WITHOUT WARRANTY OF ANY KIND, either expressed or
implied, INCLUDING, without limitation, the implied warranties of
MERCHANTABILITY and FITNESS FOR A PARTICULAR PURPOSE.

The ENTIRE RISK as to the quality and performance of the software
IS WITH YOU (the holder of the software).  Should the software prove
defective, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
CORRECTION.

IN NO EVENT WILL ANY COPYRIGHT HOLDER OR ANY OTHER PARTY WHO MAY CREATE,
MODIFY, OR DISTRIBUTE THE SOFTWARE BE LIABLE OR RESPONSIBLE TO YOU OR TO
ANY OTHER ENTITY FOR ANY KIND OF DAMAGES (no matter how awful - not even
if they arise from known or unknown flaws in the software).

Please refer to the Artistic License that came with your Perl
distribution for more details.

=cut

# declare script package
package PerlPoint::Converter::pp2cppp;

# declare version
$VERSION=$VERSION=0.02;

# pragmata
use strict;

# load modules
use Carp;
use Safe;
use Getopt::Long;
use File::Basename;
use PerlPoint::Tags;
use PerlPoint::Backend;
use PerlPoint::Constants;
use PerlPoint::Tags::CPPP;
use PerlPoint::Parser 0.36;
use Getopt::ArgvFile qw(argvFile);


# declare variables
my (
    @streamData,                # PerlPoint stream;
    @openLists,
    @openTags,                  # a buffer used to autoclose / autoopen tags exceeding example lines;

    %flags,                     # flag hash;
    %options,                   # option hash;
    %table,                     # a table buffer
    %tagHash,                   # accepted PerlPoint tags;
   );

# resolve option files
argvFile(default=>1, home=>1);

# get options
GetOptions(\%options,
                      "activeContents",    # evaluation of active contents;
                      "cache",             # control the cache;
                      "cacheCleanup",      # cache cleanup;
                      "help",              # online help, usage;
                      "nocopyright",       # suppress copyright message;
                      "noinfo",            # suppress runtime informations;
                      "nowarn",            # suppress runtime warnings;
                      "quiet",             # suppress all runtime messages except of error ones;
                      "safeOpcode=s@",     # permitted opcodes in active contents;
                      "set=s@",            # user settings;
                      "tagset=s@",         # add a tag set to the scripts own tag declarations;
                      "trace:i",           # activate trace messages;
          );

# propagate options as necessary
@options{qw(nocopyright noinfo nowarn)}=() x 3 if exists $options{quiet};
$options{trace}=$ENV{SCRIPTDEBUG} if not exists $options{trace} and exists $ENV{SCRIPTDEBUG};

# display copyright unless suppressed
warn "\n",
     basename($0), ' ',
     do {no strict 'refs'; ${join('::', __PACKAGE__, 'VERSION')}},
     ", (c) J. Stenzel (perl\@jochen-stenzel.de) 2001. \n\n"
  unless exists $options{nocopyright};

# check for a help request
(exec("pod2text $0 | less") or die "[Fatal] exec() cannot be called: $!\n") if $options{help};

# check usage
die "[Fatal] Usage: $0 [<options>] <PerlPoint source(s)>\n" unless @ARGV>=1;

# check passed sources
-r or die "[Fatal] Source file $_ does not exist or is unreadable.\n" foreach @ARGV;

# import tags
PerlPoint::Tags::addTagSets(@{$options{tagset}}) if exists $options{tagset};

# tag translation table
%tagHash=(
          # base
	  B     => 'u',
	  C     => 'u',
	  I     => 'u',

          # imported tags
          U     => 'u',
	 );

# build parser
my $parser=new PerlPoint::Parser;

# Set up active contents handling. By default, we use a Safe object.
my $safe=new Safe;
if (exists $options{safeOpcode})
 {
  unless (grep($_ eq 'ALL', @{$options{safeOpcode}}))
    {
     # configure compartment
     $safe->permit(@{$options{safeOpcode}});
    }
  else
    {
     # simply flag that we want to execute active contents
     $safe=1;
    }
 }

# and call it
$parser->run(
             stream          => \@streamData,
             files           => \@ARGV,

             filter          => 'perl|cppp',

             safe            => exists $options{activeContents} ? $safe : undef,
             activeBaseData  => {
                                 targetLanguage => 'CPPP',
                                 userSettings   => {map {$_=>1} exists $options{set} ? @{$options{set}} : ()},
                                },

             predeclaredVars => {
                                 CONVERTER_NAME    => basename($0),
                                 CONVERTER_VERSION => do {no strict 'refs'; ${join('::', __PACKAGE__, 'VERSION')}},
                                },

             vispro          => 1,
             cache           =>   (exists $options{cache} ? CACHE_ON : CACHE_OFF)
                                + (exists $options{cacheCleanup} ? CACHE_CLEANUP : 0),
             display         =>   DISPLAY_ALL
                                + (exists $options{noinfo} ? DISPLAY_NOINFO : 0)
                                + (exists $options{nowarn} ? DISPLAY_NOWARN : 0),
             trace           =>   TRACE_NOTHING
                                + ((exists $options{trace} and $options{trace} &  1) ? TRACE_PARAGRAPHS : 0)
                                + ((exists $options{trace} and $options{trace} &  2) ? TRACE_LEXER      : 0)
                                + ((exists $options{trace} and $options{trace} &  4) ? TRACE_PARSER     : 0)
                                + ((exists $options{trace} and $options{trace} &  8) ? TRACE_SEMANTIC   : 0)
                                + ((exists $options{trace} and $options{trace} & 16) ? TRACE_ACTIVE     : 0),
            ) or exit(1);

# build a backend
my $backend=new PerlPoint::Backend(
                                   name    => 'pp2cppp',
                                   display =>   DISPLAY_ALL
                                              + (exists $options{noinfo} ? DISPLAY_NOINFO : 0)
                                              + (exists $options{nowarn} ? DISPLAY_NOWARN : 0),
                                   trace   =>   TRACE_NOTHING
                                              + ((exists $options{trace} and $options{trace} & 32) ? TRACE_BACKEND : 0),
                                   vispro  => 1,
                                  );

# register backend handlers
$backend->register(DIRECTIVE_DOCUMENT, sub {print "\n\n";});

$backend->register(DIRECTIVE_BLOCK, \&handleBlock);
$backend->register(DIRECTIVE_COMMENT, \&handleComment);
$backend->register(DIRECTIVE_HEADLINE, \&handleHeadline);
$backend->register(DIRECTIVE_SIMPLE, \&handleSimple);
$backend->register(DIRECTIVE_TAG, \&handleTag);
$backend->register(DIRECTIVE_TEXT, \&handleText);
$backend->register(DIRECTIVE_VERBATIM, \&handleBlock);

$backend->register($_, \&handleList) foreach (DIRECTIVE_ULIST, DIRECTIVE_OLIST, DIRECTIVE_DLIST);
$backend->register($_, \&handleListPoint) foreach (DIRECTIVE_UPOINT, DIRECTIVE_OPOINT, DIRECTIVE_DPOINT);
$backend->register(DIRECTIVE_DPOINT_ITEM, \&handleDListPointItem);
$backend->register($_, \&handleListShift) foreach (DIRECTIVE_LIST_LSHIFT, DIRECTIVE_LIST_RSHIFT);



# init several variables
@flags{qw(listlevel textstart headline)}=(1, 0, 0, 0);

# and run it
$backend->run(\@streamData);


# SUBROUTINES ###############################################################################

# simple directive handlers
sub handleSimple
 {
  # get parameters
  my ($opcode, $mode, @contents)=@_;

  @contents=map
             {
              # complete block lines as necessary
              if ($flags{block})
                {
                 # no open tag: simply add the correct intro
                 s/\n/\n\t/;
                }

              # supply result
              $_;
             } @contents;

  # prepare beginning of text blocks if necessary
  if ($flags{textstart})
    {
     # reset flag
     $flags{textstart}=0;
    }

  # store token in a duplication buffer if we are currently processing a headline
  $flags{headlineString}=join('', $flags{headlineString}, @contents) if $flags{headline};

  # simply print the token (preface new lines by a mark within blocks, and buffer them in tables)
  present(@contents);
 }

# headlines (are generated with an anchor identical to the title)
sub handleHeadline
 {
  # get parameters
  my ($opcode, $mode, $level, @contents)=@_;

  # act mode dependend
  if ($mode==DIRECTIVE_START)
    {
     # open headline
     print "\n=t ";

     # mark that we process a headline now
     $flags{headlineString}='';
     $flags{headline}=1;
    }
  else
    {
     # complete headline
     print "\n";

     # reset flags
     $flags{headlineString}='';
     $flags{headline}=0;
    }

  # new lists start at level 1
  $flags{listlevel}=1;
 }

# text
sub handleText
 {
  # get parameters
  my ($opcode, $mode)=@_;

  # act mode dependend
  $flags{textstart}=1, print "=i " if $_[1]==DIRECTIVE_START;
  print "\n" if $_[1]==DIRECTIVE_COMPLETE;
 }

# tags
sub handleTag
 {
  # get parameters
  my ($opcode, $mode, $tag, $settings)=@_;

  # reset flag, if necessary
  $flags{textstart}=0 if $flags{textstart} and ($tag=~/^(IMAGE|TABLE|TABLE_ROW|TABLE_COL|TABLE_HL)$/ or exists $tagHash{$tag});

  # handle image tags a special way
  if ($tag eq 'IMAGE')
    {
     # compose an CPPP image macro
     present(qq(=g $settings->{src}\n)) if $mode==DIRECTIVE_START;

     # ok, well done
     return(1);
    }

  # handle *tables*
  if ($tag eq 'TABLE')
    {
     # act mode dependend
     if ($mode==DIRECTIVE_START)
       {
        # start a new table (in memory)
        %table=();
       }
     else
       {
        # get the greatest number of columns
        my $rowNr=0;
        $rowNr>=@$_ or $rowNr=@$_ for (@{$table{rows}});

        # print table
        print "=table $rowNr;;;;;\n";
        print join(';;;;;', @$_), "\n" foreach (@{$table{rows}});

        # clean up
        %table=();
       }

     # ok, well done
     return(1);
    }
  elsif ($tag eq 'TABLE_ROW')
    {
     # act mode dependend
     push(@{$table{rows}}, []) if $mode==DIRECTIVE_START;

     # ok, well done
     return(1);
    }
  elsif ($tag eq 'TABLE_COL')
    {
     # act mode dependend
     push(@{$table{rows}[-1]}, '') if $mode==DIRECTIVE_START;

     # ok, well done
     return(1);
    }
  elsif ($tag eq 'TABLE_HL')
    {
     # act mode dependend
     push(@{$table{rows}[-1]}, '') if $mode==DIRECTIVE_START;

     # ok, well done
     return(1);
    }
  elsif ($tag eq 'L')
    {
     # act mode dependend (we only need to add a "suffix" to the body)
     present(" ($settings->{url})") if $mode==DIRECTIVE_COMPLETE;

     # ok, well done
     return(1);
    }

  # translatable tags: act mode dependend
  if ($mode==DIRECTIVE_START and exists $tagHash{$tag})
    {
     # open the CPPP tag
     present("$tagHash{$tag}<");
     # remember this opened tag if we are in an example
     push(@openTags, $tagHash{$tag}) if $flags{block};
    }
  if ($mode==DIRECTIVE_COMPLETE and exists $tagHash{$tag})
    {
     # close CPPP tag
     present('>');
     # update opened tag hints if we are in an example
     pop(@openTags) if $flags{block};
    }
 }

# blocks
sub handleBlock
 {
  # get parameters
  my ($opcode, $mode)=@_;

  # update global flag
  $flags{block}="\t" if $mode==DIRECTIVE_START;
  $flags{block}=0    if $mode==DIRECTIVE_COMPLETE;

  # reset flag (if necessary)
  $flags{textstart}=0;

  # prepare or complete the CPPP block
  print "$flags{block}" if $mode==DIRECTIVE_START;
  print "\n"            if $mode==DIRECTIVE_COMPLETE;
 }

# list
sub handleList
 {
  # get parameters
  my ($opcode, $mode, $wishedStartNr)=@_;

  # update list hints
  $flags{listpoints}=defined $wishedStartNr ? $wishedStartNr-1 : 0 if $mode==DIRECTIVE_START;
 }

# list shift
sub handleListShift
 {
  # get parameters
  my ($opcode, $mode, $offset)=@_;

  # anything to do?
  return unless $mode==DIRECTIVE_START;

  # handle operation dependend
  $flags{listlevel}+=$offset if $opcode==DIRECTIVE_LIST_RSHIFT;
  $flags{listlevel}-=$offset if $opcode==DIRECTIVE_LIST_LSHIFT;
  $flags{listlevel}=1 if $flags{listlevel}<1;
 }

# list point
sub handleListPoint
 {
  # get parameters
  my ($opcode, $mode, @data)=@_;

  # update list counter if the item begins
  $openLists[0]++ if $mode==DIRECTIVE_START;

  # update list point counter
  $flags{listpoints}++;

  # act list and mode dependend
  if ($mode==DIRECTIVE_START)
    {
     print STDOUT '=i', $flags{listlevel}>1 ? $flags{listlevel} : (), ' ' if $opcode==DIRECTIVE_UPOINT or $opcode==DIRECTIVE_DPOINT;
     print STDOUT scalar($flags{listpoints}==1 ? '^' : '+') x $flags{listlevel}, ' ' if $opcode==DIRECTIVE_OPOINT;
    }
  else
    {
     print "\n";
    }
 }

# definition list point item
sub handleDListPointItem
 {
  # get parameters
  my ($opcode, $mode, @data)=@_;

  # by default, we simply add a colon to separate it from following explanations
  print ': ' if $mode==DIRECTIVE_COMPLETE;
 }

# comment
sub handleComment
 {
  # get parameters
  my ($opcode, $mode)=@_;

  # act mode dependend
  print "=comment " if $mode==DIRECTIVE_START;
  print "\n" if $mode==DIRECTIVE_COMPLETE;
 }


# write output to STDOUT or buffer it
sub present
 {
  # build a string
  my $string=join('', @_);

  # present result
  if (%table)
    {$table{rows}[-1][-1].=$string;}
  else
    {print $string;}
 }
  
