November 1998 Troubleshooting Professional Magazine

Reprinted by permission of author. Material provided as-is, use at your own risk.

webdiag.pl Source Code

#!/usr/bin/perl
#
# WEBDIAG.PRL
#
#    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., 675 Mass Ave, Cambridge, MA 02139, USA.
#
#    Copyright (C) 1998 by Marc-Henri Poget, mpoget@hospvd.ch
#
# DESCRIPTION:
#   Build a HTML based decision graphs from a small description language.
#
# LOG:
#   97/07/23    M.H. Poget      Creation
#   97/07/24    M.H. Poget      Fin mise au point
#   97/08/11    M.H. Poget      Complement HELP et ROOT pour texte a afficher
#                               Nouveaux mots-cles:
#                               DATE,COPYRIGHT,TRUE,FALSE,QUESTION,POSSIBLE 
#   97/08/21    M.H. Poget      Permet de specifier une adresse absolue pour un nouveau diagnostic
#   98/08/03    M.H. Poget      Font size and face can now be specified in COMMON.
#   98/10/12    M.H. Poget      Print English messages.
#   98/10/13    M.H. Poget      Remove warning when opening files.
#   98/10/15    M.H. Poget      Renamed $bRuleChecked into $bLinkNoQuestion

eval "exec /usr/bin/perl -S $0 $*"
    if $running_under_some_shell;
                        # this emulates #! processing on NIH machines.
                        # (remove #! line above if indigestible)

eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
                        # process any FOO=bar switches

