Re: new util method proposition for Maketext

# $Id: Extended.pm,v 1.2 2002/09/05 12:15:24 rousse Exp $

package Locale::Maketext::Extended;

use base 'Locale::Maketext';
use Carp;
use strict;

BEGIN {
    unless(defined &DEBUG) {
	*DEBUG = sub () {0}
    }
}

my %genders_cache = ();

# return correct spelling for words before nouns beginning with vowel
sub liaison {
    my ($self, $noun, @alternatives) = @_;

    return $noun unless @alternatives;

    if (@alternatives == 1) {
	return $alternatives[0] . $noun;
    } else {
	return $noun =~ /^[aeiouy]/i ?  $alternatives[1] . $noun : $alternatives[0] . $noun;
    }

}

# return correct spelling for words subject to gender according
sub accord {
    my ($self, $gender, %alternatives) = @_;

    return $gender unless %alternatives;

    return $alternatives{$gender};

}

# return gender for a noun
sub gender {
    my ($self, $noun) = @_;
    croak("genders requires at least one parameter") unless $noun;

    my $class = ref($self);

    $self->_scan_genders() unless (exists $genders_cache{$class});

    my $gender;
    foreach my $genders (@{$genders_cache{$class}}) {
	print "* Looking up \"$noun\" in $genders\n" if DEBUG;
	if (exists $genders->{$noun}) {
	    print "  Found \"$noun\" in $genders\n" if DEBUG;
	    $gender = $genders->{$noun};
	    last;
	} 
    }

    return $gender;
}

# scan all class hierarchy to find genders hashes
sub _scan_genders {
    my $class = ref($_[0]) || $_[0];
    my $seen  = ref($_[1]) ? $_[1] : {};
    print "Genders hashes lookup on $class\n" if DEBUG > 1;
    return $genders_cache{$class} if exists $genders_cache{$class};

    my @list;
    no strict 'refs';

    if( defined( *{$class . '::Genders'}{'HASH'} )) {
	push @list, *{$class . '::Genders'}{'HASH'};
	print "%" . $class . "::Genders contains ", scalar(keys %{$class . '::Genders'}), " entries\n" if DEBUG;
    }

    foreach my $superclass (@{$class . "::ISA"}) {
	print " Super-class search into $superclass\n" if DEBUG;
	next if $seen->{$superclass}++;
	push @list, @{&_scan_genders($superclass, $seen)};
    }

    $genders_cache{$class} = \@list;
    return \@list;
}

sub clear_genders_cache {
    %genders_cache = ();
    return;
}

1;