# Previously posted at: https://www.perlmonks.org/?node_id=1228072
# Changes for use-case: https://www.perlmonks.org/?node_id=1231694
#
# Changed code to be able to use wild-card in the filter and change
# configuration: e.g. cell(.*) or pin (.*)
# Additionally for this particular use-case a configuration item is
# created to be able to delete the entire line from the file.
# Note: The regxx had to be changed for this use-case,
#       and $re_context has been moved as last since changing it cause
+s
#       it to interfere with other regxx.

use warnings ;
use strict ;
use re '/msx' ;
use Data::Compare qw/Compare/ ;
use Data::Dumper ;

my $file = "1231694.txt" ;
open (my $fho, ">", $file ) or die "Cannot open $file\n" ;

my $data = do {
    local $/ ;
    <DATA> ;
} ;

# begin + horizontal space + # + Text + new line (consumes new line)
# Removed ^, end of line \n -> \n? (because a \n may be missing at the
+ eof)
my $re_comment = qr/ \h* \# [^\n]* \n? / ;
#          index_1("1,2,3,4,5") ;
my $re_ignore1 = qr/ \h* index_.*? \h* \n / ;
#          values("13, 13, 14, 16, 18",\
#                  "13, 14, 15, 16, 19",\
#                 "15, 16, 17, 18, 21") ;
my $re_ignore2 = qr/ \h* (?:values)* \h* \(? \h* \" (?:(?:\d+\h*)\,?\h
+*)+ \" \h* (?:[\,\)])? \h* (?:[\\\;)])? \h* \n / ;
# horizontal and vertical space + context=any characters (non greedy) 
++
# horizontal and vertical space + { + horizontal space optionally
# followed by new line (consumes new line)
# Regex should be improved, it is only possible now to call it as last
my $re_context = qr/ \s* (?<context>.*?) \s* \{ \h*\n* / ;
# pre=horizontal space + name=Text + mid=h-space + '=' + h-space +
# value=Text + post = horizontal space + new line (consumes new line)
# Removed ^
# Added \;\h*
my $re_namevalue = qr/ (?<pre> \h* ) (?<name> [^\n=]+?) (?<mid> \h*:\h
+* ) (?<value> [^\n]+? ) (?<post> \h*\;\h*\n ) / ;
# horizontal or vertical space + } + horizontal space +
# optional new line (consumes new line)
my $re_endblock =  qr/ \s* \} (?:\h*\n*)* / ; 

my $parseConfig = [
    [
        # Filter
        {
            "cell \(lib_1\)" => {
                "pin (\"*\")" => {
                    "timing ()" => 1,
                    # 'max_transition' => [ 20 ],
                },
            },
        },
        # Changes
        {
            "cell \(lib_1\)" => {
                "pin (\"*\")" => {
                    'max_transition' => { action => 'delete' },
                },
            },
        }
    ],
] ;

sub applyFilter {
    # Apply filter on given parameter set (non-recursive)
    my $filter = $_[0] ; # Hash reference of one filter. In case
                         # filter is empty result is true
    my $test = $_[1] ; # Hash reference with parameter value pairs
                       # and/or context (context will be ignored)
    my $result = 1 ;
    foreach my $filterItems ( keys %{$filter} ) {
        # Ignore context
        if ( ( ref $filter->{ $filterItems } ) ne 'HASH' ) {
            my $tmpResult = 0 ;
            # In case parameter does not exists in $tmpH then the
            # filter may have a bad configuration, however in other
            # contexts this parameter may exists, so no errors or
            # warnings. Since something is specified in this filter,
            # but it does not exists in this context the filter
            # silently fails
            if ( exists $test->{ $filterItems } ) {
                if ( ref $filter->{ $filterItems } eq 'ARRAY' ) {
                    foreach my $filterItem ( @{$filter->{ $filterItems
+ }} ) {
                        if ( $test->{ $filterItems } eq $filterItem ) 
+{
                            $tmpResult = 1 ;
                            last ;
                        }
                    }
                }
                # A filter function has been added that
                # allows to specify that an object MUST exists
                # inside the current object
                # Instead of specifying param => [array], specify
                # <object name> => 1
                else {
                    if ( $test->{ $filterItems } == $filter->{ $filter
+Items } ) {
                        $tmpResult = 1 ;
                    }
                }
            }
            if ( $tmpResult == 0 ) {
                return 0 ;
            }
            $result = $result && $tmpResult ;
        }
    }
    return $result ;
}

