File Coverage

blib/lib/Audio/Nama/Assign.pm

Criterion	Covered	Total	%
statement	130	193	67.3
branch	31	72	43.0
condition	7	18	38.8
subroutine	19	31	61.2
pod	0	10	0.0
total	187	324	57.7

package Audio::Nama::Assign;
use Modern::Perl;
our $VERSION = 1.0;
use 5.008;
use feature 'state';
use strict;
use warnings;
no warnings q(uninitialized);
use Carp qw(carp confess croak cluck);
use YAML::Tiny;
use File::Slurp;
use File::HomeDir;
use Audio::Nama::Log qw(logsub logpkg);
use Storable qw(nstore retrieve);
use JSON::XS;
use Data::Dumper::Concise;

require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(

		serialize
		assign
		assign_singletons
		store_vars
		json_out
		yaml_in
		json_in
		json_out
		quote_yaml_scalars
		var_map
        config_vars
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = ();

our $to_json = JSON::XS->new->utf8->allow_blessed->pretty->canonical(1) ;
use Carp;

{my $var_map = { qw(

	%devices 						$config->{devices}
	$alsa_playback_device 			$config->{alsa_playback_device}
	$alsa_capture_device			$config->{alsa_capture_device}
	$soundcard_channels				$config->{soundcard_channels}
	%abbreviations					$config->{abbreviations}
	$mix_to_disk_format 			$config->{mix_to_disk_format}
	$raw_to_disk_format 			$config->{raw_to_disk_format}
	$cache_to_disk_format 			$config->{cache_to_disk_format}
	$mixer_out_format 				$config->{mixer_out_format}
	$sample_rate					$config->{sample_rate}
	$ecasound_tcp_port 				$config->{engine_tcp_port}
	$ecasound_globals				$config->{engine_globals}
	$ecasound_buffersize 			$config->{engine_buffersize}
	$realtime_profile 				$config->{realtime_profile}
	$eq 							$mastering->{fx_eq}
	$low_pass 						$mastering->{fx_low_pass}
	$mid_pass						$mastering->{fx_mid_pass}
	$high_pass						$mastering->{fx_high_pass}
	$compressor						$mastering->{fx_compressor}
	$spatialiser					$mastering->{fx_spatialiser}
	$limiter						$mastering->{fx_limiter}
	$project_root 	 				$config->{root_dir}
	$use_group_numbering 			$config->{use_group_numbering}
	$press_space_to_start_transport $config->{press_space_to_start}
	$execute_on_project_load 		$config->{execute_on_project_load}
	$initial_mode 					$config->{initial_mode}
	$midish_enable 					$config->{use_midish}
	$quietly_remove_tracks 			$config->{quietly_remove_tracks}
	$use_jack_plumbing 				$config->{use_jack_plumbing}
	$jack_seek_delay    			$config->{engine_base_jack_seek_delay}
	$use_monitor_version_for_mixdown $config->{sync_mixdown_and_monitor_version_numbers}
	$mixdown_encodings 				$config->{mixdown_encodings}
	$volume_control_operator 		$config->{volume_control_operator}
	$serialize_formats  	        $config->{serialize_formats}
	$use_git						$config->{use_git}
	$autosave						$config->{autosave}
	$beep_command 					$config->{beep_command}
	$hotkey_beep					$config->{hotkey_beep}
	$eager							$mode->{eager}
	$alias							$config->{alias}
	$hotkeys						$config->{hotkeys}
	$new_track_rw					$config->{new_track_rw}
	$hotkeys_always					$config->{hotkeys_always}
	$use_pager     					$config->{use_pager}
	$use_placeholders  				$config->{use_placeholders}
    $edit_playback_end_margin  		$config->{edit_playback_end_margin}
    $edit_crossfade_time  			$config->{edit_crossfade_time}
	$default_fade_length 			$config->{engine_fade_default_length}
	$fade_time 						$config->{engine_fade_length_on_start_stop}
	%mute_level						$config->{mute_level}
	%fade_out_level 				$config->{fade_out_level}
	$fade_resolution 				$config->{fade_resolution}
	%unity_level					$config->{unity_level}
	$enforce_channel_bounds    		$config->{enforce_channel_bounds}
	$midi_input_dev    				$midi->{input_dev}
	$midi_output_dev   				$midi->{output_dev}
	$controller_ports				$midi->{controller_ports}
    $midi_inputs					$midi->{inputs}
	$osc_listener_port 				$config->{osc_listener_port}
	$osc_reply_port 				$config->{osc_reply_port}
	$remote_control_port 			$config->{remote_control_port}
	$engines						$config->{engines}

) };
sub var_map {  $var_map } # to allow outside access while keeping
                          # working lexical
sub config_vars { grep {$_ ne '**' } keys %$var_map }

sub assign {
  # Usage:
  # assign (
  # data 	=> $ref,
  # vars 	=> \@vars,
  # var_map => 1,
  #	class => $class
  #	);

	logsub("&assign");

	my %h = @_; # parameters appear in %h
	my $class;
	logpkg(__FILE__,__LINE__,'logcarp',"didn't expect scalar here") if ref $h{data} eq 'SCALAR';
	logpkg(__FILE__,__LINE__,'logcarp',"didn't expect code here") if ref $h{data} eq 'CODE';
	# print "data: $h{data}, ", ref $h{data}, $/;

	if ( ref $h{data} !~ /^(HASH|ARRAY|CODE|GLOB|HANDLE|FORMAT)$/){
		# we guess object
		$class = ref $h{data};
		logpkg(__FILE__,__LINE__,'debug',"I found an object of class $class");
	}
	$class = $h{class};
 	$class .= "::" unless $class =~ /::$/;  # SKIP_PREPROC
	my @vars = @{ $h{vars} };
	my $ref = $h{data};
	my $type = ref $ref;
	logpkg(__FILE__,__LINE__,'debug',<
	data type: $type
	data: $ref
	class: $class
	vars: @vars
ASSIGN
	#logpkg(__FILE__,__LINE__,'debug',sub{json_out($ref)});

	# index what sigil an identifier should get

	# we need to create search-and-replace strings
	# sigil-less old_identifier
	my %sigil;
	my %ident;
	map {
		my $oldvar = my $var = $_;
		my ($dummy, $old_identifier) = /^([\$\%\@])([\-\>\w:\[\]{}]+)$/;
		$var = $var_map->{$var} if $h{var_map} and $var_map->{$var};

		logpkg(__FILE__,__LINE__,'debug',"oldvar: $oldvar, newvar: $var") unless $oldvar eq $var;
		my ($sigil, $identifier) = $var =~ /([\$\%\@])(\S+)/;
			$sigil{$old_identifier} = $sigil;
			$ident{$old_identifier} = $identifier;
	} @vars;

	logpkg(__FILE__,__LINE__,'debug',sub{"SIGIL\n". json_out(\%sigil)});
	#%ident = map{ @$_ } grep{ $_->[0] ne $_->[1] } map{ [$_, $ident{$_}]  }  keys %ident;
	my %ident2 = %ident;
	while ( my ($k,$v) = each %ident2)
	{
		delete $ident2{$k} if $k eq $v
	}
	logpkg(__FILE__,__LINE__,'debug',sub{"IDENT\n". json_out(\%ident2)});

	#print join " ", "Variables:\n", @vars, $/ ;
	croak "expected hash" if ref $ref !~ /HASH/;
	my @keys =  keys %{ $ref }; # identifiers, *no* sigils
	logpkg(__FILE__,__LINE__,'debug',sub{ join " ","found keys: ", keys %{ $ref },"\n---\n"});
	map{
		my $eval;
		my $key = $_;
		chomp $key;
		my $sigil = $sigil{$key};
		my $full_class_path =
 			$sigil . ($key =~/:\:/ ? '': $class) .  $ident{$key};

			# use the supplied class unless the variable name
			# contains \:\:

		logpkg(__FILE__,__LINE__,'debug',<
key:             $key
sigil:      $sigil
full_class_path: $full_class_path
DEBUG
		if ( ! $sigil ){
			logpkg(__FILE__,__LINE__,'debug',sub{
			"didn't find a match for $key in ", join " ", @vars, $/;
			});
		}
		else
		{

			$eval .= $full_class_path;
			$eval .= q( = );

			my $val = $ref->{$key};

			if (! ref $val or ref $val eq 'SCALAR')  # scalar assignment
			{

				# extract value

				if ($val) { #  if we have something,

					# dereference it if needed

					ref $val eq q(SCALAR) and $val = $$val;

					# quoting for non-numerical

					$val = qq("$val") unless  $val =~ /^[\d\.,+\-e]+$/

				} else { $val = q(undef) }; # or set as undefined

				$eval .=  $val;  # append to assignment

			}
			elsif ( ref $val eq 'ARRAY' or ref $val eq 'HASH')
			{
				if ($sigil eq '$')	# assign reference
				{
					$eval .= q($val) ;
				}
				else				# dereference and assign
				{
					$eval .= qq($sigil) ;
					$eval .= q({$val}) ;
				}
			}
			else { die "unsupported assignment: ".ref $val }
			logpkg(__FILE__,__LINE__,'debug',"eval string: $eval");
			eval($eval);
			logpkg(__FILE__,__LINE__,'logcarp',"failed to eval $eval: $@") if $@;
		}  # end if sigil{key}
	} @keys;
	1;
}
}

# assign_singletons() assigns hash key/value entries
# rather than a top-level hash reference to avoid
# clobbering singleton key/value pairs initialized
# elsewhere.

my @singleton_idents = map{ /^.(.+)/; $1 }  # remove leading '$' sigil
qw(
$ui
$mode
$file
$graph
$setup
$config
$jack
$fx
$fx_cache
$text
$gui
$midi
$help
$mastering
$project

);
sub assign_singletons {
	logsub('&assign_singletons');
	my $ref = shift;
	my $data = $ref->{data} or die "expected data got undefined";
	my $class = $ref->{class} // 'Audio::Nama';
	$class .= '::'; # SKIP_PREPROC
	map {
		my $ident = $_;
		if( defined $data->{$ident}){
			my $type = ref $data->{$ident};
			$type eq 'HASH' or die "$ident: expect hash, got $type";
			map{
				my $key = $_;
				my $cmd = join '',
					'$',
					$class,
					$ident,
					'->{',
					$key,
					'}',
					' = $data->{$ident}->{$key}';
				logpkg(__FILE__,__LINE__,'debug',"eval: $cmd");
				eval $cmd;
				logpkg(__FILE__,__LINE__,'logcarp',"error during eval: $@") if $@;
			} keys %{ $data->{$ident} }
		}
	} @singleton_idents;  # list of "singleton" variables
}

our %suffix =
	(
		storable => "bin",
		perl	 => "pl",
		json	 => "json",
		yaml	 => "yml",
	);
our %dispatch =
	( storable => sub { my($ref, $path) = @_; nstore($ref, $path) },
	  perl     => sub { my($ref, $path) = @_; write_file($path, Dumper $ref) },
	  yaml	   => sub { my($ref, $path) = @_; write_file($path, json_out($ref))},
	  json	   => sub { my($ref, $path) = @_; write_file($path, json_out($ref))},
	);

sub serialize_and_write {
	my ($ref, $path, $format) = @_;
	$path .= ".$suffix{$format}" unless $path =~ /\.$suffix{$format}$/;
	$dispatch{$format}->($ref, $path)
}


{
	my $parse_re =  		# initialize only once
			qr/ ^ 			# beginning anchor
			([\%\@\$]) 		# first character, sigil
			([\w:]+)		# identifier, possibly perl namespace
			(?:->\{(\w+)})?  # optional hash key for new hash-singleton vars
			$ 				# end anchor
			/x;
sub serialize {
	logsub("&serialize");

	my %h = @_;
	my @vars = @{ $h{vars} };
	my $class = $h{class};
	my $file  = $h{file};
	my $format = $h{format} // 'perl'; # default to Data::Dumper::Concise

 	$class //= "Audio::Nama";
	$class =~ /::$/ or $class .= '::'; # SKIP_PREPROC
	logpkg(__FILE__,__LINE__,'debug',"file: $file, class: $class\nvariables...@vars");

	# first we marshall data into %state

	my %state;

	map{
		my ($sigil, $identifier, $key) = /$parse_re/;

	logpkg(__FILE__,__LINE__,'debug',"found sigil: $sigil, ident: $identifier, key: $key");

# note: for  YAML::Reader/Writer  all scalars must contain values, not references
# more YAML adjustments
# restore will break if a null field is not converted to '~'

		#my $value =  q(\\)

# directly assign scalar, but take hash/array references
# $state{ident} = $scalar
# $state{ident} = \%hash
# $state{ident} = \@array

# in case $key is provided
# $state{ident}->{$key} = $singleton->{$key};
#


		my $value =  ($sigil ne q($) ? q(\\) : q() )

							. $sigil
							. ($identifier =~ /:/ ? '' : $class)
							. $identifier
							. ($key ? qq(->{$key}) : q());

		logpkg(__FILE__,__LINE__,'debug',"value: $value");


		 my $eval_string =  q($state{')
							. $identifier
							. q('})
							. ($key ? qq(->{$key}) : q() )
							. q( = )
							. $value;

		if ($identifier){
			logpkg(__FILE__,__LINE__,'debug',"attempting to eval $eval_string");
			eval($eval_string);
			logpkg(__FILE__,__LINE__,'error', "eval failed ($@)") if $@;
		}
	} @vars;
	logpkg(__FILE__,__LINE__,'debug',sub{join $/,'\%state', Dumper \%state});

	# YAML out for screen dumps
	return( json_out(\%state) ) unless $h{file};

	# now we serialize %state

	my $path = $h{file};

	serialize_and_write(\%state, $path, $format);
}
}

sub json_out {
	logsub("&json_out");
	my $data_ref = shift;
	my $type = ref $data_ref;
	croak "attempting to code wrong data type: $type"
		if $type !~ /HASH|ARRAY/;
	$to_json->encode($data_ref);
}

sub json_in {
	logsub("&json_in");
	my $json = shift;
	my $data_ref = decode_json($json);
	$data_ref
}

sub yaml_in {

	# logsub("&yaml_in");
	my $input = shift;
	my $yaml = $input =~ /\n/ # check whether file or text
		? $input 			# yaml text
		: do
			{
				logpkg(__FILE__,__LINE__,'debug',"filename: $input");
				read_file($input);	# file name
			};
	if ($yaml =~ /\t/){
		croak "YAML file: $input contains illegal TAB character.";
	}
	$yaml =~ s/^\n+//  ; # remove leading newline at start of file
	$yaml =~ s/\n*$/\n/; # make sure file ends with newline
	my $y = YAML::Tiny->read_string($yaml);
	Audio::Nama::throw("YAML::Tiny read error: $YAML::Tiny::errstr\n") if $YAML::Tiny::errstr;
	$y->[0];
}

sub quote_yaml_scalars {
	my $yaml = shift;
	my @modified;
	map
		{
		chomp;
		if( /^(?(\s*\w+: )|(\s+- ))(?.+)$/ ){
			my($beg,$end) = ($+{beg}, $+{end});
			# quote if contains colon and not quoted
			if ($end =~ /:\s/ and $end !~ /^('|")/ ){
				$end =~ s(')(\\')g; # escape existing single quotes
				$end = qq('$end') } # single-quote string
			push @modified, "$beg$end\n";
		}
		else { push @modified, "$_\n" }
	} split "\n", $yaml;
	join "", @modified;
}


1;