#!/usr/bin/perl -w

# Copyright (c) 1999 Mark Summerfield. All Rights Reserved.
# May be used/distributed under the same terms as Perl itself.

# $Id: perl2lout,v 1.4 1999/07/18 11:20:16 root Exp $

use strict ;

use Getopt::Long ;
use Lout ;

use vars qw( $VERSION ) ;

$VERSION   = '1.00' ;

my $colour = 0 ;
my $tab    = 4 ;
my $font   = 'Courier' ;
my $size   = 8 ;
my $number = 0 ;

Getopt::Long::config 'no_ignore_case' ;
GetOptions(
    'h|help'         => \&help,
    'c|colour|color' => \$colour,
    't|tab=i'        => \$tab,
    'f|font=s'       => \$font,
    'n|number'       => \$number,
    's|size=i'       => \$size,
    ) or die "\n" ;

die "Font size of $size out of range\n" if $size < 6 or $size > 20 ;
&help unless defined $ARGV[0] ;

my %Keyword ;
my $inpod = 0 ;

&prepare ;
&head ;
my $lino = 0 ;
while( <> ) {
    $lino++ ;
    $inpod = 1 if /^=pod/o or /^=head/ ; 
    if( $inpod ) {
        my $pod = Lout::pod2lout( $_ ) ;
        $pod =~ s/^=(\w+)/\@B{=$1}/o ;
        print $pod ;
    }
    else {
        &process ;
    }
    $inpod = 0 if /^=cut/o ;
    $lino  = 0 if eof ;
}
&tail ;


sub prepare {
    while( <DATA> ) {
        chomp ;
        $Keyword{$_} = 1 if $_ ;
    }
}


sub head {
    print <<__EOT__ ;
\@SysInclude { doc }
\@Document
    \@InitialFont { $font Base ${size}p }
    \@InitialBreak { lines 1.00fx nohyphen }
//

\@Text \@Begin

\@CD { Bold +2p } \@Font "$ARGV[0]"

__EOT__
}


sub tail {
    print <<__EOT__ ;
\@End \@Text
__EOT__
}


sub process {

    chomp ;

    s/\@/\0/go ;

    # Taken from The Perl Cookbook.
    while( s/\t+/' ' x ( length( $& ) * $tab - length( $` ) % $tab)/eo ) {
        ;
    }

    s/"/\x01\@Char quotedbl\x02/go ;
    s/-/\x01\@Char hyphen\x02/go ;
    s/([{}|&^~\/])/"$1"/go ;

    if( $colour ) {
        s/#(.*)$/{ darkgreen } \@Colour { Times Slope } \@Font { #$1 }/o ; 
    }
    else {
        s/#(.*)$/{ Times Slope } \@Font { #$1 }/o ; 
    }
    s/#/"#"/go ;

    s/\\/\x01\@Char backslash\x02/go ;

    if( $colour ) {
        s/([\$\0%]\w+)/{ blue } \@Colour { $1 }/go ;
        s/("\&"\w+)/{ darkblue } \@Colour { $1 }/go ;
        s/([-][();:<>])/{ darkmagenta } \@Colour { $1 }/go ;
    }

    s/\0/"@"/go ;
    s/\x01/{/go ;
    s/\x02/}/go ;

    s/\b(\w+)\b/exists $Keyword{$1} ? "\@B { $1 }" : $1/geo ;

    printf "%05d ", $lino if $number ;
    print "$_\n" ;
}


sub help {
    print STDERR <<__EOT__ ;
perl2lout v $VERSION. Copyright (c) Mark Summerfield 1999. All Rights Reserved.
May be used/distributed under the same terms as Perl itself.

usage: perl2lout [options] file | lout > file.ps

options:
-h    --help            Print this help screen and exit
-c    --colour --color  Use colour for syntax highlighting [$colour]
-f F  --font=F          Use lout font F [$font]
-n    --number          Add line numbers [$number]
-s N  --size=N          Use a font size of N points [$size]
-t N  --tab=N           Use a tab width of N [$tab]

__EOT__
    exit ;
}


__DATA__
case
default
if
elsif
unless
else
switch
eq
ne
gt
lt
ge
le
cmp
not
and
or
xor
while
for
foreach
do
until
defined
undef
and
or
not
bless
ref
BEGIN
END
my
local
goto
return
last
next
continue
redo
chomp
chop
chr
crypt
index
lc
lcfirst
length
ord
pack
reverse
rindex
sprintf
substr
sub
uc
ucfirst
pos
quotemeta
split
study
abs
atan2
cos
exp
hex
int
log
oct
rand
sin
sqrt
srand
splice
unshift
shift
push
pop
split
join
reverse
grep
map
qw
sort
unpack
each
exists
keys
values
binmode
carp
close
closedir
confess
croak
dbmclose
dbmopen
die
eof
fileno
flock
getc
print
printf
read
readdir
rewinddir
seek
seekdir
select
syscall
sysopen
sysread
syswrite
tell
telldir
truncate
warn
write
pack
vec
chdir
chmod
chown
chroot
fcntl
glob
ioctl
link
lstat
mkdir
open
opendir
readlink
rename
rmdir
stat
symlink
umask
unlink
utime
caller
die
dump
eval
exit
wantarray
require
import
alarm
exec
fork
getpgrp
getppid
getpriority
kill
pipe
qx
setpgrp
setpriority
sleep
system
times
wait
waitpid
accept
bind
connect
getpeername
getsockname
getsockopt
listen
recv
send
setsockopt
shutdown
socket
socketpair
msgctl
msgget
msgrcv
msgsnd
semctl
semget
semop
shmctl
shmget
shmread
shmwrite
endprotoent
endservent
gethostbyaddr
gethostbyname
gethostent
getnetbyaddr
getnetbyname
getnetent
getprotobyname
getprotobynumber
getprotoent
getservbyname
getservbyport
getservent
sethostent
setnetent
setprotoent
setservent
gmtime
localtime
time
times
print
warn
formline
reset
scalar
new
delete
STDIN
STDOUT
STDERR
ARGV
use
__END__


=pod SCRIPT CATEGORIES

Lout

=pod DESCRIPTION

Converts HTML to Lout

=pod PREREQUISITES

Pragmas:

C<strict>

Modules:

C<Getopt::Long>
C<Lout>
C<HTML::LoutParser>

=pod OSNAMES

Linux

=pod LICENSE

Same as Perl

=head1 BUGS

Applies formating within quoted strings. 

Does not fully format pod - just pod `entities', like EE<gt>gtE<lt>.


=head1 TODO

Index variables, $scalar, @array and %hash; plus subroutines.

=cut
