Subversion Repositories perlutils

#!/usr/bin/env perl

# Simplified BSD License (FreeBSD License)

#

# Copyright (c) 2026, Daily Data Inc.

# All rights reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions are met:

#

# 1. Redistributions of source code must retain the above copyright notice, this

#    list of conditions and the following disclaimer.

#

# 2. Redistributions in binary form must reproduce the above copyright notice,

#    this list of conditions and the following disclaimer in the documentation

#    and/or other materials provided with the distribution.

#

# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

# perlConfigFileUtility

# Utility to merge template configuration structures with existing config files,

# edit configurations interactively, and convert between YAML and JSON formats.

# Supports reading Perl data structures as templates and YAML/JSON as config files.

# Provides interactive hierarchical editor for modifying configuration values.

# Can add new keys to hashes and elements to arrays dynamically.

# Automatically backs up config files when saving changes.

#

# Author: R. W. Rodolico <rodo@dailydata.net>

# Created: January 2026

#

# Revision History:

# Version: 1.1.0 RWR 2026-01-15

# Added ability to delete keys from hashes and elements from arrays

# Version: 1.0 RWR 2026-01-13

# Initial release with merge, edit, and format conversion capabilities

use strict;

use warnings;

use File::Slurp qw(read_file);

use Data::Dumper;

use Getopt::Long qw(GetOptions);

Getopt::Long::Configure("bundling");

our $VERSION = '1.1.0';

# ============================================================================

# FUNCTIONS

# ============================================================================

## Get a display tag showing the type and value of a data structure element.

## Returns formatted string indicating if value is a hash, array, or scalar.

##

## Arguments:

##   $value - The value to analyze

##

## Returns:

##   String: '[HASH]' for hashrefs, '[ARRAY]' for arrayrefs,

##           'value' for defined scalars, '<undef>' for undefined

sub getTypeTag {

   my ($value) = @_;

   my $ref = ref($value);

   return '[HASH]' if $ref eq 'HASH';

   return '[ARRAY]' if $ref eq 'ARRAY';

   return defined($value) ? "'$value'" : '<undef>';

}

## Display sorted hash keys with index numbers and type tags.

## Shows each key with its value type for user selection in interactive mode.

##

## Arguments:

##   $hash - Hashref to display

##   $path - String path to current location in data structure

##

## Returns:

##   Array of sorted key names

sub displayHashKeys {

   my ($hash, $path) = @_;

   $path //= 'root';

   print "\n" . "=" x 70 . "\n";

   print "Editing: $path\n";

   print "=" x 70 . "\n";

   my @keys = sort keys %$hash;

   if (@keys == 0) {

      print "  (empty hash)\n";

      return ();

   }

   for my $i (0 .. $#keys) {

      my $key = $keys[$i];

      my $typeTag = getTypeTag($hash->{$key});

      printf "  %2d) %-30s %s\n", $i + 1, $key, $typeTag;

   }

   return @keys;

}

## Display array elements with index numbers and type tags.

## Shows each element's index and value type for user selection.

##

## Arguments:

##   $array - Arrayref to display

##   $path  - String path to current location in data structure

##

## Returns:

##   Nothing (void)

sub displayArrayElements {

   my ($array, $path) = @_;

   $path //= 'root';

   print "\n" . "=" x 70 . "\n";

   print "Editing array: $path\n";

   print "=" x 70 . "\n";

   if (@$array == 0) {

      print "  (empty array)\n";

      return;

   }

   for my $i (0 .. $#$array) {

      my $typeTag = getTypeTag($array->[$i]);

      printf "  %2d) [%d] %s\n", $i + 1, $i, $typeTag;

   }

}

## Get and validate user's menu choice.

## Accepts numeric selection, back/quit commands, and optional add/delete commands.

##

## Arguments:

##   $prompt       - String prompt to display

##   $max          - Integer maximum valid selection

##   $allow_add    - Boolean whether to allow 'add' command

##   $allow_delete - Boolean whether to allow 'delete' command

##

## Returns:

##   Integer (0-based index), 'quit', 'back', 'add', 'delete', or undef for invalid input

