Module::Pragma - Support for implementation of pragmas

Module-Pragma documentation Contained in the Module-Pragma distribution.

Index

Code Index:

NAME

Top

Module::Pragma - Support for implementation of pragmas

SYNOPSIS

Top

	# Foo.pm
	package Foo;
	use base qw(Module::Pragma);

	__PACKAGE__->register_tags(qw(-SHA1 -MD5));
	__PACKAGE__->exclusive_tag( __PACKAGE__->tags );

	sub something
	{
		# ...
		if(__PACKAGE__->enabled(-SHA1)){
			$mod = 'Digest::SHA1';
		}
		elsif(__PACKAGE__->enabled(-MD5)){
			$mod = 'Digest::MD5';
		}
		else{
			$mod = $Digest_Default;
		}
		# ...
	}
	# ...
	1;
	__END__

	# foo.pl
	use Foo;

	Foo->something(); # Foo->enabled(-SHA1) is true
	{
		use Foo -MD5;
		Foo->something(); # Foo->enabled(-MD5) is true
	}
	Foo->something(); # Foo->enabled(-SHA1) is true

	# ...

DESCRIPTION

Top

With perl 5.10.0 you can write lexical pragma modules, which influence some aspect of the compile time or run time behavior of Perl programs. Module::Pragma helps to write such a module.

Module::Pragma supports bitmask-based options. That is, a subpragma takes only a bool, true or false. And a pragma uses an integer for its storage, so the number of subpragmas is limited to at most 32 or 64 (depends on the perl integer size).

How to set it up

Module::Pragma is designed as Object-Oriented and all the methods are class methods.

First, load the module and set it a super class.

	package mypragma;
	use base qw(Module::Pragma);

Next, register subpragmas (called tags in this module) with register_tags() method.

	__PACKAGE__->register_tags(qw(foo bar baz));

You can also make a bundle of tags with register_bunlde() method.

	__PACKAGE__->register_bundle('foobar' => ['foo', 'bar']);

To make some tags exclusive, call regsiter_exclusive() method.

	__PACKAGE__->register_exclusive('foo', 'baz');

Here you have finished setting up a new pragma. It's used like other pragmas.

	use mypragma 'foo';
	use mypragma 'baz';     # 'foo' and 'baz' are exclusive;
	                        #  'foo' removed and 'baz' set on.
	use mypragma ':foobar'; # 'baz' removed ,and 'foo' and 'bar' set on.

This pragma requires explicit arguments and refuses unknown tags by default.

	use mypragma;        # die!
	use mypragma 'fooo'; # die!

If you don't want this behavior, you can override default_import() and unknown_tag().

METHODS

Top

Registration of tags

PRAGMA->register_tags(tagname [ => flag] [, more tags ...])

Registers tags and returns the last value of tags. Each tag is assigned to a bitmask automatically unless othewise specified.

For example:

	PRAGMA->register_tags(
		'A' =>   0b00100,
		'B',   # 0b01000
		'C',   # 0b10000
		'D' =>   0b00001,
		'E',   # 0b00010
	); # -> returns 0b00010 (corresponding to 'E')

Cannot register those which begin with triple underscores, because they are reserved for Module::Pragma internals.

PRAGMA->register_bundle(bundlename => tags...)

Makes a bundle of tags. To use the bundle, add a semicolon to the bundlename as a prefix.

PRAGMA->register_exclusive(tags...)

Declares tags exclusive. Exclusive tags are not specified simultaneously.

Checking Effects

PRAGMA->enabled(tags...)

Checks at the run time whether tags are in effect. If no argument is supplied, it returns the state of PRAGMA.

When scalar context (including bool context) is wanted then it returns an integer, otherwise it returns a list of the tags enabled;

use/no Directives

Module::Pragma itself do nothing on import() nor unimport(). They work only when called as methods of subclass;

These two methods call check_exclusive(), so if exclusive tags are supplied at the same time, it will cause _die().

PRAGMA->import(tags...)

Enables tags and disables the exclusive tags.

If no argument list is suplied, it calls default_import(), and if it doesn't _die() then it will use the return value as the arguments.

PRAGMA->unimport(tags...)

Disables tags and enables the exclusive tags.

if no argument is suplied, it disables all the effect.

Handling Exception

There are some exception handlers which are overridable.

PRAGMA->default_import( )

Called in import() when the arguments are not supplied. It will _die() by default. So if needed, you can override it. The return values are used as the arguments of import().

PRAGMA->unknown_tag(tagname)

Called in tag() when an unknown tagname is found. It will _die() by default. To change the behavior, override it. Expected to return an integer used as a bitmask.

Utilities

Module::Pragma provides pragma module authors with utilities.

PRAGMA->hint([level_to_go_back])

Returns the state of PRAGMA.

PRAGMA->_die(messages...)

Loads Carp.pm and calls croak() with PRAGMA and messages.

PRAGMA->tag(tagname)

Returns the bitmask corresponding to tagname.

If tagname is unregistered, it will call unknown_tag() with tagname.

PRAGMA->tags( )

Returns all the registered tags.

Note that tags beginning with double underscores are ignored.

PRAGMA->pack_tags(tags...)

Returns the logical sum of tags.

PRAGMA->unpack_tags(bits)

Returns the names of tags corresponding to bits.

PRAGMA->exclusive_tags(tags...)

Returns tags which are exclusive to tags.

PRAGMA->check_exclusive(tags...)

Checks whether tags are exclusive and if so, causes _die().

EXAMPLES

Top

An implementation of less.pm

