291 lines
7.3 KiB
Perl
291 lines
7.3 KiB
Perl
######################################################################
|
|
# File : Win32/FreeStanding_Builder.pm
|
|
# Author : James A. Snyder (James@ActiveState.com)
|
|
# Copyright : Copyright (c) 1998 ActiveState Tool Corp.
|
|
######################################################################
|
|
|
|
package Win32::FreeStanding_Builder;
|
|
|
|
######################################################################
|
|
|
|
# NOTE: do not declare any lexicals before here. safe_eval() is meant
|
|
# to provide a clean lexical environment for the code to execute.
|
|
|
|
sub safe_eval ($) {
|
|
eval $_[0];
|
|
}
|
|
|
|
my %xsHash;
|
|
my $old_dynaloader_bootstrap;
|
|
#my $DEBUG = 0;
|
|
|
|
######################################################################
|
|
|
|
sub bootstrap {
|
|
CheckExtension(@_);
|
|
return &$old_dynaloader_bootstrap(@_);
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub require (*) {
|
|
my $name = shift;
|
|
my $szPkg = (caller)[0];
|
|
my $szName;
|
|
my $szTemp;
|
|
my $bOK = 0;
|
|
my $szPath;
|
|
my $szPackage;
|
|
|
|
# XXX Since build 512, $name could be a GLOBref if and only if a
|
|
# glob was explicitly passed. Barewords and strings are passed
|
|
# through as is. So this check only exists for the sake of
|
|
# earlier versions.
|
|
if ( ref($name) eq 'GLOB' ) {
|
|
$szName = "$$name";
|
|
$szName =~ s/^\*((main)?(\Q$szPkg\E)?(::)?)//; # remove leading garbage
|
|
}
|
|
else {
|
|
$szName = $name;
|
|
}
|
|
|
|
# accidental cwd translation
|
|
# XXX fix the source of this
|
|
$szName =~ s|^\./(\w:)|$1|;
|
|
$szPackage = $szName;
|
|
|
|
#warn "require $szName\n" if $DEBUG;
|
|
|
|
# if arg is bare number do version-check
|
|
if (($szName =~ /^(\d)(\.\d{3}(\d{2})?)*/)) {
|
|
if ($szName > $]) {
|
|
die "Perl version $name required, this is only version $]\n";
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# check if we have already loaded the module
|
|
$szTemp = $szPkg . '::' . $szName;
|
|
if (HasModuleBeenLoaded($szName) || HasModuleBeenLoaded($szTemp) ) {
|
|
return 1;
|
|
}
|
|
|
|
if ($szName =~ /(\.al|\.ix)$/i) {
|
|
if (BringInFile($szName, $szPackage, 0)) {
|
|
return 1;
|
|
}
|
|
else {
|
|
# this error text has to match the one output by perl.
|
|
# Tk depends on this!
|
|
die "Can't locate $szName in \@INC (\@INC contains: @INC)";
|
|
}
|
|
}
|
|
elsif (($szPath=FindModule($szName))
|
|
|| ($szPath=FindModule("$szPkg/$szName")))
|
|
{
|
|
if (BringInFile($szPath, $szPackage, 1)) {
|
|
return 1;
|
|
}
|
|
else {
|
|
# this error text has to match the one output by perl.
|
|
# Tk depends on this!
|
|
die "Can't locate $szName in \@INC (\@INC contains: @INC)";
|
|
}
|
|
}
|
|
|
|
die "use $szName Failed\n";
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub do ($) {
|
|
my $szName = shift;
|
|
my $szPath = FindFileUsingINC($szName);
|
|
|
|
if (!$szPath or !open( MODULE, $szPath )) {
|
|
# kludge to set errno appropriately
|
|
my $junk = (-f $szName and -r $szName);
|
|
return undef;
|
|
}
|
|
else {
|
|
$::INC{$szName} = $szPath;
|
|
my @content = ("\n#line 1 \"$szPath\"\n", <MODULE>);
|
|
close( MODULE );
|
|
my $szContent = join( "", @content );
|
|
safe_eval( $szContent );
|
|
die $@ if $@;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
######################################################################
|
|
# called in cpp module
|
|
sub GetXShash {
|
|
return \%xsHash;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub HasModuleBeenLoaded {
|
|
my $szPackageName = shift;
|
|
return 0 if $szPackageName =~ /Win32::Resource/i;
|
|
|
|
my $szModuleName = $szPackageName . ".pm";
|
|
$szModuleName =~ s|::|/|g;
|
|
|
|
return 1 if exists $::INC{$szModuleName};
|
|
return 0;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub FindModule {
|
|
# if the module is a complete name don't append the .pm
|
|
my $packageName = shift;
|
|
$packageName =~ s|::|/|g;
|
|
|
|
my $moduleName = FindFileUsingINC($packageName);
|
|
return $moduleName if (defined $moduleName);
|
|
$packageName .= ".pm";
|
|
return FindFileUsingINC($packageName);
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub FindFileUsingINC {
|
|
my $fileName = shift;
|
|
|
|
foreach my $val (@INC) {
|
|
my $temp = $val . "/" . $fileName;
|
|
if ((-e $temp) && !(-d $temp)) {
|
|
$temp =~ s|\\|/|g; # normalize to forward slashes
|
|
return $temp;
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub BringInFile {
|
|
my $szPath = shift;
|
|
my $szPackage = shift;
|
|
my $bAdd2Inc = shift;
|
|
|
|
if (open(MODULE, $szPath)) {
|
|
$szPath =~ s|\\|/|g; # normalize to forward slashes
|
|
my $szModuleName = '';
|
|
my @content = ("\n#line 1 \"$szPath\"\n", <MODULE>);
|
|
my $szContent = join( "", @content );
|
|
close(MODULE);
|
|
|
|
# warn "enter $szPath\n" if $DEBUG;
|
|
|
|
if ($bAdd2Inc) {
|
|
# add the full module path the %INC
|
|
$szPath =~ /(lib|LIB|\.)\/(.*)$/;
|
|
$szModuleName = $2;
|
|
# XXX the following kludge removes $archname
|
|
$szModuleName =~ s|^.*\Q$^O\E.*/||i if $^O;
|
|
$::INC{$szModuleName} = $szPath;
|
|
}
|
|
|
|
safe_eval($szContent);
|
|
|
|
# warn "leave $szPath\n" if $DEBUG;
|
|
|
|
if ($@) {
|
|
if ($bAdd2Inc) {
|
|
delete $::INC{$szModuleName};
|
|
}
|
|
die $@;
|
|
}
|
|
|
|
if ($szPackage eq 'DynaLoader') {
|
|
$old_dynaloader_bootstrap = \&DynaLoader::bootstrap;
|
|
*{"DynaLoader::bootstrap"} = \&Win32::FreeStanding_Builder::bootstrap;
|
|
}
|
|
|
|
CheckExtension($szPackage);
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub HandleDoRequireStatements {
|
|
return 0 if @_ != 1;
|
|
|
|
my $szScript = shift;
|
|
my @script = split /\n/, $szScript;
|
|
foreach my $line (@script) {
|
|
# XXX enormous kludge
|
|
if ($line =~ /^\s*(do|require)\s+[\w:'"]+\s*(;|$)/) {
|
|
safe_eval($line);
|
|
die $@ if $@;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub CheckExtension {
|
|
my $szPackage = $_[0];
|
|
my $szVersion = $_[1];
|
|
my $index = 0;
|
|
my $szXSname = '';
|
|
my $szFullPath = '';
|
|
|
|
$szXSname = $szPackage;
|
|
$index = rindex($szXSname, "::");
|
|
if ($index >= 0) {
|
|
my $dir = substr($szXSname, $index+2);
|
|
$szXSname .= "/" . $dir;
|
|
}
|
|
else {
|
|
$szXSname .= "/" . $szXSname;
|
|
}
|
|
|
|
$szXSname =~ s|::|/|g;
|
|
$szXSname .= '.dll';
|
|
|
|
foreach my $val (@INC) {
|
|
$szFullPath = $val . "/auto/" . $szXSname;
|
|
if (-e $szFullPath) {
|
|
# Create Resource ID
|
|
my $szResID = '';
|
|
|
|
$szVersion = ${$szPackage . '::VERSION'} unless $szVersion;
|
|
|
|
$szResID = $szPackage;
|
|
if ($szVersion) {
|
|
$szVersion =~ s|\.|_|g;
|
|
$szResID .= '_' . $szVersion;
|
|
}
|
|
|
|
$szResID =~ s|::|_|g;
|
|
$szResID .= '.DLL';
|
|
$xsHash{$szResID} = $szFullPath;
|
|
return 1;
|
|
}
|
|
$szFullPath = '';
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
sub import {
|
|
*{"CORE::GLOBAL::require"} = \&Win32::FreeStanding_Builder::require;
|
|
*{"CORE::GLOBAL::do"} = \&Win32::FreeStanding_Builder::do;
|
|
CORE::require DynaLoader;
|
|
}
|
|
|
|
######################################################################
|
|
|
|
1;
|