File Coverage

blib/lib/Lingua/Phonology/Segment.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

#!/usr/bin/perl -w

package Lingua::Phonology::Segment;

=head1 NAME

Lingua::Phonology::Segment - a module to represent a segment as a bundle
of feature values.

=head1 SYNOPSIS

	use Lingua::Phonology;
	$phono = new Lingua::Phonology;

	# Define a feature set
	$features = $phono->features;
	$features->loadfile;

	# Make a segment
	$segment = $phono->segment;

	# Set some values
	$segment->labial(1);
	$segment->continuant(0);
	$segment->voice(1);
    # Segment is now voiced labial stop, i.e. [b]

	# Reset the segment
	$segment->clear;

=head1 DESCRIPTION

A Lingua::Phonology::Segment object provides a programmatic representation
of a linguistic segment. Such a segment is associated with a
Lingua::Phonology::Features object that lists the available features and
the relationships between them. The segment itself is a list of the values
for those features. This module provides methods for returning and setting
these feature values. A segment may also be associated with a
Lingua::Phonology::Symbols object, which allows the segment to return the
symbol that it best matches.

=cut

use strict;
use warnings;
use warnings::register;
use Lingua::Phonology::Common;
use Lingua::Phonology::Features;
use constant {
    REF => 0,
    NUM => 1,
    TXT => 2
};

# Magical stuff:
# Automatically spell segments in string context
use overload
    # The fun stuff
    '""' => sub { defined $_[0]->{SYMBOLS} ? $_[0]->spell : overload::StrVal($_[0]) },
    'cmp' => sub {
        my ($l, $r, $swap) = @_;
        if ($swap) { return "$r" cmp "$l" }
        else { return "$l" cmp "$r" } },

    # A rediculous hack to return the non-overloaded number value. In theory,
    # '0+' => sub { $_[0] } *should* do this, but it makes the debugger
    # segfault.  This procedure is borrowed from overload.pm itself.
    '0+' => sub {
        my $package = ref $_[0];
        bless $_[0], 'my::Fake';
        my $rv = int $_[0];
        bless $_[0], $package;
        return $rv },
    'fallback' => 1;

our $VERSION = 0.3;

sub err ($) { warnings::warnif(shift); return; }

# New segment
sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self = {
		FEATURES => undef,
		SYMBOLS => undef,
		WANT => REF, #  REF, NUM, or TXT
		VALUES   => { }
	};

	my $featureset = shift; # An object in class Features
	my $values = shift; # A hashref

    # When an object method, copy feature and symbol settings
	if (ref $proto) {
		$self->{FEATURES} = $featureset || $proto->{FEATURES};
		$self->{SYMBOLS} = $proto->{SYMBOLS};
	}

    # When a class method
	else {
		$self->{FEATURES} = $featureset;
	}

	# Require a $featureset of the proper type
	return err("No featureset (or bad featureset) given for new $class") unless _is_features($self->{FEATURES});

	# Gesundheit
	bless $self, $class;

	# Set initial values
	$self->value_ref($_, $values->{$_}) for keys %$values;

	return $self;
}

sub featureset {
	my $self = shift;
	if (@_) {
		return err("Bad feature set") unless _is_features($_[0]);
        $self->{FEATURES} = shift;
	}
	return $self->{FEATURES};
}

sub symbolset {
	my $self = shift;
	if (@_) {
		return err("Bad symbol set") unless _is_symbols($_[0]);
        $self->{SYMBOLS} = shift;
	}
	return $self->{SYMBOLS};
}

# These functions locally set WANT, so that the structure generated in
# value_ref() can be built the right way the first time

sub value {
	my $self = shift;
	local $self->{WANT} = NUM;
	$self->value_ref(@_);
}

sub value_text {
	my $self = shift;
	local $self->{WANT} = TXT;
	$self->value_ref(@_);
}

