File Coverage

blib/lib/Embperl/Syntax.pm

Criterion	Covered	Total	%
statement	132	146	90.4
branch	26	38	68.4
condition	8	11	72.7
subroutine	27	28	96.4
pod	6	6	100.0
total	199	229	86.9

###################################################################################
#
#   Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh  www.ecos.de
#   Embperl - Copyright (c) 2008-2014 Gerald Richter
#
#   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: Syntax.pm 1578075 2014-03-16 14:01:14Z richter $
#
###################################################################################



package Embperl::Syntax ;

use strict ;
use vars qw{@ISA @EXPORT_OK %EXPORT_TAGS %DocumentRoot %Syntax} ;

@ISA = qw{Exporter} ;

use constant  ntypTag           => 1 ;
use constant  ntypStartTag      => 1 + 0x20 ;
use constant  ntypStartEndTag   => 1 + 0x80 ;
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 ;
use constant  ntypEntityRef       => 5 ;
use constant  ntypEntity          => 6 ;
use constant  ntypProcessingInstr => 7 ;
use constant  ntypComment         => 8 ;
use constant  ntypDocument        => 9 ;
use constant  ntypDocumentType    => 10 ;
use constant  ntypDocumentFraq    => 11 ;
use constant  ntypNotation        => 12 ;

use constant  aflgSingleQuote     => 8 ;


@EXPORT_OK = qw{
ntypTag
ntypStartTag
ntypStartEndTag
ntypEndTag
ntypEndStartTag
ntypAttr
ntypAttrValue
ntypText
ntypCDATA
ntypEntityRef
ntypEntity
ntypProcessingInstr
ntypComment
ntypDocument
ntypDocumentType
ntypDocumentFraq
ntypNotation

aflgSingleQuote
} ;



%EXPORT_TAGS = (
    types => \@EXPORT_OK,
    ) ;


###################################################################################
#
#   Methods
#
###################################################################################

# ---------------------------------------------------------------------------------
#
#   Create new Syntax Object
#
# ---------------------------------------------------------------------------------

sub new

    {
    my $class = shift ;

    my $self = $class ;
    if (!ref $class)
        {
        $self = {
                -root => $class -> CloneHash (\%DocumentRoot) ,
                -procinfotype => 'embperl',
               } ;

        bless $self, $class ;
        }

    return $self ;
    }



# ---------------------------------------------------------------------------------
#
#   Add new elemets to root
#
# ---------------------------------------------------------------------------------


sub AddToRoot

    {
    my ($self, $elements) = @_ ;

    my $root = $self -> {-root} ;

    while (my ($k, $v) = each (%$elements))
        {
        $root -> {$k} = $v ;
        }
    }

# ---------------------------------------------------------------------------------
#
#   Adds code that is execute everytime after the compile of a document
#       start and end of the execution of a document
#
# ---------------------------------------------------------------------------------


sub AddInitCode

    {
    my ($self, $compiletimecode, $initcode, $termcode, $procinfo) = @_ ;

    my $root = $self -> {-root} ;
    my $ttref ;
    foreach my $tagtype ('Document', 'DocumentFraq')
        {
        die "'$tagtype' unknown" if (!($ttref = $self -> {-root}{$tagtype})) ;
        my $pinfo = ($ttref -> {'procinfo'}{$self -> {-procinfotype}} ||= {}) ;
        $pinfo -> {'compiletimeperlcode'} .= $compiletimecode if ($compiletimecode) ;
        $pinfo -> {'perlcode'} .= $initcode if ($initcode) ;
        $pinfo -> {'perlcodeend'} .= $termcode if ($termcode) ;
        if ($procinfo)
            {
            while (my ($k, $v) = each (%$procinfo))
                {
                $pinfo -> {$k} = $v ;
                }
            }
        }
    }



# ---------------------------------------------------------------------------------
#
#   Get root
#
# ---------------------------------------------------------------------------------


sub GetRoot

    {
    my ($self) = @_ ;

    return $self -> {-root} ;
    }


# ---------------------------------------------------------------------------------
#
#   Get/create named syntax
#
# ---------------------------------------------------------------------------------


