# Begin File: SafeGlobDemo.pl
#
use strict;
use warnings;

use Safe;

print "Running SafeGlobDemo\n";

do_list_files('*');


sub some_sub
{
}

sub do_list_files
{
    my $filespec = shift;
    print "do_list_files: Listing $filespec\n";
    my $cpt = load_compartment(__PACKAGE__, 'some_sub');

    if (defined($cpt) && exists &{$cpt->varglob('list_files')})
    {
        print "do_list_files: Calling rdo.pl list_files\n";
        &{$cpt->varglob('list_files')}($filespec);
    }
}

sub load_compartment
{
    my ($package, @subs) = @_;
    my $cpt;
    print "load_compartment\n";
    if (-f 'rdo.pl')
    {
        $cpt = new Safe;
        print "load_compartment: Doing rdo.pl\n";
        $cpt->share_from('main', [ '%ENV' ]);
        if (@ARGV > 0)
        {
            # Invoke horrible workaround!
            require 'glob.pl';
            $cpt->share_from('main', [ 'CORE::GLOBAL::glob' ]);
        }
        $cpt->share_from($package, [ @subs ]);
        $cpt->deny_only();
        $cpt->rdo('rdo.pl');
        if ($@)
        {
            die "Thrown exception from rdo.pl: $@\n";
        }
    }
    return $cpt;
}

# End File: SafeGlobDemo.pl

# Begin File: rdo.pl
#
use strict;
use warnings;

print "Loading rdo.pl\n";

sub list_files
{
    my $filespec = shift;

    for my $file (glob($filespec))
    {
        print "\tFound $file in rdo\n";
    }
}

# End File: rdo.pl

# Begin File: glob.pl
#
print "Loading glob.pl\n";

for (glob('*'))
{
   print ("\tFound $_\n");
}

1;

# End File: glob.pl

# End Code







# Test Results

# Begin Tests on Perl 5.10

# Test failure

C:\GLB\test\SafeGlobDemo>perl SafeGlobDemo.pl
Running SafeGlobDemo
do_list_files: Listing *
load_compartment
load_compartment: Doing rdo.pl
Thrown exception from rdo.pl: Undefined subroutine &Internals::SvREADONLY called at C:/Perl/lib/constant.pm line 111.
BEGIN failed--compilation aborted at C:/Perl/lib/ActiveState/Path.pm line 11.
Compilation failed in require at C:/Perl/lib/ActivePerl/Config.pm line 46.
Compilation failed in require at C:/Perl/lib/XSLoader.pm line 104.
Compilation failed in require at rdo.pl line 10.
BEGIN failed--compilation aborted at rdo.pl line 10.

# Workaround

C:\GLB\test\SafeGlobDemo>perl SafeGlobDemo.pl xxx
Running SafeGlobDemo
do_list_files: Listing *
load_compartment
load_compartment: Doing rdo.pl
Loading glob.pl
        Found glob.pl
        Found rdo.pl
        Found SafeGlobDemo.pl
Loading rdo.pl
do_list_files: Calling rdo.pl list_files
        Found glob.pl in rdo
        Found rdo.pl in rdo
        Found SafeGlobDemo.pl in rdo

C:\GLB\test\SafeGlobDemo>perl -v

This is perl, v5.10.0 built for MSWin32-x86-multi-thread
(with 5 registered patches, see perl -V for more detail)

Copyright 1987-2007, Larry Wall

Binary build 1003 [285500] provided by ActiveState http://www.ActiveState.com
Built May 13 2008 16:52:49

Perl may be copied only under the terms of either the Artistic License or the
GNU General Public License, which may be found in the Perl 5 source kit.

Complete documentation for Perl, including FAQ lists, should be found on
this system using "man perl" or "perldoc perl".  If you have access to the
Internet, point your browser at http://www.perl.org/, the Perl Home Page.

# End Tests on Perl 5.10

