#!/usr/bin/perl -W
#
# scm2html
#   Transforme un ou plusieurs fichiers Scheme en une page HTML avec coloration syntaxique
# (c) Olivier Pirson --------------- DragonSoft
# Débuté le 3 juin 2006
# v.00.00.10 --- 7 juin 2006
#            --- 21 septembre 2006
# v.00.00.11 --- 13 octobre 2006
#            --- 4 avril 2007
#            --- 30 octobre 2007
#            --- 19 mai 2008
# v.00.00.12 --- 27 septembre 2009 : nouveau site web
#            --- 15 mars 2010 : nouveau site web
# v.00.00.13 --- 30 mars 2010 : remplacé <tt>...</tt> par style="font-family:monospace"
#            --- 8 août 2011 : changement de mon adresse Internet : http://www.opimedia.be/
# v.00.00.14 --- 22 décembre 2013 : changement de l'adresse e-mail de contact : olivier_pirson_opi@yahoo.fr
############################################################################################################

my $VERSION = 'v.00.00.14 --- 2013 December 22';
my $DRAGONSOFT = '(c) Olivier Pirson --- DragonSoft';
my $DRAGONSOFT_CONTACT = 'http://www.opimedia.be/DS/ --- olivier_pirson_opi@yahoo.fr';

use strict;



##############
# Constantes #
##############
my @BUILTIN = (':select');

# Contient les mots clés des types boolean, char, list, number, pair et string du 'Guile Reference Manual'
my @KEYWORD = ('\+', '-', '\*', '/', '1\+', '1-',
               '=', '&lt;=', '&lt;', '&gt;=', '&gt;',
               'abs', 'acosh', 'acos', 'and', 'angle', 'append!', 'append', 'ash', 'asinh', 'asin', 'atanh', 'atan',
               'begin', 'bit-extract',
               'car', 'caar', 'cadr', 'cdddar', 'cddddr', 'cdr', 'ceiling',
               'char=\?', 'char&lt;\?', 'char&lt;=\?', 'char&gt;\?', 'char&gt;=\?', 'char-&gt;integer', 'char-ci=\?', 'char-ci&lt;\?', 'char-ci&lt;=\?', 'char-ci&gt;\?', 'char-ci&gt;=\?', 'char-alphabetic\?', 'char-downcase', 'char-is-both\?', 'char-lower-case\?', 'char-numeric\?', 'char-upcase', 'char-upper-case\?', 'char-whitespace\?',
               'cons\*', 'cons', 'copy-random-state', 'cosh', 'cos',
               'define-module', 'define-public', 'define', 'do',
               'even\?', 'exact-&gt;inexact', 'expt', 'exp',
               'floor', 'for-each',
               'gcd',
               'if', 'imag-part', 'inexact-&gt;exact', 'integer-expt', 'integer-length', 'integer-&gt;char',
               'last-pair', 'lcm', 'length', 'let', 'list-&gt;string', 'list-copy', 'list-head', 'list-ref', 'list-tail', 'list', 'log10', 'logand', 'logcount', 'logior', 'logxor', 'lognot', 'logtest', 'logbit\?', 'log',
               'magnitude', 'make-list', 'make-rectangular', 'make-polar', 'make-string', 'map', 'max', 'member', 'memq', 'memv', 'min', 'modulo',
               'negative\?', 'not', 'number-&gt;string',
               'odd\?', 'or',
               'positive\?',
               'quotient',
               'random:exp', 'random:hollow-sphere!', 'random:normal', 'random:normal-vector!', 'random:solid-sphere!', 'random:uniform', 'random', 'real-part', 'remainder', 'reverse!', 'reverse', 'round',
               'seed-&gt;random-state', 'set!', 'set-car!', 'set-cdr!', 'sinh', 'sin', 'sqrt',
               'string=\?', 'string&lt;\?', 'string&lt;=\?', 'string&gt;\?', 'string&gt;=\?', 'string-&gt;number', 'string-&gt;list', 'string-append', 'string-capitalize!', 'string-capitalize', 'string-ci=\?', 'string-ci&lt;\?', 'string-ci&lt;=\?', 'string-ci&gt;\?', 'string-ci&gt;=\?', 'string-copy ', 'string-downcase!', 'string-downcase', 'string-fill!', 'string-index', 'string-length', 'string-ref ', 'string-rindex', 'string-set!', 'string-split', 'string-upcase!', 'string-upcase', 'string',
               'substring-fill!', 'substring-move!', 'substring',
               'tanh', 'tan', 'truncate',
               'use-modules',
               'while',
               'zero\?');

