Source AN::Tools::String

AN!Tools :: AN::Tools :: Source AN::Tools::String

String.pm

package AN::Tools::String;
 
use strict;
use warnings;
 
our $VERSION="0.1.001";
my $THIS_FILE="String.pm";
 
 
sub new
{
	my $class=shift;
 
	my $self={
		READ		=>	"./tools.xml",
		HASH		=>	{},
		FORCE_UTF8	=>	0,
		DEFAULT_LANG	=>	"en_CA",
	};
 
	bless $self, $class;
 
	return ($self);
}
 
# Get a handle on the AN::Tools object. I know that technically that is a
# sibling module, but it makes more sense in this case to think of it as a
# parent.
sub parent
{
	my $self=shift;
	my $parent=shift;
 
	$self->{HANDLE}{TOOLS}=$parent if $parent;
 
	return ($self->{HANDLE}{TOOLS});
}
 
# This forces UTF8 mode when reading a words file. This should not be used
# normally as the words file should already be UTF8 encoded.
sub force_utf8
{
	my $self=shift;
	my $set=defined $_[0] ? shift : undef;
 
	if (defined $set)
	{
		if (($set==0) || ($set==1))
		{
			$self->{FORCE_UTF8}=$set;
		}
		else
		{
			my $an=$self->parent;
			$an->Alert->error({
				fatal	=>	1,
				title	=>	"Invalid argument",
				message	=>	"The invalid argument: [$set] was passed into the 'AN::Tools::String->force_utf8()'. Only 1 or 0 are valid arguments.",
				code	=>	14,
				file	=>	"$THIS_FILE",
				line	=>	__LINE__
			});
		}
	}
 
	return ($self->{FORCE_UTF8});
}
 
