
###################################################################################
#
#   Embperl - Copyright (c) 1997-2000 Gerald Richter / ECOS
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.
#
#   THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
#   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
#   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
#   $Id$
#
###################################################################################



package HTML::Embperl::Syntax ;

use constant  ntypTag           => 1 ;
use constant  ntypStartTag      => 1 + 0x20 ;
use constant  ntypEndTag        => 1 + 0x40 ;
use constant  ntypEndStartTag   => 1 + 0x60 ;
use constant  ntypAttr	        => 2 ;
use constant  ntypAttrValue     => 2 + 0x20 ;
use constant  ntypText	        => 3 ;
use constant  ntypCDATA	        => 4 ;


sub clonehash
    {
    my ($old, $new, $replace) = @_ ;


    $replace ||= {} ;    
    my ($v, $k) ;

    while (($k, $v) = each (%$old))
        {
        if ($replace -> {$k})
            {
            $new -> {$k} = $replace -> {$k} ;
            }
        else
            {
            if (ref ($v) eq 'HASH')
                {
                $new -> {$k} = clonehash ($v, {}, $replace) ;
                }
            elsif (ref ($v) eq 'ARRAY')
                {
                $new -> {$k} = [$v] ;
                }
            else
                {
                $new -> {$k} = $v ;
                }
            }
        }

    return $new ;
    }


###################################################################################
#
#   Default Syntax
#
###################################################################################



%Cmds = (
    '-lsearch' => 1,
    'Embperl command escape' => {
        'text' => '[[',
        'nodename' => '[',
        'nodetype' => ntypCDATA,
        },
    'Embperl meta command' => {
        'text' => '[$',
        'end'  => '$]',
        'follow' => \%MetaCmds,
        'unescape' => 1,
        },
     'Embperl output code' => {
        'text' => '[+',
        'end'  => '+]',
        'unescape' => 1,
        'procinfo' => {
            embperl => { 
                    perlcode => 
                        [
                        'if (!defined (_ep_rp(%$n%,scalar(do{%#~0:$col%})))) %#~-0:$row% { if ($col == 0) { _ep_dcp (%$t%,%^*htmltable%) ; last l%^*htmltable% ; } else { _ep_dcp (%$t%,%^*htmlrow%) ; last l%^*htmlrow% ; }}',
                        'if (!defined (_ep_rp(%$n%,scalar(do{%#~0:$col%})))) { _ep_dcp (%$t%,%^*htmlrow%) ; last l%^*htmlrow% ; }',
                        'if (!defined (_ep_rp(%$n%,scalar(do{%#~0:$row%})))) { _ep_dcp (%$t%,%^*htmltable%) ; last l%^*htmltable% ; }',
                        '_ep_rp(%$n%,scalar(do{%#0%}));', 
                        ],
                    removenode  => 4,
                    mayjump => '%#~0:$col|$row|$cnt% %?*htmlrow% %?*htmltable%',
                    compilechilds => 0,
                    }
            },
        },
     'Embperl code' => {
        'text' => '[-',
        'end'  => '-]',
        'unescape' => 1,
        'procinfo' => {
            embperl => { 
                        perlcode    => [
                                '$_ep_node=%$l%;if (!defined (scalar(do{%#~0:$col%}))) %#~-0:$row% { if ($col == 0) { _ep_dcp (%$t%,%^*htmltable%) ; last l%^*htmltable% ; } else { _ep_dcp (%$t%,%^*htmlrow%) ; last l%^*htmlrow% ; }}',
                                '$_ep_node=%$l%;if (!defined (scalar(do{%#~0:$col%}))) { _ep_dcp (%$t%,%^*htmlrow%) ; last l%^*htmlrow% ; }',
                                '$_ep_node=%$l%;if (!defined (scalar(do{%#~0:$row%}))) { _ep_dcp (%$t%,%^*htmltable%) ; last l%^*htmltable% ; }',
                                '$_ep_node=%$l%;{%#0%;}',
                                ],
                        removenode  => 3,
                        mayjump     => 1,
                        compilechilds => 0,
                        },
            },
        },
     'Embperl global code' => {
        'text' => '[*',
        'end'  => '*]',
        'unescape' => 1,
        'procinfo' => {
            embperl => { 
                        perlcode    => '$_ep_node=%$l%;%#0%',
                        removenode  => 3,
                        mayjump     => 1,
                        compilechilds => 0,
                        },
            },
        },
     'Embperl startup code' => {
        'text' => '[!',
        'end'  => '!]',
        'unescape' => 1,
        'procinfo' => {
            embperl =>  { 
                        compiletimeperlcode => '%#0%;',
                        removenode  => 3,
                        compilechilds => 0,
                        }
            },
        },
     'Embperl comment' => {
        'text' => '[#',
        'end'  => '#]',
        'procinfo' => {
            embperl => { 
                compilechilds => 0,
                removenode  => 3, 
                },
            },
        },
      ) ;  
   