sub getUserChoice {

   my ($prompt, $max, $allowAdd, $allowDelete) = @_;

   my $options = "1-$max, 0=back";

   $options .= ", a=add new" if $allowAdd;

   $options .= ", d=delete" if $allowDelete;

   $options .= ", q=quit";

   print "\n$prompt ($options): ";

   my $input = <STDIN>;

   chomp $input;

   return 'quit' if $input =~ /^q/i;

   return 'back' if $input eq '0' || $input eq '';

   return 'add' if $allowAdd && $input =~ /^a/i;

   return 'delete' if $allowDelete && $input =~ /^d/i;

   if ($input =~ /^\d+$/ && $input >= 1 && $input <= $max) {

      return $input - 1;  # Convert to 0-based index

   }

   print "Invalid choice. Please enter a valid option.\n";

   return undef;

}

## Prompt user to select type for a new value.

## Displays menu of scalar, hash, or array options.

##

## Arguments:

##   None

##

## Returns:

##   String: 'scalar', 'hash', or 'array'

sub getValueType {

   print "\nSelect value type:\n";

   print "  1) Scalar (string/number)\n";

   print "  2) Hash (key-value pairs)\n";

   print "  3) Array (list of items)\n";

   print "Enter choice (1-3): ";

   my $input = <STDIN>;

   chomp $input;

   return 'scalar' if $input eq '1';

   return 'hash' if $input eq '2';

   return 'array' if $input eq '3';

   print "Invalid choice. Defaulting to scalar.\n";

   return 'scalar';

}

## Create a new value of the specified type.

## For scalars, prompts for input. For hashes/arrays, returns empty structure.

##

## Arguments:

##   $type - String: 'scalar', 'hash', or 'array'

##

## Returns:

##   New value: hashref ({}), arrayref ([]), or user-entered string

sub createNewValue {

   my ($type) = @_;

   if ($type eq 'hash') {

      return {};

   } elsif ($type eq 'array') {

      return [];

   } else {

      print "Enter value: ";

      my $value = <STDIN>;

      chomp $value;

      return $value;

   }

}

## Edit a scalar value interactively.

## Displays current value and prompts for new value.

##

## Arguments:

##   $value - Current scalar value

##   $key   - Key name in parent structure

##   $path  - String path to current location

##

## Returns:

##   New value (original if user pressed Enter without input)

sub editScalar {

   my ($value, $key, $path) = @_;

   print "\n" . "-" x 70 . "\n";

   print "Editing: $path.$key\n";

   print "Current value: " . (defined($value) ? "'$value'" : '<undef>') . "\n";

   print "Enter new value (or press Enter to keep current): ";

   my $input = <STDIN>;

   chomp $input;

   if ($input ne '') {

      print "Value updated.\n";

      return $input;

   }

   return $value;

}

## Interactively edit a hash structure.

## Displays keys, allows selection and editing of values, supports adding and deleting keys.

## Recursively calls itself for nested hashes and edit_array for arrays.

##

## Arguments:

##   $hash - Hashref to edit

##   $path - String path to current location (default 'root')

##

## Returns:

##   Nothing (modifies $hash in place)

sub editHash {

   my ($hash, $path) = @_;

   $path //= 'root';

   while (1) {

      my @keys = displayHashKeys($hash, $path);

      my $choice = getUserChoice("Select key to edit", scalar(@keys) || 1, 1, scalar(@keys) > 0);

      return if !defined $choice;

      return if $choice eq 'back';

      exit 0 if $choice eq 'quit';

      if ($choice eq 'add') {

         print "\nEnter new key name: ";

         my $newKey = <STDIN>;

         chomp $newKey;

         if ($newKey eq '') {

            print "Invalid key name.\n";

            next;

         }

         if (exists $hash->{$newKey}) {

            print "Key '$newKey' already exists.\n";

            next;

         }

         my $valueType = getValueType();

         my $newValue = createNewValue($valueType);

         $hash->{$newKey} = $newValue;

         print "Key '$newKey' added.\n";

         # If it's a hash or array, allow immediate editing

         if ($valueType eq 'hash' || $valueType eq 'array') {

            my $newPath = $path eq 'root' ? $newKey : "$path.$newKey";

            if ($valueType eq 'hash') {

               editHash($newValue, $newPath);

            } else {

               editArray($newValue, $newPath);

            }

         }

         next;

      }

      if ($choice eq 'delete') {

         return if @keys == 0;  # Empty hash, nothing to delete

         print "\nSelect key to delete (1-" . scalar(@keys) . ", 0=cancel): ";

         my $delInput = <STDIN>;

         chomp $delInput;

         if ($delInput eq '0' || $delInput eq '') {

            print "Delete cancelled.\n";

            next;

         }

         if ($delInput =~ /^\d+$/ && $delInput >= 1 && $delInput <= scalar(@keys)) {

            my $keyToDelete = $keys[$delInput - 1];

            print "Delete key '$keyToDelete' and all its children? (y/n): ";

            my $confirm = <STDIN>;

            chomp $confirm;

            if ($confirm =~ /^y/i) {

               delete $hash->{$keyToDelete};

               print "Key '$keyToDelete' deleted.\n";

            } else {

               print "Delete cancelled.\n";

            }

         } else {

            print "Invalid selection.\n";

         }

         next;

      }

      return if @keys == 0;  # Empty hash after checking for add/delete

      my $key = $keys[$choice];

      my $value = $hash->{$key};

      my $newPath = $path eq 'root' ? $key : "$path.$key";

      if (ref($value) eq 'HASH') {

         editHash($value, $newPath);

      } elsif (ref($value) eq 'ARRAY') {

         editArray($value, $newPath);

      } else {

         $hash->{$key} = editScalar($value, $key, $path);

      }

   }

}

