File Coverage

blib/lib/ctflags/memory.pm

Criterion	Covered	Total	%
statement	34	77	44.1
branch	4	16	25.0
condition	3	5	60.0
subroutine	8	15	53.3
pod	0	10	0.0
total	49	123	39.8

package ctflags::memory;

our $VERSION = '0.01';

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# this package is supposed to be private to ctflags and companion
# packages, not used from any other module so it uses directly
# @EXPORT. Anyway, the function names used are not going to cause
# too many namespace pollution problems.
our @EXPORT = qw( set_ctflag
		  get_ctflag
		  restrict_ctflags
		  allowed_ctflags
		  is_ctflag_allowed
		  set_ctflag_alias
		  resolve_ctflag_alias
		  set_ctflag_call
		  get_ctflag_call );


use ctflags::check;

my %memory;
my %meta;
my %alias;
my %call;

# In most of ctflags subrutines, argument checking is done indirectly
# when subrutines here, in ctflags::memory are called, and so all of
# the public subrutines here implement checks for the validity of its
# arguments.
#
# Only helper functions which name begins with an underscore, like
# '_is_allowed' bellow, are exent from these checks and their use is
# discouraged outside this module


# checks that the use of a flag has not been forbided inside a
# namespace or dies.

sub _is_allowed ($$) {
  my ($ns, $flag)=@_;
  !exists $meta{$ns.':restricted'}
    or index($meta{$ns.':restricted'}, $flag)>=0
      or die "ctflag '$flag' is not allowed in namespace '$ns'\n";
}


# public interface for _is_allowed. Just checks for the validity of
# its arguments

sub is_ctflag_allowed ($$) {
  check_ns $_[0];
  check_flag $_[1];
  &_is_allowed
}


# change value of ctflag

sub set_ctflag ($$$ ) {
  my ($ns, $flag, $value)=@_;
  check_ns $ns;
  check_flag $flag;
  check_value $value;
  _is_allowed $ns, $flag;
  $memory{$ns.':'.$flag}=int($value);
}


# retrieve value of ctflag

sub get_ctflag ($$) {
  my ($ns, $flagext)=@_;
  check_ns $ns;
  my ($flag, $default)=$flagext=~/($flag_re)($value_re)?/o;
  check_flag $flag;
  check_value $default;
  _is_allowed $ns, $flag;
  my $m=$memory{$ns.":".$flag};
  int(defined $m ? $m : ($default || 0));
}

sub extend_flagsetext ($$) {
  my ($fse, $ns)=@_;
  check_ns($ns);
  check_flagsetext($fse);

  if ($fse eq '*') {
    return join ('', allowed_ctflags($ns))
  }

  if ($fse=~/^!(.*)/) {
    my $inv=$1;
    return join('',
		(grep {index($inv, $_)<0 } allowed_ctflags($ns)));
  }

  return $fse;
}

# restrict which ctflags are allowed inside a namepace


sub restrict_ctflags ($$) {
  my $ns=shift;
  check_ns $ns;
  my $flagset=extend_flagsetext(shift, $ns);
  $meta{$ns.':restricted'}=$flagset;
}


# returns an array with the allowed ctflags inside a namespace

sub allowed_ctflags ($ ) {
  my $ns=shift;
  check_ns $ns;
  return split('', $meta{$ns.':restricted'})
    if (exists $meta{$ns.':restricted'});
  return ('a'..'z','A'..'Z')
}


# creates an alias (long name composed of more than one letter) for a
# ctflag

sub set_ctflag_alias ($$$ ) {
  my ($ns, $alias, $flag)=@_;
  check_alias $alias;
  check_ns $ns;
  unless (defined $flag) {
    delete $alias{$ns.':'.$alias};
    return
  }
  check_flag $flag;
  _is_allowed $ns, $flag;
  $alias{$ns.':'.$alias}=$flag;
}


# returns the value of an aliased ctflag from its alias name

sub resolve_ctflag_alias ($$) {
  my ($ns, $alias)=@_;
  check_ns $ns;
  check_alias $alias;
  exists $alias{$ns.':'.$alias}
    or die "ctflag alias '$alias' not defined in namespace '$ns'\n";
  return get_ctflag($ns, $alias{$ns.':'.$alias});
}

sub set_ctflag_call ($$$) {
  my ($ns, $flagsetext, $sub)=@_;
  check_ns $ns;
  my $flags=extend_flagsetext($flagsetext, $ns);
  check_sub $sub;
  foreach my $f (split //, $flags) {
    _is_allowed $ns, $f;
    $call{$ns.':'.$f}=$sub;
  }
}

sub get_ctflag_call ($$) {
  my ($ns, $flag) =@_;
  check_ns($ns);
  check_flag($flag);
  my $n=$ns.':'.$flag;
  if (exists $call{$n}) {
    return $call{$n};
  }
  return undef;
}

1;
__END__