clonehash (\%Cmds, \%CmdsLink, { 'unescape' => 2 }) ;

$CmdsLink{'Embperl output code'}{'nodename'} = '[+url' ;
$CmdsLink{'Embperl output code'}{'procinfo'}{'embperl'}{'perlcode'} = 
                        [
                        'if (!defined (_ep_rpurl(%$n%,scalar(do{%#~0:$col%})))) %#~-0:$row% { if ($col == 0) { _ep_dcp (%$t%,%^*htmltable%) ; last l%^*htmltable% ; } else { _ep_dcp (%$t%,%^*htmlrow%) ; last l%^*htmlrow% ; }}',
                        'if (!defined (_ep_rpurl(%$n%,scalar(do{%#~0:$col%})))) { _ep_dcp (%$t%,%^*htmlrow%) ; last l%^*htmlrow% ; }',
                        'if (!defined (_ep_rpurl(%$n%,scalar($val3=do{%#~0:$row%;})))) {  _ep_dcp (%$t%,%^*htmltable%) ; last l%^*htmltable% ; }',
                        '_ep_rpurl(%$n%,scalar(do{%#0%}));', 
                        ] ;




%Attr = (
    '-lsearch' => 1,
    'Attribut ""' => 
        {
        'text'   => '"',
        'end'    => '"',
        'inside' => \%Cmds,
        'nodetype'   => ntypAttr,
        'cdatatype'  => ntypAttrValue,
        },
    'Attribut \'\'' => 
        {
        'text'   => '\'',
        'end'    => '\'',
        'inside' => \%Cmds,
        'nodetype'   => ntypAttr,
        'cdatatype'  => ntypAttrValue,
        },
    'Attribut alphanum' => 
        {
        'contains'   => 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789',
        'inside' => \%Cmds,
        'nodetype'   => ntypAttr,
        'cdatatype'  => ntypAttrValue,
        }
    ) ;

clonehash (\%Attr, \%AttrLink, { inside => \%CmdsLink }) ;



%AssignAttr = (
    'Assign' => 
        {
        'text' => '=',
        'follow' => \%Attr,
        }
    ) ;


%AssignAttrLink = (
    'Assign' => 
        {
        'text' => '=',
        'follow' => \%AttrLink,
        }
    ) ;

%HrefLink = (
            'link'  => { 'text' => 'href',  'nodename' => 'href', follow => \%AssignAttrLink },
            %Cmds,
) ;

%SrcLink = (
            'link'  => { 'text' => 'src',  'nodename' => 'src', follow => \%AssignAttrLink },
            %Cmds,
) ;

%ActionLink = (
            'link'  => { 'text' => 'action',  'nodename' => 'action', follow => \%AssignAttrLink },
            %Cmds,
) ;

%HtmlTagsStd = (
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
         'inside'    => \%Cmds,
        ) ;


%ProcInfoTable = (
            embperl => { 
                perlcode    => 'l%$l%: for (my $row = 0; $row < $maxrow; $row++) {' ,
                perlcodeend =>  '} %?*-htmltable%' ,
                perlcoderemove => 1,
                stackname   => 'htmltable',
                'push'        => '%$l%',
                mayjump     => 1,
                }                     
            ) ;



