view release on metacpan or  search on metacpan

Scripting/Expose.pm  view on Meta::CPAN

# $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 '');