yf - yaml flattener

gistfile1.txt

#!/usr/bin/env perl

# License: MIT
# Most content reused from https://github.com/genesis-community/genesis

use strict;
use warnings;

use CWD ();
use Data::Dumper;
use File::Basename qw/basename dirname/;
use JSON::PP qw//;

sub envset {
	my $var = shift;
	(defined $ENV{$var} and scalar($ENV{$var} =~ m/^(1|y|yes|true)$/i)) ? 1 : 0;
}

my $__is_highcolour = $ENV{TERM} && $ENV{TERM} =~ /256color/;
sub _color {
	my ($fg,$bg) = @_;
	my @c = (  # NOTE: backgrounds only use the darker version unless highcolour terminal
		'Kk',    # dark grey/black)
		'Rr',    # light red/red
		'Gg',    # light green/green
		'Yy',    # yellow/amber
		'Bb',    # light blue/blue
		'MmPp',  # light magenta/magenta/light purple/purple
		'Cc',    # light cyan/dark cyan
		'Ww'     # light grey/white
	);
	my $fid = (grep {$c[$_] =~ qr/$fg/} 0..7 || ())[0] if $fg;
	my $bid = (grep {$c[$_] =~ qr/$bg/} 0..7 || ())[0] if $bg;
	return "" unless defined $fid || defined $bid;
	my @cc;
	if ($__is_highcolour) {
		push(@cc, 38, 5, $fid + ($fg eq uc($fg) ? 8 : 0)) if defined $fid;
		push(@cc, 48, 5, $bid + ($bg eq uc($bg) ? 8 : 0)) if defined $bid;
	} else {
		push @cc, "1" if $fg eq uc($fg);
		push @cc, "3$fid" if defined $fid;
		push @cc, "4$bid" if defined $bid;
	}
	return "\e[".join(";",@cc)."m";
}