$[ = 1;                 # set array base to 1
$, = ' ';               # set output field separator
$\ = "\n";              # set output record separator

####################
# States constants #
####################
$C_INITIAL = 0;
$C_COMMON = 1;
$C_NODE = 2;
$C_SWITCH = 3;
$C_IF_TRUE = 4;
$C_IF_FALSE = 5;
$C_TEXT = 6;
$C_SOL = 7;

#############
# Variables #
#############
$eState = $C_INITIAL;
$bLinkNoQuestion = 0;   # Test whether links are used outside of
                        # questions blocks (IF and SWITCH).

$sFace = 'TIMES';
$sSize = '3';

$ExitValue = 0; # When everything is ok

#############################
# Loop over the input lines #
#############################
line: while (<>) {
    chop;       # strip record separator
    @Fld = split(' ', $_, 9999);

    if (/^#/) { # skip comments starting with the pound sign
    }

    # Check every keyword of the description language.
    # Each keyword with its parameters shall fit on a single
    # input line.
    if (/^ *COMMON/) {
        &checkUnexpected($C_INITIAL, 'COMMON');
        &checkArgs(0);

        $eState = $C_COMMON;
    }

    if (/^ *FONTFACE/) {
        &checkUnexpected($C_COMMON, 'FONTFACE');
        &checkArgs(1);

        $sFace = $Fld[2];
    }

    if (/^ *FONTSIZE/) {
        &checkUnexpected($C_COMMON, 'FONTSIZE');
        &checkArgs(1);

        $sSize = $Fld[2];
    }

    if (/^ *TRUE/) {
        &checkUnexpected($C_COMMON, 'TRUE');
        &checkArgs(1);

        $sTrue = $Fld[2];
    }
        
    if (/^ *FALSE/) {
        &checkUnexpected($C_COMMON, 'FALSE');
        &checkArgs(1);

        $sFalse = $Fld[2];
    }

    if (/^ *QUESTION/) {
        &checkUnexpected($C_COMMON, 'QUESTION');
        &checkArgs(1);

        $sQuestion = $Fld[2];
    }        

    if (/^ *POSSIBLE/) {
        &checkUnexpected($C_COMMON, 'POSSIBLE');
        &checkMinArgs(1);

        &getText(2);
        $sSolution = $sText;
    }        

    if (/^ *DATE/) {
        &checkUnexpected($C_COMMON, 'DATE');
        &checkArgs(1);

        $sDate = $Fld[2];
    }

    if (/^ *COPYRIGHT/) {
        &checkUnexpected($C_COMMON, 'COPYRIGHT');
        &checkMinArgs(1);

        &getText(2);
        $sCopyright = $sText;
    }

    if (/^ *ROOT/) {
        &checkUnexpected($C_COMMON, 'ROOT');
        &checkArgs(1);

        $sRoot = $Fld[2];
    }

    if (/^ *NEW/) {
        &checkUnexpected($C_COMMON, 'NEW');
        &checkMinArgs(1);

        $sNewURL = $Fld[2];
        &getText(3);
        $sNew = $sText;
    }


    if (/^ *TITLE/) {
        &checkUnexpected($C_COMMON, 'TITLE');
        &checkMinArgs(1);

        &getText(2);
        $sTitle = $sText;
    }

    if (/^ *FNAME/) {
        &checkUnexpected($C_COMMON, 'FNAME');
        &checkArgs(1);

        $sFile = $Fld[2];
    }

    if (/^ *HELP/) {
        &checkUnexpected($C_COMMON, 'HELP');
        &checkMinArgs(1);

        $sHelp = $Fld[2];
        &getText(3);
        $sHelpText = $sText
    }

    if (/^ *NODE/) {
        &checkUnexpected($C_INITIAL, 'NODE');
        &checkArgs(1);

        $eState = $C_NODE;

        # A new node definition has been found, its
        # corresponding HTML file can be created.
        # This file becomes the new current file where to
        # write HTML statements.
        &getNode($Fld[2]);
        $sCurrFile = $aNodeFile{$Fld[2]};
        $aFileCreated{$Fld[2]} = 1;
        &putHeader($Fld[2]);
    }

    if (/^ *IF/) {
        &checkUnexpected($C_NODE, 'IF');
        &checkMinArgs(1);
        &getText(2);

        $eState = $C_IF_TRUE;

        &putQuestion($sText);
    }

    if (/^ *SWITCH/) {
        &checkUnexpected($C_NODE, 'SWITCH');
        &checkMinArgs(1);
        &getText(2);

        $eState = $C_SWITCH;

        &putQuestion($sText);
    }

    if (/^ *TEXT/) {
        &checkUnexpected($C_NODE, 'TEXT');
        &checkArgs(0);

        $eState = $C_TEXT;

        &putText();
        $bLinkNoQuestion = 1;
    }

    if (/^ *SOLUTION/) {
        &checkUnexpected($C_NODE, 'SOLUTION');
        &checkArgs(0);

        $eState = $C_SOL;

        &putSolution();
        $bLinkNoQuestion = 1;
    }

    if (/^ *NEXT/) {
        &checkMinArgs(1);

        # A link to a node has been found. Define the node.
        &getNode($Fld[2]);
        if ($eState == $C_IF_TRUE) {    
            &putNext($Fld[2], $sTrue);
            $eState = $C_IF_FALSE;
        }
        elsif ($eState == $C_IF_FALSE) {        
            &putNext($Fld[2], $sFalse);
        }
        elsif ($eState == $C_SWITCH ||  
               $eState == $C_TEXT ||  
               $eState == $C_SOL) { 
            &getText(3);
            &putNext($Fld[2], $sText);
            $bLinkNoQuestion = 1;
        }
        else {
            &dispUnexpected('NEXT');
            $ExitValue = 1; last line;
        }
    }

    if (/^ *URL/) {
        &checkMinArgs(1);
        if ($eState == $C_IF_TRUE) {    
            &putURL($Fld[2], $sTrue);
            $eState = $C_IF_FALSE;
        }
        elsif ($eState == $C_IF_FALSE) {        
            &putURL($Fld[2], $sFalse);
        }
        elsif ($eState == $C_SWITCH ||  
               $eState == $C_TEXT ||  
               $eState == $C_SOL) { 
            &getText(3);
            &putURL($Fld[2], $sText);
            $bLinkNoQuestion = 1;
        }
        else {
            &dispUnexpected('URL');
            $ExitValue = 1; last line;
        }
    }

    if (/^ *END/) {
        &checkArgs(0);

        if ($eState == $C_NODE) {       
            &putFooter();
        }

        if ($eState == $C_SWITCH ||     
            $eState == $C_IF_FALSE ||  
            $eState == $C_TEXT ||  
            $eState == $C_SOL) {

            $eState = $C_NODE;

            &endList();
        }
        else {
            $eState = $C_INITIAL;
        }
    }

    if (/^[^#]/) {
        if ($eState == $C_TEXT ||       
            $eState == $C_SOL) { 
            if ($bLinkNoQuestion == 0) {
                &Pick('>>', $sCurrFile) && (print $fh $_);
            }
        }
        $bLinkNoQuestion = 0;
    }
}

# Check whether all the nodes files have been generated.
# If not, it means that a NODE block is missing or that there
# is a spelling mistake in a NEXT statement.
print 'Nodes';
print '=====';
foreach $sNode (keys %aNode) {
    if (defined $aFileCreated{$sNode}) {
        printf "%-20s%15s\n", $sNode, $aNodeFile{$sNode};
    }
    else {
        printf "Missing definition for node: %s\n", $sNode;
    }
}
exit $ExitValue;


###################
# Local functions #
###################

sub dispUnexpected {
#
# Display a message indicating that an unexpected keyword
# has been found in the input file.
#
    local($sxKeyword) = @_;
    printf "line %d: %s unexpected\n", $., $sxKeyword;
}

sub checkUnexpected {
#
# Check whether the found keyword is authorized in the
# current state.
#
    local($exState, $sxKeyword) = @_;
    if ($eState ne $exState) {  
        &dispUnexpected($sxKeyword);
        $ExitValue = 1; last line;
    }
}

sub checkArgs {
#
# Check whether the found keyword has exactly $ixReqNbArgs.
#
    local($ixReqNbArgs) = @_;
    if (($ixReqNbArgs + 1) != $#Fld) {
        printf "line %d: waits %d arguments\n", $., $ixReqNbArgs;
        $ExitValue = 1; last line;
    }
}

sub checkMinArgs {
#
# Check whether the found keyword has at least $ixReqNbArgs.
#
    local($ixReqNbArgs) = @_;
    if (($ixReqNbArgs + 1) > $#Fld) {
        printf "line %d: waits at least %d arguments\n", $., $ixReqNbArgs;
        $ExitValue = 1; last line;
    }
}

sub getNode {
#
# Assign a node number and a filename to a node name.
#
    local($sxNode) = @_;
    if (!(defined $aNode{$sxNode})) {
        if ($sxNode eq $sRoot) {
            # Root node is the first one.
            $aNode{$sxNode} = 0;
        }
        else {
            # All other nodes are numbered starting from 1.
            $aNode{$sxNode} = ++$nNode;
        }
        # Create the filename for later use.
        $aNodeFile{$sxNode} = sprintf('%s%03d.htm', $sFile, $aNode{$sxNode});
    }
}

sub getText {
#
# Get the text following a keyword.
#
    local($ixStart) = @_;
    local ($bFirst) = 1;
    while ($ixStart <= $#Fld) {
        if ($bFirst == 1) {
          $sText = $Fld[$ixStart];
          $bFirst = 0;
        }
        else {
          $sText = $sText . ' ' . $Fld[$ixStart];
        } 
        $ixStart++;
    }
}

sub Pick {
#
# Check whether a file is opened and opens when not.
#
    local($mode,$name) = @_;
    $fh = $name;
    open($name,$mode.$name) unless $opened{$name}++;
}

##################
# HTML functions #
##################
sub putHeader {
    local($sxNode) = @_;
    &Pick('>', $sCurrFile) &&
        (printf $fh "<HTML>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<HEAD>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<TITLE>%s</TITLE>\n",$sTitle);
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<META NAME=GENERATOR CONTENT=\"Webdiag.prl 0.1\">\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<X-SAS-WINDOW TOP=25 BOTTOM=451 LEFT=81 RIGHT=749>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "</HEAD>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<BODY BGCOLOR=\"#FFFFFF\">\n\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<FONT SIZE=%s FACE=%s>\n", $sSize, $sFace);

    &Pick('>>', $sCurrFile) &&
        (printf $fh "<P><A NAME=\"NODE\"></A></P>\n\n");

#   &Pick('>>', $sCurrFile) &&
#       (printf $fh "<H2>%s: %03d</H2>\n\n", $sTitle, $aNode{$sxNode});

    &Pick('>>', $sCurrFile) &&
        (printf $fh "<H2>%s</H2>\n\n", $sTitle);

}

sub putFooter {
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<HR>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh

          "<PRE><A HREF=\"%s#NODE\" TARGET=\"_self\">%s</A>",

          $sNewURL,$sNew);
    &Pick('>>', $sCurrFile) &&
        (printf $fh "    <A HREF=\"%s\" TARGET=\"_self\">%s</A></PRE>\n",

          $sHelp,$sHelpText);
    &Pick('>>', $sCurrFile) &&


        (printf $fh "<HR>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<P>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh

          "<P><CENTER><FONT SIZE=\"-1\">&copy; %s %s</FONT></CENTER></P>\n",$sDate,$sCopyright);
    &Pick('>>', $sCurrFile) &&
        (printf $fh "</BODY>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "</HTML>\n");
}

sub putQuestion {
    local($sxText) = @_;
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<HR>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<H3>%s</H3>\n",$sQuestion);
    &Pick('>>', $sCurrFile) &&
        (printf $fh "%s\n", $sText);
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<UL>\n");
}

sub putText {
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<HR>\n");
}

sub putSolution {
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<HR>\n");
    &Pick('>>', $sCurrFile) &&
        (printf $fh "<H3>%s</H3>\n",$sSolution);
}

sub endList {
    &Pick('>>', $sCurrFile) &&
        (printf $fh "</UL>\n");
}

sub putNext {
    local($sxNode, $sxText) = @_;
    if ($eState == $C_TEXT || $eState == $C_SOL) {      
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<P>\n");
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<A HREF=\"%s#NODE\" TARGET=\"_self\">%s</A>\n",

              $aNodeFile{$sxNode}, $sxText);
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<P>\n");
    }
    else {
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<LI><A HREF=\"%s#NODE\" TARGET=\"_self\">%s</A>\n",

              $aNodeFile{$sxNode}, $sxText);
    }
}

sub putURL {
    local($sxURL, $sxText) = @_;
    if ($eState == $C_TEXT || $eState == $C_SOL) {      
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<P>\n");
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<A HREF=\"%s\" TARGET=\"_self\">%s</A>\n", $sxURL,

              $sxText);
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<P>\n");
    }
    else {
        &Pick('>>', $sCurrFile) &&
            (printf $fh "<LI><A HREF=\"%s\" TARGET=\"_self\">%s</A>\n",

              $sxURL, $sxText);
    }
}

[ Back to this month's Troubleshooting Professional Magazine ]