#!perl -w
## Note that this example only works as described if the "-w" switch
## is set!
# ======================================================================
# $toplocation = Data::Locations->new();
# $sublocation = $location->new();
# $location->filename($filename);
# $location->print(@items);
# $location->print($sublocation);
# @list = $location->read();
# ======================================================================
package Non::Sense;
## (This is to demonstrate that this example works with ANY package)
use Data::Locations;
use FileHandle;
use strict;
no strict "vars";
print "1..2\n";
$n = 1;
$self = $0;
$self =~ s!^.*[^0-9a-zA-Z_\.]!!;
$temp =
$ENV{'TMP'} || $ENV{'TEMP'} || $ENV{'TMPDIR'} || $ENV{'TEMPDIR'} || '/tmp';
$temp =~ s!/+$!!;
$file = "$temp/$self.$$";
## Redirect all output sent to STDOUT:
unless (open(FILE, ">$file"))
{
die "$self: can't write '$file': \L$!\E\n";
}
## Create scope for redirected STDOUT:
{
local(*STDOUT) = *FILE;
## Create the topmost location:
$level0 = Data::Locations->new("level0.txt");
print $level0 <<'VERBATIM';
Printing first line to location 'level0' via OPERATOR 'print'.
VERBATIM
## Create an embedded location (nested 1 level deep):
$level1 = $level0->new();
$level0->print(<<'VERBATIM');
Printing last line to location 'level0' via METHOD 'print'.
VERBATIM
## Now "tie" the embedded location to file handle STDOUT:
$level1->tie('STDOUT');
print "Printing to location 'level1' via STDOUT.\n";
## Create another location (which will be embedded later):
$level2 = Data::Locations->new();
## Create a file handle ("IO::Handle" works equally well):
$fh = FileHandle->new();
## Now "tie" the location "$level2" to this file handle "$fh":
$level2->tie($fh);
## And select "$fh" as the default output file handle:
select($fh);
print "Printing to location 'level2' via default file handle '\$fh'.\n";
## Embed location "$level2" in location "$level1":
print $level1 $level2;
## (Automatically removes "toplevel" status from location "$level2")
print STDOUT "Printing to location 'level1' explicitly via STDOUT.\n";
## Create a third embedded location (nested 3 levels deep):
$level3 = $level2->new();
## Restore STDOUT as the default output file handle:
select(STDOUT);
print $fh "Printing to location 'level2' via file handle '\$fh'.\n";
## Trap all warnings:
$SIG{__WARN__} = sub
{
print STDERR "WARNING intercepted:\n", @_, "End Of Warning.\n";
};
## Note that WITHOUT this trap, warnings would go to the system
## standard error device DIRECTLY, WITHOUT passing through the
## file handle STDERR!
## Now "tie" location "$level3" to file handle STDERR:
$level3->tie(*STDERR);
## Provoke a warning message (don't forget the "-w" switch!):
$fake = \$fh;
$level3->print($fake);
## Provoke another warning message (don't forget the "-w" switch!):
$level3->dump();
{
## Silence warning that reference count of location is still > 0:
local($^W) = 0;
## And untie file handle STDOUT from location "$level1":
untie *STDOUT;
}
print "Now STDOUT goes to the screen again.\n";
## Read from location "$level3":
while (<STDERR>) ## Copy warning messages to the screen:
{
if (/^.*?\bData::Locations::[a-z]+\(\):\s+(.+?)(?=\s+at\s|\n)/)
{
print "Warning: $1\n";
}
}
while (<STDERR>) { print; }
## (Prints nothing because location was already read past its end)
## Reset the internal reading mark:
(tied *{STDERR})->reset();
## (You should usually use "$level3->reset();", though!)
while (<STDERR>) { print; }
## (Copies the contents of location "$level3" to the screen)
}
## (End of scope for redirected STDOUT)
close(FILE);
## Read output file "level0.txt":
$txt = join('', $level0->read());
$ref = <<'VERBATIM';
Printing first line to location 'level0' via OPERATOR 'print'\..*
Printing to location 'level1' via STDOUT\..*
Printing to location 'level2' via default file handle '\$fh'\..*
WARNING intercepted:.*
Data::Locations::print\(\): REF reference ignored.*
End Of Warning\..*
WARNING intercepted:.*
Data::Locations::dump\(\): filename missing or empty.*
End Of Warning\..*
Printing to location 'level2' via file handle '\$fh'\..*
Printing to location 'level1' explicitly via STDOUT\..*
Printing last line to location 'level0' via METHOD 'print'\.
VERBATIM
$ref =~ s!\n!!g;
if ($txt =~ /$ref/s)
{print "ok $n\n";} else {print "not ok $n\n";}
$n++;
unless (open(FILE, "<$file"))
{
die "$self: can't read '$file': \L$!\E\n";
}
$txt = join('', <FILE>);
close(FILE);
unlink($file);
$ref = <<'VERBATIM';
Now STDOUT goes to the screen again\..*
Warning: REF reference ignored.*
Warning: filename missing or empty.*
WARNING intercepted:.*
Data::Locations::print\(\): REF reference ignored.*
End Of Warning\..*
WARNING intercepted:.*
Data::Locations::dump\(\): filename missing or empty.*
End Of Warning\.
VERBATIM
$ref =~ s!\n!!g;
if ($txt =~ /$ref/s)
{print "ok $n\n";} else {print "not ok $n\n";}
$n++;
#$txt = <<'VERBATIM';
#Now STDOUT goes to the screen again.
#Warning: REF reference ignored
#Warning: filename missing or empty
#WARNING intercepted:
## Data::Locations::print(): REF reference ignored
#File 'Bird:src:Pudge:pudgeprogs:perl:cpan:build:Data-Locations-4.3:t:18__example_3.t'; Line 125
#End Of Warning.
#WARNING intercepted:
## Data::Locations::dump(): filename missing or empty
#File 'Bird:src:Pudge:pudgeprogs:perl:cpan:build:Data-Locations-4.3:t:18__example_3.t'; Line 129
#End Of Warning.
#VERBATIM
#
#if ($txt =~ /$ref/s)
#{print "ok $n\n";} else {print "not ok $n\n";}
#$n++;
$level0->filename("");
__END__