sub _colorize {
	my ($c, $msg) = @_;
	$c = substr($c, 1);
	return $msg if envset('NOCOLOR');

	my @fmt = ();
	push @fmt, 3 if $c =~ /i/i && !$ENV{TMUX}; # TMUX doesn't support italics
	push @fmt, 4 if $c =~ /u/i;
	my ($fg, $bg) = grep {$_ !~ /^[ui]$/i} split(//, $c);

  my $prefix = (@fmt) ? "\e[".join(";", @fmt)."m" : "";
	if (($fg && $fg eq "*") || ($bg && $bg eq "*")) {
		my @rainbow = ('R','G','Y','B','M','C');
		my $i = 0;
		my $msgc = "";
		foreach my $char (split //, $msg) {
			my $fr = $fg && $fg eq "*" ? $rainbow[$i%6] : $fg;
			my $br = $bg && $bg eq "*" ? $rainbow[($i+3)%6] : $bg;
			$msgc = $msgc . _color($fr,$br)."$char";
			if ($char =~ m/\S/) {
				$i++;
			}
		}
		return "$prefix$msgc\e[0m";
	} else {
		return $prefix._color($fg,$bg)."$msg\e[0m";
	}
}

sub csprintf {
	my ($fmt, @args) = @_;
	return '' unless $fmt;
	my $s = sprintf($fmt, @args);
	$s =~ s/(#[-IUKRGYBMPCW*]{1,4})\{(.*?)(\})/_colorize($1, $2)/egi;
	return $s;
}

sub explain {
	explain STDOUT @_;
}

sub waiting_on {
	waiting_on STDOUT @_;
}

sub debug {
	return unless envset("DEBUG") || envset("TRACE");
	_log("DEBUG", csprintf(@_), "Wm")
}

sub error {
	my @err = @_;
	unshift @err, "%s" if $#err == 0;
	print STDERR csprintf(@err) . "$/";
}

sub bail {
	my @err = @_;
	unshift @err, "%s" if $#err == 0;
	$! = 1; die csprintf(@_)."$/";
}

sub dump_var {
	return unless envset("DEBUG") || envset("TRACE");
	my $scope = 0;
	if ($_[0] =~ '^-\d+$') {
		$scope = -(shift);
	}
	local $Data::Dumper::Deparse = 1;
	local $Data::Dumper::Terse   = 1;
	my (undef, $file, $ln) = caller($scope);
	my $sub = (caller($scope+1))[3];
	my (%vars) = @_;
	_log("VALUE", csprintf("#M{$_} = ").Dumper($vars{$_}) .csprintf("#Ki{# in $sub [$file:L$ln]}"), "Wb") for (keys %vars);
}

sub dump_stack {
	return unless envset("DEBUG") || envset("TRACE");
	my $depth=0;
	my ($package,$file,$line,$sub,@stack,@info);
	my ($sub_size, $line_size, $file_size) = (10,4,4);

  while (@info = caller($depth++)) {
		$sub = $info[3];
		$sub_size  = (sort {$b <=> $a} ($sub_size, length($sub )))[0];
		if ($file) {
			push @stack, [$line,$sub,$file];
			$line_size = (sort {$b <=> $a} ($line_size,length($line)))[0];
			$file_size = (sort {$b <=> $a} ($file_size,length($file)))[0];
		}
		$file = $info[1];
		$line = $info[2];
	}

	print STDERR "\n"; # Ensures that the header lines up at the cost of a blank line
	my $header = csprintf("#Wku{%*s}  #Wku{%-*s}  #Wku{%-*s}\n", $line_size, "Line", $sub_size, "Subroutine", $file_size, "File");
	_log("STACK", $header.join("\n",map {
		csprintf("#w{%*s}  #Y{%-*s}  #Ki{%s}", $line_size, $_->[0], $sub_size, $_->[1], $_->[2])
	} @stack), "kY");
}

sub trace {
	return unless envset "TRACE";
	_log("TRACE", csprintf(@_), "Wc")
}

sub _log {
	my ($label, $content, $colors) = @_;
	my ($gt,$gtc) = (">",$colors);
	unless (envset "NOCOLOR") {
		$gt = "⮀";
		$gtc = substr($colors,1,1);
		$label = " $label ";
	}
	my $prompt = csprintf("#%s{%s}#%s{%s}", "$colors",$label,$gtc,$gt);
	my $out = join("\n".(" "x(length($label)+2)),split(/\n/,$content));

	printf STDERR "%s %s\n", $prompt, $out;
}

sub run {
	my (@args) = @_;
	my %opts = %{((ref($args[0]) eq 'HASH') ? shift @args: {})};
	$opts{stderr} = '&1' unless exists $opts{stderr};

	my $prog = shift @args;
	if ($prog !~ /\$\{?[\@0-9]/ && scalar(@args) > 0) {
		$prog .= ' "$@"'; # old style of passing in args as array, need to wrap for shell call
	}

	local %ENV = %ENV; # To get local scope for duration of this call
	for (keys %{$opts{env} || {}}) {
		$ENV{$_} = $opts{env}{$_};
		trace("#M{Setting: }#B{$_}='#C{$ENV{$_}}'");
	}
	my $shell = $opts{shell} || '/bin/bash';
	if (!$opts{interactive} && $opts{stderr}) {
		$prog .= " 2>$opts{stderr}";
	}
	trace("#M{From directory:} #C{%s}", Cwd::getcwd);
	trace("#M{Executing:} `#C{$prog}`%s", ($opts{interactive} ? " #Y{(interactively)}" : ''));
	if (@args) {
		unshift @args, basename($shell);
		trace("#M{ - with arguments:}");
		trace("#M{%4s:} '#C{%s}'", $_, $args[$_]) for (1..$#args);
	}

	my @cmd = ($shell, "-c", $prog, @args);
	my $out;
	if ($opts{interactive}) {
		system @cmd;
	} else {
		open my $pipe, "-|", @cmd;
		$out = do { local $/; <$pipe> };
		$out =~ s/\s+$//;
		close $pipe;
	}
	my $rc = $? >>8;
	if ($rc) {
		trace("command exited with status %x (rc %d)", $rc, $rc >> 8);
		dump_var -1, run_output => $out if (defined($out));
		if ($opts{onfailure}) {
			bail("#R{%s} (run failed)%s", $opts{onfailure}, defined($out) ? ":\n$out" :'');
		}
	} else {
		trace("command exited #G{0}");
		if (defined($out)) {
			if ($out =~ m/[\x00-\x08\x0b-\x0c\x0e\x1f\x7f-\xff]/) {
				trace "[".length($out)."b of binary data omited from trace]";
			} else {
				dump_var -1, run_output => $out;
			}
		}
	}
	return unless defined(wantarray);
	return
		$opts{passfail}    ? $rc == 0 :
		$opts{interactive} ? (wantarray ? (undef, $rc) : $rc) :
		$opts{onfailure}   ? $out
		                   : (wantarray ? ($out,  $rc) : $out);
}

sub lines {
	my ($out, $rc) = @_;
	return $rc ? () : split $/, $out;
}

sub load_json {
	my ($json) = @_;
	return JSON::PP->new->allow_nonref->decode($json);
}

sub load_yaml_file {
	my ($file) = @_;
	my ($out, $rc) = run({ stderr => 0 }, 'spruce json "$1"', $file);
	return $rc ? undef : load_json($out);
}

# Because x FH args... translates to FH->x args, it is required to monkey-patch
# IO:File to facilitate printing to different streams instead of STDOUT.  With
# this in place, the Genesis functions just become wrappers.
package IO::File;

sub explain(*;@) {
	my $self = shift;
	return if main::envset "QUIET";
	print $self main::csprintf(@_)."\n";
}

sub waiting_on(*;@) {
	my $self = shift;
	return if main::envset "QUIET";
	print $self main::csprintf(@_);
}

package main;

sub process_branch {
  my ($content, @path) = @_;
	dump_var path=>\@path;
	if (ref($content) eq 'HASH') {
		for my $key (sort keys %$content) { # TODO: sort?
			process_branch($content->{$key}, @path, "#C{$key}");
		}
	} elsif (ref($content) eq 'ARRAY') {
		my $i = 0; for my $val (@$content) {
			my $index;
			if (ref($val) eq 'HASH') {
				$index = (grep {exists($val->{$_}) && ($val->{$_} !~ '^\(\(')} qw(name key id))[0];
				# TODO: Drop the key field from further output?  Prevents `thing[name=bob].name`
				$index = "[#mi{$index}#Ki{=}#y{$val->{$index}}]" if $index;
			}
			$index ||= "[#Yi{".$i++."}]";
			process_branch($val, @path, $index);
		}
	} else {
		# Node
		my $path_str = join('.',@path);
		$path_str =~ s/^\.//;
		$path_str =~ s/\.\[/\[/g;
		$path_str =~ s/([\.\[\]]+)/#K{$1}/g;
		print csprintf "%s#K{:} %s\n", $path_str, defined($content) ? $content : csprintf("#gi{(null)}");
	}
}

# -- MAIN --

bail "#R{ERROR:} No file given\n" unless @ARGV;
for my $file (@ARGV) {
	bail "#R{ERROR:} File '$file' not found\n" unless -f $file;
	explain STDERR "\n#Wk{--- Reading YAML from $file }";
	process_branch(load_yaml_file($file), "$file>");
}