view release on metacpan or  search on metacpan

lib/Params/Clean.pm  view on Meta::CPAN

	our (@keywords, @KEYWORDS);					                                    	# We need to declare these and then init them with BEGIN so they're ready for the "use UID"
	BEGIN { our @keywords=qw/POSN NAME FLAG REST TYPE PARSE/; }	                       	# UID keywords
	BEGIN { our @KEYWORDS=(@keywords, "LIST", "args"); }		                       	# all keywords (LIST handled specially)
	
	use UID @keywords;			# Set up some lexicals that won't be available anywhere else, so exporting refs to them will act as unique identifiers
	
	our %Warn;																			# categories of warning levels by caller: e.g. $Warn{main}{missing_start}=fatal
	BEGIN {
		$Warn{undef}={			               	# default warning levels
					invalid_opts=>"warn", 		# illegal warning or keyword options used
					funny_arglist=>"ignore",	# asked to PARSE something that's not an ARRAY, HASH, or CODE
					missing_start=>"ignore", 	# LIST cannot find specified starting key
					missing_end=>"warn", 		# LIST cannot find specified ending key
					invalid_list=>"warn", 		# tried to use a FLAG or LIST, etc, as endpoint to a LIST
					invalid_type=>"warn", 		# tried to use an illegal TYPE definition
					nonint_name=>"warn",  		# non-integral key will be used as a name
					orphaned_type=>"warn", 		# TYPE not followed by a definition
					misplaced_rest=>"warn", 	# REST used before last parameter
					misplaced_parse=>"die", 	# PARSE used after first parameter
					 };
		}
	# now create constants with all our exception-type names (handy, and helps catch typos!)	
	BEGIN { no strict 'refs'; for my $s (keys %{$Warn{undef}}) {*{$s}=sub {return $s, @_ if wantarray; warn "ERROR: attempt to use args after '$s' which is in scalar context (perhaps you need a comma after '$s'?)" if @_; return $s};} }	# stolen from UID...
	
	
	our $CaseSensitive=0;																# By default, we match match names case-insensitively
	our $Debug=0;																		# Whether to show debugging messages (0 level=none)
	sub same($$);	sub insame($@);	sub typewriter($$); sub warning;					# predeclare!
	sub un {grep !$_[$_], 0..@_-1;}														# pull out all the keys that work out to false (used with @used!)
	sub array { map ref($_) eq "ARRAY"?@$_:$_, (@_) }									# Normalise a list by expanding array-refs
	sub comma { "[".join(", ", array @_)."]" } 											# Format array(ref) into "[a, b, c]"
	
	sub debug 
	# For showing debugging messages
	#	Does some basic cleanup, like unpacking array-refs, or looking up our UIDs
	#	Pass each thing you want cleaned as a separate arg
	{ 
		return unless $Debug>=shift;													# do nothing unless our debugging level is high enough
		my $i; my %ID=reverse(POSN=>POSN, FLAG=>FLAG, NAME=>NAME, TYPE=>TYPE, REST=>REST);		# lookup hash for our special IDs
		warn join " ", map $ID{$_}?"|$ID{$_}|":ref eq"ARRAY"?"[".(join " ", map $ID{$_}?"|$ID{$_}|":$_, (@$_))."]":ref eq "HASH"?"{".(join "", map {$i++%2?"$_; ":"$_=>"} %$_)."}":"$_", (@_), "\n"
	}
	
	

	#===========================================================================
	#
	# 	STARTUP
	#
	#===========================================================================
	
	sub import
	# Handle module options: renaming exported UIDs and setting desired warnings
	#
	# RENAMING: pass a keyword ID followed by the new name (LIST=>"PLIST") -- setting to undef means don't export it at all
	# WARNINGS: warn=>"type", or die=>"type" or fatal=>"type", or ignore=>"type"
	{
		my $me=shift; 							# our package name
		my @opts, my $i; push @opts, [$_[$i++]=>$_[$i++]] while $i<@_;	# pair up the options (we would use a hash, but we want to preserve order, and anyway we could have the same key repeated)
		my %EXPORT=map {$_=>$_} @KEYWORDS;		# keywords to be exported (normally all @KEYWORDS) in convenient hash format
		my $keys=join "|", @KEYWORDS;			# for regex to test for any of our keywords
		my $caller=(caller)[0];					# caller's package
		
		
		# Set up warning/fatal/ignoral categories
		$Warn{$caller}={%{$Warn{undef}}};					      		# start by setting up default warning levels
		for (grep $opts[$_][0]=~/^(warn|die|fatal|ignore)$/, 0..$#opts)	# grep through the key-halves of each opt for exception-levels
		{
			my $opt=delete $opts[$_];
			warning(invalid_opts qq[WARNING: Ignoring attempt to set unrecogised warning category "$opt->[1]"]) and next unless exists $Warn{$caller}{$opt->[1]};	# complain if trying to set an invalid category
			$Warn{$caller}{$opt->[1]}=$opt->[0];		# set level for this caller and remove opts as we handle them
		}
		
		
		# Look for our keywords: pairs that start with a keyword substitute the new name instead
		$EXPORT{$opts[$_][0]}=$opts[$_][1] and delete $opts[$_] for grep $opts[$_][0]=~/^($keys)$/, grep exists $opts[$_], 0..$#opts; # look for our keywords and remove opts as we deal with them
		no strict 'refs';		                                                        # so we can manually "export" the subs to the caller's namespace
		*{$caller."::".$EXPORT{$_}}=\&{$_} for grep defined $EXPORT{$_}, keys %EXPORT;	# skipping undefs
		
		
		# If there are any opts left, we don't know what to do with them
		warning invalid_opts "WARNING: Ignoring unrecognised options [".join(", ", map "$opts[$_][0]=>$opts[$_][1]", grep exists $opts[$_], 0..$#opts)."]" if @opts;
	}
	
	
	
	#===========================================================================
	#
	# 	LISTs
	#
	#===========================================================================
	
	# "LIST" types are objects containing the pieces we need to handle lists
	#	{
	#	  spec => what kind of list this is: <abs>olute or <rel>ative, 
	#	  start => the param key(s) which begin the list, 
	#	  end => the param(s) which end an absolute list, 
	#	  pos => the list of positions to grab for a relative list,
	#	  incl => a flag indicating whether to include the starting/ending param
	#	}
	#
	#	A few operators are overloaded to provide convenient syntax for building up our LIST objects
	#	Since assignment isn't overloadable, we also tie our object so we can STORE it ourselves
	
	sub LIST ($) :lvalue { tie my $list, __PACKAGE__, @_; $list }								# takes a single arg and turns it into a tied List-object
	sub TIESCALAR { my $class=shift; bless {spec=>"abs", start=>[array @_]}, $class }			# object is a hash containing the setup; all we know upon creation is the starting-point; assume absolute [can override that later if we specify more details]
	sub FETCH { shift; };	                                                                	# nothing fancy here, just return the object straight
	
	use overload '<=>',sub { @{$_[0]}{spec=>end=>incl=>}=("abs", [array $_[1]], 1); shift };	# absolute list, include end point
	use overload '<=', sub { @{$_[0]}{spec=>end=>incl=>}=("abs", [array $_[1]], 0); shift };	# absolute list, don't include end point
	
	sub STORE($)          { @{$_[0]}{spec=>pos=>incl=>}=("rel", [array $_[1]], "?"); }			# "overload =": relative, don't force starting point either way
	use overload '&', sub { @{$_[0]}{spec=>pos=>incl=>}=("rel", [array $_[1]], "Y"); shift };	# relative list, include start point
	use overload '^', sub { @{$_[0]}{spec=>pos=>incl=>}=("rel", [array $_[1]], "N"); shift };	# relative list, don't include start point
	
	use overload q(""), sub { "{". (join ", ", map "$_=>".(join ":", array($_[0]->{$_})), (qw/spec start end pos incl/) )."}" };	#stringify for debug messages
###check for attempting to use operators more than once in a row? or to use other operators?!?	
	


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