sub reduceConfigSets {
    # Create a new configuration-set selecting the filters by indexes
    # and changes to 'one level up' for a given context.
    # Synopsis: my $reducedParseConfig =
    #     reduceConfigSets( $parseConfig, 'Object Type1', $indexes ) ;
+    
    my $config = $_[0] ; # Hash ref
    my $selection = $_[1] ; # Context key
    my $indexes = $_[2] ; # Array Ref array with indexes
    my $newConfig = [] ;
    my $ix = -1 ;
    foreach ( @{$config} ) {
        ++$ix ;
        my $skip = 1 ;
        foreach( @{$indexes} ) {
            if ( $ix == $_ ) {
                $skip = 0 ;
                last ;
            }
        }
        next if ( $skip ) ;
        my $newFilter ;
        my $newChanges ;
        #if ( exists $_->[0]->{ $selection } ) {
        #    # Note: no copies!
        #    $newFilter = $_->[0]->{ $selection } ;
        #}
        #if ( exists $_->[1]->{ $selection } ) {
        #    # Note: no copies!
        #    $newChanges = $_->[1]->{ $selection } ;
        #}
        # Replaced previous with wild-card context selection enabled
        # Using keys as regxx is probably not such a good idea
        # so just a simple use of a asterisk as wild-card will do
        foreach my $k ( keys %{$_->[0]} ) {
            my $re = quotemeta $k ;
            $re =~ s/\\\*/\.\*\?/g ;
            if ( $selection =~ /$re/ ) {
                # Added. Since objects can be filtered now as well
                # by specifying <object name> => 1 this
                # is no longer always a hash.
                # When it is not a hash, then it is not a new filter.
                if ( ref $_->[0]->{ $k } eq 'HASH' ) {
                    $newFilter = $_->[0]->{ $k } ;
                }
                # END Added.
            }
        }
        foreach my $k ( keys %{$_->[1]} ) {
            my $re = quotemeta $k ;
            $re =~ s/\\\*/\.\*\?/g ;
            if ( $selection =~ /$re/ ) {
                $newChanges = $_->[1]->{ $k } ;
            }
        }
        # END Replaced ...
        if ( $newFilter || $newChanges ) {
            push @$newConfig, [ $newFilter, $newChanges ] ;
        }
    }
    return $newConfig ;
} ;

