File Coverage

blib/lib/bitflag/ct.pm

Criterion	Covered	Total	%
statement	69	101	68.3
branch	32	58	55.1
condition	0	3	0.0
subroutine	10	16	62.5
pod	0	5	0.0
total	111	183	60.6

package bitflag::ct;

use 5.008007;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT_OK = qw ( getmask );
our @EXPORT = qw( );
our $VERSION = 0.01;

no strict 'refs';

my %pkgDefaultHandle;
my ($caller);

    sub inithandle    # constructor
    {
        my $class = shift;
        my $option = takeHASH(shift);
        $option->{sm} = delete $option->{startmask}  if exists $option->{startmask};
        $option->{sm} = 1 unless exists $option->{sm};
        bless { option=>$option, flagmap => {}}, $class;
    }

{
    sub takeHASH
    {
        my $v = shift;
        ref($v) eq 'HASH' ? $v : ref($v) eq 'ARRAY' ? {@$v} : undef;
    }

    sub casealias
    {
        {
            'uc'        => sub {uc $_[0]},
            'ucfirst'   => sub {ucfirst $_[0]},
            'lc'        => sub {lc $_[0]},
        }
    }
}

sub import
{
    my $class = shift;
    $caller = caller; # i.e. = caller[0]
    my $option = takeHASH ($_[0]);

    if ( defined $option )
    {
        shift;
        # for compatibility wrt. "package bitflag"
        if ( $option->{ic} ) { $option->{alias} = 'uc' }
        if ( exists $option->{alias} )
        {
            if (exists casealias->{$option->{alias}} )
            {
                $option->{alias} = casealias->{$option->{alias}}
            }
            elsif (defined $option->{alias})
            {
                die sprintf('$option->{alias}=%s must be a CODE',$option->{alias})
                unless ref($option->{alias}) eq 'CODE';
            }
        }
    }


    *{$caller.'::getmask'} = \&{$class.'::getmask'}
        unless defined *{$caller.'::getmask'};

    my $handle;
    my $handle_isnew; # = 0;

    if ( exists $option->{handle} )
    {
        my $refhandle= delete $option->{handle};
#        die "handle=>$refhandle must be a ref\n" unless ref($refhandle);

        if
        (
            $handle_isnew =
            ref($refhandle)? ref($$refhandle) ne $class : !defined(*{$caller.'::'.$refhandle})
        )
        {
            #  create and call import with handle

            if ( $option->{default} && exists $pkgDefaultHandle{$caller} )
            {
                delete $option->{default};
                $option = {%{$pkgDefaultHandle{$caller}{option}},@$option}
            }

            # create new $handle by constructor
            $handle = $class->inithandle($option);

            if (ref($refhandle))
            {
                # usage case : handle => \$variable_for_handle
                $$refhandle = $handle;
            }
            else
            {
                # usage case : handle => 'symbolname_for_handle'
                *{$caller.'::'.$refhandle} = sub () {$handle};
            }
        }
        else
        {
            # recall import with already created handle

            if (ref($refhandle))
            {
                # usage case : handle => \$variable_for_handle
                $handle = $$refhandle;
            }
            else
            {
                # usage case : handle => 'symbolname_for_handle'
                $handle = &{$caller.'::'.$refhandle};
            }
        }
    }
    else
    {
        if ($handle_isnew = !(exists $pkgDefaultHandle{$caller}))
        {
            $handle = $class->inithandle($option);
            $pkgDefaultHandle{$caller} = $handle;

        }
        else
        {
            $handle = $pkgDefaultHandle{$caller};
        }
    }

    unless ($handle_isnew)
    {
#       @{$handle->{option}}{keys %$option} = values %$option;
#       but as 'sm' is the only key to be considered ..
        if ( exists $option->{sm} )
        {
            $handle->{option}{sm} = $option->{sm};
        }
        $option = $handle->{option};
    }

    return unless @_;
    my $mask = ($_[0] =~ qr{\A\d+\Z}) ? shift : $option->{sm};
    my $alias = $handle->{option}{alias};

    foreach my $flagname (@_)
    {
        if ( exists ${$caller.'::'}{$flagname} )
        {
            my $elsecode = \&{$caller.'::'.$flagname};
            undef *{$caller.'::'.$flagname};
            delete ${$caller.'::'}{$flagname};
            *{$caller.'::'.$flagname} =
            sub
            {
                my ($context) = @_;
                $context==$handle ? $mask : $elsecode->(@_);
            };

#            print "\$mask=$mask\t\$elsecode=$elsecode =run=> ".&$elsecode."\n";
        }
        else
        {
            *{$caller.'::'.$flagname} = sub {$mask};
        }
        $handle->{flagmap}{defined $alias ? $alias->($flagname) : $flagname} = $mask;
        $mask <<= 1
    }

    $handle->{option}{sm} = $mask;
}

    sub getmask
    {
        my $cand = shift;
        my $handle = ref($cand) ? $cand : $pkgDefaultHandle{$cand};
        die 'getmask needs a preceding "use bitflag::ct"' unless defined $handle;
        undef $cand;
        my $option= $handle->{option};
        my $r = 0;
        my $alias= $option->{alias};
        my $nameslist = defined $alias ? [map $alias->($_),@_] : \@_;
        foreach my $v (@$nameslist)
        {
            if ( exists $handle->{flagmap}{$v} )
            {
                $r |= $handle->{flagmap}{$v}
            }
            else
            {
                warn "unknown flagname: $v\n";
            }
        }
        $r
    }

    sub pkghandle
    {
        $pkgDefaultHandle{$_[1]}
    }

1;
__END__