# Begin Tests on Perl 5.8

# Test failure

D:\GLB\test\SafeGlobDemo>perl SafeGlobDemo.pl
Running SafeGlobDemo
do_list_files: Listing *
load_compartment
load_compartment: Doing rdo.pl
Thrown exception from rdo.pl: Can't locate object method "can" via package "DynaLoader" at C:/Perl/lib/XSLoader.pm line 90.
Compilation failed in require at rdo.pl line 10.
BEGIN failed--compilation aborted at rdo.pl line 10.


# Workaround

D:\GLB\test\SafeGlobDemo>perl SafeGlobDemo.pl xxx
Running SafeGlobDemo
do_list_files: Listing *
load_compartment
load_compartment: Doing rdo.pl
Loading glob.pl
        Found glob.pl
        Found rdo.pl
        Found SafeGlobDemo.pl
Loading rdo.pl
do_list_files: Calling rdo.pl list_files
        Found glob.pl in rdo
        Found rdo.pl in rdo
        Found SafeGlobDemo.pl in rdo

D:\GLB\test\SafeGlobDemo>perl -v

This is perl, v5.8.8 built for MSWin32-x86-multi-thread
(with 18 registered patches, see perl -V for more detail)

Copyright 1987-2007, Larry Wall

Binary build 822 [280952] provided by ActiveState http://www.ActiveState.com
Built Jul 31 2007 19:34:48

Perl may be copied only under the terms of either the Artistic License or the
GNU General Public License, which may be found in the Perl 5 source kit.

Complete documentation for Perl, including FAQ lists, should be found on
this system using "man perl" or "perldoc perl".  If you have access to the
Internet, point your browser at http://www.perl.org/, the Perl Home Page.

# End Tests on Perl 5.8

# Begin File::Copy code

# File: SafeCopyDemo.pl
#
use strict;
use warnings;

use Safe;

print "Running SafeCopyDemo\n";

do_copy_file(@ARGV);


sub some_sub
{
}

sub do_copy_file
{
    if (@_ != 2)
    {
        print ("Usage: SafeCopyDemo.pl from_file to_file\n");
        return;
    }
    my ($from_filespec, $to_filespec) = @_;
    print "do_copy_file: Copying from $from_filespec to $to_filespec\n";
    my $cpt = load_compartment(__PACKAGE__, 'some_sub');

    if (defined($cpt) && exists &{$cpt->varglob('copy_file')})
    {
        print "do_copy_file: Calling rdo.pl copy_file\n";
        &{$cpt->varglob('copy_file')}($from_filespec, $to_filespec);
    }
}

sub load_compartment
{
    my ($package, @subs) = @_;
    my $cpt;
    print "load_compartment\n";
    if (-f 'rdo.pl')
    {
        $cpt = new Safe;
        print "load_compartment: Doing rdo.pl\n";
        $cpt->share_from('main', [ '%ENV' ]);
        $cpt->share_from($package, [ @subs ]);
        $cpt->deny_only();
        $cpt->rdo('rdo.pl');
        if ($@)
        {
            die "Thrown exception from rdo.pl: $@\n";
        }
    }
    return $cpt;
}

# File: rdo.pl
#
use strict;
use warnings;

use File::Copy;

print "Loading rdo.pl\n";

sub copy_file
{
    my ($from_filespec, $to_filespec) = @_;

    copy ($from_filespec, $to_filespec);

    print "\tCopied $from_filespec to $to_filespec\n";
}

# End File::Copy code

# Begin File::Copy Test on Perl 5.8

Running SafeCopyDemo
do_copy_file: Copying from XXX to YYY
load_compartment
load_compartment: Doing rdo.pl
Loading rdo.pl
do_copy_file: Calling rdo.pl copy_file
Unable to create sub named "*Config::launcher" at C:/Perl/lib/Config.pm line 71.

# End File::Copy Test on Perl 5.8