# $Source: /Users/clajac/cvsroot//Scripting/Scripting/Expose.pm,v $
# $Author: clajac $
# $Date: 2003/07/21 10:10:05 $
# $Revision: 1.10 $
package Scripting::Expose;
use Attribute::Handlers;
use Scripting::Expose::Class;
use Scripting::Expose::Function;
use strict;
my %Classes;
my %Functions;
my %Variables;
my %Packages;
sub is_valid_symbol {
my $sym = shift;
return $sym =~ /^[A-Za-z][A-Za-z0-9_]*$/ ? 1 : 0;
}
sub import {
shift;
die "Odd number of arguments in use\n" if(@_ & 1);
my %args = (@_);
my $pkg = (caller)[0];
# Class name
my $name = $pkg;
$name = $args{as} if(exists $args{as});
die "Undefined class name in '$pkg'\n" unless(defined $name);
die "Empty class name in '$pkg'\n" if($name eq '');
die "Unsupported class name '$name' in '$pkg'\n" unless(is_valid_symbol($name));
# For categories
my $to;
if (exists $args{to}) {
$to = $args{to};
die "To must be a scalar or an ARRAY reference in '$pkg'\n" unless(ref $to eq '' || ref eq 'ARRAY');
$to = [$to] unless(ref $to);
for (@$to) {
die "Invalid to '$_' in '$pkg'\n" unless(is_valid_symbol($_));
}
} else {
$to = [qw(_Global)];
}
$Packages{$pkg} = {} unless(ref $Packages{$pkg} eq 'HASH');
$Packages{$pkg}->{$_} = 1 for(@$to);
if ($name) {
my $class = Scripting::Expose::Class->new($name, $pkg);
if (exists $Classes{$class->package} && $class->package ne $pkg) {
die "Class '@{[$class->class]}' already in package '@{[$class->package]}'\n";
}
$Classes{$class->package} = $class;
unless (exists $Functions{$pkg}) {
my $func_table = Scripting::Expose::Function->new();
$Functions{$pkg} = $func_table;
}
}
1;
}
sub _process {
my ($pkg, $symbol, $ref, $handler, $options, $phase) = @_;
die "Can't expose anonymous subrutines\n" if($symbol eq 'ANON');
die "Invalid symbol '$symbol'\n" unless(ref $symbol eq 'GLOB');
my ($name) = *$symbol =~ /^.*::(.*)$/;
my $orig_name = $name;
my $secure = 0;
if ($options) {
die "Odd number of arguments to '$handler' in '$pkg'\n" if(ref $options ne 'ARRAY' || @$options & 1);
my %args = (@$options);
if (exists $args{as} && ($name = $args{as})) {
die "Undefined name for '$orig_name' in '$pkg'\n" unless(defined $name);
die "Empty name for '$orig_name' in '$pkg'\n" if($name eq '');
die "Unsupported name '$name' for '$orig_name' in '$pkg'\n" unless(is_valid_symbol($name));
}
if (exists $args{secure}) {
die "Unsupported security '$args{secure}' for '$orig_name' in '$pkg'\n" unless($args{secure} =~ /^arguments$/);
$secure = $args{secure};
}
}
die "Package '$pkg' not bound as class\n" if($handler =~ /Method$/ && not exists $Classes{$pkg});
if($handler eq 'Constructor') {
die "Constructor already defined in '$Classes{$pkg}->{class}'\n" if($Classes{$pkg}->has_constructor());
die "Can't mix Contstructor/InstanceMethod with ClassMethods in '$pkg'\n" if($Classes{$pkg}->is_class_object());
$Classes{$pkg}->add_constructor($ref,$secure);
} elsif($handler eq 'ClassMethod') {
die "ClassMethod '$name' already bound in '$Classes{$pkg}->{class}'\n" if($Classes{$pkg}->has_method($name));
die "Can't mix ClassMethods with Constructor/InstanceMethod in '$pkg'\n" if($Classes{$pkg}->is_instance_object());
$Classes{$pkg}->add_class_method($name, $ref, $secure);
} elsif ($handler eq 'InstanceMethod') {
die "InstanceMethod '$name' already bound in '$Classes{$pkg}->{class}'\n" if($Classes{$pkg}->has_method($name));
die "Can't mix Contstructor/InstanceMethod with ClassMethods in '$pkg'\n" if($Classes{$pkg}->is_class_object());
$Classes{$pkg}->add_instance_method($name, $ref, $secure);
} elsif ($handler eq 'Function') {
$Functions{$pkg}->add_function($name, $ref, $secure);
}
}
sub UNIVERSAL::Constructor : ATTR(CODE) {
my ($pkg, $symbol, $ref, $handler, $options, $phase) = @_;
_process($pkg, $symbol, $ref, 'Constructor', $options, $phase);
}
sub UNIVERSAL::ClassMethod : ATTR(CODE) {
my ($pkg, $symbol, $ref, $handler, $options, $phase) = @_;
_process($pkg, $symbol, $ref, 'ClassMethod', $options, $phase);
}
sub UNIVERSAL::InstanceMethod : ATTR(CODE) {
my ($pkg, $symbol, $ref, $handler, $options, $phase) = @_;
_process($pkg, $symbol, $ref, 'InstanceMethod', $options, $phase);
}
sub UNIVERSAL::Function : ATTR(CODE) {
my ($pkg, $symbol, $ref, $handler, $options, $phase) = @_;
_process($pkg, $symbol, $ref, 'Function', $options, $phase);
}
sub has_namespace {
my ($pkg, $ns) = @_;
for (values %Packages) {
return 1 if(exists $_->{$ns});
}
0;
}
sub functions_for_namespace {
my ($self, $ns) = @_;
my @func;
for(grep { exists $Packages{$_}->{$ns} } keys %Packages) {
push @func, $Functions{$_}->functions;
}
return @func;
}
sub classes_for_namespace {
my ($self, $ns) = @_;
my @classes;
for(grep { exists $Packages{$_}->{$ns} } keys %Packages) {
push @classes, $Classes{$_};
}
return @classes;
}
1;