Printing to stdout from a Perl XS extension - perl

I recently started playing around with writing Perl (v5.8.8) extensions using XS. One of the methods I am writing collects a bunch of data and splats it to the client. I want to write some unit tests that make assertions against the output, but I'm running in to a problem: It doesn't appear that the PerlIO methods are passing data through the same channels as a print call in Perl does. Normally, you can tie in to the STDOUT file handler and intercept the result, but the PerlIO methods seem to be bypassing this completely.
I've pasted an example below, but the basic jist of my test is this: Tie in to STDOUT, run code, untie, return collected string. Doing this, I'm able to capture print statements, but not the PerlIO_* calls from my module. I've tried using PerlIO_write, PerlIO_puts, PerlIO_printf, and more. No dice.
From scratch, here is a minimal repro of what I'm doing:
h2xs -A -n IOTest
cd IOTest
Put this in to IOTest.xs:
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
MODULE = IOTest PACKAGE = IOTest
void
oink ()
CODE:
PerlIO_puts(PerlIO_stdout(), "oink!\n");
And this goes in to a file called test.pl (The interesting part is near the bottom, everything else is just for capturing stdout):
# Set up the include path to match the build directories
BEGIN {
push #INC, './blib/lib/';
push #INC, './blib/arch/auto/IOTest';
}
use IOTest;
# This package is just a set of hooks for tieing in to stdout
{
# Lifted from the Test::Output module found here:
# http://search.cpan.org/~bdfoy/Test-Output-1.01/lib/Test/Output.pm
package OutputTie;
sub TIEHANDLE {
my $class = shift;
my $scalar = '';
my $obj = shift || \$scalar;
bless( $obj, $class);
}
sub PRINT {
my $self = shift;
$$self .= join(defined $, ? $, : '', #_);
$$self .= defined $\ ? $\ : '';
}
sub PRINTF {
my $self = shift;
my $fmt = shift;
$$self .= sprintf $fmt, #_;
}
sub read {
my $self = shift;
my $data = $$self;
$$self = '';
return $data;
}
}
# Runs a sub, intercepts stdout and returns it as a string
sub getStdOut (&) {
my $callback = shift;
select( ( select(STDOUT), $| = 1 )[0] );
my $out = tie *STDOUT, 'OutputTie';
$callback->();
my $stdout = $out->read;
undef $out;
untie *STDOUT;
return $stdout;
}
# This is the interesting part, the actual test:
print "Pre-capture\n";
my $output = getStdOut(sub {
print "before";
IOTest::oink();
print "after";
});
print "Captured StdOut:\n" . $output . "\nend\n";
Building and testing is then just a matter of:
perl Makefile.PL
make
perl test.pl
The output I'm seeing is:
Pre-capture
oink!
Captured StdOut:
beforeafter
end
Obviously, I'm expecting "oink!" to be sandwiched between "before" and "after", but that doesn't appear to be happening.
Any ideas?

I think the capturing is faulty. Compare:
use IOTest;
use Capture::Tiny qw(capture);
print "Pre-capture\n";
my $output = capture {
print "before";
IOTest::oink();
print "after";
};
print "Captured StdOut:\n" . $output . "\nend\n";
Pre-capture
Captured StdOut:
beforeoink!
after
end

Related

Saving a reference to a localized filehandle. How does it work?

This question is based on the observed behavior of patch running with a certain version of perl. When running a command like:
$ patch -N -p0 -u -b .bak < my.patch
I occasionally got output like:
print() on unopened filehandle NULL at patch line 715, <IN> line 12330.
When looking into the code, I see that the NULL filehandle is localized and saved in the object hash:
sub new {
# ....
local *NULL;
tie *NULL, 'Dev::Null';
$self->{o_fh} = \*NULL; # output filehandle
# ....
}
Since this behavior (the output of the message print() on unopened filehandle NULL) only occured for certain versions of perl and (maybe certain version of the patch program) I wondered if this is a bug? To me it looks like one should not localize NULL since we are saving a reference to it and the value of reference (*NULL) will be restored to its previous value when returning from new().
Here is a minimal example:
use feature qw(say);
use strict;
use warnings;
my $p = Patch->new();
$p->apply();
package Patch;
sub new {
my ( $class ) = #_;
my $self = bless {}, $class;
local *NULL;
tie *NULL, 'Dev::Null';
$self->{null} = \*NULL;
local *OUT;
my $out = 'out.txt';
open OUT, ">$out" or die "Couldn't open '$out': $!\n";
$self->{out} = \*OUT;
return $self;
}
sub apply {
my ( $self ) = #_;
my $null = $self->{null};
say $null "This should be discarded..";
my $out = $self->{out};
say $out "This is output to the file..";
}
package Dev::Null;
sub TIEHANDLE { bless \my $null }
sub PRINT {}
sub PRINTF {}
sub WRITE {}
sub READLINE {''}
sub READ {''}
sub GETC {''}
The output when I run this is:
say() on unopened filehandle NULL at ./p.pl line 34.
say() on unopened filehandle OUT at ./p.pl line 36.
It's a bug in patch.
$self->{...} = \*NULL;
should be
$self->{...} = *NULL;
Let's look at these four snippets:
my $r; $s = "abc"; $r = \$s; say $$r;
my $r; { local $s; $s = "abc"; $r = \$s; } say $$r;
my $r; *F = \*STDOUT; $r = \*F; say $r "abc";
my $r; { local *F; *F = \*STDOUT; $r = \*F; } say $r "abc";
Given that the first three work, we would expect the fourth to work too, but it doesn't.
We can't really talk in terms of variables and values in Perl. Perl's model is far more complex than C's where a variable is just a name that represents a location. Globs are even more complex because they're both a variable type (*FOO) something that can be found in a scalar ($foo = *FOO;). The above difference is related to this.
The following does work while still properly localizing *F:
my $r; { local *F; *F = \*STDOUT; $r = *F; } say $r "abc";
patch already uses this approach for *OUT, but it needs to use it for *NULL too. It probably went unnoticed because *NULL is used as a sink, and using an undefined handle also acts as a sink (if you disregard the warning and the error returned by print).

Expect.pm send trims the number sign

I'm trying to use Expect.pm on an old machine with perl 5.8.8.
It works but when I send a text that contains a "#" sign it is removed from the text.
Is there a way to escape/protect it?
Thanks
Sorry corrected it is 5.8.8
#!/usr/bin/perl
use Expect;
use IPC::Open2;
my $cmd="./rec";
my $e = Expect->new;
$e->debug(0);
$e->spawn($cmd) or die;
$e->log_stdout(1);
$e->raw_pty(0);
my $cmd="#some command";
print "cmd: [$cmd]\n";
$e->send($cmd);
$e->expect(1,
[ qr/^I:.*/ => sub { my $exp = shift; print "ok\n"; exp_continue;}],
[ qr/^E:.*/ => sub {
my $self = shift;
print "ko\n";
print "Match: <\n", $self->match, "\n>\n";
print "Before: <", $self->before, ">\n";
print "After: <", $self->after, ">\n";
exp_continue;
}]
);
print "closing\n";
$e->clear_accum();
$e->close();
the rec is a simple c program chat echoes what it receives for debug purpose and prints only
some command
taking the # away.
The actual program I want to control needs that # I cannot make without it.

Perl print out all subs arguments at every call at runtime

I'm looking for way to debug print each subroutine call from the namespace Myapp::* (e.g. without dumping the CPAN modules), but without the need edit every .pm file manually for to inserting some module or print statement.
I just learning (better to say: trying to understand) the package DB, what allows me tracing the execution (using the shebang #!/usr/bin/perl -d:Mytrace)
package DB;
use 5.010;
sub DB {
my( $package, $file, $line ) = caller;
my $code = \#{"::_<$file"};
print STDERR "--> $file $line $code->[$line]";
}
#sub sub {
# print STDERR "$sub\n";
# &$sub;
#}
1;
and looking for a way how to use the sub call to print the actual arguments of the called sub from the namespace of Myapp::*.
Or is here some easier (common) method to
combine the execution line-tracer DB::DB
with the Dump of the each subroutine call arguments (and its return values, if possible)?
I don't know if it counts as "easier" in any sane meaning of the word, but you can walk the symbol table and wrap all functions in code that prints their arguments and return values. Here's an example of how it might be done:
#!/usr/bin/env perl
use 5.14.2;
use warnings;
package Foo;
sub first {
my ( $m, $n ) = #_;
return $m+$n;
}
sub second {
my ( $m, $n ) = #_;
return $m*$n;
}
package main;
no warnings 'redefine';
for my $k (keys %{$::{'Foo::'}}) {
my $orig = *{$::{'Foo::'}{$k}}{CODE};
$::{'Foo::'}{$k} = sub {
say "Args: #_";
unless (wantarray) {
my $r = $orig->(#_);
say "Scalar return: $r";
return $r;
}
else {
my #r = $orig->(#_);
say "List return: #r";
return #r
}
}
}
say Foo::first(2,3);
say Foo::second(4,6);

Problems appending to a file in perl

I have problem with logging some messages in perl. I created simple log package. I still get just first row to the file. Seems like there is appending to file not working. Any ideas?
even when i run that script more times, there arent any changes in output log file. There is always just written "something". I need to append that "somethingElse" to the output file. Do I have some mistake in log?
package Logger;
sub new {
my $package = shift;
my $self = {};
bless $self , $package;
$self->initialize(#_);
return $self;
}
sub initialize {
my $self = shift;
$self->{logfile} = shift;
return;
}
sub logger {
my $self = shift;
my $message = shift;
my (undef,$script, $line) = caller;
open(LOG, ">>$self->{logfile}");
print LOG substr(scalar localtime(),4,15), " ", $message, "\n";
close(LOG);
return;
}
my $log = Logger->new('/usr/local/logs/test.log');
$log->logger("something");
$log->logger("somethingElse");
Thank you
This code works fine for me, so I can't be sure this is the correct solution, but often when some code doesn't print what you want it to, it's because of an autoflush problem. You could try adding this:
$| = 1
or if you prefer:
use English qw( -no_match_vars );
$OUTPUT_AUTOFLUSH = 1;
to the beginning of your program and see if that helps.

How can I store and access a filehandle in a Perl class?

please look at the following code first.
#! /usr/bin/perl
package foo;
sub new {
my $pkg = shift;
my $self = {};
my $self->{_fd} = undef;
bless $self, $pkg;
return $self;
}
sub Setfd {
my $self = shift;
my $fd = shift;
$self_->{_fd} = $fd;
}
sub write {
my $self = shift;
print $self->{_fd} "hello word";
}
my $foo = new foo;
My intention is to store a file handle within a class using hash. the file handle is undefined at first, but can be initilized afterwards by calling Setfd function. then
write can be called to actually write string "hello word" to a file indicated by the file handle, supposed that the file handle is the result of a success "write" open.
but, perl compiler just complains that there are syntax error in the "print" line. can anyone of you tells me what's wrong here? thanks in advance.
You will need to put the $self->{_fd} expression in a block or assign it to a simpler expression:
print { $self->{_fd} } "hello word";
my $fd = $self->{_fd};
print $fd "hello word";
From perldoc -f print:
Note that if you're storing FILEHANDLEs in an array, or if you're using any other expression more complex than a scalar variable to retrieve it, you will have to use a block returning the filehandle value instead:
print { $files[$i] } "stuff\n";
print { $OK ? STDOUT : STDERR } "stuff\n";
Alternately:
use IO::Handle;
# ... later ...
$self->{_fd}->print('hello world');