#!/usr/bin/perl

use strict;
use warnings;

use IO::Scalar;

my $data;

{
    local *STDOUT;
    tie *STDOUT, 'IO::Scalar', \$data; 
    &print_something();
}

print "\$data: $data";

sub print_something()
{
    print "something\n";
}
[download]

$data: something
[download]

#!/usr/bin/perl

use strict;
use warnings;

sub function {
    print "Hello, world\n";
}


my $kid;
my $pid = open ($kid, "-|");
die "Failed to fork: $!" unless defined $pid;

unless ($pid) { # Child.
    function;
    exit;
}

undef $/;
my $scalar = <$kid>;

print "Got: $scalar";
__END__
Got: Hello, world
[download]

See also the perlipc manual page.

    close STDOUT; # comment out to see the difference, try opening STD
+OUT to something else
    use Perl;
    my $p = Perl->new( ARGV => [ '-le', 'print(1)for(1..22)'] );
    $p->run;
[download]

use strict;

my $out;
{
open local(*STDOUT), '>', \$out;
foo();
}

print "Std: $out\n";

sub foo{
    print "from foo";
}
[download]

That looks like a really elegant solution. When I tried it on my system, I ended up with a file named SCALAR(0x17651f0) containing "from foo". What am I missing?

perl5.8 probably.

use strict;
use warnings;

use Perl;

my $p = Perl->new;
my $data = $p->eval(q{ do{
    use IO::Scalar;
    my $result;
    tie *STDOUT, 'IO::Scalar', \$result;

    print 'some stuff';

    $result;
} });

print "|||$data|||\n";
[download]

If you want to run a perl script change the print line to do 'somefile.pl';

Thats an interesting idea, my only problem is that the entire script has to be recompiled and reexecuted every time I try to run it. The main reason I'm playing with Perl.pm is to be able to "cache" the compilation of perl scripts, for speed purposes. Theoretically, with the Perl->new() method, it will load and compile the script, then I can run it multiple times with the ->run method. Maybe. In your method it would have to get reloaded every time, I think.

package IO::Redirect ;

sub TIEHANDLE {
  my $class = shift ;
  my ($stdout , $globpath) = @_ ;
  my $prevstdout = \*{$globpath} ;
  my $this = { STDOUT => $stdout , PREVIO => $prevstdout , PREVIOPATH 
+=> $globpath } ;
  return bless($this , $class) ;
}

sub print { &PRINT ;}

sub print_stdout {
  my $this = shift ; return 1 if $_[0] eq '' ;
  
  my $stdout = $this->{STDOUT} ;

  if ( ref($stdout) eq 'SCALAR' ) { $$stdout .= $_[0] ;}
  elsif ( ref($stdout) eq 'CODE' ) { &$stdout($this , $_[0]) ;}
  else { print $stdout $_[0] ;}

  return 1 ;
}

sub PRINT {
  my $this = shift ;
  $this->print_stdout( join("", (@_[0..$#_])) ) ;
  return 1 ;
}

sub PRINTF { &PRINT($_[0],sprintf($_[1],@_[2..$#_])) ;}

sub CLOSE {
  my $this = shift ;
  untie *{ $this->{PREVIOPATH} } ;
}

sub UNTIE {
  my $this = shift ;
  *{ $this->{PREVIOPATH} } = $this->{PREVIO} ;
}

sub DESTROY { &CLOSE }

#######
# END #
#######

package main ;
  
  my $catcher ;

  tie(*{"main::STDOUT"} => 'IO::Redirect' , \$catcher , 'main::STDOUT'
+) ;
  
    print "Hello World!\n" ;
  
  close( *main::STDOUT ) ;
  
  print "<<$catcher>>\n" ;

exit;
[download]

What a brilliant ide! It's too bad tie doesn't work. Maybe you should try testing your solution first?

Tested on Perl 5.6.1 and it works. Depending on your Perl version you need to add the sub STORE {} to no get errors.

Graciliano M. P.
"Creativity is the expression of liberty".