You are viewing a plain text version of this content. The canonical link for it is here.
Posted to embperl-cvs@perl.apache.org by ri...@apache.org on 2001/08/16 09:50:15 UTC
cvs commit: embperl Changes.pod epdat.h epio.c test.pl
richter 01/08/16 00:50:15
Modified: . Changes.pod epdat.h epio.c test.pl
Log:
tied stdout/stdin are now used
Revision Changes Path
1.181 +3 -1 embperl/Changes.pod
Index: Changes.pod
===================================================================
RCS file: /home/cvs/embperl/Changes.pod,v
retrieving revision 1.180
retrieving revision 1.181
diff -u -r1.180 -r1.181
--- Changes.pod 2001/08/15 03:28:34 1.180
+++ Changes.pod 2001/08/16 07:50:15 1.181
@@ -23,7 +23,9 @@
- Added options optAddUserSessionToLinks, optAddStatusSessionToLinks
and optNoSessionCookies to control how the session id is passed.
- Make sure the HTML::Embperl::Mail generates correct line endings
-
+ - If Perl's STDOUT and/or STDIN are tied to any package, Embperl now
+ calls the Perl methods PRINT and READ for doing I/O. This currently
+ only works, when not running under mod_perl.
=head1 1.3.3 (RELEASE) 6. Juni 2001
1.35 +4 -1 embperl/epdat.h
Index: epdat.h
===================================================================
RCS file: /home/cvs/embperl/epdat.h,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -r1.34 -r1.35
--- epdat.h 2001/08/12 12:19:32 1.34
+++ epdat.h 2001/08/16 07:50:15 1.35
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: epdat.h,v 1.34 2001/08/12 12:19:32 richter Exp $
+# $Id: epdat.h,v 1.35 2001/08/16 07:50:15 richter Exp $
#
###################################################################################*/
@@ -481,6 +481,9 @@
FILE * ofd ; /* output file */
FILE * lfd ; /* log file */
#endif
+
+ SV * ofdobj ; /* perl object that is tied to stdout, if any */
+ SV * ifdobj ; /* perl object that is tied to stdin, if any */
long nLogFileStartPos ; /* file position of logfile, when logfile started */
char * sOutputfile ; /* name of output file */
1.19 +115 -12 embperl/epio.c
Index: epio.c
===================================================================
RCS file: /home/cvs/embperl/epio.c,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- epio.c 2001/08/12 12:19:32 1.18
+++ epio.c 2001/08/16 07:50:15 1.19
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: epio.c,v 1.18 2001/08/12 12:19:32 richter Exp $
+# $Id: epio.c,v 1.19 2001/08/16 07:50:15 richter Exp $
#
###################################################################################*/
@@ -339,11 +339,26 @@
/*in*/ const char * sFilename)
{
+ MAGIC *mg;
+ GV *handle ;
+
#ifdef APACHE
if (r -> pApacheReq)
return ok ;
#endif
+ handle = gv_fetchpv("STDIN", TRUE, SVt_PVIO) ;
+ if (handle && SvMAGICAL(handle) && (mg = mg_find((SV*)handle, 'q')) && mg->mg_obj)
+ {
+ r -> ifdobj = mg->mg_obj ;
+ if (r -> bDebug)
+ {
+ char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
+ lprintf (r, "[%d]Open TIED STDIN %s...\n", r -> nPid, package) ;
+ }
+ return ok ;
+ }
+
if (r -> ifd && r -> ifd != PerlIO_stdinF)
PerlIO_close (r -> ifd) ;
@@ -387,6 +402,21 @@
int CloseInput (/*i/o*/ register req * r)
{
+ if (0) //r -> ifdobj)
+ {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(r -> ifdobj);
+ PUTBACK;
+ perl_call_method ("CLOSE", G_VOID | G_EVAL) ;
+ FREETMPS;
+ LEAVE;
+ r -> ifdobj = NULL ;
+ }
+
+
#ifdef APACHE
if (r -> pApacheReq)
return ok ;
@@ -418,6 +448,43 @@
if (size == 0)
return 0 ;
+ if (r -> ifdobj)
+ {
+ int num ;
+ int n ;
+ SV * pBufSV ;
+
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(r -> ifdobj);
+ XPUSHs(sv_2mortal(pBufSV = NEWSV(0, 0)));
+ PUTBACK;
+ num = perl_call_method ("READ", G_SCALAR) ;
+ SPAGAIN;
+ n = 0 ;
+ if (num > 0)
+ {
+ int n = POPi ;
+ char * p ;
+ STRLEN l ;
+ if (n >= 0)
+ {
+ p = SvPV (pBufSV, l) ;
+ if (l > size)
+ l = size ;
+ if (l > n)
+ l = n ;
+ memcpy (ptr, p, l) ;
+ }
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return n ;
+ }
+
#if defined (APACHE)
if (r -> pApacheReq)
{
@@ -544,6 +611,9 @@
/*in*/ const char * sFilename)
{
+ MAGIC *mg;
+ GV *handle ;
+
r -> pFirstBuf = NULL ;
r -> pLastBuf = NULL ;
r -> nMarker = 0 ;
@@ -561,16 +631,6 @@
if (sFilename == NULL || *sFilename == '\0')
{
- /*
- GV * io = gv_fetchpv("STDOUT", TRUE, SVt_PVIO) ;
- if (io == NULL || (r -> ofd = IoOFP(io)) == NULL)
- {
- if (r -> bDebug)
- lprintf ("[%d]Cannot get Perl STDOUT, open os stdout\n", r -> nPid) ;
- r -> ofd = PerlIO_stdoutF ;
- }
- */
-
#if defined (APACHE)
if (r -> pApacheReq)
{
@@ -579,7 +639,20 @@
return ok ;
}
#endif
- r -> ofd = PerlIO_stdoutF ;
+
+ handle = gv_fetchpv("STDOUT", TRUE, SVt_PVIO) ;
+ if (handle && SvMAGICAL(handle) && (mg = mg_find((SV*)handle, 'q')) && mg->mg_obj)
+ {
+ r -> ofdobj = mg->mg_obj ;
+ if (r -> bDebug)
+ {
+ char *package = HvNAME(SvSTASH((SV*)SvRV(mg->mg_obj)));
+ lprintf (r, "[%d]Open TIED STDOUT %s for output...\n", r -> nPid, package) ;
+ }
+ return ok ;
+ }
+
+ r -> ofd = PerlIO_stdoutF ;
if (r -> bDebug)
{
@@ -631,6 +704,20 @@
return ok ;
#endif */
+ if (0) /* r -> ofdobj) */
+ {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(r -> ifdobj);
+ PUTBACK;
+ perl_call_method ("CLOSE", G_VOID | G_EVAL) ;
+ FREETMPS;
+ LEAVE;
+ r -> ofdobj = NULL ;
+ }
+
if (r -> ofd && r -> ofd != PerlIO_stdoutF)
PerlIO_close (r -> ofd) ;
@@ -746,6 +833,22 @@
if (r -> nMarker)
return bufwrite (r, ptr, n) ;
+
+ if (r -> ofdobj)
+ {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(r -> ofdobj);
+ XPUSHs(sv_2mortal(newSVpv((char *)ptr,size)));
+ PUTBACK;
+ perl_call_method ("PRINT", G_SCALAR) ;
+ FREETMPS;
+ LEAVE;
+ return size ;
+ }
+
#if defined (APACHE)
if (r -> pApacheReq && r -> ofd == NULL)
1.113 +57 -1 embperl/test.pl
Index: test.pl
===================================================================
RCS file: /home/cvs/embperl/test.pl,v
retrieving revision 1.112
retrieving revision 1.113
diff -u -r1.112 -r1.113
--- test.pl 2001/08/14 04:28:07 1.112
+++ test.pl 2001/08/16 07:50:15 1.113
@@ -11,7 +11,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: test.pl,v 1.112 2001/08/14 04:28:07 richter Exp $
+# $Id: test.pl,v 1.113 2001/08/16 07:50:15 richter Exp $
#
###################################################################################
@@ -870,8 +870,36 @@
$vmhttpdsize = 0 ;
$vmhttpdinitsize = 0 ;
+
#####################################################
+#
+# test for output tie
+#
+
+ {
+ package HTML::Embperl::Test::STDOUT ;
+
+ sub TIEHANDLE
+
+ {
+ my $class ;
+
+ return bless \$class, shift ;
+ }
+
+ sub PRINT
+
+ {
+ shift ;
+ $output .= shift ;
+ }
+ }
+
+
+
+#####################################################
+
sub s1 { 1 } ;
sub s0 { 0 } ;
@@ -1610,6 +1638,34 @@
open FH, ">$outfile" or die "Cannot open $outfile ($!)" ;
print FH $outdata ;
+ close FH ;
+ $err = CmpFiles ($outfile, $org) if ($err == 0) ;
+ print "ok\n" unless ($err) ;
+ }
+
+ if ($err == 0 || $opt_ignoreerror)
+ {
+ $txt2 = "$txt to tied handle...";
+ $txt2 .= ' ' x (30 - length ($txt2)) ;
+ print $txt2 ;
+
+ my $outdata ;
+ my @errors ;
+ unlink ($outfile) ;
+ $HTML::Embperl::Test::STDOUT::output = '' ;
+ tie *STDOUT, 'HTML::Embperl::Test::STDOUT' ;
+ $t1 = HTML::Embperl::Clock () ;
+ $err = HTML::Embperl::Execute ({'inputfile' => $src,
+ 'mtime' => 1,
+ 'debug' => $defaultdebug,
+ }) ;
+ $t_exec += HTML::Embperl::Clock () - $t1 ;
+ untie *STDOUT ;
+
+ $err = CheckError ($errcnt) if ($err == 0) ;
+
+ open FH, ">$outfile" or die "Cannot open $outfile ($!)" ;
+ print FH $HTML::Embperl::Test::STDOUT::output ;
close FH ;
$err = CmpFiles ($outfile, $org) if ($err == 0) ;
print "ok\n" unless ($err) ;
---------------------------------------------------------------------
To unsubscribe, e-mail: embperl-cvs-unsubscribe@perl.apache.org
For additional commands, e-mail: embperl-cvs-help@perl.apache.org