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

# ---------------------------------------------------------------------------------------
# version | date   | author   | changes
# ---------------------------------------------------------------------------------------
# 0.04    |02.01.03| JSTENZEL | modern run() call;
# 0.03    |10.06.01| JSTENZEL | new script namespace "PerlPoint::Converter::pp2pp";
#         |        | JSTENZEL | adapted to new tag declarations;
# 0.02    |07.12.00| JSTENZEL | new module namespace "PerlPoint";
# 0.01    |01.06.00| JSTENZEL | new.
# ---------------------------------------------------------------------------------------

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

=head1 NAME

B<pp2pp> - a Perl Point demo translator to PP itself (in variable syntaxi)

=head1 VERSION

This manual describes version B<0.04>.

=head1 DESCRIPTION

This is a demonstration application of the PP package. It
translates PP into PP.

The target syntax depends on the specified I<-target> option.
It can be version 1, which is the I<original Perl Point syntax> as
introduced by I<T. Christiansen>, or version 2 which is version 1
with the extensions made by I<L. Domke>, or version 3 which is the
most recent syntax and equal to the source processed by PerlPoint::Package.

Besides the demonstration of PerlPoint::Package usage, a translator like this
provides a way to use I<syntax 3> (as declared for PerlPoint::Package) with
an existing I<syntax 1> or I<syntax 2> translator.

=head1 SYNOPSIS

=head1 FILES

=head1 ENVIRONMENT

=head1 NOTES

This is a demonstration only. A real life C<pp2pp> translator surely
should be more robust etc., the intention of this code is simply
to I<show the usage of PerlPoint::Package>, not a perfect translator.

=head1 SEE ALSO

PerlPoint::Parser

PerlPoint::Backend

=head1 AUTHOR

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

=cut

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

# declare version
$VERSION=$VERSION=0.04;

# pragmata
use strict;

# load modules
use Carp;
use Getopt::Long;
use PerlPoint::Tags;
use PerlPoint::Backend;
use PerlPoint::Constants;
use PerlPoint::Tags::Basic;
use PerlPoint::Parser 0.34;
use Getopt::ArgvFile qw(argvFile);


# declare variables
my ($verbatim, %options, @streamData, @olists)=(0);

# get options
argvFile(home=>1, default=>1);
GetOptions(\%options,
           "tagset=s@",         # add a tag set to the scripts own tag declarations;
           "target=i",          # target syntax;
          );

# check options
$options{target}=3 unless exists $options{target};
die "PP syntax $options{target} can currently not be generated by this translator.\n" if $options{target}>3;

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

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

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

             filter          => 'perl',

             safe            => exists $options{activeContents} ? $safe : undef,
             activeBaseData  => {
                                 targetLanguage => 'PerlPoint',
                                 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} & TRACE_PARAGRAPHS) ? TRACE_PARAGRAPHS : 0)
                                + ((exists $options{trace} and $options{trace} & TRACE_LEXER)      ? TRACE_LEXER      : 0)
                                + ((exists $options{trace} and $options{trace} & TRACE_PARSER)     ? TRACE_PARSER     : 0)
                                + ((exists $options{trace} and $options{trace} & TRACE_SEMANTIC)   ? TRACE_SEMANTIC   : 0)
                                + ((exists $options{trace} and $options{trace} & TRACE_ACTIVE)     ? TRACE_ACTIVE     : 0)
                                + ((exists $options{trace} and $options{trace} & TRACE_TMPFILES)   ? TRACE_TMPFILES   : 0),
            ) or exit(1);

# build a backend
my $backend=new PerlPoint::Backend(name=>'pp2pp2', trace=>TRACE_NOTHING, display=>DISPLAY_NOINFO);

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

$backend->register(DIRECTIVE_SIMPLE, \&handleSimple);
$backend->register(DIRECTIVE_TAG, \&handleTag);
$backend->register(DIRECTIVE_HEADLINE, \&handleHeadline);

$backend->register(DIRECTIVE_TEXT, sub {print "\n\n" if $_[1]==DIRECTIVE_COMPLETE;});

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