sub GetSyntax

    {
    my ($name, $oldname) = @_ ;

    my %names ;
    my $op = '' ;
    if ($name =~ /^(\+|\-)\s*(.*?)$/)
        {
        $op   = $1 ;
        $name = $2;
        }
    $name = "$oldname $name" if ($op eq '+') ;

    my @split = split (/\s/, $name) ;
    if ($op eq '-')
        {
        my @mnames = map { /::/?$_:'Embperl::Syntax::'. $_ } @split  ;
        foreach (@mnames)
            {
            $names{$_} = 1 ;
            }
        @split = split (/\s/, $oldname) ;
        }

    my @xnames = map { /::/?$_:'Embperl::Syntax::'. $_ } @split  ;
    my @names ;
    foreach (@xnames)
        {
        push @names, $1 if (!$names{$_} && (/^\s*([a-zA-Z_0-9:]+)\s*$/)) ;
        $names{$_} = 1 ;
        }

    $name = join (' ', @names) ;

    print Embperl::LOG "[$$]SYNTAX: switch to $name\n" ;

    return undef if (!$name) ;
    return $Syntax{$name} if (exists ($Syntax{$name})) ;

    foreach my $n (@names)
        {
        eval "require $n" ;
        if ($@)
            {
            warn $@ ;
            return undef ;
            }
        }

    my $first = shift @names ;

    my $self = $first -> new ;

    foreach my $n (@names)
        {
no strict ;
        &{"${n}::new"}($self) ;
use strict ;
        }

    $self -> {-name} = $name ;

    BuildTokenTable ($self) ;
    $Syntax{$name} = $self ;
    return $self ;
    }

# ---------------------------------------------------------------------------------
#
#   Deep clone a hash and make replacements
#
# ---------------------------------------------------------------------------------

sub CloneHash
    {
    my ($self, $old, $replace, $seen, $new) = @_ ;


    $new     ||= {} ;
    $replace ||= {} ;
    $seen    ||= {$old => $new} ;

    my ($v, $k) ;


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

    return $new ;
    }



###################################################################################
#
#   Definitions for documents
#
###################################################################################


%DocumentRoot = (
    '-lsearch' => 1,

    # The document node is generated always and is not parserd, but can be used to include code
    'Document' => {
        'nodename'  => 'Document',
        'nodetype'  => ntypDocument,
        'procinfo'  => {
            embperl => {
                perlcode    => q{
# any initialisation could be put here
#$DB::single = 1 ;
$maxrow=100;$maxcol=10;
},
                compiletimeperlcode => q{
use vars ('$_ep_DomTree', '@ISA', '@param') ;
*_ep_rp=\\&XML::Embperl::DOM::Node::iReplaceChildWithCDATA;
*_ep_rpid=\\&XML::Embperl::DOM::Node::iReplaceChildWithMsgId;
*_ep_rpurl=\\&XML::Embperl::DOM::Node::iReplaceChildWithUrlDATA;
*_ep_cp=\\&XML::Embperl::DOM::Tree::iCheckpoint;
*_ep_dcp=\\&XML::Embperl::DOM::Tree::iDiscardAfterCheckpoint;
*_ep_opt=\\&Embperl::Cmd::Option;
*_ep_hid=\\&Embperl::Cmd::Hidden;
*_ep_ac=\\&XML::Embperl::DOM::Node::iAppendChild;
*_ep_sa=\\&XML::Embperl::DOM::Element::iSetAttribut;
Embperl::Util::CreateAliases ;
},
                perlcodeend => q{# Include here any cleanup code
                                $DB::single = 0 ;
                                },
                stackname   => 'metacmd',
                stackmatch  => 'Document',
                'push'      => 'Document',
                mayjump     => 1,
                }
            },
        },
    # The document fraq node is generated always and is not parserd, but can be used to include code
    'DocumentFraq' => {
        'nodename'  => 'DocumentFraq',
        'nodetype'  => ntypDocumentFraq,
        'procinfo'  => {
            embperl => {
                perlcode    => q{
#my $_ep_param_save = \@param ;
#*param = $Embperl::req -> component -> param -> param || [];
},
                compiletimeperlcode => q{
use vars ('$_ep_DomTree', '@ISA', '@param') ;
*_ep_rp=\\&XML::Embperl::DOM::Node::iReplaceChildWithCDATA;
*_ep_rpid=\\&XML::Embperl::DOM::Node::iReplaceChildWithMsgId;
*_ep_rpurl=\\&XML::Embperl::DOM::Node::iReplaceChildWithUrlDATA;
*_ep_cp=\\&XML::Embperl::DOM::Tree::iCheckpoint;
*_ep_dcp=\\&XML::Embperl::DOM::Tree::iDiscardAfterCheckpoint;
*_ep_opt=\\&Embperl::Cmd::Option;
*_ep_hid=\\&Embperl::Cmd::Hidden;
*_ep_ac=\\&XML::Embperl::DOM::Node::iAppendChild;
*_ep_sa=\\&XML::Embperl::DOM::Element::iSetAttribut;
Embperl::Util::CreateAliases ;
},
                perlcodeend => q{
#*param = $_ep_param_save ;
},
                stackname   => 'metacmd',
                stackmatch  => 'DocumentFraq',
                'push'      => 'DocumentFraq',
                mayjump     => 1,
                }
            },
        },
    ) ;

1;

__END__