my @TYPE = ('array\?', 'boolean\?', 'char\?', 'complex\?', 'exact\?', 'hook\?', 'inexact\?', 'integer\?',
            'keyword\?', 'list\?', 'null\?', 'number\?', 'pair\?', 'rational\?', 'real\?', 'regexp\?',
            'string\?', 'string-null\?', 'struct\?', 'struct-vtable\?', 'symbol\?', 'vector\?');



my $TAB = '&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;';


#############
# Variables #
#############
my $o_allnums  = 0;  # si 1 alors ajoute le numéro de toutes les lignes
my $o_filename = 1;  # si 1 alors ajoute le nom du fichier
my $o_head     = 0;  # si 1 alors crée une page HTML complète, sinon seulement le code des fichiers
my $o_hr       = 1;  # si 1 alors entoure le fichier de deux barres horizontales
my $o_name     = 1;  # si 1 alors ajoute une référence HTML au nom de fichier
my $o_nameref  = 1;  # si 1 alors ajoute un lien vers le fichier source
my $o_nums     = 1;  # si 1 alors ajoute le numéro des lignes non vides



#############
# Fonctions #
#############
# Affiche l'écran d'aide et termine.
sub help() {
  print STDERR
      "scm2html [options] files\n",
      "                  $DRAGONSOFT\n",
      "  $DRAGONSOFT_CONTACT\n",
      "                          $VERSION\n",
      "  Options:\n",
      "    +allnums, -allnums\n",
      "    +filename, -filename\n",
      "    +head, -head\n",
      "    +hr, -hr\n",
      "    +name, -name\n",
      "    +nameref, -nameref\n",
      "    +nums, -nums\n",
      "    --help\n",
      "  Work in progress... or not\n";
  exit(1);
}