The minimal implementation of less.pm would be something like this:

	package less;
	use base qw(Module::Pragma);
	sub default_import{
		return 'please';
	}
	sub unknown_tag{
		my($class, $tag) = @_;
		return $class->register_tags($tag);
	}
	1; # End of file

This is almost equal to the standard less.pm module (but the interface is a little different).

	require less;
	sub foo{
		if(less->enabled()){
			foo_using_less_resource();
		}
		else{
			foo_using_more_resource();
		}
	}

	{
		use less; # or use less 'CPU' etc.
		foo(); # in foo(), less->enabled() returns true
	}
	foo(); # less->enabled() returns false

BUGS

Top

Please report bugs relevant to Module::Pragma to <gfuji(at)cpan.org>.

SEE ALSO

Top

See perlpragma for the internal details.

AUTHOR

Top

Goro Fuji (藤 吾郎) <gfuji(at)cpan.org>

COPYRIGHT AND LICENSE

Top

Copyright (c) 2008 Goro Fuji.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

Module-Pragma documentation Contained in the Module-Pragma distribution. 
package Module::Pragma;

use 5.010_000;

use strict;
use warnings;

#use Smart::Comments; # for debugging

our $VERSION = '0.02';

my %register  = ();

sub import
{
	my $class = shift @_;

	return if $class eq __PACKAGE__;

	@_ = $class->default_import() unless @_;

	### import: \@_, join ' ', caller

	$class->check_exclusive(@_);

	$^H{$class}  |=  $class->pack_tags(@_);
	$^H{$class}  &= ~$class->pack_tags( $class->exclusive_tags(@_) );
}

sub unimport
{
	my $class = shift @_;

	return if $class eq __PACKAGE__;

	### unimport: \@_, join ' ', caller

	if(@_){
		$class->check_exclusive(@_);

		$^H{$class}  |=  $class->pack_tags( $class->exclusive_tags(@_) );
		$^H{$class}  &= ~$class->pack_tags(@_);
	}
	else{
		delete $^H{$class};
	}
}

sub enabled
{
	my $class = shift @_;

	my $bits = $class->hint(1);

	$bits &= $class->pack_tags(@_) if @_;

	return wantarray ? $class->unpack_tags($bits) : $bits;
}

sub hint
{
	my($class, $level) = @_;

	my $hint_hash;
	my $bits;
	do {
		my $pkg;
		($pkg, $hint_hash) = ( caller ++$level )[0, 10];

		return undef unless defined $pkg;

	} until defined( $bits =  $hint_hash->{$class} );

	return $bits;
}

sub unknown_tag
{
	my($class, $tag) = @_;

	$class->_die("unknown subpragma '$tag'");
}


sub default_import
{
	my($class) = @_;

	$class->_die('requires explicit arguments');
}

sub _die
{
	my $class = shift @_;

	require Carp;
	Carp::croak("$class: ", @_);
}


sub register_tags
{
	my($class, @tags) = @_;

	my $map = $register{$class} //= {};

	my $bit_ref = \($map->{___bit___});


	while(defined(my $tag = shift @tags)){

		unless($$bit_ref){
			$$bit_ref = 1;
		}
		else{
			my $old = $$bit_ref;
			$$bit_ref <<= 1;

			#bitmask test
			if($$bit_ref == 0){
				__PACKAGE__->_die("$tag=($old << 1) is not a valid bitmask (integer overflowed?)");
			}
		}

		if($tag =~ /^___/){
			__PACKAGE__->_die("'$tag' is not a valid tag name");
		}

		if(@tags && $tags[0] =~ /^\d+$/){
			$$bit_ref = int shift @tags;
		}

		$map->{$tag} = $$bit_ref;

	}

	return $$bit_ref;
}

sub register_bundle
{
	my($class, $bundle, @tags) = @_;

	$register{$class}{':' . $bundle} = $class->pack_tags(@tags);
}

sub register_exclusive
{
	my $class = shift @_;

	my $ex = $register{$class}{___ex___} //= {};

	foreach my $x(@_){
		foreach my $y(@_){
			unless($x eq $y){
				push @ {$ex->{$x} }, $y;
				$ex->{$x, $y} = 1;
			}
		}
	}
}

sub exclusive_tags
{
	my $class = shift @_;

	my $ex = $register{$class}{___ex___} or return;

	my @ex_tags;
	my %seen;

	# expansion and regulation
	foreach my $tag(grep{ $ex->{$_} } map{ $class->unpack_tags( $class->tag($_) ) } @_)
	{
		push @ex_tags,
			grep{ !$seen{$_}++ } # uniq
			map { $class->unpack_tags( $class->tag($_) ) }
			@{ $ex->{$tag} };

	}
	return @ex_tags;
}
sub check_exclusive
{
	my $class = shift @_;

	my $ex = $register{$class}{___ex___} or return;

	# check whether these are exclusive
	foreach my $x(@_){
		foreach my $y(@_){
			$class->_die("'$x' and '$y' are exclusive mutually") if $ex->{$x, $y};
		}
	}
}

sub tag
{
	my($class, $tag) = @_;
	return $register{$class}{$tag} // $class->unknown_tag($tag);
}

sub tags
{
	my($class) = @_;

	my $map = $register{$class} or return;

	return grep{ not( /^:/ or /^__/ ) } keys %$map;
}


sub pack_tags
{
	my $class = shift @_;

	my $bits = 0;
	foreach my $tag(@_){
		$bits |= $class->tag($tag);
	}
	return $bits;
}
sub unpack_tags
{
	my($class, $bits) = @_;

	return unless defined $bits;

	return grep{ $class->tag($_) & $bits or $class->tag($_) == $bits } $class->tags;
}

1;
__END__