view release on metacpan or  search on metacpan

lib/Module/Generic.pm  view on Meta::CPAN

                    # We add the 8 bits compliant version only if any colour was provided, i.e.
                    # This is not just a style definition
                    CORE::push( @$params8, $styles->{lc($s)} ) if( scalar( @$params8 ) );
                }
            }
        }
        CORE::push( @$data, "\e[" . CORE::join( ';', @$params8 ) . "m" ) if( scalar( @$params8 ) );
        CORE::push( @$data, "\e[" . CORE::join( ';', @$params ) . "m" ) if( scalar( @$params ) );
        return( $data );
    };

    # NOTE: process_params()
    my $process_params = sub
    {
        my( $params ) = @_;
        return if( !defined( $params ) || !length( $params // '' ) );
        my $def = {};
        # Example: bold green underline on black
        if( $params =~ m{
            ^[[:blank:]]*
            (?:
                (?<style1>$style_re)
                [[:blank:]]+
            )?
            (?<fg_colour>$colour_re)
            (?:
                [[:blank:]]+
                (?<style2>$style_re)
            )?
            (?:
                [[:blank:]]+on[[:blank:]]+
                (?<bg_colour>$colour_re)
            )?
            [[:blank:]]*$
            }xi )
        {
            my $style = $+{style1} || $+{style2};
            my $fg = $+{fg_colour};
            my $bg = $+{bg_colour};
            $def = 
            {
                style     => $style,
                colour    => $fg,
                bg_colour => $bg,
            };
            $self->__message( 120, "\$process_params->(): Params regular expression matched -> ", sub{ $self->Module::Generic::dump( $def ) } );
        }
        else
        {
            $self->__message( 120, "\$process_params->(): Params regular expression failed to match. Trying to eval '$params' instead." );
            # Only allow characters that make sense for hash-like parameters.
            # This forbids variables, code blocks, Perl ops, backticks, etc.
            if( $params =~ /[^a-zA-Z0-9_,\=>\s\h[:blank:]'"\|\(\)\.\-]/ )
            {
                $self->__message( 120, "\$process_params->(): Illegal characters found inside eval." );
                return;
            }
            # illegal functions that have no business being here, and could pass through the previous check
            elsif( $params =~ /\b(?:
                    qx|system|open|exec|fork|require|use|eval|do|
                    package|sub|BEGIN|UNITCHECK|CHECK|INIT|END|
                    readpipe|sysopen|unlink|rename|chmod|chown|utime|truncate|mkdir|rmdir|opendir|readdir|closedir|glob
                )\b/i )
            {
                $self->__message( 120, "\$process_params->(): Illegal functions used inside eval." );
                return;
            }

            local $SIG{__WARN__} = sub{};
            local $SIG{__DIE__} = sub{};
            local $@;
            my @res = eval( $params );
            $self->__message( 120, "\$process_params->(): evaluating '$params' produced -> ", sub{ $self->Module::Generic::dump( \@res ) } );
            $def = { @res } if( scalar( @res ) && !( scalar( @res ) % 2 ) );
            if( $@ || ref( $def ) ne 'HASH' )
            {
                my $err = $@ || "Invalid styling \"${params}\"";
                $self->__message( 120, "\$process_params->(): Error evaluating '$params' -> $@" );
                $def = {};
            }
        }

        if( scalar( keys( %$def ) ) )
        {
            $self->__message( 120, "\$process_params->(): colour definition is: ", sub{ $self->Module::Generic::dump( $def ) } );
            my $ref = $colour_format->( $def );
            $self->__message( 120, "\$process_params->(): Returning -> ", sub{ $self->Module::Generic::dump( $ref ) } );
            return if( !$ref || !scalar( @$ref ) );
            return( $ref );
        }
        $self->__message( 120, "\$process_params->(): Returning nothing." );
        return;
    };

    # NOTE: parse()
    my $parse;
    $parse = sub
    {
        # $chunk is the text from position $pos until the end of the string, as provided by parent
        my $chunk   = shift( @_ );
        my $args    = shift( @_ ) || {};
        my $copy    = $chunk;
        my $out     = '';
        my $level   = $args->{level} // 1;
        my $counter = $args->{counter} // 0;
        return( $chunk ) if( $level > $max_depth );
        my( $open_d, $close_d );
        # If we are given specific open and close delimiter use them, otherwise, use our list of candidates.
        # This only happens the first time we hist the text to parse and search for those delimiters.
        # Afterward, as a rule, we always stick to the same delimiters used. The user cannot mix delimiters in the same string.
        # We create Regexp object on purpose, so we can differentiate from plain string later in our code.
        # The initial '$open' and '$close' are simple strings, not Regexp object, so we can differentiate them:
        # Regexp -> confirmed open and close delimiters
        # Non-Regexp -> prospective open and close delimiters
        # Once the open and close delimiters are confirmed they never change.
#         $open_d  = $args->{open}  ? ( ref( $args->{open} )  ? $args->{open}  : qr{(?<open_d>\Q$args->{open}\E)} ) : $open;
#         $close_d = $args->{close} ? ( ref( $args->{close} ) ? $args->{close} : qr{?<close_d>\Q$args->{close})} )  : $close;
        $open_d  = $args->{open}  ? $args->{open}  : $open;
        $close_d = $args->{close} ? $args->{close} : $close;
        $self->__message( 120, "\$parse->() [LEVEL ${level}]: Using \$open_d '$open_d', and \$close_d '$close_d' with closing counter '$counter'" );
        $self->__message( 120, "\$parse->() [LEVEL ${level}]: Processing string '", ( $chunk // 'undef' ), "'" );