view release on metacpan or  search on metacpan

lib/Apache2/Expression.pm  view on Meta::CPAN

##----------------------------------------------------------------------------
## Apache2 Server Side Include Parser - ~/lib/Apache2/Expression.pm
## Version v0.1.1
## Copyright(c) 2021 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2021/02/20
## Modified 2025/03/22
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Apache2::Expression;
BEGIN
{
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( Module::Generic );
    use vars qw( $VERSION );
    use Regexp::Common qw( Apache2 );
    use PPI;
    our $VERSION = 'v0.1.1';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    $self->{legacy} = 0;
    $self->{trunk}  = 0;
    $self->SUPER::init( @_ );
    return( $self );
}

sub legacy { return( shift->_set_get_boolean( 'legacy', @_ ) ); }

sub parse
{
    my $self = shift( @_ );
    my $data = shift( @_ );
    return( '' ) if( !length( $data ) );
    my $opts = $self->_get_args_as_hash( @_ );
    pos( $data ) = 0;
    my $prefix = $self->legacy ? 'Legacy' : $self->trunk ? 'Trunk' : '';
    my @callinfo = caller(0);
    $opts->{top} = 0;
    $opts->{top} = 1 if( $callinfo[0] ne ref( $self ) || ( $callinfo[0] eq ref( $self ) && substr( (caller(1))[3], rindex( (caller(1))[3], ':' ) + 1 ) ne 'parse' ) );
    # This is used to avoid looping when an expression drills down its substring by calling parse again
    my $skip = {};
    if( ref( $opts->{skip} ) eq 'ARRAY' &&
        scalar( @{$opts->{skip}} ) )
    {
        @$skip{ @{$opts->{skip}} } = ( 1 ) x scalar( @{$opts->{skip}} )
    }
    my $p = {};
    $p->{is_negative} = 0;
    my $elems = [];
    my $hash =
    {
    raw => $data,
    elements => $elems,
    };
    my $looping = 0;
    PARSE:
    {
        my $pos = pos( $data );
        if( pos( $data ) == length( $data ) )
        {
            last PARSE;
        }
        if( $data =~ m/\G\r?\n$/ )
        {
            redo PARSE;
        }
        elsif( $data =~ /\A\G$RE{Apache2}{LegacyVariable}\Z/gmcs && 
               length( $+{variable} ) )
        {
            my $re = { %+ };
            $self->whereami( \$data, pos( $data ) );
            my $def =
            {
                elements => [],
                type => 'variable',
                raw => $re->{variable},
                re => $re,
            };
            if( length( $re->{var_func_name} ) )
            {
                $def->{subtype} = 'function';
                $def->{name}    = $re->{var_func_name};
                $def->{args}    = $re->{var_func_args};
                if( length( $def->{args} ) )
                {
                    my @argv = $self->parse_args( $def->{args} );
                    $def->{args_def} = [];
                    foreach my $this ( @argv )
                    {
                        my $this = $self->parse( $this );
                        push( @{$def->{elements}}, @{$this->{elements}} );
                        push( @{$def->{args_def}}, @{$this->{elements}} );
                    }
                }
            }
            elsif( length( $re->{varname} ) )
            {
                $def->{subtype} = 'variable';
                $def->{name}    = $re->{varname};