File Coverage

blib/lib/Constant/Generate.pm

Criterion	Covered	Total	%
statement	147	156	94.2
branch	43	54	79.6
condition	22	25	88.0
subroutine	28	29	96.5
pod	0	1	0.0
total	240	265	90.5

package Constant::Generate;
use strict;
use warnings;
our $VERSION  = '0.17';

use Data::Dumper;
use Carp qw(confess);
use Constant::Generate::Dualvar;
use Scalar::Util qw(looks_like_number);

#these two functions produce reverse mapping, one for simple constants, and
#one for bitfields

use constant {
	CONST_BITFLAG 	=> 1,
	CONST_SIMPLE	=> 2,
	CONST_STRING	=> 3
};

sub _gen_bitfield_fn {
	no strict "refs";
	my ($name,$rhash) = @_;
	*{$name} = sub($) {
		my $flag = $_[0];
		join("|",
			 @{$rhash}{(
				grep($flag & $_, keys %$rhash)
			 )}
		);
	};
}

sub _gen_int_fn {
	no strict 'refs';
	my ($name,$rhash) = @_;
	*{$name} = sub ($) { $rhash->{$_[0] + 0} || "" };
}

sub _gen_str_fn {
	no strict 'refs';
	my ($name,$rhash) = @_;
	*{$name} = sub ($) { $rhash->{ $_[0] } || "" };
}


sub _gen_integer_syms {
	my ($uarr, $symhash, $start) = @_;
	foreach my $sym (@$uarr) {
		$symhash->{$sym} = $start;
		$start++;
	}
}

sub _gen_bitflag_syms {
	my ($uarr,$symhash,$start) = @_;
	foreach my $sym (@$uarr) {
		$symhash->{$sym} = 1 << $start;
		$start++;
	}
}

sub _gen_string_syms {
	my ($uarr,$symhash,$prefix) = @_;
	foreach my $sym (@$uarr) {
		$symhash->{$sym} = $sym;
	}
}

sub _gen_constant {
	my ($pkg,$name,@values) = @_;
	no strict 'refs';
	my $fqname = $pkg . "::$name";
	if(@values == 1) {
        my $value = $values[0];
		*{$fqname} = sub () { $value };
	} else {
		*{$fqname} = sub () { @values };
	}
}

sub _gen_map_rhash {
	my ($symhash, $prefix, $display_prefix) = @_;
	my (%maphash,%rhash);
	if($prefix && $display_prefix) {
		while (my ($sym,$val) = each %$symhash) {
			$maphash{$prefix.$sym} = $val;
		}
	} else {
		%maphash = %$symhash;
	}

	#Check for duplicate constants pointing to the same value
	while (my ($sym,$val) = each %maphash) {
		push @{$rhash{$val}}, $sym;
	}
	while (my ($val,$syms) = each %rhash) {
		if(@$syms > 1) {
			$rhash{$val} = sprintf("(%s)", join(",", @$syms));
		} else {
			$rhash{$val} = $syms->[0];
		}
	}
	return \%rhash;
}

sub _mangle_exporter {
	my ($pkg, $symlist, $tag,
		$uspec_export, $uspec_export_ok, $uspec_export_tags) = @_;

	my @emap = (
		[$uspec_export, \my $my_export, 'EXPORT', 'ARRAY'],
		[$uspec_export_ok, \my $my_export_ok, 'EXPORT_OK', 'ARRAY'],
		[$uspec_export_tags, \my $my_export_tags, 'EXPORT_TAGS', 'HASH', \$tag]
	);

	foreach (@emap) {
		my ($uspec,$myspec,$pvar,$vtype,$depvar) = @$_;
		if(!$uspec) {
			next;
		}
		if (defined $depvar && !$$depvar) {
			next;
		}
		if(ref $uspec) {
			$$myspec = $uspec;
		} else {
			no strict 'refs';
			if(!defined ($$myspec = *{$pkg."::$pvar"}{$vtype})) {
				confess "Requested mangling of $pvar, but $pvar not yet declared!";
			}
		}
	}

	if($uspec_export_ok) {
		push @$my_export_ok, @$symlist;
	}
	if($uspec_export) {
		push @$my_export, @$symlist;
	}
	if($uspec_export_tags) {
		$my_export_tags->{$tag} = [ @$symlist ];
	}
	#Verify the required variables
}

