nama 1.078-2 / usr / share / perl5 / Audio / Nama / Assign.pm

package Audio::Nama::Assign;
our $VERSION = 1.0;
use 5.008;
use strict;
use warnings;
no warnings q(uninitialized);
use Carp;
use YAML::Tiny;
use File::Slurp;
use File::HomeDir;
use Storable qw(nstore retrieve);
#use Devel::Cycle;

require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(
		
		serialize
		assign
		assign_vars
		store_vars
		yaml_out
		yaml_in
		create_dir
		join_path
		wav_off
		strip_all
		strip_blank_lines
		strip_comments
		remove_spaces
		expand_tilde
		resolve_path
		quote_yaml_scalars
) ] );

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

our @EXPORT = ();


package Audio::Nama;
our ($debug, $debug2, $debug3);
package Audio::Nama::Assign;

use Carp;

sub assign {
	
	$debug2 and print "&assign\n";
	
	my %h = @_; # parameters appear in %h
	my $class;
	carp "didn't expect scalar here" if ref $h{data} eq 'SCALAR';
	carp "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}; 
		$debug and print "I found an object of class $class...\n";
	} 
	$class = $h{class};
 	$class .= "::" unless $class =~ /::$/;  # SKIP_PREPROC
	my @vars = @{ $h{vars} };
	my $ref = $h{data};
	my $type = ref $ref;
	$debug and print <<ASSIGN;
	data type: $type
	data: $ref
	class: $class
	vars: @vars
ASSIGN
	#$debug and print yaml_out($ref);

	my %sigil;
	map{ 
		my ($s, $identifier) = /(.)([\w:]+)/;
		$sigil{$identifier} = $s;
	} @vars;
	#print yaml_out(\%sigil); exit;
	#print join " ", "Variables:\n", @vars, $/ ;
	croak "expected hash" if ref $ref !~ /HASH/;
	my @keys =  keys %{ $ref };
	$debug and print join " ","found keys: ", keys %{ $ref },"\n---\n";
	map{  
		my $eval;
		my $key = $_;
		chomp $key;
		my $full_class_path = 
			$sigil{$key} . ($key =~/:\:/ ? '': $class) . $key;

			# use the supplied class unless the variable name
			# contains \:\:
			
# 		$debug and print <<DEBUG;
# key:             $key
# full_class_path: $full_class_path
# sigil{key}:      $sigil{$key}
# DEBUG
		if ( ! $sigil{$key} ){
			$debug and carp 
			"didn't find a match for $key in ", join " ", @vars, $/;
		} else {
			my ($sigil, $identifier) = ($sigil{$key}, $key);
			$eval .= $full_class_path;
			$eval .= q( = );

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

			if ($sigil eq '$') { # 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

			} else { # array, hash assignment
					

				$eval .= qq($sigil\{);
				$eval .= q($ref->{ );
				$eval .= qq("$identifier");
				$eval .= q( } );
				$eval .= q( } );
			}
			$debug and print $eval, $/; 
			eval($eval);
			$debug and $@ and carp "failed to eval $eval: $@\n";
		}  # end if sigil{key}
	} @keys;
	1;
}

sub assign_vars {
	$debug2 and print "&assign_vars\n";
	
	my %h = @_;
	my $source = $h{source};
	my @vars = @{ $h{vars} };
	my $class = $h{class};
	my $format = $h{format};
	# assigns vars in @var_list to values from $source
	# $source can be a :
	#      - filename or
	#      - string containing YAML data
	#      - reference to a hash array containing assignments
	#
	# returns a $ref containing the retrieved data structure
	$debug and print "source: ", (ref $source) || $source, "\n";
	$debug and print "variable list: @vars\n";
	my $ref;

### figure out what to do with input

	if ($source !~ /\n/ and -f $source){
		if ( $source =~ /\.yml$/i or $format eq 'yaml'){
				$debug and print "found a yaml file: $source\n";
				$ref = yaml_in($source);
		} elsif ( $source =~ /\.pl$/i or $format eq 'perl'){
				$debug and print "found a perl file: $source\n";
				my $code = read_file($source);
				$ref = eval $code or carp "$source: eval failed: $@\n";
		} else {
				$debug and print "assuming Storable file: $source\n";
				$ref = retrieve($source) # Storable
		}

	} elsif ( $source =~ /\n/ ){
		$debug and print "found yaml text\n";
		$ref = yaml_in($source);

	# pass a hash_ref to the assigner
	} elsif ( ref $source ) {
		$debug and print "found a reference\n";
		$ref = $source;
	} else { carp "$source: missing data source\n"; }

	assign(data => $ref, 
			vars => \@vars, 
			class => $class);
	1;	

}