## Interactively edit an array structure.

## Displays elements, allows selection and editing, supports adding and deleting elements.

## Recursively handles nested hashes and arrays.

##

## Arguments:

##   $array - Arrayref to edit

##   $path  - String path to current location (default 'root')

##

## Returns:

##   Nothing (modifies $array in place)

sub editArray {

   my ($array, $path) = @_;

   $path //= 'root';

   while (1) {

      displayArrayElements($array, $path);

      my $choice = getUserChoice("Select element to edit", scalar(@$array) || 1, 1, scalar(@$array) > 0);

      return if !defined $choice;

      return if $choice eq 'back';

      exit 0 if $choice eq 'quit';

      if ($choice eq 'add') {

         my $valueType = getValueType();

         my $newValue = createNewValue($valueType);

         push @$array, $newValue;

         my $newIndex = $#$array;

         print "Element added at index $newIndex.\n";

         # If it's a hash or array, allow immediate editing

         if ($valueType eq 'hash' || $valueType eq 'array') {

            my $newPath = "$path\[$newIndex\]";

            if ($valueType eq 'hash') {

               editHash($newValue, $newPath);

            } else {

               editArray($newValue, $newPath);

            }

         }

         next;

      }

      if ($choice eq 'delete') {

         return if @$array == 0;  # Empty array, nothing to delete

         print "\nSelect element to delete (1-" . scalar(@$array) . ", 0=cancel): ";

         my $delInput = <STDIN>;

         chomp $delInput;

         if ($delInput eq '0' || $delInput eq '') {

            print "Delete cancelled.\n";

            next;

         }

         if ($delInput =~ /^\d+$/ && $delInput >= 1 && $delInput <= scalar(@$array)) {

            my $indexToDelete = $delInput - 1;

            print "Delete element at index $indexToDelete and all its children? (y/n): ";

            my $confirm = <STDIN>;

            chomp $confirm;

            if ($confirm =~ /^y/i) {

               splice @$array, $indexToDelete, 1;

               print "Element at index $indexToDelete deleted.\n";

            } else {

               print "Delete cancelled.\n";

            }

         } else {

            print "Invalid selection.\n";

         }

         next;

      }

      return if @$array == 0;  # Empty array after checking for add/delete

      my $value = $array->[$choice];

      my $newPath = "$path\[$choice\]";

      if (ref($value) eq 'HASH') {

         editHash($value, $newPath);

      } elsif (ref($value) eq 'ARRAY') {

         editArray($value, $newPath);

      } else {

         print "\n" . "-" x 70 . "\n";

         print "Editing: $newPath\n";

         print "Current value: " . (defined($value) ? "'$value'" : '<undef>') . "\n";

         print "Enter new value (or press Enter to keep current): ";

         my $input = <STDIN>;

         chomp $input;

         if ($input ne '') {

            $array->[$choice] = $input;

            print "Value updated.\n";

         }

      }

   }

}

## Return usage string for command line help.

##

## Arguments:

##   None

##

## Returns:

##   String containing usage information

