File Coverage

blib/lib/ctflags.pm

Criterion	Covered	Total	%
statement	64	80	80.0
branch	10	18	55.5
condition			n/a
subroutine	16	19	84.2
pod	2	7	28.5
total	92	124	74.1

package ctflags;

our $VERSION = '0.04';

use 5.006;

use strict;
use warnings;

use Carp;

use ctflags::memory;
use ctflags::check;

use constant PREFIX => "ctflag_";

# set and get functions are wrappers around
# ctflags::memory::(set|get)_ctflag, wrappers capture errors an report
# them via croak

sub set ($$$ ) {
  eval { &set_ctflag };
  if ($@) { chomp $@; croak $@ };
}

sub get ($$ ) {
  my $r=eval { &get_ctflag };
  if ($@) { chomp $@; croak $@ };
  return $r;
}


# parse_flags breaks a string defining a flag set maybe with default
# values. If strings is '*' it expand it to all the flags allowed in
# the namespace (allowed ctflags are not the flags defined but the
# ones configured with ctflags::memory::restrict_ctflags() subrutine).

sub parse_flags ($$) {
  my ($ns, $flags)=@_;
  return allowed_ctflags($ns)
    if $flags eq '*';

  return ($flags=~/\G$flag_re$value_re?/go)
}


# export_sub creates the constant subrutine in the given package

sub export_sub ($$$ ) {
  my $qname=$_[0].'::'.$_[1];
  my $value=$_[2];

  no strict 'refs';
  *$qname = sub () { $value };
}

sub export_subsub ($$$ ) {
  my $qname=$_[0].'::'.$_[1];
  my $sub=$_[2];

  no strict 'refs';
  *$qname = $sub
}

# export_ctflags_as combine ctflag set with arithmetic or and export
# constant with the resulting value

sub export_ctflags_as ($$$$) {
  my ($package, $ns, $flags, $name)=@_;
  my $acu=0;
  $acu|=get_ctflag($ns, $_) foreach (parse_flags $ns, $flags);
  export_sub $package, $name, $acu;
}


# export every flag specified in $flags as package::prefix_flag

sub export_ctflags ($$$$) {
  my ($package, $ns, $flags, $prefix)=@_;
  foreach my $fe (parse_flags $ns, $flags) {
    my ($f)=split '', $fe;
    my $v=get_ctflag($ns, $fe);
    my $sub=get_ctflag_call($ns, $f);
    if ($sub) {
      export_subsub $package, $prefix,
	sub () {&$sub($ns, $f, $v); $v}
    }
    else {
      export_sub $package, $prefix.$f, $v;
    }
  }
}


# see pod docs below for import description.

sub import {
  my $self=shift;
  my $prefix=PREFIX; # prefix to use until another one is defined.
  my ($package)=caller; # by default constants are exported to calling
                        # package
  eval {
    while (@_) {
      my $key=shift;
      if (my ($name, $ns, $flags)=
	  $key=~m{^              # all the string should match.
	  (?:($identifier_re)=)? # name for the constant, optional.
	  ($ns_re)               # namespace.
	  :                      # namespace/flags separator ':'
	  (
	   \*                    # asterisk
	   |                     # or
	   (?:$flag_re           # flag name
	    $value_re?)          # maybe with default value,
	   *                     # several allowed
	  )$
	  }xo ) {
	# option is a ctflags -> constants conversion specification.
	if ($name) {
	  export_ctflags_as($package, $ns, $flags, $name)
	}
	else {
	  export_ctflags($package, $ns, $flags, $prefix)
	}
      }
      elsif ($key eq 'prefix') {
	$prefix=shift;
	check_cntprefix $prefix;
      }
      elsif ($key eq 'package') {
	$package=shift;
	check_package $package;
      }
      else {
	die "unknow option or invalid ctflags specification '$key'\n";
      }
    }
  };
  if ($@) { chomp $@; croak $@ };
}


1;
__END__