sub serialize {
	$debug2 and print "&serialize\n";
	my %h = @_;
	my @vars = @{ $h{vars} };
	my $class = $h{class};
	my $file  = $h{file};
	my $format = $h{format};
 	$class .= "::" unless $class =~ /::$/; # SKIP_PREPROC
	$debug and print "file: $file, class: $class\nvariables...@vars\n";
	my %state;
	map{ my ($sigil, $identifier) = /(.)([\w:]+)/; 



# for  YAML::Reader/Writer
#
#  all scalars must contain values, not references

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

							. $sigil
							. ($identifier =~ /:/ ? '' : $class)
							. $identifier;

# more YAML adjustments 
#
# restore will break if a null field is not converted to '~'
			
		 my $eval_string =  q($state{')
							. $identifier
							. q('})
							. q( = )
							. $value;
	$debug and print "attempting to eval $eval_string\n";
	eval($eval_string) or $debug  and print 
		"eval returned zero or failed ($@\n)";
	} @vars;
	# my $result1 = store \%state, $file; # old method
	if ( $h{file} ) {

		if ($h{format} eq 'storable') {
			my $result1 = nstore \%state, $file; # old method
		} elsif ($h{format} eq 'perl'){
			$file .= '.pl' unless $file =~ /\.pl$/;
			#my $pl = dump \%state;
			#write_file($file, $pl);
		} elsif ($h{format} eq 'yaml'){
			$file .= '.yml' unless $file =~ /\.yml$/;
			#find_cycle(\%state);
			my $yaml = yaml_out(\%state);
			write_file($file, $yaml);
			$debug and print $yaml;
		}
	} else { yaml_out(\%state) }

}

sub yaml_out {
	
	$debug2 and carp "&yaml_out";
	my ($data_ref) = shift; 
	my $type = ref $data_ref;
	$debug and print "data ref type: $type\n "; 
	carp "can't yaml-out a Scalar!!\n" if ref $data_ref eq 'SCALAR';
	croak "attempting to code wrong data type: $type"
		if $type !~ /HASH|ARRAY/;
	my $output;
	#$debug and print join $/, keys %$data_ref, $/;
	$debug and print "about to write YAML as string\n";
	my $y = YAML::Tiny->new;
	$y->[0] = $data_ref;
	my $yaml = $y->write_string() . "...\n";
}
sub yaml_in {
	
	# $debug2 and print "&yaml_in\n";
	my $input = shift;
	my $yaml = $input =~ /\n/ # check whether file or text
		? $input 			# yaml text
		: 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);
	print "YAML::Tiny read error: $YAML::Tiny::errstr\n" if $YAML::Tiny::errstr;
	$y->[0];
}

## support functions

sub create_dir {
	my @dirs = @_;
	map{ my $dir = $_;
	$debug and print "creating [ $dir ]\n";
		-e $dir 
#and (carp "create_dir: '$dir' already exists, skipping...\n") 
			or system qq( mkdir -p $dir)
		} @dirs;
}

sub join_path {
	
	my @parts = @_;
	my $path = join '/', @parts;
	$path =~ s(/{2,})(/)g;
	#$debug and print "path: $path\n";
	$path;
}

sub wav_off {
	my $wav = shift;
	$wav =~ s/\.wav\s*$//i;
	$wav;
}

sub strip_all{ strip_trailing_spaces(strip_blank_lines( strip_comments(@_))) }

sub strip_trailing_spaces {
	map {s/\s+$//} @_;
	@_;
}
sub strip_blank_lines {
	map{ s/\n(\s*\n)+/\n/sg } @_;
	map{ s/^\n+//s } @_;
	@_;
	 
}

sub strip_comments { #  
	map{ s/#.*$//mg; } @_;
	map{ s/\s+$//mg; } @_;

	@_
} 

sub remove_spaces {                                                             
        my $entry = shift;                                                      
        # remove leading and trailing spaces                                    
                                                                                
        $entry =~ s/^\s*//;                                                     
        $entry =~ s/\s*$//;                                                     
                                                                                
        # convert other spaces to underscores                                   
                                                                                
        $entry =~ s/\s+/_/g;                                                    
        $entry;                                                                 
}                                                                               
sub resolve_path {
	my $path = shift;
	$path = expand_tilde($path);
	$path = File::Spec::Link->resolve_all($path);
}
sub expand_tilde { 
	my $path = shift; 

 	my $home = File::HomeDir->my_home;


	# ~bob -> /home/bob
	$path =~ s(
		^ 		# beginning of line
		~ 		# tilde
		(\w+) 	# username
	)
	(File::HomeDir->users_home($1))ex;

	# ~/something -> /home/bob/something
	$path =~ s( 
		^		# beginning of line
		~		# tilde
		/		# slash
	)
	($home/)x;
	$path
}
sub quote_yaml_scalars {
	my $yaml = shift;
	my @modified;
	map
		{  
		chomp;
		if( /^(?<beg>(\s*\w+: )|(\s+- ))(?<end>.+)$/ ){
			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;