%HtmlTags = (
    'input' => {
        'text' => 'input',
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => 
            {
            'type'  => { 'text' => 'type',  'nodename' => 'type',  follow => \%AssignAttr },
            'name'  => { 'text' => 'name',  'nodename' => 'name',  follow => \%AssignAttr },
            'value' => { 'text' => 'value', 'nodename' => 'value', follow => \%AssignAttr },
            'checked' => { 'text' => 'checked', 'nodetype'   => ntypAttr, },
            %Cmds,
            },
        'procinfo' => {
            embperl => { 
                perlcode =>
                    [ 
                    'HTML::Embperl::Cmd::InputCheck (%$n%, %&*\'name%, %&*\'value%) ;  %&=-type:radio|checkbox% ',
                    '$idat{%&*\'name%}=$fdat{%&*\'name%} ; XML::Embperl::DOM::Element_setAttribut (%$n%, \'value\', $fdat{%&*\'name%} || \'\') ;   %&!-value%',
                    '$idat{%&*\'name%}=%&*\'value% ; ',
                    ]
                }                     
            },
         },
    'textarea' => {
        'text' => 'textarea',
        'nodetype'   => ntypStartTag, 
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => 
            {
            'name'  => { 'text' => 'name',  'nodename' => 'name',  follow => \%AssignAttr },
            %Cmds,
            },
        'procinfo' => {
            embperl => { 
                perlcode =>
                    [ 
                    '$idat{%&*\'name%}=$fdat{%&*\'name%};XML::Embperl::DOM::Node_appendChild (%$n%, HTML::Embperl::Syntax::ntypText, $fdat{%&*\'name%}) ;   %#!-0%',
                    '$idat{%&*\'name%}=\'%#*0%\' ; ',
                    ]
                }                     
            },
         },
    '/textarea' => {
        'text' => '/textarea',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'tr' => {
        'text' => 'tr',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => {
            embperl => { 
                perlcode    => 'l%$l%: for (my $col = 0; $col < $maxcol; $col++) {' ,
                perlcodeend => '} %?*-htmlrow%' ,
                perlcoderemove => 1,
                stackname   => 'htmlrow',
                'push'        => '%$l%',
                mayjump     => 1,
                }                     
            },
        },
    '/tr' => {
        'text' => '/tr',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'table' => {
        'text' => 'table',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/table' => {
        'text' => '/table',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'table' => {
        'text' => 'table',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/table' => {
        'text' => '/table',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'ol' => {
        'text' => 'ol',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/ol' => {
        'text' => '/ol',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'ul' => {
        'text' => 'ul',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/ul' => {
        'text' => '/ul',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'dl' => {
        'text' => 'dl',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/dl' => {
        'text' => '/dl',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'menu' => {
        'text' => 'menu',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/menu' => {
        'text' => '/menu',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'dir' => {
        'text' => 'dir',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'procinfo' => \%ProcInfoTable,
         },
    '/dir' => {
        'text' => '/dir',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
#    'th' => {
#        'text' => 'th',
#        'nodetype'   => ntypStartTag, 
#        %HtmlTagsStd,
#         },
#    '/th' => {
#        'text' => '/th',
#        'nodetype'   => ntypEndTag, 
#        'cdatatype'  => 0,
#         },
    'select' => {
        'text' => 'select',
        'nodetype'   => ntypStartTag, 
        'inside' => 
            {
            'name'  => { 'text' => 'name',  'nodename' => 'name', follow => \%AssignAttr },
            %Cmds,
            },
        'procinfo' => {
            embperl => { 
                stackname2   => 'htmlselect',
                push2        => '%&*name%',

                perlcode    => 'l%$l%: for (my $row = 0; $row < $maxrow; $row++) {' ,
                perlcodeend =>  '} %?*-htmltable%' ,
                perlcoderemove => 1,
                stackname   => 'htmltable',
                'push'        => '%$l%',
                mayjump     => 1,
                }                     
            },
         },
    'option' => {
        'text' => 'option',
        'nodetype'   => ntypStartTag, 
        %HtmlTagsStd,
        'inside' => 
            {
            'value'  => { 'text' => 'value',  'nodename' => 'value',  follow => \%AssignAttr },
            'selected' => { 'text' => 'selected', 'nodetype'   => ntypAttr, },
            %Cmds,
            },
        'procinfo' => {
            embperl => { 
                perlcode =>
                    [ 
                    'HTML::Embperl::Cmd::Option (%$n%, %^*\'htmlselect%, %&*\'value%);',
                    'HTML::Embperl::Cmd::Option (%$n%, %^*\'htmlselect%, %#*\'0%);',
                    ]
                }                     
            },
         },
    '/option' => {
        'text' => '/option',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    '/select' => {
        'text' => '/select',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => 0,
         },
    'body' => {
        'text' => 'body',
        %HtmlTagsStd,
         },
    'a' => {
        'text' => 'a',
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => \%HrefLink,
         },
    'frame' => {
        'text' => 'frame',
        'inside' => \%SrcLink,
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
         },
    'iframe' => {
        'text' => 'iframe',
        'inside' => \%SrcLink,
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
         },
    'embed' => {
        'text' => 'embed',
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => \%SrcLink,
         },
    'layer' => {
        'text' => 'layer',
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => \%SrcLink,
         },
    'img' => {
        'text' => 'img',
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => \%SrcLink,
         },
    'form' => {
        'text' => 'form',
        'forcetype'  => ntypAttrValue,
        'cdatatype'  => ntypAttrValue,
        'inside' => \%ActionLink,
         },

    ) ;


%MetaCmds = (
    'if' => {
        'text' => 'if',
        'nodetype'   => ntypStartTag, 
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
        'endtag'   => 'endif',
        'procinfo' => {
            embperl => { 
                perlcode => 'if (%&<noname>%) { ', 
                perlcodeend => '}',
                removenode => 10,
                mayjump     => 1,
                }
            },
         },
    'else' => {
        'text' => 'else',
        'nodetype'   => ntypEndStartTag, 
        'unescape' => 1,
        'endtag'   => 'endif',
        'procinfo' => {
            embperl => { 
                perlcode => 'else {',
                perlcodeend => '}',
                removenode => 10,
                mayjump     => 1,
                }
            },
         },
    'endif' => {
        'text' => 'endif',
        'nodetype'   => ntypEndTag, 
         },
    'elsif' => {
        'text' => 'elsif',
        'nodetype'   => ntypEndStartTag, 
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
        'endtag'   => 'endif',
        'procinfo' => {
            embperl => { 
                perlcode => 'elsif (%&<noname>%) { ', 
                perlcodeend => '}',
                removenode => 10,
                mayjump     => 1,
                }
            },
         },
    'while' => {
        'text' => 'while',
        'nodetype'   => ntypStartTag, 
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
        'endtag'   => 'endwhile',
        'procinfo' => {
            embperl => { 
                perlcode => 'while (%&<noname>%) { ', 
                perlcodeend => '}',
                removenode => 10,
                mayjump     => 1,
                }
            },
         },
    'endwhile' => {
        'text' => 'endwhile',
        'nodetype'   => ntypEndTag, 
         },
    'foreach' => {
        'text' => 'foreach',
        'nodetype'   => ntypStartTag, 
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
        'endtag'   => 'endforeach',
        'procinfo' => {
            embperl => { 
                perlcode => 'foreach %&<noname>% { ', 
                perlcodeend => '}',
                removenode => 10,
                mayjump     => 1,
                }
            },
         },
    'endforeach' => {
        'text' => 'endforeach',
        'nodetype'   => ntypEndTag, 
         },
    'do' => {
        'text' => 'do',
        'nodetype'   => ntypStartTag, 
        'unescape' => 1,
        'endtag'   => 'until',
        'procinfo' => {
            embperl => { 
                perlcode => 'do { ', 
                perlcodeend => '} until (%&<noname>%) ; ',
                removenode => 10,
                mayjump     => 1,
                }
            },
         },
    'until' => {
        'text' => 'until',
        'nodetype'   => ntypEndTag, 
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
         },
    'var' => {
        'text' => 'var',
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
        'procinfo' => {
            embperl => { 
                perlcode => 'use strict ; use vars qw {%&<noname>%} ;', 
                removenode => 3,
                }
            },
         },
    'hidden' => {
        'text' => 'hidden',
        'cdatatype'  => ntypAttrValue,
        'unescape' => 1,
        'procinfo' => {
            embperl => { 
                perlcode => 'HTML::Embperl::Cmd::Hidden (%$n%,%&\'<noname>%);', 
                removenode => 8,
                }
            },
         },
    ) ;


%MetaCmdsDropTag = (
    'br' => {
        'text' => '<br>',
        'follow' => \%MetaCmds,
        },
    'p' => {
        'text' => '<p>',
        'follow' => \%MetaCmds,
        },
    %MetaCmds,
    ) ;


%Default = (
    '-lsearch' => 1,
    'HTML Tag' => {
        'text' => '<',
        'end'  => '>',
        'follow' => \%HtmlTags,
        },
    'HTML Comment' => {
        'text' => '<!--',
        'end'  => '-->',
        },
    %Cmds,
    ) ;




__END__

=pod



=over 4

=item    '-lsearch' => 1

Do an linear serach instead of a binary search. This is necessary if the 
tokens can't clearly separated.

=item    <name> => \%token

All items which does not start with a slash are treated as names. The name
of a token is only descriptiv and is used in error messages. The item must
contain a hashref which describes the token.

=back

=head2 Tokendescription

=over 4

=item 'text' => '<'

Start text

=item 'end'  => '>'

End text

=item 'contains'   => 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789'

Token consists of the following characters. Either C<start> and C<end> B<or> C<contains>
could be specified.

=item 'unescape' => 1

If C<optRawInput> isn't set unescape the data of the inside the node

=item 'nodetype'   => ntypEndTag

Type of the node

=item 'cdatatype'  => ntypAttrValue

Type of nodes for data inside this node.

=item 'endtag'

Name of the tag that marks the end of a block.

=item 'follow' => \%HtmlTags

Hashref that specifices one or more tokens that must follow this token.

=item 'inside' => \%Cmds

Hashref that specifices one or moer tokens that could occur inside
a node that is started with this token.

=item 'procinfo' => 

Processor info. Hashref with informations how to process this token.

=back

=head2 Processor info for Embperl 

            embperl => { 
                        perlcode    => '%#0%;',
                        removenode  => 1,
                        },


=over 4

=item perlcode => <string> or <arrayref>

Code to generate. You can also specify a arrayref of string.
The first string which contains matching attributes are used.
The following special strings are replaced:

=over 4

=item %#<N>% 

Text of childnode number <N> (starting with zero)

=item %&<attr>%

Value of attribute <attr>.

=item %^<stackname>%

Stringvalue of given stack

=item %?<stackname>%

Set if stackvalue was used

=item %$n%

Node number.

=item %$l%

Unique label

=item %$l+%

Unique label and increment to next label

=back


All of the above special values (expect those start with $) allows the following
modifiers:

=over 4

=item %<X>B<*><N>%

Attribute/Child etc. must exist.

=item %<X>B<!><N>%

Attribute/Child etc. must not exist.

=item %<X>B<=><N>:<value1>|<value2>|<value3>%

Attribute/Child etc. must have the value = <value1> or <value2> etc.

=item %<X>B<~><N>:<value1>|<value2>|<value3>%

Attribute/Child etc. must contain the substring <value1> or <value2> etc.

=back

writing a minus sign (-) after * ! = or ~ will cause the child/attribute
not to be included, but the condition is evaluated. Writing an ' will cause
the value to be quoted.

=item perlcodeend => <string> 

Code to generate at the end of the block.

=item compiletimeperlcode => <string> or <arrayref>

Code that is executed at compile time. You can also specify a arrayref of string.
The first string which contains matching attributes are used.
The same special strings are replaced as in C<perlcode>.

=item perlcoderemove => 0/1

Remove perlcode if perlcodeend condition is not met.


=item removenode => <removelevel>

Remove node after compiling. <removelevel> could be one of the following,
values could be added:

=over 4

=item 1

Remove this node only

=item 2

Remove next node if it consists of only white spaces and optKeepSpaces isn't set.

=item 4

Replace next node with one space if next node consists only of white spaces and
optKeepSpaces isn't set.

=item 8

Set this node to ignore for output.

=back

=item mayjump => 0/1

If set, tells the compiler that this code may jump to another programm location.
(e.g. if, while, goto etc.).


=back

