richter 02/03/01 00:24:37
Modified: . Tag: Embperl2c epmain.c test.pl
Embperl Tag: Embperl2c Object.pm
Embperl/Form Tag: Embperl2c Validate.pm
Embperl/Form/Validate Tag: Embperl2c Rules.pm
Embperl/Form/Validate/Messages Tag: Embperl2c Default.pm
Test.pm
Embperl/Syntax Tag: Embperl2c POD.pm
Log:
EO error handling & form validation
Revision Changes Path
No revision
No revision
1.75.4.106 +11 -9 embperl/epmain.c
Index: epmain.c
===================================================================
RCS file: /home/cvs/embperl/epmain.c,v
retrieving revision 1.75.4.105
retrieving revision 1.75.4.106
diff -u -r1.75.4.105 -r1.75.4.106
--- epmain.c 1 Mar 2002 05:38:51 -0000 1.75.4.105
+++ epmain.c 1 Mar 2002 08:24:36 -0000 1.75.4.106
@@ -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.75.4.105 2002/03/01 05:38:51 richter Exp $
+# $Id: epmain.c,v 1.75.4.106 2002/03/01 08:24:36 richter Exp $
#
###################################################################################*/
@@ -1304,15 +1304,17 @@
r -> Component.bReqRunning = 1 ;
- if ((rc = ProcessFile (r, 0 /*r -> Buf.pFile -> nFilesize*/)) != ok)
- if (rc == rcExit)
- rc = ok ;
- else
- LogError (r, rc) ;
-
- if (r -> Component.Param.nImport > 0)
- export (r) ;
+ if (!r -> bError)
+ {
+ if ((rc = ProcessFile (r, 0 /*r -> Buf.pFile -> nFilesize*/)) != ok)
+ if (rc == rcExit)
+ rc = ok ;
+ else
+ LogError (r, rc) ;
+ if (r -> Component.Param.nImport > 0)
+ export (r) ;
+ }
/* --- Restore Operatormask and Package, destroy temp perl sv's --- */
FREETMPS ;
1.70.4.119 +45 -21 embperl/test.pl
Index: test.pl
===================================================================
RCS file: /home/cvs/embperl/test.pl,v
retrieving revision 1.70.4.118
retrieving revision 1.70.4.119
diff -u -r1.70.4.118 -r1.70.4.119
--- test.pl 1 Mar 2002 05:38:52 -0000 1.70.4.118
+++ test.pl 1 Mar 2002 08:24:36 -0000 1.70.4.119
@@ -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.70.4.118 2002/03/01 05:38:52 richter Exp $
+# $Id: test.pl,v 1.70.4.119 2002/03/01 08:24:36 richter Exp $
#
###################################################################################
@@ -2277,7 +2277,28 @@
if (($loc ne '' && $err == 0 && $loopcnt == 0 && !$opt_nostart) || $opt_start
|| $opt_startinter)
{
- system "kill `cat $tmppath/httpd.pid` 2> /dev/null" if (!$EPWIN32 &&
$opt_start) ;
+ if ($opt_start)
+ {
+ if (open FH, "$tmppath/httpd.pid")
+ {
+ $httpdpid = <FH> ;
+ chop($httpdpid) ;
+ close FH ;
+
+ unlink "$tmppath/httpd.pid" ;
+
+ print "Try to kill Apache pid = $httpdpid\n" ;
+ if ($EPWIN32)
+ {
+ my $exitcode = 0 ;
+ #Win32::Process::KillProcess($httpdpid, $exitcode)
+ }
+ else
+ {
+ kill 15, $httpdpid ;
+ }
+ }
+ }
#### Configure httpd conf file
$EPDEBUG = $defaultdebug ;
@@ -2335,27 +2356,30 @@
system ("$EPHTTPD $XX -f $EPPATH/$httpdconf " .
($opt_startinter?'':'&')) and die "***Cannot start $EPHTTPD" ;
}
}
- sleep (3) ;
- if (!open FH, "$tmppath/httpd.pid")
- {
- sleep (7) ;
- if (!open FH, "$tmppath/httpd.pid")
- {
- sleep (($opt_gdb || $opt_ddd)?15:7) ;
- if (!open FH, "$tmppath/httpd.pid")
- {
- open (FERR, "$httpderr") ;
- print $_ while (<FERR>) ;
- close FERR ;
- die "Cannot open $tmppath/httpd.pid" ;
- }
+
+ my $tries = ($opt_gdb || $opt_ddd)?20:10 ;
+ $httpdpid = 0 ;
+ while ($tries-- > 0)
+ {
+ if (open FH, "$tmppath/httpd.pid")
+ {
+ $httpdpid = <FH> ;
+ chop($httpdpid) ;
+ close FH ;
+ last ;
}
+ sleep (1) ;
+ }
- }
- $httpdpid = <FH> ;
- chop($httpdpid) ;
- close FH ;
- print "pid = $httpdpid ok\n" ;
+ die "Cannot open $tmppath/httpd.pid" if (!$httpdpid) ;
+
+ if ($EPWIN32)
+ {
+ $httpdpid = $HttpdObj -> GetProcessID ;
+ }
+
+
+ print "pid = $httpdpid ok\n" ;
close ERR ;
open (ERR, "$httpderr") ;
No revision
No revision
1.1.2.12 +43 -32 embperl/Embperl/Attic/Object.pm
Index: Object.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Attic/Object.pm,v
retrieving revision 1.1.2.11
retrieving revision 1.1.2.12
diff -u -r1.1.2.11 -r1.1.2.12
--- Object.pm 28 Feb 2002 07:54:58 -0000 1.1.2.11
+++ Object.pm 1 Mar 2002 08:24:37 -0000 1.1.2.12
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Object.pm,v 1.1.2.11 2002/02/28 07:54:58 richter Exp $
+# $Id: Object.pm,v 1.1.2.12 2002/03/01 08:24:37 richter Exp $
#
###################################################################################
@@ -217,12 +217,12 @@
my $cparam = {%$req, inputfile => $fn, import => 0 } ;
my $c = $r -> setup_component ($cparam) ;
$c -> run ;
- $basepackage = $packages{$fn} = $c -> curr_package ;
+ $basepackage = $packages{$fn} = $c -> curr_package if (!$r -> error) ;
$c -> cleanup ;
- print Embperl::LOG "[$$]Embperl::Object import base finished: $fn,
package = $basepackage\n" if ($debug);
+ print Embperl::LOG "[$$]Embperl::Object import base ", ($r ->
error?'with ERRORS ':'') . "finished: $fn, " . ($basepackage?"package = $basepackage
\n":"\n") if ($debug);
}
no strict ;
- if (!@{"$basepackage\:\:ISA"})
+ if (!@{"$basepackage\:\:ISA"} && !$r -> error)
{
@{"$basepackage\:\:ISA"} = ($appcfg -> object_handler_class ||
'Embperl::Req') ;
}
@@ -230,7 +230,7 @@
$r -> config -> path (\@searchpath) ;
- if ($appcfg -> object_app)
+ if ($appcfg -> object_app && !$r -> error)
{
my $appfn = $appcfg -> object_app ;
print Embperl::LOG "[$$]Embperl::Object import new Application:
$appfn\n" if ($debug);
@@ -238,29 +238,34 @@
my $cparam = {object => $appfn, syntax => 'Perl'} ;
my $c = $r -> setup_component ($cparam) ;
my $app = $c -> run ;
- my $package = $packages{"$fn::$appfn"} = $c -> curr_package ;
+ my $package = $packages{"$fn::$appfn"} = $c -> curr_package if (!$r ->
error) ;
$c -> cleanup ;
- print Embperl::LOG "[$$]Embperl::Object import new Application
finished: $fn, package = $package\n" if ($debug);
+ print Embperl::LOG "[$$]Embperl::Object import new Application ", ($r
-> error?'with ERRORS ':'') . "finished: $fn, " . ($package?"package =
$package\n":"\n") if ($debug);
- #return 500 if (!$app) ;
-
- no strict ;
- if (!@{"$package\:\:ISA"})
+ if (!$r -> error)
{
- @{"$package\:\:ISA"} = ("Embperl::App") if ($package ne
$basepackage) ;
- }
- use strict ;
+ no strict ;
+ if (!@{"$package\:\:ISA"})
+ {
+ @{"$package\:\:ISA"} = ("Embperl::App") if ($package ne
$basepackage) ;
+ }
+ use strict ;
- $app = $r -> app ;
- bless $app, $package ;
+ $app = $r -> app ;
+ bless $app, $package ;
- my $status = $app -> init ($r) ;
- if ($status)
- {
- $r -> cleanup ;
- return $status ;
+ my $status = eval { $app -> init ($r) ; } ;
+ if ($@)
+ {
+ $r -> logerror (Embperl::Constant::rcEvalErr, $@, $apr) ;
+ }
+ elsif ($status)
+ {
+ $r -> cleanup ;
+ return $status ;
+ }
+ $filename = norm_path ($r -> param -> filename, $cwd) ;
}
- $filename = norm_path ($r -> param -> filename, $cwd) ;
}
if (!-f $filename && $appcfg -> object_fallback)
@@ -273,31 +278,35 @@
if ($fn eq $filename)
{
$r -> logerror (Embperl::Constant::rcForbidden, $filename, $apr) ;
+ $r -> cleanup ;
return FORBIDDEN ;
}
- if (!$package || $fallback)
+ if ((!$package || $fallback) && !$r -> error)
{
print Embperl::LOG "[$$]Embperl::Object import new file: $filename\n"
if ($debug && !$fallback);
my $cparam = {%$req, inputfile => $filename, import => 0 } ;
my $c = $r -> setup_component ($cparam) ;
$c -> run ;
- $package = $packages{$filename} = $c -> curr_package ;
+ $package = $packages{$filename} = $c -> curr_package if (!$r -> error);
$c -> cleanup ;
print Embperl::LOG "[$$]Embperl::Object import finished: $filename,
package = $package\n" if ($debug);
}
- no strict ;
- if (!@{"$package\:\:ISA"})
+ if (!$r -> error)
{
- @{"$package\:\:ISA"} = ($basepackage) if ($package ne $basepackage) ;
- }
- use strict ;
+ no strict ;
+ if (!@{"$package\:\:ISA"})
+ {
+ @{"$package\:\:ISA"} = ($basepackage) if ($package ne $basepackage)
;
+ }
+ use strict ;
- $r -> param -> filename ($filename) if ($filename ne $fn) ;
- bless $r, $package ;
+ $r -> param -> filename ($filename) if ($filename ne $fn) ;
+ bless $r, $package ;
+ }
my $cparam = {%$req, inputfile => $fn } ;
my $c = $r -> setup_component ($cparam) ;
@@ -308,7 +317,9 @@
}
- $apr -> log_error ("Embperl::Object $basename not found. Searched
'@searchpath'" . ($addpath?" and '@$addpath' ":'')) if ($apr) ;
+ $r -> logerror (Embperl::Constant::rcNotFound, $basename, $apr) ;
+ $apr -> log_error ("Embperl::Object base $basename not found. Searched
'@searchpath'" . ($addpath?" and '@$addpath' ":'')) if ($apr) ;
+ $r -> cleanup ;
return &NOT_FOUND ;
}
No revision
No revision
1.1.2.2 +28 -9 embperl/Embperl/Form/Attic/Validate.pm
Index: Validate.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Attic/Validate.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Validate.pm 27 Feb 2002 15:42:50 -0000 1.1.2.1
+++ Validate.pm 1 Mar 2002 08:24:37 -0000 1.1.2.2
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Validate.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $
+# $Id: Validate.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $
#
###################################################################################
@@ -20,7 +20,7 @@
use strict;
use vars qw($VERSION);
-$VERSION = q$Id: Validate.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $;
+$VERSION = q$Id: Validate.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $;
=head1 NAME
@@ -1053,6 +1053,8 @@
}
}
}
+ if (wrong == '-')
+ wrong = '' ;
return wrong;
}
";
@@ -1130,7 +1132,7 @@
{
my $name = shift;
my $prefix = shift;
- $name =~ s/^/$prefix/ if $name !~ /^$prefix/ && $name ne 'required';
+ $name =~ s/^/$prefix/ if ($name !~ /^$prefix/) && $name ne 'required' && $name
ne 'emptyok';
return $name
}
@@ -1150,12 +1152,29 @@
contain the name of a test and the value to test against, except for
the keys
- * 'type', which contains the type of field, e.g. 'String' or 'Integer',
- * 'rules_prefix', which contains the prefix for the error messages
- and scripting functions, e.g. 'string_',
- * 'name', which contains the literal name of the field (e.g. 'zip code'),
- and
- * 'messages', which contains field specific error messages.
+=over
+
+=item * 'type'
+
+contains the type of field, e.g. 'String' or 'Integer', required.
+
+=item * 'rules_prefix'
+
+contains the prefix for the error messages and scripting functions,
+e.g. 'string_', optional defaults to 'type'
+
+
+=item * 'name'
+
+contains the literal description of the field (e.g. 'zip code'),
+optional defaults to the name of the field
+
+
+=ietm * 'messages'
+
+contains field specific error messages. optional.
+
+=back
Here\'s an example for some fictive rules:
No revision
No revision
1.1.2.2 +23 -5 embperl/Embperl/Form/Validate/Attic/Rules.pm
Index: Rules.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Attic/Rules.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Rules.pm 27 Feb 2002 15:42:50 -0000 1.1.2.1
+++ Rules.pm 1 Mar 2002 08:24:37 -0000 1.1.2.2
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Rules.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $
+# $Id: Rules.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $
#
###################################################################################
@@ -20,7 +20,7 @@
use strict;
use vars qw($VERSION %error_messages %script_functions);
-$VERSION = q$Id: Rules.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $;
+$VERSION = q$Id: Rules.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $;
%error_messages =
(
@@ -30,13 +30,16 @@
%script_functions =
( javascript => {
- required => ['function EPForm_validate_required (object, desc, req) {
+ required => [
+
+'function EPForm_validate_required (object, desc, req) {
if (!object.value) {
return "$errormessage";
} else {
return "";
}
}',
+
'"+object.name+"',
'"+desc+"',
'"+req+"',
@@ -44,13 +47,23 @@
'"+object.value+"',
{ map { (ref $_ ? $_->{required} : $_ ) } %error_messages}
],
- emptyok => ['function EPForm_validate_emptyok (object, desc, req) {
+
+ emptyok => [
+
+'function EPForm_validate_emptyok (object, desc, req) {
if (!object.value) {
return "-";
} else {
return "";
}
}',
+
+ '"+object.name+"',
+ '"+desc+"',
+ '"+req+"',
+ '"+object.value+"',
+ '"+object.value+"',
+ { map { (ref $_ ? $_->{required} : $_ ) } %error_messages}
]
} );
@@ -177,6 +190,11 @@
$needed_tests{required} = 1;
next;
}
+ if ($frule eq 'emptyok')
+ {
+ $needed_tests{emptyok} = 1;
+ next;
+ }
next if ($frule eq 'type' ||
$frule eq 'messages' ||
$frule eq 'prefixes' ||
@@ -190,7 +208,7 @@
if ($type eq 'required' || $type eq 'emptyok')
{
push(@functions,
- $type => $script_functions{$script_lang}{emptyok});
+ $type => $script_functions{$script_lang}{$type});
}
else
{
No revision
No revision
1.1.2.2 +19 -3 embperl/Embperl/Form/Validate/Messages/Attic/Default.pm
Index: Default.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Messages/Attic/Default.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Default.pm 27 Feb 2002 15:42:50 -0000 1.1.2.1
+++ Default.pm 1 Mar 2002 08:24:37 -0000 1.1.2.2
@@ -1,7 +1,23 @@
-package EPForm::Messages::Default;
-my
-$VERSION = q$Id: Default.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $;
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2002 Gerald Richter / ecos gmbh www.ecos.de
+#
+# 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: Default.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::Messages::Default;
+
+my $VERSION = q$Id: Default.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $;
use strict;
1.1.2.2 +19 -3 embperl/Embperl/Form/Validate/Messages/Attic/Test.pm
Index: Test.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate/Messages/Attic/Test.pm,v
retrieving revision 1.1.2.1
retrieving revision 1.1.2.2
diff -u -r1.1.2.1 -r1.1.2.2
--- Test.pm 27 Feb 2002 15:42:50 -0000 1.1.2.1
+++ Test.pm 1 Mar 2002 08:24:37 -0000 1.1.2.2
@@ -1,7 +1,23 @@
-package EPForm::Messages::Test;
-my
-$VERSION = q$Id: Test.pm,v 1.1.2.1 2002/02/27 15:42:50 richter Exp $;
+###################################################################################
+#
+# Embperl - Copyright (c) 1997-2002 Gerald Richter / ecos gmbh www.ecos.de
+#
+# 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.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $
+#
+###################################################################################
+
+
+package Embperl::Form::Validate::Messages::Test;
+
+my $VERSION = q$Id: Test.pm,v 1.1.2.2 2002/03/01 08:24:37 richter Exp $;
use strict;
use base qw(EPForm::Messages::Default);
No revision
No revision
1.1.2.12 +27 -22 embperl/Embperl/Syntax/Attic/POD.pm
Index: POD.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Syntax/Attic/POD.pm,v
retrieving revision 1.1.2.11
retrieving revision 1.1.2.12
diff -u -r1.1.2.11 -r1.1.2.12
--- POD.pm 1 Mar 2002 05:38:52 -0000 1.1.2.11
+++ POD.pm 1 Mar 2002 08:24:37 -0000 1.1.2.12
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: POD.pm,v 1.1.2.11 2002/03/01 05:38:52 richter Exp $
+# $Id: POD.pm,v 1.1.2.12 2002/03/01 08:24:37 richter Exp $
#
###################################################################################
@@ -22,7 +22,7 @@
use Embperl::Syntax::EmbperlBlocks ;
use strict ;
-use vars qw{@ISA %Tags %Format %Escape %Para %ParaItem %ParaTitle %List %Search
%ListStart %CDATA} ;
+use vars qw{@ISA %Tags %Format %Escape %Para %ParaItem %ParaTitle %List %Search
%ListStart %CDATA %Skip} ;
@@ -279,6 +279,29 @@
) ;
+%Skip =
+ (
+ 'skip1' =>
+ {
+ 'text' => "\n",
+ 'contains' => "\r\n",
+ 'nodetype' => ntypTag,
+ 'cdatatype' => 0,
+ 'removespaces' => 0,
+ 'nodename' => "!:\n",
+ },
+ 'skip2' =>
+ {
+ 'text' => "\r",
+ 'contains' => "\r\n",
+ 'nodetype' => ntypTag,
+ 'cdatatype' => 0,
+ 'removespaces' => 0,
+ 'nodename' => "!:\n",
+ },
+ ) ;
+
+
%Para =
(
%List,
@@ -311,25 +334,7 @@
'nodetype' => ntypStartEndTag,
'cdatatype' => ntypText,
},
-
- 'skip1' =>
- {
- 'text' => "\n",
- 'contains' => "\r\n",
- 'nodetype' => ntypTag,
- 'cdatatype' => 0,
- 'removespaces' => 0,
- 'nodename' => "!:\n",
- },
- 'skip2' =>
- {
- 'text' => "\r",
- 'contains' => "\r\n",
- 'nodetype' => ntypTag,
- 'cdatatype' => 0,
- 'removespaces' => 0,
- 'nodename' => "!:\n",
- },
+ %Skip,
) ;
%ParaTitle =
@@ -514,7 +519,7 @@
'cdatatype' => 0,
'exitinside' => 1,
},
-
+ %Skip,
# %Para,
) ;
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