sub usageString {

   return "Usage: $0 [-t <template_file>] [-c <config_file>] [-o <output_file>] [-e]\n" .

          "       $0 <template_file> [config_file]\n" .

          "\nAt least one of template or config file must be specified.\n" .

          "\nOptions:\n" .

          "  -t, --template <file>  Template file (Perl hashref)\n" .

          "  -c, --config <file>    Config file (YAML or JSON)\n" .

          "  -o, --output <file>    Output file (default: STDOUT)\n" .

          "  -e, --edit             Interactive edit mode\n" .

          "  -v, --version          Show version information\n" .

          "  -h, --help             Show this help message\n";

}

## Print usage information to STDOUT.

##

## Arguments:

##   None

##

## Returns:

##   Nothing (void)

sub printUsage {

   print usageString();

}

## Parse command line options using Getopt::Long.

## Supports both option-style and positional arguments for backward compatibility.

##

## Arguments:

##   None (reads from @ARGV)

##

## Returns:

##   Hashref with keys: templateFile, configFile, outputFile, editMode

sub parseCommandLine {

   my $opts = {

      templateFile => undef,

      configFile   => undef,

      outputFile   => undef,

      editMode     => 0,

   };

   GetOptions(

      't|template=s' => \$opts->{templateFile},

      'c|config=s'   => \$opts->{configFile},

      'o|output=s'   => \$opts->{outputFile},

      'e|edit'       => \$opts->{editMode},

      'v|version'    => sub { print "$0 version $VERSION\n"; exit 0; },

      'h|help'       => sub { printUsage(); exit 0; },

   ) or die "Error in command line arguments\n";

   # For backward compatibility, also accept positional arguments

   if (!$opts->{templateFile} && !$opts->{configFile} && @ARGV >= 1) {

      $opts->{templateFile} = $ARGV[0];

      $opts->{configFile} = $ARGV[1] if @ARGV >= 2;

   }

   # Check that at least one input file is specified

   die "Error: At least one of template or config file required\n" . usageString() 

      unless $opts->{templateFile} || $opts->{configFile};

   return $opts;

}

## Load and evaluate a Perl template file.

## Template file should contain a hashref data structure.

##

## Arguments:

##   $templateFile - Path to template file

##

## Returns:

##   Hashref from template, or empty hashref if no file specified

sub loadTemplate {

   my ($templateFile) = @_;

   return {} unless $templateFile;

   die "Template file '$templateFile' does not exist\n" unless -f $templateFile;

   my $templateContent = read_file($templateFile);

   my $template = eval $templateContent;

   die "Error parsing template file: $@\n" if $@;

   die "Template must be a hashref\n" unless ref($template) eq 'HASH';

   return $template;

}

## Detect file format based on extension.

## Recognizes .yaml, .yml, and .json extensions.

##

## Arguments:

##   $filename - Path to file

##

## Returns:

##   String: 'yaml' or 'json'

##   Dies if extension not recognized

sub detectFileFormat {

   my ($filename) = @_;

   return 'yaml' if $filename =~ /\.ya?ml$/i;

   return 'json' if $filename =~ /\.json$/i;

   die "Config file must be YAML (.yaml/.yml) or JSON (.json)\n";

}

## Load a YAML file using available YAML library.

## Tries YAML::XS, YAML::Tiny, and YAML in order.

##

## Arguments:

##   $filename - Path to YAML file

##

## Returns:

##   Perl data structure from YAML file

##   Dies if no YAML library available

sub loadYamlFile {

   my ($filename) = @_;

   for my $yamlModule ('YAML::XS', 'YAML::Tiny', 'YAML') {

      if (eval "require $yamlModule; 1") {

         $yamlModule->import('LoadFile');

         return LoadFile($filename);

      }

   }

   die "No YAML library available. Install YAML::XS, YAML::Tiny, or YAML\n";

}

## Load a JSON file using available JSON library.

## Tries JSON::XS, JSON::PP, and JSON in order.

##

## Arguments:

##   $filename - Path to JSON file

##

## Returns:

##   Perl data structure from JSON file

##   Dies if no JSON library available

sub loadJsonFile {

   my ($filename) = @_;

   for my $jsonModule ('JSON::XS', 'JSON::PP', 'JSON') {

      if (eval "require $jsonModule; 1") {

         my $jsonText = read_file($filename);

         return $jsonModule->new->decode($jsonText);

      }

   }

   die "No JSON library available. Install JSON::XS, JSON::PP, or JSON\n";

}

