Source AN::Tools::String
From AN!Wiki
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. |