# This takes a word key and, optionally, a hash reference, a language and/or an
# variables array reference. It returns the corresponding string from the hash
# reference data containing the data from a 'read_words()' call.
sub get_string
{
	my $self=shift;
	my $param=shift;
 
	# This just makes the code more consistent.
	my $an=$self->parent;
 
	# Clear any prior errors as I may set one here.
	$an->Alert->_set_error;
 
	my $key;
	my $hash=$an->data;
	my $vars;
	my $lang=$self->{DEFAULT_LANG};
 
	# Now see if the user passed the values in a hash reference or
	# directly.
	if (ref($param) eq "HASH")
	{
		# Values passed in a hash, good.
		$key=$param->{key} if $param->{key};
		$vars=$param->{variable} if $param->{variable};
		$hash=$param->{hash} if $param->{hash};
		$lang=$param->{language} if $param->{language};
	}
	else
	{
		# Values passed directly.
		$key=$param;
		$vars=$_[0] if defined $_[0];
		$hash=$_[1] if defined $_[1];
		$lang=$_[2] if defined $_[2];
	}
 
	# Make sure that 'hash' is a hash reference
	if (ref($hash) ne "HASH")
	{
		$an->Alert->error({
			fatal	=>	1,
			title	=>	"Invalid Argument",
			message	=>	"The 'AN::Tools::String' module's 'get_string' method was passed an invalid 'hash' argument: [$hash]. This must be a hash reference containing data read in from an XML words file by the 'read_words()' method.",
			code	=>	15,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
		# Return nothing in case the user is blocking fatal
		# errors.
		return (undef);
	}
 
	# Make sure that 'vars' is an array reference, if set.
	if (($vars) && (ref($vars) ne "ARRAY"))
	{
		$an->Alert->error({
			fatal	=>	1,
			title	=>	"Invalid Argument",
			message	=>	"The 'AN::Tools::String' module's 'get_string' method was passed an invalid 'variable' argument: [$vars]. This must be an array reference containing elements intended to replace corresponding #!var!x!# replacement keys in the requested string.",
			code	=>	16,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
		return (undef);
	}
 
	# Make sure that the request language exists in the hash.
	if (ref($hash->{words}{lang}{$lang}) ne "HASH")
	{
		$an->Alert->error({
			fatal	=>	1,
			title	=>	"Invalid Language",
			message	=>	"The 'AN::Tools::String' module's 'get_string' method was passed an invalid 'language' argument: [$lang]. This must match one of the languages in the words file's <langs>...</langs> block.\n",
			code	=>	17,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
		return (undef);
	}
 
	# Make sure that the request key is in the language hash.
	if (not exists $hash->{words}{lang}{$lang}{key}{$key}{content})
	{
		$an->Alert->error({
			fatal	=>	1,
			title	=>	"Invalid String Key",
			message	=>	"The 'AN::Tools::String' module's 'get_string' method was passed the 'key' argument: [$key] which was not found in the language: [$lang]. This key must be defined in one of the read in words files.\n",
			code	=>	18,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
		return (undef);
	}
 
	# Now pick out my actual string.
	my $string=$hash->{words}{lang}{$lang}{key}{$key}{content};
	$string=~s/^\n//;
 
	# This clears off the new-line and trailing white-spaces caused by the
	# indenting of the '</key>' field in the words XML file when printing
	# to the command line.
	$string=~s/\n(\s+)$//;
 
	# Substitute in any variables if needed.
	if ($vars)
	{
		$string=$an->String->_insert_vars({
			  string	=>	$string,
			  variable	=>	$vars,
		});
	}
 
	# Process the just-read string.
	$string=$an->String->_process({
		  string	=>	$string,
		  language	=>	$lang,
		  hash		=>	$hash,
	});
 
	return ($string);
}
 
# This takes a string and substitutes out the various replacement keys as
# needed until the string is ready for display. The only thing it doesn't
# handle is substituting '#!var!x!#' keys into a string. For that, call the
# 'get_string' method with it's given variable array reference and store the
# results in a string. This is requried because there is currently no way for
# any of the called methods within here to know which string the variables in
# the array reference belong in.
sub _process
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	# Start looping through the passed string until all the replacement
	# keys are gone.
	my $i=0;
	while ( $param->{string} =~ /#!(.+?)!#/ )
	{
		# Substitute 'word' keys, but without 'vars'. This has to be
		# first! 'protect' will catch 'word' keys, because no where
		# else are they allowed.
		$param->{string}=$an->String->_insert_word({
			  string	=>	$param->{string},
			  language	=>	$param->{language},
			  hash		=>	$param->{hash},
		});
 
		# Protect unmatchable keys.
		$param->{string}=$an->String->_protect({
			string		=>	$param->{string},
		});
 
		# Inject any 'data' values.
		$param->{string}=$an->String->_insert_data({
			string	=>	$param->{string},
		});
 
		die "Infinite loop detected while processing the string: [$param->{string}], exiting.\n" if $i > $an->_error_limit;
		$i++;
	}
 
	# Restore and unrecognized substitution values.
	$param->{string}=$an->String->_restore_protected({
		string		=>	$param->{string},
	});
 
	# Do any output mode specific formatting.
	$param->{string}=$an->String->_format_mode({
		string		=>	$param->{string},
	});
 
	return ($param->{string});
}
 
# Do any output mode specific formatting.
sub _format_mode
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	# I don't think I need this now as I only wrap the string after it's
	# been processed by 'print_template'. It may have future use though.
	return ($param->{string});
}
 
# This restores the original key format for keys that were protected by the
# '_protect' method.
sub _restore_protected
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	# Restore and unrecognized substitution values.
	my $i=0;
	while ( $param->{string} =~ /!#(.+?)#!/ )
	{
		my $check=$1;
		$param->{string}=~s/!#$check#!/#!$check!#/g;
 
		die "Infinite loop detected while restoring protected replacement keys in the string: [$param->{string}], exiting.\n" if $i > $an->_error_limit;
		$i++;
	}
 
	return ($param->{string});
}
 
# This does the actual work of substituting 'data' keys.
sub _insert_data
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	my $i=0;
	while ($param->{string} =~ /#!data!(.+?)!#/)
	{
		my $id=$1;
		if ( $id =~ /::/ )
		{
			# Multi-dimensional hash.
			my $value=$an->_get_hash_reference({
				key	=>	$id,
			});
			if (not defined $value)
			{
				$param->{string}=~s/#!data!$id!#/!!a[$id]!!/;
			}
			else
			{
				$param->{string}=~s/#!data!$id!#/$value/;
			}
		}
		else
		{
			# One dimension
			if (not defined $an->data->{$id})
			{
				$param->{string}=~s/#!data!$id!#/!!b[$id]!!/;
			}
			else
			{
				my $val=$an->data->{$id};
				$param->{string}=~s/#!data!$id!#/$val/;
			}
		}
 
		die "Infinite loop detected while replacing data keys in the string: [$param->{string}], exiting.\n" if $i > $an->_error_limit;
		$i++;
	}
 
	return ($param->{string});
}
 
# Protect unrecognized or unused replacement keys. I do this to protect strings
# possibly set or created by a user.
sub _protect
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	my $i=0;
	foreach my $check ( $param->{string} =~ /#!(.+?)!#/ )
	{
		if (( $check !~ /^free/ ) &&
		( $check !~ /^replace/ ) &&
		( $check !~ /^data/ ) &&
		( $check !~ /^word/ ) &&
		( $check !~ /^var/ ))
		{
			# Simply invert the '#!...!#' to '!#...#!'.
			$param->{string}=~s/#!($check)!#/!#$1#!/g;
		}
 
		die "Infinite loop detected while protecting replacement keys in the string: [$param->{string}], exiting.\n" if $i > $an->_error_limit;
		$i++;
	}
 
	return ($param->{string});
}
 
# This is called to process '#!word!...!#' keys in string. It DOES NOT
# support substituting '#!var!x!#' keys found in imported word strings! This
# is meant to insert simple word strings into template files.
sub _insert_word
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	# Loop through the string until all '#!word!...!#' keys are gone.
	my $i=0;
	while ($param->{string} =~ /#!word!(.+?)!#/)
	{
		my $key=$1;
		my $say_word=$an->String->get_string({
			  key		=>	$key,
			  language	=>	$param->{language},
			  hash		=>	$param->{hash},
			  variable	=>	undef,
		});
		if ($say_word)
		{
			$param->{string}=~s/#!word!$key!#/$say_word/;
		}
		else
		{
			$param->{string}=~s/#!word!$key!#/!!e[$key]!!/;
		}
 
		die "Infinite loop detected while replacing #!word!...!# keys in the string: [$param->{string}], exiting.\n" if $i > $an->_error_limit;
		$i++;
	}
	return ($param->{string});
}
 
# This takes a string with '#!var!x!#' keys, where 'x' is an integer matching
# an entry in the passed array reference and uses the data from the array to
# replace the matching '#!var!x!#' entry.
sub _insert_vars
{
	my $self=shift;
	my $param=shift;
 
	my $an=$self->parent;
 
	my $i=0;
	while ( $param->{string} =~ /#!var!(.+?)!#/ )
	{
		my $val=$param->{variable}->[$1];
		if ( not defined $param->{variable}->[$1] )
		{
			# I can't expect there to always be a defined value in
			# the @vals array at any given position so if it's
			# blank I blank the key.
			$param->{string}=~s/#!var!$1!#//;
		}
		else
		{
			chomp $val;
			$param->{string}=~s/#!var!$1!#/$val/;
		}
		die "Infinite loop detected while injecting variables into the string: [$param->{string}], exiting.\n" if $i > $an->_error_limit;
		$i++;
	}
 
	return ($param->{string});
}
 
# This takes the path/name of an XML file containing AN::Tools type words and
# reads them into a hash reference.
sub read_words
{
	my $self=shift;
	my $param=shift;
 
	# This just makes the code more consistent.
	my $an=$self->parent;
 
	# Clear any prior errors as I may set one here.
	$an->Alert->_set_error;
 
	# Setup my variables.
	my $file=0;
	my $hash=0;
 
	# Now see if the user passed the values in a hash reference or
	# directly.
	if (ref($param) eq "HASH")
	{
		# Values passed in a hash, good.
		$file=$param->{file} ? $param->{file} : $self->{FILE};
		$hash=ref($param->{hash}) eq "HASH" ? $param->{hash} : $self->{HASH};
	}
	else
	{
		# Values passed directly.
		$file=$param;
		$hash=((defined $_[0]) && (ref($_[0]) eq "HASH")) ? shift : $self->{HASH};
	}
	$file=$self->{READ} if not $file;
	print "Reading: [$file] into: [$hash] (\$an->data is: [".$an->data()."]\n";
 
	# Make sure that the 'file' exists and is readable.
	if ( not -e $file )
	{
		$an->Alert->error({
			fatal	=>	1,
			title	=>	"Unable to find the words file.'",
			message	=>	"The words file: [$file] could not be found. Please check that it exists.",
			code	=>	11,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
		# Return nothing in case the user is blocking fatal
		# errors.
		return (undef);
	}
	if ( not -r $file )
	{
		$an->Alert->error({
			fatal	=>	1,
			title	=>	"Unable to read the words file.'",
			message	=>	"The words file: [$file] was found but could not be read. Please check that it exists.",
			code	=>	12,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
		# Return nothing in case the user is blocking fatal
		# errors.
		return (undef);
	}
 
	my $in_comment=0;	# Set to '1' when in a comment stanza that spans more than one line.
	my $in_data=0;		# Set to '1' when reading data that spans more than one line.
	my $closing_key="";	# While in_data, look for this key to know when we're done.
	my $xml_version="";	# The XML version of the words file.
	my $encoding="";	# The encoding used in the words file. Should only be UTF-8.
	my $data="";		# The data being read for the given key.
	my $key_name="";	# This is a double-colon list of hash keys used to build each hash element.
 
	# Load IO::Handle if needed.
	$an->_load_io_handle() if not $an->_io_handle_loaded();
 
	# Read in the XML file with the word strings to load.
	my $read=IO::Handle->new;
	my $shell_call="<$file";
	open ($read, $shell_call) || $an->Alert->error({
			fatal	=>	1,
			title	=>	"'AN::Tools::String->read()' was not able to open the words file for reading.",
			message	=>	"The AN::Tools::String methid 'read' was not able to open the words file: [$file]. The error was: $!",
			code	=>	13,
			file	=>	"$THIS_FILE",
			line	=>	__LINE__
		});
 
	# If I have been asked to read in UTF-8 mode, do so.
	if ($an->String->force_utf8)
	{
		binmode $read, "encoding(utf8)";
	}
 
	# Now loop through the XML file, line by line.
	while (<$read>)
	{
		chomp;
		my $line=$_;
 
		### Deal with comments.
		# Look for a clozing stanza if I am (still) in a comment.
		if (($in_comment) && ( $line =~ /-->/ ))
		{
			$line=~s/^(.*?)-->//;
			$in_comment=0;
		}
		next if ($in_comment);
 
		# Strip out in-line comments.
		while ( $line =~ /<!--(.*?)-->/ )
		{
			$line=~s/<!--(.*?)-->//;
		}
 
		# See if there is an comment opening stanza.
		if ( $line =~ /<!--/ )
		{
			$in_comment=1;
			$line=~s/<!--(.*)$//;
		}
		### Comments dealt with.
 
		### Parse data
		# XML data
		if ( $line =~ /<\?xml version="(.*?)" encoding="(.*?)"\?>/ )
		{
			$xml_version=$1;
			$encoding=$2;
			next;
		}
 
		# If I am not "in_data" (looking for more data for a currently in use key).
		if (not $in_data)
		{
			# Skip blank lines.
			next if $line =~ /^\s+$/;
			next if $line eq "";
			$line=~s/^\s+//;
 
			# Look for an inline data-structure.
			if (( $line =~ /<(.*?) (.*?)>/ ) && ( $line =~ /<\/$1>/ ))
			{
				# First, look for CDATA.
				my $cdata="";
				if ( $line=~/<!\[CDATA\[(.*?)\]\]>/ )
				{
					$cdata=$1;
					$line=~s/<!\[CDATA\[$cdata\]\]>/$cdata/;
				}
 
				# Pull out the key and name.
				my $key=$line;
				my $name=$line;
				my $data=$line;
				$key=~s/^<(\w+).*/$1/;
				$name=~s/^<$key name="(\w+).*/$1/;
				$data=~s/^<$key name="$name">(.*?)<\/$key>(.*)/$1/;
 
				# If I picked up data within a CDATA block,
				# push it into 'data' proper.
				$data=$cdata if $cdata;
 
				# No break out the data and push it into the
				# corresponding keyed hash reference
				# '$an->data'.
				$an->_make_hash_reference($an->data, "${key_name}::${key}::${name}::content", $data);
 
				next;
			}
 
			# Look for a self-contained unkeyed structure.
			if (( $line =~ /<(.*?)>/ ) && ( $line =~ /<\/$1>/ ))
			{
				my $key=$line;
				$key=~s/<(.*?)>.*/$1/;
				$data=$line;
				$data=~s/<$key>(.*?)<\/$key>/$1/;
				$an->_make_hash_reference($an->data, "${key_name}::${key}", $data);
				next;
			}
 
			# Look for a line with a closing stanza.
			if ( $line =~ /<\/(.*?)>/ )
			{
				my $closing_key=$line;
				$closing_key=~s/<\/(\w+)>/$1/;
				$key_name=~s/(.*?)::$closing_key(.*)/$1/;
				next;
			}
 
			# Look for a key with an embedded value.
			if ( $line =~ /^<(\w+) name="(.*?)" (\w+)="(.*?)">/ )
			{
				my $key=$1;
				my $name=$2;
				my $key2=$3;
				my $data=$4;
				$key_name.="::${key}::${name}";
				$an->_make_hash_reference($an->data, "${key_name}::${key}::${key2}", $data);
				next;
			}
 
			# Look for a contained value.
			if ( $line =~ /^<(\w+) name="(.*?)">(.*)/ )
			{
				my $key=$1;
				my $name=$2;
				# Don't scope 'data' locally in case it spans
				# multiple lines.
				$data=$3;
 
				# Parse the data now.
				if ( $data =~ /<\/$key>/ )
				{
					# Fully contained data.
					$data=~s/<\/$key>(.*)$//;
					$an->_make_hash_reference($an->data, "${key_name}::${key}::${name}", $data);
				}
				else
				{
					# Element closes later.
					$in_data=1;
					$closing_key=$key;
 
					$name=~s/^<$key name="(\w+).*/$1/;
					$key_name.="::${key}::${name}";
					$data=~s/^<$key name="$name">(.*)/$1/;
					$data.="\n";
				}
				next;
			}
 
			# Look for an opening data structure.
			if ( $line =~ /<(.*?)>/ )
			{
				my $key=$1;
				$key_name.="::$key";
				next;
			}
		}
		else
		{
			### I'm in a multi-line data block.
			# If this line doesn't close the data block, feed it
			# wholesale into 'data'. If it does, see how much of
			# this line, if anything, is pushed into 'data'.
			if ( $line !~ /<\/$closing_key>/ )
			{
				$data.="$line\n";
			}
			else
			{
				# This line closes the data block.
				$in_data=0;
				$line=~s/(.*?)<\/$closing_key>/$1/;
				$data.="$line";
 
				# If this line contain new-line control
				# characters, break the line up into multiple
				# lines and process them seperately.
				my $save_data="";
				my @lines=split/\n/, $data;
 
				# I use this to track CDATA blocks.
				my $in_cdata=0;
 
				# Loop time.
				foreach my $line (@lines)
				{
					# If I am in a CDATA block, check for
					# the closing stanza.
					if (( $in_cdata == 1 ) && ( $line =~/]]>$/ ))
					{
						# CDATA closes here.
						$line =~s/]]>$//;
						$save_data.="\n$line";
						$in_cdata=0;
					}
 
					# If this line is a self-contained
					# CDATA block, pull the data out.
					# Otherwise, check if this line starts
					# a CDATA block.
					if (( $line =~/^<\!\[CDATA\[/ ) && ( $line =~/]]>$/ ))
					{
						# CDATA opens and closes in this line.
						$line=~s/^<\!\[CDATA\[//;
						$line=~s/]]>$//;
						$save_data.="\n$line";
					}
					elsif ( $line =~/^<\!\[CDATA\[/ )
					{
						$line=~s/^<\!\[CDATA\[//;
						$in_cdata=1;
					}
 
					# If I am in a CDATA block, feed the
					# (sub)line into 'save_data' wholesale.
					if ( $in_cdata == 1 )
					{
						# Don't analyze, just store.
						$save_data.="\n$line";
					}
					else
					{
						# Not in CDATA, look for XML data.
						while (( $line =~ /<(.*?)>/ ) && ( $line =~ /<\/$1>/ ))
						{
							# Found a value.
							my $key=$line;
							$key=~s/.*?<(.*?)>.*/$1/;
							$data=$line;
							$data=~s/.*?<$key>(.*?)<\/$key>/$1/;
 
							$an->_make_hash_reference($an->data, "${key_name}::${key}", $data);
							$line =~ s/<$key>(.*?)<\/$key>//
						}
						$save_data.="\n$line";
					}
				}
 
				# Knock out and new-lines and save.
				$save_data=~s/^\n//;
				if ( $save_data =~ /\S/s )
				{
					# Record the data in my '$an->data'
					# hash reference.
					$an->_make_hash_reference($an->data, "${key_name}::content", $save_data);
				}
 
				$key_name=~s/(.*?)::$closing_key(.*)/$1/;
			}
		}
		next if $line eq "";
	}
	$read->close();
 
	# Set a couple values about this file.
	$self->{FILE}->{XML_VERSION}=$xml_version;
	$self->{FILE}->{ENCODING}=$encoding;
 
	# Return the number.
	return (1);
}
 
1;

 

Any questions, feedback, advice, complaints or meanderings are welcome.
Us: Alteeve's Niche!	Support: Mailing List	IRC: #clusterlabs on Freenode		© Alteeve's Niche! Inc. 1997-2019
legal stuff: All info is provided "As-Is". Do not use anything here unless you are willing and able to take responsibility for your own actions.