package Win32::FreeStanding;

# 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 ($) {
    package main;
    eval $_[0];
}

my $DEBUG = 0;
#use Cwd;

sub my_require (*) {
    my $name = shift;
    my ($pkg, $file, $line) = caller;

    warn "require $name from $pkg at $file line $line\n" if $DEBUG;

    # normalize to forward slashes
    $name =~ s|\\|/|g;

    # accidental cwd translation (XXX fix the source of this!)
    if ($name =~ s|^\./(\w:)|$1|) {
	warn "\$name changed\n" if $DEBUG;
    }

    if ($name =~ /^\x5/) {
#	warn "interpreted as require vx.x.x\n" if $DEBUG;
	if ($^V lt $name) {
	    my $name = sprintf("v%vd", $name);
	    my $version = sprintf("v%vd", $^V);
	    my ($callpkg, $callfile, $callline) = caller;
	    die "Perl v$name required--this is only v$version, stopped at $callfile line $callline\n";
	}
	return 1;
    }
    # if arg is bare number do version-check        
    elsif ($name =~ /^(\d)(\.\d{3}(\d{2})?)*/) {
#	warn "interpreted as require x.x\n" if $DEBUG;
	if ($name > $]) {
	    my ($callpkg, $callfile, $callline) = caller;
	    die "Perl v$name required--this is only v$], stopped at $callfile line $callline\n";
	}   
	return 1;
    }
    # see if it is a module name
    elsif ($name =~ /^([A-Za-z_]\w*::)*[A-Za-z_]\w*$/) {
#	warn "interpreted as require filename\n" if $DEBUG;
	$name =~ s|::|/|g;
        $name .= ".pm";
    }
    # treat it as a filename
    warn "$name, $pkg\n" if $DEBUG;

    # check if we have already loaded the file
    if (exists $INC{$name}) {
	warn "$name already loaded\n" if $DEBUG;
	return 1;
    }

    if (load_file($name, $pkg, 1)) {
	return 1;
    }
    else {
	warn "Couldn't load $name\n" if $DEBUG;
    }

    # this error text has to match the one output by perl.
    # Tk depends on this!
    die "Can't locate $name in \@INC (\@INC contains: @INC) at $file line $line.\n";
}

sub my_do ($) {
    my $name = shift;
    my ($pkg, $file, $line) = caller;

    warn "do $name from $pkg at $file line $line\n" if $DEBUG;

    # normalize to forward slashes
    $name =~ s|\\|/|g;

    # accidental cwd translation (XXX fix the source of this!)
    $name =~ s|^\./(\w:)|$1|;

    # if arg is bare number do version-check
    if (($name =~ /^(\d)(\.\d{3}(\d{2})?)*/)) {		
	if ($name > $]) {
	    die "Perl version $name required, this is only version $]\n";
	}
	return 1;
    }

    return 1 if load_file($name, $pkg, 0);

    # this error text has to match the one output by perl.
    # Tk depends on this!
    die "Can't locate $name in \@INC (\@INC contains: @INC) at $file line $line.\n";
}

sub find_path_in_INC {
    my $name = shift;

    foreach my $val (@INC) {
	my $fullname = $val . "/" . $name;
	if ((-e $fullname) && !(-d $fullname)) {
	    if ($fullname =~ m|^//|) {
		$fullname =~ s|//|/|g;		# remove doubled forward slashes
		$fullname = "/" . $fullname;	# readd first forward slash
	    }
	    else {
		$fullname =~ s|//|/|g;		# remove doubled forward slashes
	    }
	    return $fullname;
	}
    }
    warn "Couldn't locate: $name in \@INC\n" if $DEBUG;
    return undef;
}

sub load_file {
    my $path = shift;
    my $caller_pack = shift;
    my $fail_if_false = shift;
    my $fullpath;
    my $contents;
    my $retval;

    $contents = GetModule($path) if defined &GetModule;

    # Special case for Win32::Resource
    if($path eq 'Win32/Resource.pm') {
	(my $partial = $path) =~ s:(.*)/(.*)\.pm$:auto/$1/$2/$2.dll:i;
	if($fullpath = find_path_in_INC($partial)) {
	    $Win32::FreeStanding_Builder::xsHash{$partial} = $fullpath;
	}
    }

    if (defined $contents) {
	$fullpath = $path;
	$contents = "package $caller_pack;\n#line 1 \"$path\"\n$contents";
    }
    else {
	$contents = "package $caller_pack;\n#line 1 \"$path\"\n";
	if ($path =~ m#^([A-Z]:)?/#i or $path =~ m#^\.?\./#) {
	    $fullpath = $path;
	}
	else {
	    $fullpath = find_path_in_INC($path);
	    $fullpath = $path unless defined $fullpath;
	}

	if (open(MODULE, "<$fullpath")) {
	    {
		local $/;
		$contents .= <MODULE>;
		close MODULE;
	    }
	}
	else {
	    # kludge to set errno appropriately
	    my $junk = (-f $fullpath and -r $fullpath);
	    return 0;
	}
    }
    $INC{$path} = $fullpath;
    
    # disable warnings for eval
    {
	local $^W = 0;
	local $SIG{__WARN__} = sub {
	    warn $_[0] unless $_[0] =~ /^Unquoted string "[^"]+" may clash/;
	};
	$retval = safe_eval($contents);
    }

#XXX This is an attempt to fix a bug doing a chdir and then a require
#although PerlApps compile with this, they do not execute :( 
=pod

    if ($INC{$path} =~ /^\.\//) {
	warn "$path to $INC{$path}\n";    
	Win32::SetCwd(cwd());    
	$INC{$path} = cwd() . "/$path";
	warn "$path to $INC{$path}\n";    
    }
=cut

    if ($@) {
	delete $INC{$path};
	die $@;
    }
    
    if ($fail_if_false and !$retval) {
	delete $INC{$path};
	die "$path did not return a true value.\n";
    }
    warn "\$INC{'$path'} = '$fullpath'\n" if $DEBUG;
    return 1;
}

BEGIN {
    *{"CORE::GLOBAL::require"}	= \&my_require;
    *{"CORE::GLOBAL::do"}	= \&my_do;
}

1;
