Class::Phrasebook - Implements the Phrasebook pattern

  use Class::Phrasebook;
  my $pb = new Class::Phrasebook($log, "test.xml");
  $pb->load("NL"); # using Dutch as the language
  $phrase = $pb->get("ADDRESS", 
		     { street => "Chaim Levanon",
		       number => 88,
		       city   => "Tel Aviv" } );

 <?xml version="1.0"?>
 <!DOCTYPE phrasebook [
	       <!ELEMENT phrasebook (dictionary)*>              
	       <!ELEMENT dictionary (phrase)*>
               <!ATTLIST dictionary name CDATA #REQUIRED>
               <!ELEMENT phrase (#PCDATA)>
               <!ATTLIST phrase name CDATA #REQUIRED>
 ]>

 <?xml version="1.0"?>
 <!DOCTYPE phrasebook [
	       <!ELEMENT phrasebook (dictionary)*>              
	       <!ELEMENT dictionary (phrase)*>
               <!ATTLIST dictionary name CDATA #REQUIRED>
               <!ELEMENT phrase (#PCDATA)>
               <!ATTLIST phrase name CDATA #REQUIRED>
 ]>
 <phrasebook>
 <dictionary name="EN">

 <phrase name="HELLO_WORLD">
            Hello World!!!
 </phrase>

 <phrase name="THE_HOUR">
            The time now is $hour. 
 </phrase>

 <phrase name="ADDITION">
            add $a and $b and you get $c
 </phrase>




 <!-- my name is the same in English Dutch and French. -->
 <phrase name="THE_AUTHOR">
            Rani Pinchuk
 </phrase>
 </dictionary>

 <dictionary name="FR">
 <phrase name="HELLO_WORLD">
            Bonjour le Monde!!!
 </phrase>

 <phrase name="THE_HOUR">
            Il est maintenant $hour. 
 </phrase>

 <phrase name="ADDITION">
            $a + $b = $c
 </phrase>

 </dictionary>

 <dictionary name="NL">
 <phrase name="HELLO_WORLD">
            Hallo Werld!!!
 </phrase>

 <phrase name="THE_HOUR">
            Het is nu $hour. 
 </phrase>

 <phrase name="ADDITION">
            $a + $b = $c
 </phrase>

 </dictionary>

 </phrasebook>

package Class::Phrasebook;

use strict;

our $VERSION = '0.88';


use Term::ANSIColor 1.03 qw(:constants);
use strict;
use XML::Parser 2.30;
use Log::NullLogLite 0.2;
use bytes;
# reset to normal at the end of each line.
$Term::ANSIColor::AUTORESET = 1;

my $Dictionaries_cache;
my $Clean_out_of_scope_dictionaries = 1;

#############################################################
# new($log, $file_path)
#############################################################
# the constructor
sub new {
    my $proto = shift; # get the class name
    my $class = ref($proto) || $proto;
    my $self  = {};

    $self->{LOG} = shift || new Log::NullLogLite;
    $self->{FILE_PATH} = shift || "";
    
    # we bless already so we can use the method get_xml_path
    bless ($self, $class);

    # check that we can find this file
    $self->{FILE_PATH} = $self->get_xml_path($self->{FILE_PATH});
    unless ($self->{FILE_PATH}) {
	return undef;
    }    

    # get the file name for using as part of the key of the dictionary
    $self->{FILE_PATH} =~ /[^\/]+$/;
    $self->{FILE_NAME} = $&;
    # dictionary key holds a representative key for the dictionary that is 
    # loaded.
    $self->{DICTIONARY_KEY} = "";
    $self->{PHRASES} = {};
    # defaults
    if (defined($ENV{PHRASEBOOK_AS_IS_BETWEEN_TAGS})) {
	$self->{AS_IS_BETWEEN_TAGS} = $ENV{PHRASEBOOK_AS_IS_BETWEEN_TAGS};
    }
    else {
	$self->{AS_IS_BETWEEN_TAGS} = 1; # set by default
    }
    $self->{REMOVE_NEW_LINES} = 0;
    return $self;
} # of new

##############################
# Dictionaries_names_in_cache
##############################
sub Dictionaries_names_in_cache {    
    return keys ( % { $Dictionaries_cache } );
} # of Dictionaries_names_in_cache

###############
# DESTROY
###############
sub DESTROY {
    my $self = shift;
    if ($self->{DICTIONARY_KEY}) {	
	$Dictionaries_cache->{$self->{DICTIONARY_KEY}}{COUNTER}--;
	# clean that dictionary from the cache if needed.
	if ($Dictionaries_cache->{$self->{DICTIONARY_KEY}}{COUNTER} == 0) {
	    if ($Clean_out_of_scope_dictionaries) {
		delete($Dictionaries_cache->{$self->{DICTIONARY_KEY}});
	    }
	}
    }

} # of DESTROY

#################
# file_path
#################
sub file_path {
    my $self = shift;
    if (@_) { 
	$self->{FILE_PATH} = shift;

        # check that we can find this file
	$self->{FILE_PATH} = $self->get_xml_path($self->{FILE_PATH});
	unless ($self->{FILE_PATH}) {
	    return undef;
	}
    }
    return $self->{FILE_PATH};
} # of file_path

#################
# log
#################
sub log {
    my $self = shift;
    if (@_) { $self->{LOG} = shift }
    return $self->{LOG};
} # of log

###################################
# clean_out_of_scope_dictionaries
###################################
sub clean_out_of_scope_dictionaries {
    my $proto = shift; # get the class name
    $Clean_out_of_scope_dictionaries = shift;
    return $Clean_out_of_scope_dictionaries;
} # of clean_out_of_scope_dictionaries

#################
# dictionary_name
#################
sub dictionary_name {
    my $self = shift;
    if (@_) { $self->{DICTIONARY_NAME} = shift }
    return $self->{DICTIONARY_NAME};
} # of dictionary_name

####################
# remove_new_lines
####################
sub remove_new_lines {
    my $self = shift;
    if (@_) { $self->{REMOVE_NEW_LINES} = shift }
    return $self->{REMOVE_NEW_LINES};
} # of remove_new_lines

#####################
# as_is_between_tags
#####################
sub as_is_between_tags {
    my $self = shift;
    if (@_) { $self->{AS_IS_BETWEEN_TAGS} = shift }
    return $self->{AS_IS_BETWEEN_TAGS};
} # of as_is_between_tags

####################################
# load($dictionary_name)
####################################
sub load {
    my $self = shift;
    my $requested_dictionary_name = shift || "";
    # get a unique key that represents this dictionary of that file.
    my $dictionary_key = 
	$self->{FILE_NAME}."/".$requested_dictionary_name;
    # if the object already loaded a dictionary, and now it loads other 
    # dictionary, we should reduce the counter of the dictionary that was
    # loaded till now.
    if ($self->{DICTIONARY_KEY} && 
	$self->{DICTIONARY_KEY} ne $dictionary_key) {
	$Dictionaries_cache->{$self->{DICTIONARY_KEY}}{COUNTER}--;

	# clean that dictionary from the cache if needed.
	if ($Dictionaries_cache->{$self->{DICTIONARY_KEY}}{COUNTER} == 0) {
	    if ($Clean_out_of_scope_dictionaries) {
		delete($Dictionaries_cache->{$self->{DICTIONARY_KEY}});
	    }
	}
    }
    # zero the cache counter for that dictionary if this is the first time
    # that this dictionary is loaded
    if (!defined($Dictionaries_cache->{$dictionary_key}) ||
	!defined($Dictionaries_cache->{$dictionary_key}{COUNTER})) {
	$Dictionaries_cache->{$dictionary_key}{COUNTER} = 0;
    }
    # keep the dictionary key
    $self->{DICTIONARY_KEY} = $dictionary_key;
    # and increment the counter of this dictionary
    $Dictionaries_cache->{$self->{DICTIONARY_KEY}}{COUNTER}++;
    # the the dictionaries cache keeps the phrases of all the dictionaries
    if (defined($Dictionaries_cache->{$self->{DICTIONARY_KEY}}) &&
	defined($Dictionaries_cache->{$self->{DICTIONARY_KEY}}{PHRASES}) &&
	ref($Dictionaries_cache->{$self->{DICTIONARY_KEY}}{PHRASES}) 
	eq "HASH") {
	$self->{PHRASES} = 
	    $Dictionaries_cache->{$self->{DICTIONARY_KEY}}{PHRASES};
	return 1;
    }
    
    # the load may set the data member DICTIONARY_NAME. On the other hand
    # if the requested_dictionary_name is not defined, we will try to use
    # the data member.
    if ($requested_dictionary_name) {
	$self->{DICTIONARY_NAME} = $requested_dictionary_name;
    }
    else {
	$requested_dictionary_name = $self->{DICTIONARY_NAME} || "";
    }

    my $phrases; # a reference to anonymous hash that will hold all the 
                 # phrases
    my $phrase_name; # the name of the current phrase.
    my $phrase_value; # the string of the phrase. 

    # the first dictionary is the default one and should be read. this flag
    # will tell if it was read.
    my $default_was_read = 0;
    
    # this flag will be set to zero after the default dictionary was read. then
    # it will be set to one when the requested dictionary should be read.
    my $read_on = 1;

    # create the XML parser object
    my $parser = new XML::Parser(ErrorContext => 2);
    $parser->setHandlers(
        Start => sub {
            my $expat = shift;
            my $element = shift;
            my %attributes = (@_);	    
	    
            # deal with the dictionary element
            if ($element =~ /dictionary/) {
		my $dictionary_name = $attributes{name};
                unless (defined($dictionary_name)) {
                    $self->log()->write("The dictionary element must".
					" have the name attribute", 4);
                    return 0; # we must have name
                }
		# if the default was already read, and the dictionary name
		# is not the requested one, we should not read on.
                if ($default_was_read && 
		    $dictionary_name ne $requested_dictionary_name) {
		    $read_on = 0;
		}
		# in any other case we should read on
		else {
		    $read_on = 1;
		}
            }

            # deal with the phrase element
            if ($element =~ /^phrase$/) {
                $phrase_name = $attributes{name};
                unless (defined($phrase_name)) {
                    $self->log()->write("The phrase element must".
					" have the name attribute", 4);
                    return 0; # we must have name
                }
            }
	    if ($self->{AS_IS_BETWEEN_TAGS}) {
		# we should clean the $phrase_value after the start of the tag
		# so in the phrase we will have only the text that is between
		# the phrase tags.
		$phrase_value = "";
	    }	    
        }, # of Start
	
        End => sub {
            my $expat = shift;
            my $element = shift;
	    if ($element =~ /^dictionary$/i) {
		$default_was_read = 1;
	    }
	    
            if ($element =~ /^phrase$/i) {
		if ($read_on) {
		    $phrases->{$phrase_name} = $phrase_value;
		    $phrase_value = "";
		}
            }
        }, # of End
	
        Char => sub {
            my $expat = shift;
            my $string = shift;
	    # if $read_on flag is true and the string is not empty we set the 
	    # value of the phrase.
	    if ($self->{AS_IS_BETWEEN_TAGS}) {
		if ($read_on && length($string)) {
		    $phrase_value .= $string;
		}		
	    }
	    else { # this block is here for legacy reasons.
		if ($read_on && $string =~ /[\S]/) { 
		    # if we have already $phrase_value, we should add a 
		    # new line to it, before we add the next line.
		    $phrase_value .= "\n" if ($phrase_value);
		    $phrase_value .= $string;
		}
	    }
        } # of Char
    ); # of the parser setHandlers class

    # open the xml file as a locked file and parse it
    my $fh = new IO::LockedFile("<".$self->{FILE_PATH});
    unless ($fh) {
        $self->log()->write("Could not open ".$self->{FILE_PATH}.
			    " to read.", 4);
	return 0;
    }
    eval { $parser->parse($fh) }; # I use eval because the parse function dies
                                  # on parsing error.
    if ($@) {
        $self->log()->write("Could not parse the ".$self->{FILE_PATH}.
			    " file: ".$@, 4);
        return 0; # there was an error in parsing the XML.
    }

    $self->{PHRASES} = $phrases;
    # keep the phrases 
    $Dictionaries_cache->{$self->{DICTIONARY_KEY}}{PHRASES} = $self->{PHRASES};

    return 1; # success 
} # of load

###################################################################
# $phrase = get($key, { var1 => $value1, var2 => value2 ... })
#   where $key will be the key to certain phrase, and var1, var2
#   and so on will be $var1 and $var2 in the definition of that 
#   phrase in the load method above.
###################################################################
sub get {
    my $self = shift;
    my $key = shift;
    my $variables = shift;
    
    # the DEBUG_PRINTS is controlled by an environment.
    my $debug_prints = lc($ENV{PHRASEBOOK_DEBUG_PRINTS}) || "";
    
    if ($debug_prints) {
	if ($debug_prints eq "color") {
	    # check that all the variables defined in $variables
	    foreach my $key (keys(%$variables)) {	
		unless (defined($variables->{$key})) {
		    print "[";
		    print GREEN called_by();
		    print "]";
		    print BLUE "[";
		    print RED "$key is not defined";
		    print BLUE "]\n";
		}
	    }
	}
	elsif ($debug_prints eq "html") {
	    # check that all the variables defined in $variables
	    foreach my $key (keys(%$variables)) {	
		unless (defined($variables->{$key})) {
		    print "<pre>[<font color=darkgreen>";
		    print called_by();
		    print "</font>]";
		    print "<font color=blue>[</font>";
		    print "<font color=red>$key is not defined</font>";
		    print "<font color=blue>]</font></pre>\n";
		}
	    }
	}
	elsif ($debug_prints eq "text") {
	    # check that all the variables defined in $variables
	    foreach my $key (keys(%$variables)) {	
		unless (defined($variables->{$key})) {
		    print "[";
		    print called_by();
		    print "]";
		    print "[";
		    print "$key is not defined";
		    print "]\n";
		}
	    }
	}
    }

    my $phrase = $self->{PHRASES}{$key};
    unless (defined($phrase)) {        
	if ($debug_prints) {
	    if ($debug_prints eq "color") {
		print RED "No phrase for $key\n";
	    }
	    elsif ($debug_prints eq "html") {
		print "<pre><font color=red>No phrase for $key".
		    "</font></pre>\n";
	    }
	    elsif ($debug_prints eq "text") {
		print "No phrase for $key\n";
	    }
	} 
	$self->{LOG}->write ("No phrase for ".$key."\n", 3);
        return undef;
    }

    # process the placeholders 
    if ($debug_prints) {
	$phrase =~ 
	    s/\$([a-zA-Z0-9_]+)/debug_print_variable($1, $variables)/ge;
	$phrase =~ 
	    s/\$\(([a-zA-Z0-9_]+)\)/debug_print_variable($1, $variables)/ge;
    }
    $phrase =~ s/\$([a-zA-Z0-9_]+)/$variables->{$1}/g;
    # also process variables in $(var_name) format.
    $phrase =~ s/\$\(([a-zA-Z0-9_]+)\)/$variables->{$1}/g;

    # remove new lines if needed
    if ($self->{REMOVE_NEW_LINES}) {
	$phrase =~ s/\n//g; 
    }

    if ($debug_prints) {
	if ($debug_prints eq "color") {
	    print "[";
	    print GREEN called_by();
	    print "]";
	    print RED "[";
	    print BLUE $key;
	    print RED "]\n";
	    print $phrase."\n";
	}
	elsif ($debug_prints eq "html") {
	    print "<pre>[";
	    print "<font color=darkgreen>".called_by()."</font>";
	    print "]";
	    print "<font color=red>[</font>";
	    print "<font color=blue>$key</font>";
	    print "<font color=red>]</font>\n";
	    print $phrase."</pre>\n";
	}
	elsif ($debug_prints eq "text") {
	    print "[";
	    print called_by();
	    print "]";
	    print "[";
	    print $key;
	    print "]\n";
	    print $phrase."\n";	    
	}
    }
    
    unless ($phrase) {
	if ($debug_prints) {
	    if ($debug_prints eq "color") {
		print RED "Oops - no phrase for $key !!!\n";
	    }
	    elsif ($debug_prints eq "html") {
		print "<pre><font color=red>Oops - no phrase for $key".
		    "</font></pre>\n";
	    }
	    elsif ($debug_prints eq "text") {
		print "Oops - no phrase for $key !!!\n";
	    }
	}
    }
    return $phrase;
} # of get

#######################
# called_by
#######################
sub called_by {
    my $depth = 2;
    my $args; 
    my $pack; 
    my $file; 
    my $line; 
    my $subr; 
    my $has_args;
    my $wantarray;
    my $evaltext; 
    my $is_require; 
    my $hints; 
    my $bitmask;
    my @subr;
    my $str = "";
    while ($depth < 7) {
	($pack, $file, $line, $subr, $has_args, $wantarray, 
	 $evaltext, $is_require, $hints, $bitmask) = caller($depth);
        unless (defined($subr)) {
            last;
        }
        $depth++;       	
        $line = "$file:".$line."-->";
	push(@subr, $line.$subr);
    }
    @subr = reverse(@subr);
    foreach $subr (@subr) {
        $str .= $subr;
        $str .= " > ";
    }
    $str =~ s/ > $/: /;
    return $str;
} # of called_by

#######################################################
# is_variables_defined_in_this_line($line, $variables)
#######################################################
sub is_variables_defined_in_this_line {
    my $line = shift;
    my $variables = shift;
    while ($line =~ /\$([a-zA-Z0-9_]+)/ ) {
	unless (defined($variables->{$1})) {
	    return 0;
	}
	$line = $';
    }
    return 1;
} # of is_variables_defined_in_this_line

##################
# to_string()
##################
sub to_string {
    my $self = shift;
    my $string = "";
    foreach my $key (keys(% { $self->{PHRASES} } )) {
	my $phrase = $self->{PHRASES}{$key};
	$string .= $key." => \n".$phrase."\n\n";
    }
    return $string;
} # of to_string

#######################
# get_xml_path()
#######################
sub get_xml_path {
    my $self = shift;
    my $file = $self->{FILE_PATH};

    # first deal with absolute path
    if (is_absolute_path($file)) {
	if (-e $file) {
	    return $file;
	}
	else {
	    $self->{LOG}->write("Cannot find the XML file ".
				$self->{FILE_PATH}, 4);
	    return undef;
	}
    }
    else {
	my @dirs = (".", "./lib", "../lib", @INC);
	
	foreach my $dir (@dirs) {
	    my $path = $dir."/".$file;
	    if (-e $path) {
		return $path;
	    }
	}	    
	
	# we could not find that file, announce it.
	$self->{LOG}->write("Cannot find the XML file ".
			    $file." in tghe directories: (".
			    join(", ", @INC).")", 4);
	
	return undef;
    }
} # of get_xml_path

######################
# is_absolute_path
######################
sub is_absolute_path {
    my $path = shift;

    unless (defined($path)) {
        return 0;
    }
    # the different Operating Systems
    my %operating_systems = ( "mswin32"  => '^(?:[a-zA-Z]:)?[\\\/]+',
			      "cygwin"   => '^([A-Za-z]:)|^(\/)',
                              "linux"    => '^\/');    
    my $os = lc($^O);
    my $reg_expression = $operating_systems{$os} || 
        $operating_systems{'linux'};
    return $path =~ /$reg_expression/;
} # is_absolute_path

#########################
# debug_print_variable
#########################
sub debug_print_variable {
    my $key = shift;
    my $variables = shift;
    my $value = $variables->{$key};
    my $debug_prints = lc($ENV{PHRASEBOOK_DEBUG_PRINTS}) || "";
    if ($debug_prints eq "color") {
	print MAGENTA "$key = ";
	if (defined($value)) {
	    print MAGENTA "$value\n";
	}
	else {
	    print RED "undef\n";
	}
    }
    elsif ($debug_prints eq "html") {
	print "<pre><font color=magenta> $key = </font>";
	if (defined($value)) {
	    print "<font color=magenta>$value</font></pre>\n";
	}
	else {
	    print "<font color=red>undef</font></pre>\n";
	}	
    }
    elsif ($debug_prints eq "text") {
	print "$key = ";
	if (defined($value)) {
	    print "$value\n";
	}
	else {
	    print "undef\n";
	}
    }
    return "\$".$key;
} # of debug_print_varibale

1; # make perl happy

__END__
# Below is the stub of documentation for your module. You better edit it!