my $FN_CONST_TBL = {
	CONST_BITFLAG, \&_gen_bitflag_syms,
	CONST_SIMPLE, \&_gen_integer_syms,
	CONST_STRING, \&_gen_string_syms
};

my $FN_RMAP_TBL = {
	CONST_BITFLAG, \&_gen_bitfield_fn,
	CONST_SIMPLE, \&_gen_int_fn,
	CONST_STRING, \&_gen_str_fn,
};

sub utype2const {
	my $utype = shift;
	if(!$utype || $utype =~ /int/i) {
		return CONST_SIMPLE;
	} elsif ($utype =~ /bit/i) {
		return CONST_BITFLAG;
	} elsif ($utype =~ /str/i) {
		return CONST_STRING;
	} else {
		die "Unrecognized type '$utype'";
	}
}

sub _getopt(\%$) {
	my ($h,$opt) = @_;
	foreach ($opt,"-$opt") { return delete $h->{$_} if exists $h->{$_} }
}

sub import {
	my ($cls,$symspecs,%opts) = @_;
	return 1 unless $symspecs;

	my $reqpkg = caller();
	my $type = utype2const(_getopt(%opts, "type"));

	#Determine our tag for %EXPORT_TAGS and reverse mapping

	my $mapname 		= _getopt(%opts, "mapname");
	my $export_tag 		= _getopt(%opts, "tag");
	my $prefix			= _getopt(%opts, "prefix") || "";
	my $display_prefix 	= _getopt(%opts, "show_prefix");
	my $start 			= _getopt(%opts, "start_at") || 0;
	my $stringy			= _getopt(%opts, "stringy_vars")
						|| _getopt(%opts, "dualvar");

	my $listname		= _getopt(%opts, "allvalues");
	my $symsname		= _getopt(%opts, "allsyms");

	if((!$mapname) && $export_tag) {
		$mapname = $export_tag . "_to_str";
	}

	#Generate the values.
	my %symhash;
	#Initial value

	ref $symspecs eq 'HASH' ? %symhash = %$symspecs :
		$FN_CONST_TBL->{$type}->($symspecs, \%symhash, $start);

	#tie it all together

	while (my ($symname,$symval) = each %symhash) {
		if($stringy && looks_like_number($symval)) {

			my $dv_name = $display_prefix ? $prefix . $symname : $symname;

			$symval = Constant::Generate::Dualvar::CG_dualvar(
				$symval, $dv_name);
		}
		_gen_constant($reqpkg, $prefix.$symname, $symval);
	}

	#After we have determined values for all the symbols, we can establish our
	#reverse mappings, if so requested
	if($mapname) {
		my $rhash = _gen_map_rhash(\%symhash, $prefix, $display_prefix);
		$FN_RMAP_TBL->{$type}->($reqpkg."::$mapname", $rhash);
	}

	if($prefix) {
		foreach my $usym (keys %symhash) {
			my $v = delete $symhash{$usym};
			$symhash{$prefix.$usym} = $v;
		}
	}

	my $auto_export = _getopt(%opts, "export");
	my $auto_export_ok = _getopt(%opts, "export_ok");
	my $h_etags = _getopt(%opts, "export_tags");

	my @symlist = keys %symhash;

	if($listname) {
		my %tmp = reverse %symhash;
		_gen_constant($reqpkg, $listname, keys %tmp);
		push @symlist, $listname;
	}
	if($symsname) {
		_gen_constant($reqpkg, $symsname, keys %symhash);
		push @symlist, $symsname;
	}

	push @symlist, $mapname if $mapname;
	_mangle_exporter($reqpkg, \@symlist,
					 $export_tag,
					 $auto_export, $auto_export_ok, $h_etags || $export_tag);

	if(%opts) {
		die "Unknown keys " . join(",", keys %opts);
	}
}

__END__