$backend->register(DIRECTIVE_LIST_LSHIFT, \&handleListShift);
$backend->register(DIRECTIVE_LIST_RSHIFT, \&handleListShift);

$backend->register(DIRECTIVE_BLOCK, \&handleBlock);
$backend->register(DIRECTIVE_VERBATIM, \&handleVerbatim);

$backend->register(DIRECTIVE_COMMENT, \&handleComment);

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


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

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

  # try to emulate empty verbatim lines, if necessary
  if ($options{target}==2)
    {
     if ($token eq "\n")
       {
        $verbatim++;
        print '.' if $verbatim>1;
       }
     else
       {$verbatim=0;}
    }

  # simply print the token (restoring backslashes)
  $token=~s/\\/\\\\/;
  print $token;
 }

# headlines
sub handleHeadline
 {
  # get parameters
  my ($opcode, $mode, $level, @contents)=@_;

  # act mode dependend
  print '=' x $level if $mode==DIRECTIVE_START;
  print "\n\n"       if $mode==DIRECTIVE_COMPLETE;
 }

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

  # declare tag translations
  my %tags=(
            1 => {
                  I => 'I',
                 },
            2 => {
                  I => 'I',
                 },
            3 => {
                  I => '\I',
                 },
           );

  # act mode dependend
  if ($mode==DIRECTIVE_START)
    {
     # preparations
     $tag=uc($tag);

     # print tag
     print exists $tags{$options{target}}{$tag} ? $tags{$options{target}}{$tag} : ($options{target}==3 ? "\\$tag" : $tag);

     # print tag options, if necessary
     if (%$settings and $options{target}==3)
       {
        # start tag options
        print '{';
        # print option settings
        print " $_=$settings->{$_} " foreach sort keys %$settings;
        # close option part
        print '}';
       }

     # open tag body
     print '<';
    }
  else
    {
     # close tag
     print '>';
    }
 }

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

  # anything to do?
  return unless $options{target}<3 and $opcode==DIRECTIVE_OLIST;

  # handle mode dependend to emulate ordered lists
  unshift(@olists, 0) if $mode==DIRECTIVE_START;
  shift(@olists)      if $mode==DIRECTIVE_COMPLETE;
 }

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

  # anything to do?
  return unless $mode==DIRECTIVE_START and $options{target}==3;

  # handle operation dependend
  print "\n>\n\n" if $opcode==DIRECTIVE_LIST_RSHIFT;
  print "\n<\n\n" if $opcode==DIRECTIVE_LIST_LSHIFT;
 }

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

  # act list, mode and target dependend
  print '* '          if $mode==DIRECTIVE_START and $opcode==DIRECTIVE_UPOINT;

  if ($options{target}==3)
    {
     print '# '          if $mode==DIRECTIVE_START and $opcode==DIRECTIVE_OPOINT;
     print ":$data[0]: " if $mode==DIRECTIVE_START and $opcode==DIRECTIVE_DPOINT;
    }
  else
    {
     print "* B<", ++$olists[0], ".> " if $mode==DIRECTIVE_START and $opcode==DIRECTIVE_OPOINT;
     print "* B<$data[0]:> "           if $mode==DIRECTIVE_START and $opcode==DIRECTIVE_DPOINT;
    }

  print "\n\n"        if $mode==DIRECTIVE_COMPLETE;
 }

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

  # act mode dependend
  print $options{target}==3 ? '//' : '#' if $mode==DIRECTIVE_START;
  print "\n"                             if $mode==DIRECTIVE_COMPLETE;
 }

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

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

# verbatim block
sub handleVerbatim
 {
  # get parameters
  my ($opcode, $mode)=@_;

  # act mode dependend for target syntax 3
  if ($options{target}==3)
    {
     print "<<EOM\n" if $mode==DIRECTIVE_START;
     print "EOM\n\n" if $mode==DIRECTIVE_COMPLETE;
    }
  elsif ($options{target}==2)
    {
     # set a flag ...
     $verbatim=1;
     print "\n\n" if $mode==DIRECTIVE_COMPLETE;
    }
 }