sub processData {
    my ( $data, $position, $config ) = @_ ; # Refs
    pos( $$data ) = $position ;
    my $ident = 0 ;
    my $tmpH = {} ;
    while ( pos( $$data ) < length( $$data ) ) {
        if ( $$data =~ m{\G$re_comment}gc ) {
            # comment, nothing to do\
        } elsif ( $$data =~ m{\G$re_ignore1}gc ) {
            # some data, nothing to do
        } elsif ( $$data =~ m{\G$re_ignore2}gc ) {
            # some data, nothing to do
        } elsif ( $$data =~ m{\G$re_namevalue}gc ) {
            if ( $ident == 0 ) {
                foreach ( @{$config} ) {
                    # If a parameter needs to be collected within the
                    # current context (filter data)
                    # or
                    # If a change exists for this
                    # parameter (change data)
                    if ( ( exists $_->[0]->{ $+{ name } } ) || ( exist
+s $_->[1]->{ $+{ name } } ) ) {
                        $tmpH->{ $+{ name } } = $+{ value } ;
                    }
                }
            }
        } elsif ( $$data =~ m{\G$re_endblock}gc ) {
            if ( $position == 0 ) {
                die "'}' with no opening '{'?" unless $ident ;
            }
            # if ( --$ident == -1 ) { # ?
            --$ident ;
            if ( $ident == -1 ) {
                last ;
            }
        } elsif ( $$data =~ m{\G$re_context}gc ) {
            if ( $ident == 0 ) {
                foreach ( @{$config} ) {
                    # If a change exists in config for this
                    # context (change data)
                    #if ( exists $_->[1]->{ $+{ context } } ) {
                    #    $tmpH->{ $+{ context } } = 1 ;
                    #}
                    # Replaced previous with wild-card context
                    # selection
                    my $context_copy = $+{ context } ;
                    foreach my $k ( keys %{$_->[1]} ) {
                        my $re = quotemeta $k ;
                        $re =~ s/\\\*/\.\*\?/g ;
                        if ( $context_copy =~ /$re/ ) {
                            $tmpH->{ $k } = 1 ;
                        }
                    }
                    # END Replaced ...
                    # Added, there seems to be need for searching
                    # objects in the current object (not only params)
                    foreach my $k ( keys %{$_->[0]} ) {
                        my $re = quotemeta $k ;
                        $re =~ s/\\\*/\.\*\?/g ;
                        if ( $context_copy =~ /$re/ ) {
                            $tmpH->{ $k } = 1 ;
                        }
                    }
                    # END Added
                }
            }
            ++$ident ;
        } else {
            die "Failed to parse at: \"" . 
                substr( $$data, pos $$data, 70 ) . "...\"" . " at posi
+tion " . pos $$data ;
        }
    }
    $ident = 0 ;
    pos( $$data ) = $position ;
    while ( pos( $$data ) < length( $$data ) ) {
        my $repl ;
        if ( $$data =~ m{\G$re_comment}gc ) {
            # comment, nothing to do            
            print $fho $repl // substr( $$data, $-[0], $+[0] - $-[0] )
+ ;
        } elsif ( $$data =~ m{\G$re_ignore1}gc ) {
            # some data, nothing to do
            print $fho $repl // substr( $$data, $-[0], $+[0] - $-[0] )
+ ;
        } elsif ( $$data =~ m{\G$re_ignore2}gc ) {
            # some data, nothing to do
            print $fho $repl // substr( $$data, $-[0], $+[0] - $-[0] )
+ ;
        } elsif ( $$data =~ m{\G$re_namevalue}gc ) {
            # Name/value pair always exists inside $tmpH
            if ( exists $tmpH->{ $+{ name } } ) {
                foreach my $configItem ( @{$config} ) {
                    # Cascading filters
                    my $filter = $configItem->[0] ;
                    # If there are filters left within this
                    # context (no filter means: allow change)
                    if ( applyFilter( $filter, $tmpH ) ) {
                        # If a parameter needs to be changed within
                        # the current context (change data)
                        my $changes = $configItem->[1] ;
                        foreach( keys %{$changes} ) {
                            if ( ( ref $changes->{ $_ } ) ne 'HASH' ) 
+{
                                if ( $_ eq $+{name} ) {
                                    my $curVal = $tmpH->{ $+{name} } ;
                                    my $newValue ;
                                    my $instruction = "\$newValue = " 
+. $changes->{ $_ } ;
                                    eval( $instruction ) ;
                                    $repl = $+{ pre } . $+{ name } . $
++{ mid } . $newValue . $+{ post } ;
                                    # Filter is cascading so update
                                    # the value inside the temp hash
                                    # as well
                                    $tmpH->{ $+{ name } } = $newValue 
+;
                                }
                            }
                            # Added for use-case:
                            #    www.perlmonks.org/?node_id=1231694
                            else {
                                # Fix: This if was missing.
                                #      This caused multiple 'action'
                                #      configuration to interfere with
                                #      each-other
                                if ( $_ eq $+{name} ) {
                                    if ( exists $changes->{ $_ }->{ ac
+tion } ) {
                                        if ( $changes->{ $_ }->{ actio
+n } eq 'delete' ) {
                                            $repl = '' ;
                                        }
                                    }
                                }
                            }
                        }
                    }
                }
            }
            print $fho $repl // substr( $$data, $-[0], $+[0] - $-[0] )
+ ;
        } elsif ( $$data =~ m{\G$re_endblock}gc ) {
            print $fho $repl // substr( $$data, $-[0], $+[0] - $-[0] )
+ ;
            # if ( --$ident == -1 ) # ?
            --$ident ;
            if ( $ident == -1 ) {
                return ;
            }
        } elsif ( $$data =~ m{\G$re_context}gc ) {
            my $contextSelected = 0 ;
            my $useConfigItems = [] ;
            # if ( exists $tmpH->{ $+{ context } } ) {
            # Replaced previous with wild-card context selection enabl
+ed
            my $context_copy = $+{ context } ;
            my $do_context = 0 ;
            foreach my $k ( keys %{$tmpH} ) {
                my $re = quotemeta $k ;
                $re =~ s/\\\*/\.\*\?/g ;
                if ( $context_copy =~ /$re/ ) {
                    $do_context = 1 ;
                    last ;
                }
            }
            if ( $do_context ) {
                # Parameter(s) needs to be checked within the
                # current context (filter data)
                my $changeAllowed = 0 ;
                my $configIndex = -1 ;
                foreach my $configItem ( @{$config} ) {
                    ++$configIndex ;
                    my $filter = $configItem->[0] ;
                    my $tmpChangeAllowed = applyFilter( $filter, $tmpH
+ ) ;                    
                    if ( $tmpChangeAllowed ) {
                        $changeAllowed = 1 ;
                        push @{$useConfigItems}, $configIndex ;
                    }    
                }
                if ( $changeAllowed ) {
                    $contextSelected = 1 ;
                }
            }
            if ( $contextSelected ) {
                print $fho $repl // substr( $$data, $-[0], $+[0] - $-[
+0] ) ;
                my $reducedParseConfig = reduceConfigSets( $config, $c
+ontext_copy, $useConfigItems ) ;
                # Warning: $- and $+ variables can no longer be
                #          used after this call
                processData( $data, pos( $$data ), $reducedParseConfig
+ ) ;
            } else {
                ++$ident ;
                print $fho $repl // substr( $$data, $-[0], $+[0] - $-[
+0] ) ;
            }
        } else {
            die "Failed to parse at: \"" . 
                substr( $$data, pos $$data, 70 ) . "...\"" . " at posi
+tion " . pos $$data ;
        }
    }
}

