[ # Filter { "cell \(lib_1\)" => { "pin (\"*\")" => { "timing ()" => 1, # 'max_transition' => [ 20 ], }, }, }, # Changes { "cell \(lib_1\)" => { "pin (\"*\")" => { 'max_transition' => { action => 'delete' }, }, }, } ], #### # 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 causes # 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 $/ ; ; } ; # 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* (?.*?) \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/ (?
 \h* ) (? [^\n=]+?) (? \h*:\h* ) (? [^\n]+? ) (? \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
				#  => 1
				else {
					if ( $test->{ $filterItems } == $filter->{ $filterItems } ) {
						$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  => 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 } } ) || ( exists $_->[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 position " . 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->{ $_ }->{ action } ) {
										if ( $changes->{ $_ }->{ action } 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 enabled
			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, $context_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 position " . 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") ;
        }  
      }  
    }
  }