# Lit le fichier filename et envoie sa conversion en HTML sur la sortie standard.
sub scm2html($) {  # filename
    my $filename = $_[0];  # nom du fichier Scheme à convertir
    my @f;                 # contenu du fichier

    if ( open(FILE, "< $filename") ) {
        @f = reverse <FILE>;

        close(FILE);
    } else {
        print STDERR "File '$filename' not founded !\n";
        return();
    }

    my $PREFIX = "     "; # espace préfixant le numéro des lignes

    my $num = 0;                   # numéro des lignes
    my $len = length(scalar(@f));  # taille du numéro des lignes

    if ( $o_filename > 0 ) {
        print '<h2 align="center">';
        if ( $o_name > 0 || $o_nameref ) {
            print '<a';
            print ' name="', $filename, '"' if ( $o_name > 0 );
            print ' class="relative" href="', $filename, '"' if ( $o_nameref > 0 );
            print '>';
        }
        print $filename;
        print '</a>' if ( $o_name > 0 || $o_nameref );
        print "</h2>\n";
    }
    print "<hr>\n" if ( $o_hr );
    while ( scalar(@f) > 0 ) {
        $num++;

        my $l = pop @f;  # ligne avant commentaire
        my $c = '';      # commentaire

        chomp $l;

        if ( $l =~ /(.*?);/ ) {
            $l = $1;
            $c = ";$'";
            $c =~ s/ /&nbsp;/g;
        }

        # Transformations
        $l =~ s/</&lt;/g;
        $l =~ s/>/&gt;/g;

        $l =~ s/\t/$TAB/g;

        $l =~ s|\"(.+?)\"|<span class="stringC">&quot;$1&quot;</span>|g;

        if ( $l =~ /(\(define(-public)?\s+)\((\S*)(.*?)\)(.*)/ ) {
            $l = $`.$1.'(<span'."\t".'class="functionC">'.$3.'</span>'.$4.')'.$5.$';  # '
        }

        $l =~ s/ /&nbsp;/g;
        $l =~ s/\t/ /g;

        foreach my $w (@BUILTIN) {
            $l =~ s|$w|<span class="builtinC">$&</span>|g;
        }

        foreach my $w (@KEYWORD) {
            $l =~ s|\(((&nbsp;)*$w)|\(<span class="keywordC">$1</span>|g;
        }

        foreach my $w (@TYPE) {
            $l =~ s|\(((&nbsp;)*$w)|\(<span class="typeC">$1</span>|g;
        }

        # Affichage
        if ( $o_nums > 0 || $o_allnums > 0 ) {
            if ( $o_allnums > 0 || length($l) > 0 || length($c) > 0 ) {
                # Numéro de ligne
                my $tmp = substr($PREFIX.($num),-$len,$len);

                $tmp =~ s/ /&nbsp;/g;
                print '<span style="color:gray">', $tmp, '</span>&nbsp;';
            }
        }
        print $l;  # ligne proprement dite
        if ( length($c) > 0 ) {
            print '<span class="commentC">', $c, '</span>';  # commentaire
        }
        print '<br>', "\n";  # fin de ligne
    }
    print "<hr>\n" if ( $o_hr );
}



########
# Main #
########
help() if ( scalar(@ARGV) == 0 );

print STDERR "scm2html --- $VERSION\n";

for (my $i=0; $i<scalar(@ARGV); $i++) {
    if ( $ARGV[$i] eq '--help' ) {
        help();
    } elsif ( $ARGV[$i] eq '+head' ) {
        $o_head = 1;
    } elsif ( $ARGV[$i] eq '-head' ) {
        $o_head = 0;
    }
}

if ( $o_head == 1 ) {
    print "<html>\n";
    print "<head>\n";
    print '<style type="text/css"><!--
  .builtinC  {color:#de71d6;
              font-family:monospace;}
  .commentC  {color:#b52021;
              font-family:monospace;}
  .functionC {color:blue;
              font-family:monospace;}
  .keywordC  {color:purple;
              font-family:monospace;}
  .stringC   {color:#bd8e8c;
              font-family:monospace;}
  .typeC     {color:#218a21;
              font-family:monospace;}
--></style>', "\n";
    print "</head>\n";
    print '<body style="font-family:monospace">\n';
}

while ( scalar(@ARGV) > 0 ) {
    my $arg = shift @ARGV;

    print STDERR "$arg\n";
    if ( substr($arg,0,1) eq '+' || substr($arg,0,1) eq '-' ) {
        my $v = (substr($arg,0,1) eq '+' ? 1 : 0);

        $arg = substr $arg,1;
        if ( $arg eq '-help' || $arg eq 'head' ) {
        } elsif ($arg eq 'allnums') {
            $o_allnums = $v;
        } elsif ($arg eq 'filename') {
            $o_filename = $v;
        } elsif ($arg eq 'hr') {
            $o_hr = $v;
        } elsif ($arg eq 'name') {
            $o_name = $v;
        } elsif ($arg eq 'nameref') {
            $o_nameref = $v;
        } elsif ($arg eq 'nums') {
            $o_nums = $v;
        } else {
            help();
        }
    } else {
        scm2html($arg);
    }
}

if ( $o_head == 1 ) {
  print '</body>', "\n";
  print '</html>', "\n";
}