processData( \$data, 0, $parseConfig ) ;

__DATA__
  cell (lib_1) {
    dont_use : true ;
    dont_touch : true ;

    pin ("HIZIBI_IN_1") {
      direction : input ;
      clock : true ;
      max_transition : 1 ;
      capacitance : 12 ;
    }  
    pin ("HIZIBI_79")    {
      direction : output ;
      max_transition : 10;
      min_capacitance : 3 ;
    }              
    pin ("HIZIBI_IN_1") {
      direction : input ;
      clock : true ;
      max_transition : 1 ;
      capacitance : 1 ;
    }  
    pin ("HIZIBI_78")    {
      direction : output ;
      max_transition : 10;
      min_capacitance : 34 ;
      capacitance : 34 ;
    }            
    pin ("HIZIBI")    {
      direction : output ;
      clock : true ;
      max_transition : 20;
      related_power_pin : VDD ;
      related_ground_pin : VSS ;
      timing () {
        cell_fall (into_f1) {
          index_1("1,2,3,4,5") ;
          index_2("1,2,3,4,5") ;
          values("13, 13, 14, 16, 18",\
                 "13, 14, 15, 16, 19",\
                 "14, 15, 16, 17, 20",\
                 "15, 15, 16, 18, 20",\
                 "15, 16, 17, 18, 21") ;
        }  
      }  
    }
  }
[download]