## Load config file and detect its format.

## Handles both YAML and JSON formats automatically.

##

## Arguments:

##   $configFile - Path to config file

##

## Returns:

##   List: ($config_hashref, $format_string)

##   Returns ({}, 'yaml') if no file specified

sub loadConfig {

   my ($configFile) = @_;

   my $config = {};

   my $format = 'yaml';  # Default format

   if ($configFile && -f $configFile) {

      $format = detectFileFormat($configFile);

      if ($format eq 'yaml') {

         $config = loadYamlFile($configFile);

      } elsif ($format eq 'json') {

         $config = loadJsonFile($configFile);

      }

      die "Config must be a hashref\n" unless ref($config) eq 'HASH';

   }

   return ($config, $format);

}

## Recursively merge template into config.

## Template values are only applied for missing keys in config.

## Handles nested hashes and arrays, tracking changes in messages array.

##

## Arguments:

##   $template - Hashref template structure

##   $config   - Hashref config to merge into

##   $path     - Current path string for messages (default '')

##   $messages - Arrayref to collect change notifications (default [])

##

## Returns:

##   List: ($config, $messages) - updated config and array of change messages

sub mergeHash {

   my ($template, $config, $path, $messages) = @_;

   $path //= '';  # Track the key path for notifications

   $messages //= [];  # Array to collect notification messages

   for my $key (keys %$template) {

      my $currentPath = $path ? "$path.$key" : $key;

      if (!exists $config->{$key}) {

         # Key missing in config, copy from template

         $config->{$key} = $template->{$key};

         push @$messages, "Added key: $currentPath";

      } elsif (ref($template->{$key}) eq 'HASH' && ref($config->{$key}) eq 'HASH') {

         # Both are hashes, recurse

         mergeHash($template->{$key}, $config->{$key}, $currentPath, $messages);

      } elsif (ref($template->{$key}) eq 'ARRAY' && ref($config->{$key}) eq 'ARRAY') {

         # Both are arrays, merge by index

         my $templateArray = $template->{$key};

         my $configArray = $config->{$key};

         # Extend config array if template is longer

         for my $i (0 .. $#$templateArray) {

            if ($i > $#$configArray) {

               # Config array is shorter, append from template

               push @$configArray, $templateArray->[$i];

               push @$messages, "Extended array: $currentPath\[$i\] (added from template)";

            } elsif (ref($templateArray->[$i]) eq 'HASH' && ref($configArray->[$i]) eq 'HASH') {

               # Both elements are hashes, merge them

               mergeHash($templateArray->[$i], $configArray->[$i], "$currentPath\[$i\]", $messages);

            }

            # Otherwise keep existing config value at this index

         }

      }

      # If key exists in config with different types, keep config value (don't override)

   }

   return ($config, $messages);

}

## Merge template and config or return whichever is provided.

## Determines merge strategy based on which files are present.

##

## Arguments:

##   $template     - Hashref from template file

##   $config       - Hashref from config file

##   $hasTemplate - Boolean whether template file was provided

##   $hasConfig   - Boolean whether config file was provided

##

## Returns:

##   List: ($merged_hashref, $messages_arrayref)

sub mergeConfigs {

   my ($template, $config, $hasTemplate, $hasConfig) = @_;

   if ($hasTemplate && $hasConfig) {

      return mergeHash($template, $config);

   } elsif ($hasTemplate) {

      return ($template, []);

   } else {

      return ($config, []);

   }

}

## Output notification messages to STDERR.

##

## Arguments:

##   $messages - Arrayref of message strings

##

## Returns:

##   Nothing (void)

sub outputMessages {

   my ($messages) = @_;

   return unless @$messages;

   warn "$_\n" for @$messages;

}

## Format data structure as JSON.

## Tries JSON::XS, JSON::PP, and JSON libraries in order.

## Uses pretty-printing and canonical key ordering.

##

## Arguments:

##   $data - Perl data structure to format

##

## Returns:

##   String containing JSON representation

##   Dies if no JSON library available

sub formatAsJson {

   my ($data) = @_;

   for my $jsonModule ('JSON::XS', 'JSON::PP', 'JSON') {