How do I use tied filehandles from Perl XS code?

Question

The following minimal example defines a wrapper around PerlIO_write:

MODULE = My::FH        PACKAGE = My::FH
INCLUDE: const-xs.inc
int
write_fh (SV* fh, SV* str)
CODE:
STRLEN len
char* buf = SvPV(str, len);
PerlIO* io = IoIFP(sv_2io(fh));
if (io) {
    RETVAL = PerlIO_write(io, buf, len);
} else {
    croak("cannot use fh as a PerlIO handle");
}
OUTPUT:
RETVAL

Using the write_fh function on a filehandle that has been created using open $fh, '<', \$buf works as expected. However, a tied filehandle created using the following snippet is not turned into a PerlIO handle:

my $fh = Symbol::gensym;
tie *$fh, 'My::TIEFH', \$buf;

My::TIEFH contains the required methods and writing to it via print $fh $str works just as expected.

What do I need to do to write to the tied filehandle from XS land?

Answer 1

print uses call_method to call PRINT when

io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))

is true. The blessed object to place on the stack is

SvTIED_obj(MUTABLE_SV(io), mg)

---

By the way, the XS compiler can place non-declaration code before the content of CODE, so the content of CODE cannot start with declarations.

CODE:
    STRLEN len
    char* buf = SvPV(str, len);
    PerlIO* io = IoIFP(sv_2io(fh));
    if (io) {
    ...

should be

CODE:
    {
        STRLEN len
        char* buf = SvPV(str, len);
        PerlIO* io = IoIFP(sv_2io(fh));
        if (io) {
        ...
    }

or

PREINIT:
    STRLEN len
    char* buf = SvPV(str, len);
    PerlIO* io = IoIFP(sv_2io(fh));
CODE:
    if (io) {
    ...

Answer 2

After trying to make sense of the definition of print in pp_hot.c and reading perlcall(3), I have come up with the following piece of code. Does that make sense?

MODULE = My::FH        PACKAGE = My::FH
INCLUDE: const-xs.inc
int
write_fh (SV* fh, SV* str)
INIT:
STRLEN len;
char* buf = SvPV(str, len);
PerlIO* pio = IoIFP(sv_2io(fh));
CODE:
if (pio) {
  RETVAL = PerlIO_write(pio, buf, len);
} else {
  if (!SvROK(fh))
    croak("fh is not a reference");
  IO* io = GvIO(SvRV(fh));
  if (io == NULL)
    croak("fh is not a GLOB reference");
  MAGIC* mg = SvTIED_mg((const SV*)io, PERL_MAGIC_tiedscalar);
  if (mg == NULL)
    croak("fh is not a tied filehandle");
  SV* obj = SvTIED_obj(MUTABLE_SV(io), mg);
  if (obj == NULL) 
    croak("???");
  ENTER;
  SAVETMPS;
  PUSHMARK(SP);
  XPUSHs(obj);
  XPUSHs(str);
  PUTBACK;
  RETVAL = call_method("PRINT", G_SCALAR);
  if (i != 1)
    croak("wrong number of return values (%i)", RETVAL);
  SPAGAIN;
  RETVAL=POPi;
  PUTBACK;
  FREETEMPS;
  LEAVE;
}
OUTPUT:
RETVAL