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/05/10 21:08:41 UTC
cvs commit: embperl/test/html http.htm
richter 01/05/10 12:08:40
Modified: . Changes.pod Embperl.pm Embperl.pod Embperl.xs
EmbperlD.pod INSTALL.pod Intro.pod IntroD.pod
Makefile.PL embpexec.pl.templ epmain.c eputil.c
test.pl
test/cmp http.htm
test/html http.htm
Log:
- adapted make test to Perl 5.6.1 and 5.7.1 so now it passes sucessfully.
- fixed problem with cleanup in threaded Perl 5.6.1 and higher
- added pod documentation to embperl.pl. Patch from Angus Lees.
- %http_headers_out can take now array refs as elements to set multiple
headers of the same value. Patch from Maxwell Krohn.
- No module-documenations (like Intro.pod Faq.pod etc) now get copied under
the correct directory and man pages are generated with the correct name
(e.g. perldoc HTML::Embperl::Intro works now after installation). Based
on an idea from Angus Lees.
Revision Changes Path
1.161 +9 -0 embperl/Changes.pod
Index: Changes.pod
===================================================================
RCS file: /home/cvs/embperl/Changes.pod,v
retrieving revision 1.160
retrieving revision 1.161
diff -u -r1.160 -r1.161
--- Changes.pod 2001/05/02 04:08:54 1.160
+++ Changes.pod 2001/05/10 19:08:03 1.161
@@ -28,6 +28,15 @@
- Embperl is now added to the Serversoftware identification when
preloaded under mod_perl.
- adapted make test to Perl 5.6.1 and 5.7.1 so now it passes sucessfully.
+ - fixed problem with cleanup in threaded Perl 5.6.1 and higher
+ - added pod documentation to embperl.pl. Patch from Angus Lees.
+ - %http_headers_out can take now array refs as elements to set multiple
+ headers of the same value. Patch from Maxwell Krohn.
+ - No module-documenations (like Intro.pod Faq.pod etc) now get copied under
+ the correct directory and man pages are generated with the correct name
+ (e.g. perldoc HTML::Embperl::Intro works now after installation). Based
+ on an idea from Angus Lees.
+
=head1 1.3.1 (RELEASE) 13 Feb. 2001
1.149 +6 -24 embperl/Embperl.pm
Index: Embperl.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl.pm,v
retrieving revision 1.148
retrieving revision 1.149
diff -u -r1.148 -r1.149
--- Embperl.pm 2001/05/02 05:30:15 1.148
+++ Embperl.pm 2001/05/10 19:08:04 1.149
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Embperl.pm,v 1.148 2001/05/02 05:30:15 richter Exp $
+# $Id: Embperl.pm,v 1.149 2001/05/10 19:08:04 richter Exp $
#
###################################################################################
@@ -84,7 +84,6 @@
%http_headers_out
$pathsplit
- $multiplicity
) ;
@@ -123,8 +122,6 @@
%filepack = () ; # translate filename to packagename
$packno = 1 ; # for assigning unique packagenames
-$multiplicity = Multiplicity () ;
-
@cleanups = () ; # packages which need a cleanup
$LogOutputFileno = 0 ;
$pathsplit = $^O eq 'MSWin32'?';':';|:' ; # separators for path
@@ -1280,7 +1277,6 @@
my $packfile ;
my %addcleanup ;
my $varfile ;
- my %revinc = map { ($_ => 1) } values (%INC) if ($multiplicity) ;
my ($k, $v) ;
$seen{''} = 1 ;
@@ -1294,17 +1290,13 @@
#print LOG "GVFile $package\::__ANON__\n" ;
$packfile = GVFile (*{"$package\::__ANON__"}) ;
- if ($multiplicity && !$revinc{$packfile})
- {
- #print LOG "$packfile -> -- eval --\n" ;
- $packfile = "-- eval --" ;
- }
$packfile = '-> No Perl in Source <-' if ($packfile eq ('_<' . __FILE__) || $packfile eq __FILE__) ;
$addcleanup = \%{"$package\:\:CLEANUP"} ;
$addcleanup -> {'CLEANUP'} = 0 ;
+ $addcleanup -> {'ISA'} = 0 ;
if ($Debugflags & dbgShowCleanup)
{
- print LOG "[$$]CUP: ***** Cleanup package: $package (m=$multiplicity) *****\n" ;
+ print LOG "[$$]CUP: ***** Cleanup package: $package *****\n" ;
print LOG "[$$]CUP: Source $packfile\n" ;
}
if (defined (&{"$package\:\:CLEANUP"}))
@@ -1323,16 +1315,11 @@
my $cleanfile = \%{"$package\:\:CLEANUPFILE"} ;
foreach $key (@vars)
{
+ next if ($key =~ /^::/) ;
$val = ${*{"$package\::"}}{$key} ;
local(*ENTRY) = $val;
- #print LOG "$key = " . GVFile (*ENTRY) . "\n" ;
+ print LOG "$key = " . GVFile (*ENTRY) . "\n" ;
$varfile = GVFile (*ENTRY) ;
- if ($multiplicity && !$revinc{$varfile})
- {
- #print LOG "$varfile -> -- eval --\n" ;
- $varfile = "-- eval --" ;
- }
-
$glob = $package.'::'.$key ;
if (defined (*ENTRY{SCALAR}) && defined (${$glob}) && ref (${$glob}) eq 'DBIx::Recordset')
{
@@ -1410,6 +1397,7 @@
my $cleanfile = \%{"$package\:\:CLEANUPFILE"} ;
while (($key,$val) = each(%{*{"$package\::"}}))
{
+ next if ($key =~ /^::/) ;
local(*ENTRY) = $val;
$glob = $package.'::'.$key ;
if (defined (*ENTRY{SCALAR}) && defined (${$glob}) && ref (${$glob}) eq 'DBIx::Recordset')
@@ -1420,12 +1408,6 @@
else
{
$varfile = GVFile (*ENTRY) ;
- if ($multiplicity && !$revinc{$varfile})
- {
- #print LOG "$varfile -> -- eval --\n" ;
- $varfile = "-- eval --" ;
- }
-
if (($packfile eq $varfile || $addcleanup -> {$key} ||
$cleanfile->{$varfile}) &&
(!($key =~ /\:\:$/) && !(defined ($addcleanup -> {$key}) && $addcleanup -> {$key} == 0)))
1.70 +15 -0 embperl/Embperl.pod
Index: Embperl.pod
===================================================================
RCS file: /home/cvs/embperl/Embperl.pod,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -r1.69 -r1.70
--- Embperl.pod 2001/04/27 06:37:52 1.69
+++ Embperl.pod 2001/05/10 19:08:06 1.70
@@ -1861,6 +1861,21 @@
[- $http_headers_out{'Location'} = "http://www.ecos.de/embperl/" -]
+Starting with version 1.3.2 all headers with the exception "Location" and
+"Content-Type" can take multiple values.
+For instance, if you wanted to set two cookies, you can proceed as follows:
+
+ [- $http_headers_out{'Set-Cookie'} =
+ ['name=cook1;value=2;','name=cook2;value=b'] ; -]
+
+If you supply multiple values for "Location" or "Content-Type" via an array
+reference, then Embperl will simply use the first in the list. Empty arrays
+will be ignored. For instance, the following will neither change the status
+to 301 nor create a Location: line in the HTTP headers:
+
+ [- $http_headers_out{'Location'} = [] ; -]
+
+
see also META HTTP-EQUIV=
=head2 $optXXX $dbgXXX
1.42 +10 -1 embperl/Embperl.xs
Index: Embperl.xs
===================================================================
RCS file: /home/cvs/embperl/Embperl.xs,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- Embperl.xs 2001/05/02 05:30:15 1.41
+++ Embperl.xs 2001/05/10 19:08:07 1.42
@@ -85,14 +85,23 @@
embperl_GVFile(gv)
SV * gv
CODE:
+ char buf[20] ;
RETVAL = "" ;
#ifdef GvFILE
if (gv && SvTYPE(gv) == SVt_PVGV && GvGP (gv))
{
+ /*
char * name = GvFILE (gv) ;
if (name)
RETVAL = name ;
- }
+ */
+ /* workaround for not working GvFILE in Perl 5.6.1+ with threads */
+ if(GvIMPORTED(gv))
+ RETVAL = "i" ;
+ else
+ RETVAL = "" ;
+
+ }
#else
if (gv && SvTYPE(gv) == SVt_PVGV && GvGP (gv))
{
1.42 +16 -0 embperl/EmbperlD.pod
Index: EmbperlD.pod
===================================================================
RCS file: /home/cvs/embperl/EmbperlD.pod,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -r1.41 -r1.42
--- EmbperlD.pod 2001/04/27 06:37:53 1.41
+++ EmbperlD.pod 2001/05/10 19:08:08 1.42
@@ -1768,6 +1768,22 @@
[- $http_headers_out{'Location'} = "http://www.ecos.de/embperl/" -]
+
+Ab 1.3.2 k�nnen alle HTTP Header (au�er "Location" und "Content-Type") auch
+mehrere Werte erhalten. Um z.B. mehrere Cookie zu setzen, kann man folgendes schreiben:
+
+
+ [- $http_headers_out{'Set-Cookie'} =
+ ['name=cook1;value=2;','name=cook2;value=b'] ; -]
+
+F�r "Location" und "Content-Type" wird nur der erste Wert ber�cksichtigt. Leere
+Arrays werden ignoriert. Z.B. f�hrt Folgendes B<nicht> zu einem Redirect:
+
+ [- $http_headers_out{'Location'} = [] ; -]
+
+
+
+
siehe auch L<META HTTP-EQUIV= ...>
=head2 $optXXX $dbgXXX
1.18 +18 -2 embperl/INSTALL.pod
Index: INSTALL.pod
===================================================================
RCS file: /home/cvs/embperl/INSTALL.pod,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- INSTALL.pod 2001/02/13 05:39:11 1.17
+++ INSTALL.pod 2001/05/10 19:08:09 1.18
@@ -52,7 +52,7 @@
=over 4
-=item * File::Spec 0.82 or higher
+=item * File::Spec 0.8 or higher
=back
@@ -172,7 +172,7 @@
=over 4
-=item * File::Spec 0.82 or higher
+=item * File::Spec 0.8 or higher
=back
@@ -181,8 +181,22 @@
+=head2 How to continue
+
+You can view the documentation at any time from the Embperl source directory,
+by using the following commands metioned below. After the installation you can
+also view documention by specifying the full module name: e.g.
+
+perldoc HTML::Embperl, perldoc HTML::Embperl::Intro etc.
+
+To get familiar how Embperl works, read the L<"Intro"|"Intro.pod"> and
+L<"IntroEmbperlObject"|"IntroEmbperlObject.pod"> documents.
+To learn how to use and configure Embperl, read the L<"Embperl documentation"|"Embperl.pod">.
+
+
=head2 Further Documentation (english)
+
See L<"perldoc Features"|"Features.pod"> for list of Embperls features
See L<"perldoc Intro"|"Intro.pod"> for an step by step
@@ -212,3 +226,5 @@
See B<perldoc EmbperlD> for complete documentation.
or you can view it online on http://www.ecos.de/embperl/
+
+
1.5 +10 -6 embperl/Intro.pod
Index: Intro.pod
===================================================================
RCS file: /home/cvs/embperl/Intro.pod,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Intro.pod 1999/08/08 23:56:26 1.4
+++ Intro.pod 2001/05/10 19:08:10 1.5
@@ -109,8 +109,10 @@
[$ <cmd> <arg> $]
-=head3 if, elsif, else, endif
+=over 8
+=item if, elsif, else, endif
+
The if command is just the same as in Perl. It is used to
conditionally output/process parts of the document.
Example:
@@ -127,7 +129,7 @@
of $ENV{REQUEST_METHOD}.
-=head3 while, endwhile
+=item while, endwhile
The while command can be used to create a loop in the HTML
document. For example:
@@ -139,7 +141,7 @@
The above example will display all environment variables, each
terminated with a line break.
-=head3 do, until
+=item do, until
The do until also create a loop, but with a condition at the end.
For example:
@@ -149,7 +151,7 @@
[+ $arr[ $i++ ] +]
[$ until $i > $#arr $]
-=head3 foreach, endforeach
+=item foreach, endforeach
Create a loop iterating over every element of an array/list.
Example:
@@ -159,7 +161,7 @@
[$ endforeach $]
-=head3 var <var1> <var2> ...
+=item var <var1> <var2> ...
By default, you do not need to declare any variables you use within
an Embperl page. Embperl takes care of deleting them at the end of
@@ -172,11 +174,13 @@
use strict ;use vars qw {$a @b %c} ;
-=head3 hidden
+=item hidden
hidden is used for creating hidden form fields and is described in
the form field section below.
+
+=back
=head1 Dynamic Tables
1.4 +10 -7 embperl/IntroD.pod
Index: IntroD.pod
===================================================================
RCS file: /home/cvs/embperl/IntroD.pod,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- IntroD.pod 2000/03/01 04:29:55 1.3
+++ IntroD.pod 2001/05/10 19:08:11 1.4
@@ -104,8 +104,10 @@
[$ <cmd> <arg> $]
-=head3 if, elsif, else, endif
+=over 8
+=item if, elsif, else, endif
+
Der if Befehl hat die selben Auswirkungen wie in Perl. Er kann genutzt
werden um Teile des Dokuments nur unter bestimmten Bedingungen auszugeben/auszuf�hren.
Beispiel:
@@ -122,7 +124,7 @@
von $ENV{REQUEST_METHOD} aus.
-=head3 while, endwhile
+=item while, endwhile
Der while Befehl wird dazu benutzt, um eine Schleife innerhalb des
HTML Dokuments zu erzeugen. Beispiel:
@@ -134,7 +136,7 @@
Das Beispiel zeigt alle Environementvariablen, jede abgeschlossen
mit einem Zeilenumbruch (<BR>).
-=head3 do, until
+=item do, until
C<do> C<until> erzeugt ebenso eine Schleife, jedoch mit der Bedingung am Ende.
Beispiel:
@@ -144,7 +146,7 @@
[+ $arr[ $i++ ] +]
[$ until $i > $#arr $]
-=head3 foreach, endforeach
+=item foreach, endforeach
Erzeugt eine Schleife, die �ber jedes Element einer Liste/Arrays iteriert.
Beispiel:
@@ -154,7 +156,7 @@
[$ endforeach $]
-=head3 var <var1> <var2> ...
+=item var <var1> <var2> ...
Standartm��ig ist es nicht n�tig irgenwelche Variablen innerhalb einer
Embperlseite zu deklarieren. Embperl k�mmert sich darum nach jedem Request
@@ -167,11 +169,13 @@
use strict ; use vars qw {$a @b %c} ;
-=head3 hidden
+=item hidden
hidden erm�glicht es versteckte Formularfelder zu erzeugen und wird weiter unten
im Abschnitt �ber Formularfelder beschrieben.
+=back
+
=head1 Dynamische Tabellen
Ein sehr leistungsf�higes Feature von Embperl ist das Erzeugen von
@@ -770,7 +774,6 @@
- entfernt HTML tags aus dem Perlcode (z.B. <br> welches durch einen
HTML Editor eingef�gt wurde)
-=back
=head2 Ausgabe: Escaping
1.43 +45 -17 embperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /home/cvs/embperl/Makefile.PL,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -r1.42 -r1.43
--- Makefile.PL 2001/04/27 06:37:55 1.42
+++ Makefile.PL 2001/05/10 19:08:12 1.43
@@ -174,7 +174,37 @@
}
+ sub MY::post_initialize
+ {
+ my $self = shift ;
+ # move docs to the right place
+
+ my $pm = $self -> {PM} ;
+ my $k ;
+ my $v ;
+ while (($k, $v) = each (%$pm))
+ {
+ if (($k =~ /\.pod$/) && !($k =~ /^Embperl/) )
+ {
+ $v =~ s#^(.*/)(.*?)\.pod$#$1Embperl/$2.pod# ;
+ $pm -> {$k} = $v ;
+ }
+ }
+
+ my $man = $self -> {MAN3PODS} ;
+ while (($k, $v) = each (%$man))
+ {
+ if (!($v =~ /::Embperl/))
+ {
+ $v =~ s#HTML::#HTML::Embperl::# ;
+ $man -> {$k} = $v ;
+ }
+ }
+
+ $self -> MM::post_initialize (@_) ;
+ }
+
## ----------------------------------------------------------------------------
sub GetString
@@ -345,6 +375,7 @@
if ($ARGV[0] eq 'debug')
{
+ shift @ARGV;
if ($win32)
{
$ccdebug = '-Zi -W3' ;
@@ -356,7 +387,8 @@
$lddebug = '-g' ;
}
}
-elsif (defined ($ARGV[0]) && ($ARGV[0] =~ /^\W/))
+
+if (defined ($ARGV[0]) && ($ARGV[0] =~ /^\W/))
{
$apache = 2 ;
$b = 1 ;
@@ -489,13 +521,13 @@
if ($win32)
{
$i = "-I. -I$inc_dir -I$apache_src/regex -I$apache_src/os/win32" ;
- if (!-e "$apache_src/CoreR/ApacheCore.lib")
+ if (!-e "$apache_src/CoreD/ApacheCore.lib")
{
- $o = " $apache_src/CoreD/ApacheCore.lib" ;
+ $o = " $apache_src/CoreR/ApacheCore.lib" ;
}
else
{
- $o = " $apache_src/CoreR/ApacheCore.lib" ;
+ $o = " $apache_src/CoreD/ApacheCore.lib" ;
}
}
else
@@ -584,12 +616,12 @@
}
else
{
- $EPHTTPD = "$apache_src/ApacheR/Apache.exe" ;
- $EPHTTPDDLL = "$apache_src/CoreR" ;
+ $EPHTTPD = "$apache_src/ApacheD/Apache.exe" ;
+ $EPHTTPDDLL = "$apache_src/CoreD" ;
if (!-e $EPHTTPD)
{
- $EPHTTPD = "$apache_src/ApacheD/Apache.exe" ;
- $EPHTTPDDLL = "$apache_src/CoreD" ;
+ $EPHTTPD = "$apache_src/ApacheR/Apache.exe" ;
+ $EPHTTPDDLL = "$apache_src/CoreR" ;
}
#$EPMODPERL="LoadModule perl_module $mpdll" ;
$EPUSER = 'www' ; # dummy value
@@ -792,9 +824,9 @@
$SessVer ||= 0 ;
- if (($FSVer = CheckModule ("File::Spec", "-> Required for EmbperlObject, make test will fail whithout File::Spec")) < 0.82)
+ if (($FSVer = CheckModule ("File::Spec", "-> Required for EmbperlObject, make test will fail whithout File::Spec")) < 0.8)
{
- print "-> EmbperlObject requires File::Spec 0.82 or higher, found $FSVer, please upgrade!\n" ;
+ print "-> EmbperlObject requires File::Spec 0.8 or higher, found $FSVer, please upgrade!\n" ;
}
CheckModule ("CGI", "-> File Upload will not work without CGI.pm installed") ;
@@ -907,21 +939,17 @@
WriteMakefile(
'NAME' => 'HTML::Embperl',
'VERSION_FROM' => 'Embperl.pm', # finds $VERSION
- 'OBJECT' => 'Embperl$(OBJ_EXT) epmain$(OBJ_EXT) epio$(OBJ_EXT) epchar$(OBJ_EXT) epcmd$(OBJ_EXT) eputil$(OBJ_EXT) epeval$(OBJ_EXT) epapinit$(OBJ_EXT)' .
+ 'OBJECT' => 'Embperl$(OBJ_EXT) epmain$(OBJ_EXT) epio$(OBJ_EXT) epchar$(OBJ_EXT) epcmd$(OBJ_EXT) eputil$(OBJ_EXT) epeval$(OBJ_EXT) epapinit$(OBJ_EXT) ' .
($EP2?'epcmd2$(OBJ_EXT) epparse$(OBJ_EXT) epdom$(OBJ_EXT) epcomp$(OBJ_EXT)':'') . $o,
'LIBS' => [''],
'DEFINE' => "$d \$(DEFS)",
'INC' => $i,
- 'MAN3PODS' => {
- 'Embperl.pod' => 'blib/man3/HTML::Embperl.3',
- 'EmbperlD.pod' => 'blib/man3/HTML::EmbperlD.3',
- 'EmbperlObject.pm' => 'blib/man3/HTML::EmbperlObject.3',
- },
+ 'EXE_FILES' => [ 'embpexec.pl' ],
'clean' => { FILES => 'dirent.h test/conf/httpd.conf test/tmp/* Embperl.c' },
'realclean' => { FILES => 'embpexec.pl embpexec.bat embpcgi.pl embpcgi.test.pl embpcgi.bat test/conf/config.pl' },
'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz'},
'dynamic_lib' => $dynlib,
- 'PREREQ_PM' => { 'File::Spec' => 0.82 },
+ 'PREREQ_PM' => { 'File::Spec' => 0.8 },
'ABSTRACT' => 'Embed Perl code in HTML documents',
'AUTHOR' => 'Gerald Richter <ri...@dev.ecos.de>',
1.3 +56 -1 embperl/embpexec.pl.templ
Index: embpexec.pl.templ
===================================================================
RCS file: /home/cvs/embperl/embpexec.pl.templ,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- embpexec.pl.templ 2001/02/13 05:39:17 1.2
+++ embpexec.pl.templ 2001/05/10 19:08:13 1.3
@@ -11,7 +11,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: embpexec.pl.templ,v 1.2 2001/02/13 05:39:17 richter Exp $
+# $Id: embpexec.pl.templ,v 1.3 2001/05/10 19:08:13 richter Exp $
#
###################################################################################
@@ -23,3 +23,58 @@
HTML::Embperl::run (@ARGV) ;
+__END__
+
+=head1 NAME
+
+embpexec.pl - Run an HTML::Embperl file offline
+
+=head1 SYNOPSIS
+
+embpexec.pl [B<-o> I<outputfile>] [B<-l> I<logfile>] [B<-d> I<debugflags>] I<htmlfile> [I<query_string>]
+
+=head1 DESCRIPTION
+
+Converts an HTML file (or any other ascii file) with embedded Perl statements into a standard
+HTML file.
+
+I<htmlfile> is the full pathname of the HTML file which should be
+processed by Embperl.
+
+I<query_string> is optional and has the same meaning as the
+environment variable C<QUERY_STRING> when invoked as a CGI
+script. That is, C<QUERY_STRING> contains everything following the
+first "?" in a URL. I<query_string> should be URL-encoded. The default
+is no query string.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-o> I<outputfile>
+
+Optional. Gives the filename to which the output is written. The
+default is stdout.
+
+=item B<-o> I<logfile>
+
+Optional. Gives the filename of the logfile. The default is
+F</tmp/embperl.log>.
+
+=item B<-d> I<debugflags>
+
+Optional. Specifies the level of debugging (what is written to the log
+file). The default is nothing. See L<HTML::Embperl/EMBPERL_DEBUG> for
+exact values.
+
+=back
+
+=head1 SEE ALSO
+
+L<HTML::Embperl>
+
+=head1 AUTHOR
+
+G. Richter (richter@dev.ecos.de)
+
+=end
1.99 +61 -7 embperl/epmain.c
Index: epmain.c
===================================================================
RCS file: /home/cvs/embperl/epmain.c,v
retrieving revision 1.98
retrieving revision 1.99
diff -u -r1.98 -r1.99
--- epmain.c 2001/05/02 04:08:55 1.98
+++ epmain.c 2001/05/10 19:08:15 1.99
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: epmain.c,v 1.98 2001/05/02 04:08:55 richter Exp $
+# $Id: epmain.c,v 1.99 2001/05/10 19:08:15 richter Exp $
#
###################################################################################*/
@@ -2689,24 +2689,78 @@
HE * pEntry ;
char * pKey ;
I32 l ;
+
+
+ I32 i;
+ I32 len;
+ AV *arr;
+ SV **svp;
+
+ /* loc = 0 => no location header found
+ * loc = 1 => location header found
+ * loc = 2 => location header + value found
+ */
+ I32 loc;
hv_iterinit (r -> pHeaderHash) ;
while ((pEntry = hv_iternext (r -> pHeaderHash)))
{
pKey = hv_iterkey (pEntry, &l) ;
pHeader = hv_iterval (r -> pHeaderHash, pEntry) ;
-
+ loc = 0;
if (pHeader && pKey)
{
- p = SvPV (pHeader, ldummy) ;
+
if (strnicmp (pKey, "location", 8) == 0)
- r -> pApacheReq->status = 301;
- if (strnicmp (pKey, "content-type", 12) == 0)
- r -> pApacheReq->content_type = pstrdup(r -> pApacheReq->pool, p);
- else
+ loc = 1;
+ if (strnicmp (pKey, "content-type", 12) == 0)
+ {
+ p = NULL;
+ if ( SvROK(pHeader) && SvTYPE(SvRV(pHeader)) == SVt_PVAV )
+ {
+ arr = (AV *)SvRV(pHeader);
+ if (av_len(arr) >= 0)
+ {
+ svp = av_fetch(arr, 0, 0);
+ p = SvPV(*svp, ldummy);
+ }
+ }
+ else
+ {
+ p = SvPV(pHeader, ldummy);
+ }
+ if (p)
+ r->pApacheReq->content_type = pstrdup(r->pApacheReq->pool, p);
+ }
+ else if (SvROK(pHeader) && SvTYPE(SvRV(pHeader)) == SVt_PVAV )
+ {
+ arr = (AV *)SvRV(pHeader);
+ len = av_len(arr);
+ for (i = 0; i <= len; i++)
+ {
+ svp = av_fetch(arr, i, 0);
+ p = SvPV(*svp, ldummy);
+ table_add( r->pApacheReq->headers_out, pstrdup(r->pApacheReq->pool, pKey),
+ pstrdup(r->pApacheReq->pool, p ) );
+ if (loc == 1)
+ {
+ loc = 2;
+ break;
+ }
+ }
+ }
+ else
+ {
+ p = SvPV(pHeader, ldummy);
table_set(r -> pApacheReq->headers_out, pstrdup(r -> pApacheReq->pool, pKey), pstrdup(r -> pApacheReq->pool, p)) ;
+ if (loc == 1) loc = 2;
+ }
+
+ if (loc == 2) r->pApacheReq->status = 301;
}
}
+
+
if (pCookie)
{
table_add(r -> pApacheReq->headers_out, sSetCookie, pstrdup(r -> pApacheReq->pool, SvPV(pCookie, ldummy))) ;
1.21 +26 -4 embperl/eputil.c
Index: eputil.c
===================================================================
RCS file: /home/cvs/embperl/eputil.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- eputil.c 2001/05/02 04:08:57 1.20
+++ eputil.c 2001/05/10 19:08:17 1.21
@@ -1,6 +1,6 @@
/*###################################################################################
#
-# Embperl - Copyright (c) 1997-1999 Gerald Richter / ECOS
+# Embperl - Copyright (c) 1997-2001 Gerald Richter / ECOS
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
@@ -10,6 +10,8 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
+# $Id: eputil.c,v 1.21 2001/05/10 19:08:17 richter Exp $
+#
###################################################################################*/
@@ -863,6 +865,7 @@
return ok ;
}
+
#ifdef EP2
/* ------------------------------------------------------------------------- */
@@ -897,8 +900,10 @@
HV * pCleanupHV ;
char * s ;
GV * pFileGV ;
+ /*
GV * symtabgv ;
GV * symtabfilegv ;
+ */
dTHR;
@@ -913,9 +918,11 @@
return ;
}
+ /*
symtabgv = (GV *)*ppSV ;
symtabfilegv = (GV *)GvFILEGV (symtabgv) ;
-
+ */
+
pSV = newSVpvf ("%s::CLEANUP", sPackage) ;
s = SvPV (pSV, l) ;
pCV = perl_get_cv (s, 0) ;
@@ -951,7 +958,12 @@
while ((val = hv_iternextsv(symtab, &key, &klen)))
{
if(SvTYPE(val) != SVt_PVGV)
+ {
+ if (bDebug)
+ lprintf (r, "[%d]CUP: Ignore ??? because it's no gv\n", r -> nPid) ;
+
continue;
+ }
s = GvNAME((GV *)val) ;
l = strlen (s) ;
@@ -975,15 +987,25 @@
continue ;
}
+ if (s[0] == ':' && s[1] == ':')
+ {
+ if (bDebug)
+ lprintf (r, "[%d]CUP: Ignore %s because it's special\n", r -> nPid, s) ;
+ continue ;
+ }
+
+ /*
pFileGV = GvFILEGV ((GV *)val) ;
if (pFileGV != symtabfilegv)
{
if (bDebug)
- lprintf (r, "[%d]CUP: Ignore %s because it's defined in another source file\n", r -> nPid, s) ;
+ lprintf (r, "[%d]CUP: Ignore %s because it's defined in another source file (%s)\n", r -> nPid, s, GvFILE((GV *)val)) ;
continue ;
}
+ */
}
+
if((sv = GvSV((GV*)val)) && SvOK (sv))
{
if (bDebug)
@@ -1016,8 +1038,8 @@
}
}
-
#endif
+
/* ------------------------------------------------------------------------- */
/* */
1.102 +111 -26 embperl/test.pl
Index: test.pl
===================================================================
RCS file: /home/cvs/embperl/test.pl,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -r1.101 -r1.102
--- test.pl 2001/05/02 05:30:15 1.101
+++ test.pl 2001/05/10 19:08:18 1.102
@@ -1,8 +1,23 @@
#!/usr/bin/perl --
+
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2001 Gerald Richter / ECOS
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+#
+# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+#
+# $Id: test.pl,v 1.102 2001/05/10 19:08:18 richter Exp $
+#
+###################################################################################
+
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
-
# version =>
# errors =>
# query_string =>
@@ -17,10 +32,15 @@
# compartment =>
# cookie =>
# condition =>
+# param =>
+# reqbody =>
+# respheader => \%
@testdata = (
'ascii' => { },
- 'pure.htm' => { },
+ 'pure.htm' => {
+# 'noloop' => 1,
+ },
'plain.htm' => {
repeat => 3,
},
@@ -164,13 +184,19 @@
},
'java.htm' => { },
'inputjava.htm' => { },
+ 'inputjs2.htm' => {
+ 'version' => 2,
+ },
'heredoc.htm' => { },
'post.htm' => {
'offline' => 0,
+ 'reqbody' => "f1=abc1&f2=1234567890&f3=" . 'X' x 8192,
},
'upload.htm' => {
'query_info' => 'multval=A&multval=B&multval=C&single=S',
'offline' => 0,
+# 'noloop' => 1,
+ 'reqbody' => "Hi there!",
},
'reqrec.htm' => {
'offline' => 0,
@@ -221,6 +247,17 @@
'version' => 2,
'repeat' => 2,
},
+ 'execfirst.htm' => {
+ 'version' => 2,
+ },
+ 'execsecond.htm' => {
+ 'version' => 2,
+ },
+ 'execprint.htm' => {
+ 'version' => 2,
+ },
+# 'execinside.htm' => {
+# },
'importsub.htm' => {
'repeat' => 2,
},
@@ -245,6 +282,9 @@
},
'sub.htm' => { },
'sub.htm' => { },
+ 'subtab.htm' => {
+ 'version' => 2,
+ },
'exit.htm' => {
'version' => 1,
'offline' => 0,
@@ -288,6 +328,8 @@
'http.htm' => {
'offline' => 0,
'version' => 1,
+ 'reqbody' => "a=b", # Force POST, so no redirect happens
+ 'respheader' => { 'location' => 'http://www.ecos.de/embperl/', 'h1' => 'v0', h2 => [ 'v1', 'v2'] },
},
'div.htm' => {
'repeat' => 2,
@@ -529,10 +571,37 @@
'incperl.htm' => {
'version' => 2,
},
+ 'asp.htm' => {
+ 'version' => 2,
+ },
'syntax.htm' => {
'version' => 2,
'repeat' => 2,
},
+ 'rtf/rtfbasic.asc' => {
+ 'version' => 2,
+ 'syntax' => 'RTF',
+ 'offline' => 1,
+ 'param' => { one => 1, hash => { a => 111, b => 222, c => [1111,2222,3333,4444]}, array => [11,22,33] },
+ },
+ 'rtf/rtffull.asc' => {
+ 'version' => 2,
+ 'syntax' => 'RTF',
+ 'offline' => 1,
+ 'param' => { 'Nachname' => 'Richter', Vorname => 'Gerald' },
+ },
+ 'rtf/rtfloop.asc' => {
+ 'version' => 2,
+ 'syntax' => 'RTF',
+ 'offline' => 1,
+ 'param' => [
+ { 'Kunde' => 'blabla', Kurs => 'blubblub', 'Nachname' => 'Richter', Vorname => 'Gerald' },
+ { 'Kunde' => 'blabla', Kurs => 'blubblub', 'Nachname' => 'Richter2', Vorname => 'Gerald2' },
+ { 'Kunde' => 'blabla', Kurs => 'blubblub', 'Nachname' => 'Richter3', Vorname => 'Gerald3' },
+ { 'Kunde' => 'blabla', Kurs => 'blubblub', 'Nachname' => 'Richter4', Vorname => 'Gerald4' },
+ { 'Kunde' => 'blabla', Kurs => 'blubblub', 'Nachname' => 'Richter5', Vorname => 'Gerald5' },
+ ]
+ },
) ;
for ($i = 0 ; $i < @testdata; $i += 2)
@@ -576,7 +645,7 @@
$opt_testlib = 1 ;
}
- if ($INC[0] =~ /^blib/)
+ if ($INC[0] =~ /^(\.\/)?blib/)
{
my $i = 0 ;
foreach (@INC)
@@ -898,7 +967,7 @@
sub REQ
{
- my ($loc, $file, $query, $ofile, $content, $upload, $cookieaction) = @_ ;
+ my ($loc, $file, $query, $ofile, $content, $upload, $cookieaction, $respheader) = @_ ;
eval 'require LWP::UserAgent' ;
@@ -972,7 +1041,7 @@
#print $response -> headers -> as_string () ;
- return $response -> message if (!$response->is_success) ;
+ return $response -> message if (!($response->is_success || ($response->is_redirect && $respheader && $respheader ->{location}) )) ;
my $m = 'ok' ;
print "\nExpected new cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectnew/) && ($sendcookie eq $c || !$c)) ;
@@ -980,6 +1049,38 @@
print "\nExpected no cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectno/) && $c) ;
print "\nExpected expire cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectexpire/) && !($c =~ /^EMBPERL_UID=; expires=/)) ;
+
+ if ($respheader)
+ {
+ local $^W = 0 ;
+ while (my ($k, $v) = each (%$respheader))
+ {
+ my @x ;
+ my $i ;
+
+ if (ref ($v) eq 'ARRAY')
+ {
+ @x = split (/\s*,\s*/, $response -> header ($k)) ;
+ $i = 0 ;
+ foreach (@$v)
+ {
+ if ($x[$i] ne $_)
+ {
+ print "\nExpected HTTP header #$i $k: $_, Got value $x[$i]" ;
+ $m = 'header missing' ;
+ }
+ $i++ ;
+ }
+ }
+ elsif (($x = $response -> header ($k)) ne $v)
+ {
+ print "\nExpected HTTP header $k: $v, Got value $x" ;
+ $m = 'header missing' ;
+ }
+ }
+ }
+
+
return $m ;
}
@@ -1064,7 +1165,7 @@
open SVLOG, $logfile or die "Cannot open $logfile ($!)" ;
- seek SVLOG, -3000, 2 ;
+ seek SVLOG, ($EP2?-10000:-3000), 2 ;
while (<SVLOG>)
{
@@ -1289,6 +1390,7 @@
@testargs = ( '-o', $outfile ,
'-l', $logfile,
'-d', $debug,
+ ($test->{param}?(ref ($test->{param}) eq 'ARRAY'?map { ('-p', $_) } @{$test->{param}}:('-p', $test->{param})):()),
$page, $test -> {query_info} || '') ;
unshift (@testargs, 'dbgbreak') if ($opt_dbgbreak) ;
@@ -1906,21 +2008,6 @@
}
-=pod
- next if ($file =~ /\// && $loc eq $cgiloc) ;
- next if ($file eq 'taint.htm' && $loc eq $cgiloc) ;
- next if ($file eq 'reqrec.htm' && $loc eq $cgiloc) ;
- next if (($file =~ /^exit.htm/) && $loc eq $cgiloc) ;
- #next if ($file eq 'error.htm' && $loc eq $cgiloc && $errcnt < 16) ;
- next if ($file eq 'varerr.htm' && $loc eq $cgiloc && $errcnt > 0) ;
- next if ($file eq 'varerr.htm' && $looptest) ;
- next if (($file =~ /registry/) && $loc eq $cgiloc) ;
- next if (($file =~ /match/) && $loc eq $cgiloc) ;
- #next if ($file eq 'http.htm' && $loc eq $cgiloc) ;
- #next if ($file eq 'notallow.xhtm' && $loc eq $cgiloc && $EPWIN32) ;
- next if ($file eq 'clearsess.htm' && !$looptest) ;
- next if (($file =~ /EmbperlObject/) && $loc eq $cgiloc) ;
-=cut
next if ($file eq 'chdir.htm' && $EPWIN32) ;
next if ($file eq 'notfound.htm' && $loc eq $cgiloc && $EPWIN32) ;
next if ($file =~ /opmask/ && $EPSTARTUP =~ /_dso/) ;
@@ -1968,13 +2055,11 @@
print $txt ;
unlink ($outfile) ;
- $content = undef ;
- $content = "f1=abc1&f2=1234567890&f3=" . 'X' x 8192 if ($file eq 'post.htm') ;
+ $content = $test -> {reqbody} || undef ;
$upload = undef ;
if ($file eq 'upload.htm')
{
$upload = "f1=abc1\r\n&f2=1234567890&f3=" . 'X' x 8192 ;
- $content = "Hi there!" ;
}
if (!$EPWIN32 && $loc eq $embploc && !($file =~ /notfound\.htm/))
@@ -1989,7 +2074,7 @@
$file .= '-1' if ($opt_ep1 && -e "$page-1") ;
if (defined ($opt_ab))
{
- $m = REQ ("$loc$locver", $file, $test -> {query_info}, $outfile, $content, $upload, $test -> {cookie}) if ($opt_abpre) ;
+ $m = REQ ("$loc$locver", $file, $test -> {query_info}, $outfile, $content, $upload, $test -> {cookie}, $test -> {respheader}) if ($opt_abpre) ;
$locver ||= '' ;
$opt_ab = 10 if (!$opt_ab) ;
my $cmd = "ab -n $opt_ab 'http://$host:$port/$loc$locver/$file" . ($test->{query_info}?"?$test->{query_info}'":"'") ;
@@ -2004,7 +2089,7 @@
}
else
{
- $m = REQ ("$loc$locver", $file, $test -> {query_info}, $outfile, $content, $upload, $test -> {cookie}) ;
+ $m = REQ ("$loc$locver", $file, $test -> {query_info}, $outfile, $content, $upload, $test -> {cookie}, $test -> {respheader}) ;
}
$t_req += HTML::Embperl::Clock () - $t1 ;
1.6 +12 -0 embperl/test/cmp/http.htm
Index: http.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/http.htm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- http.htm 1999/10/07 07:07:02 1.5
+++ http.htm 2001/05/10 19:08:36 1.6
@@ -13,6 +13,18 @@
<tr>
<td>Formatter</td><td>Embperl</td>
</tr>
+
+ <tr>
+ <td>Location</td><td>http://www.ecos.de/embperl/</td>
+ </tr>
+
+ <tr>
+ <td>h1</td><td>v0</td>
+ </tr>
+
+ <tr>
+^ <td>h2<\/td><td>ARRAY\(.*?\)<\/td>
+ </tr>
</table>
1.5 +5 -2 embperl/test/html/http.htm
Index: http.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/http.htm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- http.htm 1999/10/07 07:07:07 1.4
+++ http.htm 2001/05/10 19:08:38 1.5
@@ -9,9 +9,12 @@
<meta http-equiv="Formatter" content="Embperl">
-[#
+[-
$http_headers_out{'Location'} = "http://www.ecos.de/embperl/" ;
-#]
+$http_headers_out{'h1'} = "v0" ;
+$http_headers_out{'h2'} = ['v1', 'v2'] ;
+-]
+
[- @ks = sort keys %http_headers_out -]
<table>
---------------------------------------------------------------------
To unsubscribe, e-mail: embperl-cvs-unsubscribe@perl.apache.org
For additional commands, e-mail: embperl-cvs-help@perl.apache.org