sub value_ref {
	my ($self, $feature, $val, $hash) = @_;
	return unless $self->{FEATURES}->feature($feature);

	# Assign primary values, checking the size of @_ because $val could be
	# undef. Skip this part if $val is undef and we have 4 args
	if (@_ > 2 and not (@_ > 3 and not defined $val)) {

		# If given a plain scalar ref, replace the old ref
		if (ref($val) eq 'SCALAR') {
            # This errs if $$val is not an lvalue
            eval {
                $$val = $self->{FEATURES}->number_form($feature, $$val);
            };

            # ...in which case we work around
            if ($@) {
                my $nval = $self->{FEATURES}->number_form($feature, $$val);
                $self->{VALUES}->{$feature} = \$nval;
            }
            else {
                $self->{VALUES}->{$feature} = $val;
            }
		}

		# Otherwise, change the val via the current ref
		else {
			$val = $self->{FEATURES}->number_form($feature, $val);

			# If this feature is already defined, assign via existing ref
			if (my $ref = $self->{VALUES}->{$feature}) {
				$$ref = $val;
			}

			# If it's not defined, assign as a ref
			else {
				$self->{VALUES}->{$feature} = \$val;
			}

		}
	}

	# Assign child values
	HASH: if (@_ > 3 && defined $hash) {
		unless (_is($hash, 'HASH')) {
			err("Third argument to value() must be a hash reference");
			last HASH;
		}

        # Get children that are also in our hash (implicitly ignoring bad children in $hash)
		for (grep { exists $hash->{$_} } $self->{FEATURES}->children($feature)) {
			# For pairs like $feature => [ $val, { child vals } ]
			if (_is($hash->{$_}, 'ARRAY')) {
				$self->value_ref($_, @{$hash->{$_}});
			}

			# For pairs like $feature => $val
			else {
				$self->value_ref($_, $hash->{$_});
			}
		}
	}

	# Quit in void context
	return if not defined wantarray;

	# Find the return value or a ref to undef
	my $retval = $self->{VALUES}->{$feature} || \undef;
	{
		# Less strictness here for when $retval is undef
		#no strict 'refs';
		#no warnings 'uninitialized';

		if ($self->{WANT} == TXT) {
			$retval = $self->{FEATURES}->text_form($feature, $$retval);
		}
		elsif ($self->{WANT} == NUM) {
			$retval = $$retval;
		}
	}

    # Return these in scalar context
	if (not wantarray) {
        # Return the actual value if the feature is defined
		return $retval if exists $self->{VALUES}->{$feature} && defined ${$self->{VALUES}->{$feature}};

        # Otherwise return the child hashref
		return $self->_children($feature);
	}

	# Get the hashref to return if we want an array
    my $rethash = $self->_children($feature);
    return $retval => $rethash; # if (defined $rethash || defined $retval);

    # When everything's undef
	return;
}

# Build a hashref of child values, or undef if you're childless
sub _children {
	my ($self, $feature) = @_;
	my $rethash = {};

    # Nodes w/ children
	if (my @kids = $self->{FEATURES}->children($feature)) {
		for (@kids) {
			my ($val, $kids) = $self->value_ref($_);
			if (defined $val || defined $kids) {
				$rethash->{$_} = [ $val, $kids ];
			}
		}
	}

    # Terminal nodes
	else {
		return;
	}

    # Nodes with no defined children
	return if not keys %$rethash;

    # Normal case
	return $rethash;
}

sub delink {
	my $self = shift;
	my @return = ();
	for (@_) {
		push @return, delete($self->{VALUES}->{$_});
		push @return, $self->delink($self->{FEATURES}->children($_));
	}
	return @return;
}

sub all_values {
	my $self = shift;

	# Get the real values for each feature
    my %h = map { $_ => ${$self->{VALUES}->{$_}} } keys %{$self->{VALUES}};
    return wantarray ? %h : \%h;
}

sub spell {
	my ($self) = @_;

	return err "No symbol set defined for spell()" if not $self->{SYMBOLS};
    return $self->{SYMBOLS}->spell($self);
}

sub duplicate {
	my $self = shift;
	return $self->new(undef, { $self->all_values });
}

sub clear {
	my $self = shift;
	$self->{VALUES} = {};
	return 1;
}

# Allows you to call changes to feature settings directly
# with syntax like $segment->feature_name($value)
our $AUTOLOAD;
sub AUTOLOAD {
	my $feature = $AUTOLOAD;
	$feature =~ s/.*:://;
    my $self = shift;

    no strict 'refs';
    *$feature = sub {
        my $self = splice @_, 0, 1, $feature;
        $self->value(@_);
    };

	$self->$feature(@_);
}

sub DESTROY {}

1;

__END__