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 2002/11/20 07:56:29 UTC
cvs commit: embperl/test/html/app i18n.htm
richter 2002/11/19 22:56:29
Modified: . Changes.pod DOM.xs MANIFEST epcache.c epcmd2.c
epdom.c
Embperl/Form Validate.pm
eg/web config.pl epwebapp.pl footer.htm messages.pl
notfound.htm
eg/web/db add.epl addsel.epl content.epl data.epd
epwebapp.pl show.epl
eg/webutil db.schema
podsrc Config.spod
test/cmp2 hidden.htm input.htm
Added: . IntroEmbperl2.pod
eg/web/db list.epl newpw.mail newuser.admin.mail
newuser.mail updateditem.mail
test/cmp hostconfig.htm hostconfig.htm.3 hostconfig.htm.4
hostconfig.htm.5 i18n.htm mail.htm mailformto.htm
pod.xml pod.xml.xalan
test/html errormismatch.htm errormismatchcmd.htm
hostconfig.htm mail.htm mailformto.htm
test/html/app i18n.htm
Removed: eg/webutil EmbperlWebRecipe.pm
Log:
move 2.0 to HEAD
Revision Changes Path
1.191 +4 -2 embperl/Changes.pod
Index: Changes.pod
===================================================================
RCS file: /home/cvs/embperl/Changes.pod,v
retrieving revision 1.190
retrieving revision 1.191
diff -u -r1.190 -r1.191
--- Changes.pod 15 Nov 2002 06:17:36 -0000 1.190
+++ Changes.pod 20 Nov 2002 06:56:25 -0000 1.191
@@ -37,10 +37,12 @@
- Added [$last$], [$next$], [$redo$] and documented [* next *] etc.
- Readdeded missing MailFormTo and added test for it.
- Fixed escaping inside of html attributes of Embperl generated tags like input
- and [$ hidden $].
+ and [$ hidden $]. Reported by Axel Beckert.
- checked and selected attributes are now correctly set when values contains
entities (e.g. <)
-
+ - Fixed segfault when cleanup is called to early. Reported by Neil Gunton.
+ - If no name is given for a key, Form::Validate now tries to lookup the correct
+ text via Embperl's gettext method.
=head1 2.0b8 (BETA) 25. Juni 2002
1.5 +0 -0 embperl/DOM.xs
Index: DOM.xs
===================================================================
RCS file: /home/cvs/embperl/DOM.xs,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
1.74 +2 -3 embperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /home/cvs/embperl/MANIFEST,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -r1.73 -r1.74
--- MANIFEST 22 Oct 2002 05:29:04 -0000 1.73
+++ MANIFEST 20 Nov 2002 06:56:26 -0000 1.74
@@ -541,9 +541,8 @@
test/html/xml/pod.xml
test/html/xml/pod.xsl
test/html/xml/podold.xsl
-test/html2/error.htm
-test/html2/errormismatch.htm
-test/html2/errormismatchcmd.htm
+test/html/errormismatch.htm
+test/html/errormismatchcmd.htm
test/testapp.pl
typemap
xs/Embperl/App/App.xs
1.3 +10 -7 embperl/epcache.c
Index: epcache.c
===================================================================
RCS file: /home/cvs/embperl/epcache.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- epcache.c 22 Oct 2002 05:29:04 -0000 1.2
+++ epcache.c 20 Nov 2002 06:56:26 -0000 1.3
@@ -122,15 +122,18 @@
int Cache_CleanupRequest (req * r)
{
- int n = ArrayGetSize (r -> pApp, pCachesToRelease) ;
- int i ;
+ if (pCachesToRelease)
+ {
+ int n = ArrayGetSize (r -> pApp, pCachesToRelease) ;
+ int i ;
- /* lprintf (r -> pApp, "XXXXX Cache_CleanupRequest [%d/%d] pProviders=%x pCacheItems=%x pCachesToRelease=%x", _getpid(), GetCurrentThreadId(), pProviders, pCacheItems, pCachesToRelease) ; */
+ /* lprintf (r -> pApp, "XXXXX Cache_CleanupRequest [%d/%d] pProviders=%x pCacheItems=%x pCachesToRelease=%x", _getpid(), GetCurrentThreadId(), pProviders, pCacheItems, pCachesToRelease) ; */
- for (i = 0; i < n; i++)
- Cache_FreeContent (r, pCachesToRelease[i]) ;
+ for (i = 0; i < n; i++)
+ Cache_FreeContent (r, pCachesToRelease[i]) ;
- ArraySetSize(r -> pApp, &pCachesToRelease, 0) ;
+ ArraySetSize(r -> pApp, &pCachesToRelease, 0) ;
+ }
return ok ;
}
1.8 +0 -0 embperl/epcmd2.c
Index: epcmd2.c
===================================================================
RCS file: /home/cvs/embperl/epcmd2.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
1.8 +0 -0 embperl/epdom.c
Index: epdom.c
===================================================================
RCS file: /home/cvs/embperl/epdom.c,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
1.1 embperl/IntroEmbperl2.pod
Index: IntroEmbperl2.pod
===================================================================
=head1 NAME Embperl 2 - Introduction to advanced features of Embperl 2
=head1 Introduction
In the early days of the of the web, (server-side) dynamic web pages
meant CGI scripts. However, CGI scripts were lousy to read because of
a lot of C<print> statements with a lot of escaping, over
long lines and nearly no chance to guess the final output at one
glance.
These problems were mostly solved by the so called templating systems.
Popular templating systems are PHP, JSP and ASP.
In Perl there are multiple templating systems, each
which it's own advantages and disadvantages. One of the most powerfull
and widely used systems is I<Embperl>.
These templating systems embed the program code into the markup and
not vice versa as CGI scripts did. This usually made the code more
readable and the final output easier to guess.
The possibility to
include other files made complex web pages manageable, because you
can have common portions of the site in just one file and
include them in many others. So you could change the layout of the
headers, footers or menus each in just
one file and the design changed on all pages.
But imagine, you once want to the menu component - which always was on
the left side - on the right side. You would have to change all files
and move the statement which generates or includes the menu from in
front of the content to behind the content. If your site is large,
this can be a lot of (dumb) work.
Another disadvantage of this method is, that if you want one branch of
your site to have a slightly different layout - let's say it differs in
one of the included files - you'll have to change this information in
each of the affected files at top level. In object-oriented
programming, you would derive a new class from an existing one,
overriding just one or a few methods and all other methods will be
inherited from it's parent class(es).
So why not carryover the concept of object-oriented programming to
creating dynamic websites? Embperl does that by providing
I<Embperl::Object> and thereby facilating the conception and
implementation of big dynamic component-based websites.
Using Embperl's own website (http://perl.apache.org/embperl/)
as example, the following sections will show how
I<Embperl::Object> works. The full source code of the Embperl
website is included in the distribution of version 2.0 of Embperl in
the directory C</eg/web>
=head1 The Layout
=head2 Overview
The Embperl website basically is structured as follows:
+----------------------------------------------------------+
| base.epl |
| +------------------------------------------------------+ |
| | header.epl | |
| +------------------------------------------------------+ |
| |
| +--------------+ +------------------------------------+ |
| | menuleft.epl | | content.epl | |
| | | | +-------------------+ +----------+ | |
| | | | | * | | news.epl | | |
| | | | | | | | | |
| | | | | | | | | |
| | | | | | | | | |
| | | | | | | | | |
| | | | | | | | | |
| | | | | | | | | |
| | | | | | | | | |
| | | | +-------------------+ +----------+ | |
| +--------------+ +------------------------------------+ |
| |
| +------------------------------------------------------+ |
| | footer.epl | |
| +------------------------------------------------------+ |
+----------------------------------------------------------+
If a web page is requested (e.g. I</index.epl>,
I<Embperl::Object> first searches for the base template.
In case of the Embperl website this is
I<base.epl> (name can be configured in the web server
configuration), which looks like this:
<html>
<head>
<title>Embperl</title>
</head>
<body bgcolor="#ffffff">
[- Execute ('header.epl') -]
<table width="100%" border="0">
<tr>
<td>[- Execute ('menuleft.epl') -]</td>
<td>[- Execute ('content.epl') -]</td>
</tr>
</table>
[- Execute ('footer.htm') -]
</body>
</html>
I<base.epl> contains several calls to Execute. In our example C<Execute>
just includes the named pages, but it is very powerfully and has a
long list of possible arguments.
So I<base.epl> will include I<header.epl>,
I<menuleft.epl>, I<content.epl> and finally
include I<footer.htm>.
Let take a look at I<content.epl>. It looks like this:
<table width="100%" border="0">
<tr>
<td>[- Execute('*') -]</td>
<td>[- Execute('news.epl') -]</td>
</tr>
</table>
It contains again calls to C<Execute> of which one will call
I<news.epl> and the other one is special:
C<Execute('*')> includes the file initially requested from
the web server, in our case I</index.epl>.
So we have separated the layout from the content in a way, which
doesn't need any inclusion of headers, footers or menus in the files
providing the content. If we want to change the content, we just have
to modify one of the above mentioned files and the whole sites may
have changed it's layout without great effort.
There is another advantage: On pages other then the home page,
we don't want to show the news column and this can be simply done
by replacing I<content.epl> in a subdirectory. For example
under the directory I</pod> all the documentation is located. Now we
put there the file I</pod/content.epl>, which only contains:
[- Execute('*') -]
What's happeing now is, that when you request a file under the I</pod>
directory Embperl::Object uses this content.epl file and because of that,
the news comlumn will not be included.
So let make an example. When you request the file I</pod/doc/index.epl>,
which contains a list of all the documentation
available, Embperl::Object first searches the base template (base.epl).
It does this by walking up the directory tree, starting in the directory
where the requested file is located, until it either found it or reached
the document root (or the directory configured with C<EMBPERL_OBJECT_STOPDIR>).
When base.epl is found, the same search is taking place for all files
that are called via C<Execute>. This is the reason why it picks up the
/pod/content.epl in this case and header.epl etc. are still taken form the
same directory as before.
So what we done here is, that we have overridden I<content.epl> in the
sub directory I<pod>.
=head1 Separation of Application Logic and Content
After having separated the content from the layout, we usually still
have content mixed with application logic. To isolate the application
logic from the content, C<Embperl::Object> provides with
C<EMBPERL_OBJECT_APP> the possibility to define a file,
which contains all application code. For the Embperl website, the
application code resides I<epwebapp.pl>. For loading it,
C<Embperl::Object> searches the same path as for all other
included elements and the base template.
For each application file loaded this way, Embperl create on the fly a package and
a hash reference. It then I<bless>es the hash reference into the
package. So it provides easy object-oriented access to the
application. (Because Embperl already does this, you should B<not> include
a C<package> statement in that file.)
The application code file also will be automatically
inherited from C<Embperl::App> via C<@ISA>. This
enables easy access to all methods of superior objects as e.g session
handling.
Also note that the application file only contains Perl code and no markup,
since we are defining the application logic.
After loading the application code and preparing all request related
informations (like e.g. submitted form data, session data),
C<Embperl::Object> calls the method
C<init>, which - as usual for Perl methods - get's a reference
to the application object as first parameter. The second parameter is
Embperl's request object.
The following C<init> method is used at the emperl website
e.g. to generate the menus.
sub init
{
my ($self, $r) = @_;
my $config = Execute({ object => 'config.pl', syntax => 'Perl' });
$config->new($r) ;
$r->{config} = $config ;
$r->{menu} = $config->get_menu($r);
fill_menu($config, $r->{menu}, $r->{baseuri}, $r->{root});
my $filename = map_file($r);
$r->param->filename($filename);
return 0;
}
First the file I<config.pl> is loaded and used to generate an
object (as happend with the application code file itself), which is
returned by C<Execute()>. Then it initializes the new object
by calling its C<new> method and generates a menu by calling
the method C<get_menu>.
=head1 Defining the navigation structure
How the menu structure is defined in I<config.epl> doesn't matter.
In case of the Embperl website this is done within a Perl hash,
but it could also have been a XML file, the only point is
that the method C<get_menu> returns it in a well defined way.
The config object and the menu struture is placed into the request object.
Just like the application object, the request object is a blessed
hash reference. You can use theses hashs to store your own object data.
Embperl itself doesn't store anything inside of these hashs. The difference
between request and application object is their life time. While the
request object and all data it contains, is destroyed at the end of the request,
the application object is only destroyed when the server ends.
The method C<fill_menu> now takes this menu structure and the
parameters of the request and prepares it for displaying.
So when finaly C<menuleft.epl> is invoked to display the
menu, it only has to take the prepared data and surround it
with a nice layout. It doesn't contain any logic anymore,
so we have seprated the logic into the application object and
the layout into the template.
Another imported feature of the application object is, that it
is invoked before any output is generated, so you are able
to modify most of the request parameters. This is done in the next
few lines of the C<init> method, by callining C<map_file>.
C<map_file> tries to locate the requested uri in the configuration
provided by config.epl and, if found, returns the actual filename
for it. It also takes into account other parameters like
the prefered language to map to the correct file.
The init method now modifies the request to serve this file,
instead of using the one that come out of the mapping done by Apache.
As we have seen before the application object is search in the same
way as other pages. We can use this to define a derived application
object to extent functionality.
For the Embperl website this is done in the C</db> directory.
The website provides several informations which are stored
in a database, like news, links, examples, etc.
All necessary pages for the database access are beneath the C</db>
directory and it also contains a file C<epwebapp.pl>. So when
any page underneath /db is requested Embperl::Object will find
this application object instead of the one in the base directory.
This application object provides all necessary logic for the
database access, but we still need the functions from
application object we have discussed above. So what we do
is tell Embperl that is application object inherits from
the first one. This is done by calling Execute with the isa
parameter:
BEGIN { Execute ({isa => '../epwebapp.pl', syntax => 'Perl'}) ; }
This call load and compiles the base object and adjusts the C<@ISA>
array of the calling object accordingly to get a proper inherence.
This object also has an C<init> method, which looks like this:
sub init
{
my $self = shift ;
my $r = shift ;
$self->SUPER::init($r) ;
$self->initdb($r) ;
if ($fdat{-add_category})
{
$self -> add_category ($r) ;
$self -> get_category($r) ;
}
elsif ($fdat{-add_item})
{
$self -> add_item ($r) ;
$self -> get_category($r) ;
$self -> get_item_lang($r) ;
}
elsif ($fdat{-show_item})
{
$self -> get_category($r) ;
$self -> get_item_lang($r) ;
}
else
{
$self -> get_category($r) ;
$self -> get_item($r) ;
}
return 0 ;
}
First it calls C<SUPER::init> to give the base
class a chance to do its initialization. Then
it calls C<initdb>, which sets up database connections etc.
As next step it checks the hash C< %fdat>, which contains all the
form data that is send
by GET or POST to the page. Depending on what the user requested
when he/she submit the form, different methods are called,
which do the database access, like retrieving data and inserting new items etc.
The result of the database access is again placed into the request object
so it's available to the be displayed.
=head1 Converting different formats: Providers and Recipes
Not only on the Embperl website the content has different source formats.
For example the documentation is written in POD (Plain Old Documentation)
while the home page is HTML and other pages are HTML with some Perl code
in it. To manage these different formats you can give the C<syntax>
parameter to the C<Execute> function and tell Embperl how the source should
be interpreted. Embperl comes with different predefined syntaxes
(among others SSSI, ASP, Text, Perl, RTF, POD), but you can also
define your own syntax.
In the above example we can see that when reading the configuration file,
syntax => 'Perl' is used to tell Embperl that the configuration file
contains only Perl code. Similar you can use syntax => 'Text' to pass
the file through without doing any interpretation of the content.
Things get more compilcated when we try to process POD, because Embperl
not only has to understand the syntax, but also need to generate
the markup (HTML in this case).
For this purpose Embperl provides I<recipes>. A recipe defines which steps
are taken to process a source file. Each of these steps are done by a provider.
If no recipe is selected, the default is used which defines the steps
parse, compile, execute and output. Additionaly there are recipes
for processing XML and doing XSLT as part of the Embperl distribution.
If they don't fit your needs, you can define your own recipes.
For displaying POD on the Embperl website, we use the C<EmbperlXSLT>
recipe. Addtionaly we set the C<syntax> parameter to POD. This
tells Embperl to convert the POD source into XML data, so the
XSLT provider defined by the recipe can transform this into
the destination format (e.g. HTML). To make this happen
an addional provider cares about reading the XSL stylesheet
and providers transforms the text version
of the XML and XSL into some internal format suitable for the
XSLT processor. Since Embperl is able to cache any of these
intermediate results, this can speed up pocessing considerably,
when doing a lot of pages.
Since we don't want to configure for any individual page which recipe
to use, it seems to be a good idea to use file extentions
for selecting a recipe.
This can be implemented by overiding the method C<get_recipe>
in the application object. Embperl is calling this
method before every file is processed. So in our
epwebapp.pl we define the following method:
sub get_recipe
{
my ($class, $r, $recipe) = @_ ;
my $self ;
my $param = $r -> component -> param ;
my $config = $r -> component -> config ;
my ($src) = $param -> inputfile =~ /^.*\.(.*?)$/ ;
my ($dest) = $r -> param -> uri =~ /^.*\.(.*?)$/ ;
if ($src eq 'pl')
{
$config -> syntax('Perl') ;
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
if ($src eq 'pod' || $src eq 'pm')
{
$config -> escmode(0) ;
if ($dest eq 'pod')
{
$config -> syntax('Text') ;
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
$config -> syntax('POD') ;
if ($dest eq 'xml')
{
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
$config -> xsltstylesheet('pod.xsl') ;
$r -> param -> uri =~ /^.*\/(.*)\.(.*?)$/ ;
$param -> xsltparam({
page => $fdat{page} || 0,
basename => "'$1'",
extension => "'$2'",
imageuri => "'$r->{imageuri}'",
baseuri => "'$r->{baseuri}'",
}) ;
return Embperl::Recipe::EmbperlXSLT -> get_recipe ($r, $recipe) ;
}
if ($src eq 'epd')
{
$config -> escmode(0) ;
$config -> options($config -> options | &Embperl::Constant::optKeepSpaces) ;
if ($dest eq 'pod')
{
$config -> syntax('EmbperlBlocks') ;
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
$config -> xsltstylesheet('pod.xsl') ;
$r -> param -> uri =~ /^.*\/(.*)\.(.*?)$/ ;
$param -> xsltparam({
page => $fdat{page} || 0,
basename => "'$1'",
extension => "'$2'",
imageuri => "'$r->{imageuri}'",
baseuri => "'$r->{baseuri}'",
}) ;
return Embperl::Recipe::EmbperlPODXSLT -> get_recipe ($r, $recipe) ;
}
if ($src eq 'epl' || $src eq 'htm')
{
$config -> syntax('Embperl') ;
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
$config -> syntax('Text') ;
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
First C<get_recipe> determinates the extentions of the
source and destination file (C<$src> and C<$dest>).
Depending on the combination of these two it selects
the correct recipe. Because of that you can produce
different output formats (e.g. POD, XML, HTML) from the
same source. Additional get_recipe set some parameters
like syntax, output escaping and parameters
passed to the XSLT stylesheet, so they fit to the desired
source and destination formats.
=head1 Internationalisation
Like many other website, the Embperl website, must exist in multiple languages. In
this case english and german. Embperl provides some support, that makes life easier.
First of all it retrieves the C<Accept-Language> HTTP header and sets the C<language>
parameter of the request object accodingly. Next you can take this information
and feed the correct table of messages into Embperl, which Embperl uses to resolve
message ids which are embedded into the sources. Here is a part of the file F<messages.pl>
which contains the messages for the Embperl website:
%messages =
(
'de' =>
{
'addsel1' => 'Klicken Sie auf die Kategorie zu der Sie etwas hinzuf�gen m�chten:',
'addsel2' => 'oder f�gen Sie eine neue Kategorie hinzu. Bitte geben Sie die Beschreibung in so....',
'addsel3' => 'Falls Sie die �bersetzung nicht wissen, lassen Sie das entsprechende Eingabefeld leer.',
'addsel4' => 'Kategorie hinzuf�gen',
'user_email' => 'E-Mail Adresse',
'user_password' => 'Kennwort',
},
'en' =>
{
'addsel1' => 'Click on the category for wich you want to add a new item:',
'addsel2' => 'or add new category. Please enter the description in as much languages as possible.',
'addsel3' => 'If you don\'t know the translation leave the corresponding input field empty.',
'addsel4' => 'Add category',
'user_email' => 'E-Mail address',
'user_password' => 'Password',
}
) ;
$lang = $request -> param -> language ;
push @{$request -> messages}, $messages{$lang} ;
push @{$request -> default_messages}, $messages{'en'} if ($lang ne 'en') ;
C<$request -> param -> language> retrieves the language as given by the browsers
C<Language-Accept> HTTP header (or set before in your program). Then it selects
the correct message table (either german or english) from the C<%messages> hash.
This message table is pushed on the array given by $request -> messages. This array
holds a set of hash which are search for the correct message id, when a message id needs
to be resolved. The C<$request -> default_messages> is a second array that is searched, when
nothing is found in the messages array.
Inside a page you can now insert
[= addsel1 =]
which will be replaced by
Klicken Sie auf die Kategorie zu der Sie etwas hinzuf�gen m�chten:
if the language was german (de) or
Click on the category for wich you want to add a new item:
if the language was english (en). The last will also be the case for all other languages
because we use the method C<default_messages> to set the english message table as
the default if Embperl can't find anything inside the tables set by the C<messages> method.
Sometimes you don't want to insert the result of a message lookup directly into the outpt.
In this case you can use the request method gettext, e.g.
[-
$msg = $request -> gettext('addsel1') ;
-]
This will assign the same text as seen above to the variable C<$msg>.
Now when you have created all your pages with message ids inserted, you have to create the
table that holds the actual message. Embperl ships with a script that helps you doing so.
By running
perl embpmsgid.pl /path/to/sourcefile.epl
For example running this on the file add.epl of the Embperl website give the following result:
#perl embpmsgid.pl eg/web/db/add.epl
$msgids = {
'state' => '',
'add2a' => '',
'add1' => '',
'hide' => '',
'add2b' => '',
'add3' => '',
'display' => '',
'delete3' => '',
'update3' => '',
'edit1' => ''
};
As you see it's a list of all message ids and it's up to you to assign the correct texts. You
can also give the desired language already on the command line with -l option and write
the output to a file with the -d option, e.g.
perl embpmsgid.pl -l de -l en -d msg.pl eg/web/db/add.epl
This will create a file msg.pl which contains empty definitions for 'en' and 'de'
with all the ids found in the page. If the file msg.pl already exists, the definitions
are added. You can give more then one filename to the commandline. The format of the
msg.pl file is written with Data::Dumper, so it can be easily read in via 'do' and
postprocessed.
The remaining question is, where is the best place inside a request to select message tables
for the request and the answer is in the C<init> method of the application object. The Embperl
website application object's C<init> method does this by calling the file F<messages.pl>:
Execute ({inputfile => 'messages.pl', syntax => 'Perl'}) ;
which contains the message table and the code which assigns the correct table as we saw it above.
=head1 Form Validation
Most dynamic web application uses forms to let the user enter some data. Because the
user makes errors while filling out the form it's necessary to validate them.
Embperl has a module called Embperl::Form::Validate, which does this job for you.
It works
on the server side by checking the posted form data and it
generates client side script functions, to validate the
form values, as far as possible, before they are send to
the server, to avoid another server roundtrip.
It can be extended by new validation rules for
additional syntaxes (e.g. US zip codes, German
Postleitzahlen, number plates, iso-3166 2-digit language or country
codes, etc.)
Each module has the ability to rely it's answer on parameters like
e.g. the browser, which caused the request for or submitted the form.
The module fully supports internationalisation. Any message can be
provided in multiple languages and it makes use of Embperl's
multilanguage support.
Let's look at an example. The login form of the Embperl website contains
the following code:
[-
$epf1 = new Embperl::Form::Validate([ -key => 'user_email',
required => 1,
-key => 'user_password',
required => 1,
length_min => 5],
'login');
-]
<script>
[+ do { local $escmode = 0 ; $epf1 -> get_script_code } +]
</script>
<form action="[+ $param[0] +]" method="POST" name="login" onSubmit="return epform_validate_login()">
<table>
<tr>
<td class="cText">[= user_email =]</td>
<td class="cInput"><input type="text" name="user_email"></td>
</tr>
<tr>
<td class="cText">[= user_password =]</td>
<td class="cInput"><input type="password" name="user_password"></td>
</tr>
</table>
<p>
<input type="submit" name="-login" value="[= login =]">
</p>
</form>
It first creates a Embperl::Form::Validate object, which get's passed some rules and
the name of the form, which it should validate. Below we add some script code that is
created by Embperl::Form::Validate and add a C<onSubmit> handler to the form tag, to
verify that the input conforms to our rules, when the user hits the submit button.
The rules are an array. All rules are processed in the order given. First you have to
name the formfield which should be validated, then you can give the rules it should conform to.
For the email address we tell Embperl::Form::Validate that it is a required field, for the
password we addtionaly say that it has to be at least five characters long.
There are a lot more possibilies that can be used to validate the form and you can modify
message and names that Embperl display in the error message. If you do't give a name of
fields which should presented to the user, Embperl takes the -key argument and tries to
lookup the correct text to display for this name from the Embperl internationalization feature.
So in the case of the Embperl website we already have defined message ids for user_email
and user_password, so the error message will contain the fieldnames in the correct language.
Since the rest of error message also depend on the language defined by Embperl the whole
error message is internationalizied. Embperl::Form::Validate already has build in support
english and german error messages, but it's up to you to translate them in your favorite
language.
Of course browser side form validation is a nice feature, but the user can turn of
JavaScript and nothing will be happen. So we need an addtional server side form validation.
Embperl::Form::Validate does this when you call C<validate_messages>. It returns an
array ref with all error message or an array ref to an empty error in case everything is ok.
It's up to you to display the message to the user and take the correct action.
If Embperl::Form::Validate doesn't already have the sort of validation your application
needs, you can extent it by writing a new class and derive it from Embperl::Form::Validate::Default.
=head1 Include external components
When running Embperl with Apache 2.0 there are some extented
possibilities. While Apache 1.x has send all it's ouput directly
to the browser, Apache 2.0 introduces a concept of filters,
which allows to process the output of any Apache handler
through a chain of filters. Embperl can use this
to embed any output that Apache can generate as a Embperl::Object
component, just like it is any native Embperl page.
This can be done by using the C<subreq> parameter:
[- Execute ({subreq=>'/cgi-bin/script.cgi'}) -]
The above code includes the output of a cgi script into
a page.
This is especially usefull for application that are not
newly written from ground up, but has grown over years,
because you can include existing solution into your
Embperl::Object driven website. Because of the flexibilty
of the recipe/provider concept, you can not only include
the output of thoses other components, but also postprocess it.
For example you can include the output of a cgi script,
for which you don't have the source code and can adapt the
output to your current layout.
In the same way you can combine applications written in
differnet languages like PHP and Java under a common layout.
When you have included the Apache proxy module, the
source must not reside localy on your machine, but you are
able to request it from any webserver. You may for example
query XML data from another server, for example news in the RSS
format and run an XSL-transformation
to make it look nicely into your layout.
=head1 Finaly
This text has only touched some of the most important features
of Embperl, but should have give you an impression of what is
possible.
If you interested in more you find addtional
information on the Embperl website
http://perl.apache.org/embperl
or
http://www.ecos.de/embperl
=head1 Authors
Gerald Richter (richter at ecos dot de)
Axel Beckert (abe at ecos dot de)
1.3 +3 -3 embperl/Embperl/Form/Validate.pm
Index: Validate.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Form/Validate.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Validate.pm 22 Oct 2002 05:39:49 -0000 1.2
+++ Validate.pm 20 Nov 2002 06:56:27 -0000 1.3
@@ -357,7 +357,7 @@
my $default_language = $pref -> {default_language} ;
my $txt ;
- $name ||= $key ;
+ $name ||= $epreq?$epreq -> gettext($key):$key ;
if (ref $name eq 'ARRAY')
{
my @names ;
1.3 +5 -0 embperl/eg/web/config.pl
Index: config.pl
===================================================================
RCS file: /home/cvs/embperl/eg/web/config.pl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- config.pl 22 Oct 2002 05:39:50 -0000 1.2
+++ config.pl 20 Nov 2002 06:56:27 -0000 1.3
@@ -11,6 +11,7 @@
$self -> {dbdsn} = $^O eq 'MSWin32'?'dbi:ODBC:embperl':'dbi:mysql:embperl' ;
$self -> {dbuser} = 'www' ;
$self -> {dbpassword} = undef ;
+ $self -> {adminemail} = 'abe@ecos.de';
# There is normaly no need to change anything below this line
@@ -91,6 +92,9 @@
{ menu => 'Embperl::Object', uri => 'IntroEmbperlObject.htm', file => 'IntroEmbperlObject.pod',
desc => { en => 'Introduction to object-oriented website creation with Embperl',
de => 'Einf�hrung in das objekt-orientierte Erstellen von Websites mit Embperl' }},
+ { menu => 'Embperl 2 Advanced', uri => 'IntroEmbperl2.htm', file => 'IntroEmbperl2.pod',
+ desc => { en => 'Introduction to advanced features of Embperl 2',
+ de => 'Einf�hrung in erweiterte M�glichkeiten von Embperl 2' }},
{ menu => 'DBIx::Recordset', uri => 'IntroRecordset.htm', path => '%lib_dbix%/DBIx/Intrors.pod',
desc => { en => 'Introduction to database access with DBIx::Recordset',
de => 'Einf�hrung in den Datenbankzugriff mit DBIx::Recordset' }},
@@ -197,6 +201,7 @@
{ menu => 'Enter info to add about Embperl', uri => 'db/add.epl' },
{ menu => 'Show info added about Embperl', uri => 'db/show.epl'},
{ menu => 'Infos about Embperl', uri => 'db/data.epd' },
+ { menu => 'Infos about Embperl', uri => 'db/list.epl' },
],
},
) ;
1.3 +7 -0 embperl/eg/web/epwebapp.pl
Index: epwebapp.pl
===================================================================
RCS file: /home/cvs/embperl/eg/web/epwebapp.pl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- epwebapp.pl 22 Oct 2002 05:39:50 -0000 1.2
+++ epwebapp.pl 20 Nov 2002 06:56:27 -0000 1.3
@@ -311,6 +311,13 @@
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
+ if ($src eq 'mail')
+ {
+ $config -> syntax('EmbperlBlocks') ;
+ return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
+ }
+
+
$config -> syntax('Text') ;
return Embperl::Recipe::Embperl -> get_recipe ($r, $recipe) ;
}
1.3 +6 -1 embperl/eg/web/footer.htm
Index: footer.htm
===================================================================
RCS file: /home/cvs/embperl/eg/web/footer.htm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- footer.htm 22 Oct 2002 05:39:50 -0000 1.2
+++ footer.htm 20 Nov 2002 06:56:27 -0000 1.3
@@ -2,6 +2,11 @@
<table width="100%" border=0 cellspacing=0 cellpadding=0><tr>
<td align=left class="cFoot">© 1997-2002 Gerald Richter / <a href="http://www.ecos.de/">ecos gmbh</a></td>
[$if $udat{user_id} $]
-<td align=right class="cFoot">[= logged_in_as =] [+ $udat{user_email} +]</td>
+<td align=right class="cFoot">
+[= logged_in_as =] [+ $udat{user_email} +]
+[$ if $udat{user_admin} $]
+[Admin]
+[$ endif $]
+</td>
[$endif$]
</tr></table>
1.3 +98 -10 embperl/eg/web/messages.pl
Index: messages.pl
===================================================================
RCS file: /home/cvs/embperl/eg/web/messages.pl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- messages.pl 22 Oct 2002 05:39:50 -0000 1.2
+++ messages.pl 20 Nov 2002 06:56:27 -0000 1.3
@@ -1,10 +1,12 @@
-
+
$r = shift ;
%messages =
(
'de' =>
{
+ 'add_item'=> 'Eintrag hinzuf�gen',
+ 'items_of'=> 'Bearbeiten der Eintr�ge von',
'addsel1' => 'Klicken Sie auf die Kategorie zu der Sie etwas hinzuf�gen m�chten:',
'addsel2' => 'oder f�gen Sie eine neue Kategorie hinzu. Bitte geben Sie die Beschreibung in so vielen Sprachen wie Ihnen m�glich ein.',
'addsel3' => 'Falls Sie die �bersetzung nicht wissen, lassen Sie das entsprechende Eingabefeld leer.',
@@ -15,6 +17,7 @@
'addsel_login3' => '.',
'add1' => 'Hinzuf�gen eines neuen Eintrages zu',
'edit1' => 'Bearbeiten eines Eintrages von',
+ 'del1' => 'L�schen eines Eintrages',
'add2a' => 'Bitte geben Sie die Beschreibung in so vielen Sprachen wie Ihnen m�glich ein.',
'add2b' => 'Falls Sie die �bersetzung nicht wissen, lassen Sie das entsprechende Eingabefeld leer.',
'add3' => 'Hinzuf�gen zu',
@@ -23,7 +26,9 @@
'heading' => '�berschrift',
'url' => 'URL',
'description' => 'Beschreibung',
+ 'state' => 'Status',
'show2' => 'Folgender Eintrag wurde erfolgreich der Datenbank hinzugef�gt/ge�ndert',
+ 'del2' => 'Der Eintrag wurde erfolgreich aus der Datenbank entfernt',
'Search' => 'Suchen',
'under_construction' => 'Hinweis: Dieser Teil der Website befindet sich noch im Aufbau.',
'more_news' => 'Weitere News...',
@@ -31,10 +36,13 @@
'display' => 'anzeigen',
'hide' => 'nicht anzeigen',
'logged_in_as' => 'Angemeldet als',
+ 'already_logged_in_as' => 'Sie sind bereits angemeldet als',
+ 'logoff' => 'Hier k�nnen Sie sich wieder abmelden',
'need_login' => 'Sie m�ssen sich erst anmelden um diesen Bereich zu nutzen.',
'login_head' => q{Hier k�nnen Sie sich auf der Embperl-Site anmelden. Dies erlaubt Ihnen
Informationen bez�glich Embperl (Neugigkeiten, Sites die Embperl benutzen,
Ver�ffentlichungen, Beispiele etc.) hinzuzuf�gen, zu �ndern und zu l�schen.},
+ 'loginnew' => 'Sie erhalten Ihr Kennwort per E-Mail zugeschickt, bitte tragen Sie es unten ein um die Anmeldung zu vollenden und klicken dann auf "Anmelden".',
'login1' => 'Wenn Sie sich schon einmal angemeldet haben, geben Sie bitte Ihre E-Mail Adresse und Ihr Kennwort ein und klicken dann auf "Anmelden".',
'login2' => q{Wenn Sie sich das erste Mal anmelden, geben Sie lediglich Ihre E-Mail Adresse an
und klicken auf "Neuen Benutzer-Account einrichten".
@@ -43,14 +51,41 @@
auf "Neues Kennwort". Sie bekommen
dann ein neues Kennwort zugesandt.},
'cookie_note' => 'HINWEIS: Zur Anmeldung ist es erforderlich das Ihr Browser Cookies akzeptiert',
- 'email' => 'E-Mail Adresse',
- 'password' => 'Kennwort',
+ 'user_email' => 'E-Mail Adresse',
+ 'user_password' => 'Kennwort',
'login' => 'Anmelden',
+ 'logout' => 'Abmelden',
'newuser' => 'Neuen Benutzer-Account einrichten',
- 'newpassword' => 'Neues Kennwort',
+ 'newpassword' => 'Neues Kennwort',
+ 'error' => 'Fehler',
+ 'warning' => 'Warnung',
+ 'error_reason' => 'Grund',
+
+ # Mail Handling
+ 'mail_greeting' => 'Hallo!',
+ 'mail_account_request' => 'Sie oder jemand anderes haben ein Benutzer-Konto auf der Embperl Website angefordert.',
+ 'mail_note1' => 'Ihr Kontoname ist Ihre E-Mail-Adresse, d.h. sie sollten auf der Embperl-Webseite',
+ 'mail_note2' => 'als Login-Name angeben.',
+ 'mail_your_pw_is' => 'Ihr Pa�wort ist auf',
+ 'mail_note_quotes' => 'gesetzt (ohne die Hochkommata)',
+ 'mail_note_login' => 'Sie k�nnen sich jetzt unter folgender Adresse anmelden:',
+ 'mail_sig' => 'Gr��e von der Embperl Webseite',
+ 'mail_pw' => 'Sie oder jemand anders hat ein neues Pa�wort f�r Ihr Benutzerkonto auf der Embperl Webseite beantragt.',
+ 'mail_subj_newuser' => 'Ihr Benutzerkonto auf der Embperl Webseite',
+ 'mail_subj_newpw' => 'Ihr neues Pa�wort auf der Embperl Webseite',
+
+ # Errors
+
+
+ # Warnings
+
+
+ # Success
},
- 'en' =>
+ 'en' =>
{
+ 'add_item'=> 'Add new entry',
+ 'items_of'=> 'Edit items from',
'addsel1' => 'Click on the category for wich you want to add a new item:',
'addsel2' => 'or add new category. Please enter the description in as much languages as possible.',
'addsel3' => 'If you don\'t know the translation leave the corresponding input field empty.',
@@ -60,7 +95,8 @@
'addsel_login2' => 'login',
'addsel_login3' => 'first.',
'add1' => 'Add a new item to',
- 'add1' => 'Edit item of',
+ 'edit1' => 'Edit item of',
+ 'del1' => 'Delete item',
'add2a' => 'Please enter the description in as much languages as possible.',
'add2b' => 'If you don\'t know the translation leave the corresponding input field empty.',
'add3' => 'Add to',
@@ -68,8 +104,10 @@
'delete3' => 'Delete',
'heading' => 'Heading',
'url' => 'URL',
- 'description' => 'Description',
+ 'description' => 'Description',
+ 'state' => 'State',
'show2' => 'The following entry has been sucessfully added/modified to the database',
+ 'del2' => 'The entry has been sucessfully removed from the database',
'Search' => 'Search',
'under_construction' => 'NOTE: This part of the site is still under contruction.',
'more_news' => 'more news...',
@@ -77,11 +115,14 @@
'display' => 'display',
'hide' => 'hide',
'logged_in_as' => 'logged in as',
+ 'already_logged_in_as' => 'You are already logged in as',
+ 'logoff' => 'Here you can logoff from the site',
'need_login' => q{You must be logged in to access this area.},
'login_head' => q{Here you can logon to the Embperl-Site.
This allows you to enter information about Embperl like news,
sites using Embperl, publications, examples etc.
You may also edit and delte the information you have enterd before},
+ 'loginnew' => 'You will receive your new password via e-mail. Please enter it in the form below and click on "Login".',
'login1' => q{If you have already a user account, please enter your email address and
password and click on 'Login'. },
'login2' => q{If you have not already a user account, just enter your email and click
@@ -92,11 +133,57 @@
a new password will be mailed
to your email address.},
'cookie_note' => 'NOTE: For login it\'s necessary that your browser accepts cookies',
- 'email' => 'E-Mail address',
- 'password' => 'Password',
+ 'user_email' => 'E-Mail address',
+ 'user_password' => 'Password',
'login' => 'Login',
+ 'logout' => 'Logout',
'newuser' => 'Create new account',
- 'newpassword' => 'New password',
+ 'newpassword' => 'New password',
+ 'error' => 'Error',
+ 'warning' => 'Warning',
+ 'error_reason' => 'Reason',
+
+ # Mail Handling
+ 'mail_greeting' => 'Hi!',
+ 'mail_account_request' => 'You or someone else requested a user account for the Embperl website.',
+ 'mail_note1' => 'Your account name is your e-mail address, that means you should enter',
+ 'mail_note2' => 'as login name on the Embperl website.',
+ 'mail_your_pw_is' => 'Your password is set to',
+ 'mail_note_quotes' => '(without the single quotes)',
+ 'mail_note_login' => 'You can now log in at the following address:',
+ 'mail_sig' => 'Regards, Your Embperl Website',
+ 'mail_pw' => 'You or possible someone else requested a new password for your account on the Embperl Website',
+ 'mail_subj_newuser' => 'Your Embperl Website Account',
+ 'mail_subj_newpw' => 'Your new Embperl Website password',
+
+ # Errors
+ 'err_email_needed' => "You haven't entered an email address. This is mandatory for the requested action.",
+ 'err_access_denied' => 'Access Denied. Either user name (e-mail address) or password were wrong.',
+ 'err_user_exists' => 'User already exists. Perhaps you want a new password sent to this address?',
+ 'err_user_not_exists' => "User doesn't exists. Maybe there's a typo in the address or you registered with a different address?",
+ 'err_user_mail' => 'Could not sent mail to user.',
+ 'err_pw_mail' => 'Could not sent mail with password to user.',
+ 'err_db' => 'Database error',
+ 'err_update_db' => 'Database error while updating',
+ 'err_update_lang_db' => 'Database error while updating languages',
+ 'err_cannot_update_no_id' => 'Update failed: Permission denied',
+ 'err_cannot_update_maybe_wrong_user' => 'Update failed: Permission denied',
+ 'err_cannot_delete_no_id' => 'Deletion failed: Permission denied',
+ 'err_cannot_delete_maybe_wrong_user_or_no_such_item' => 'Deletion failed: Permission denied',
+ 'err_cannot_delete_db_error' => 'Deletion failed: Database error',
+ 'err_item_not_found_or_access_denied' => 'Item not found or access denied',
+
+ # Warnings
+ 'warn_url_removed_white_space' => 'Removed whitespaces from URL.',
+ 'warn_url_added_http' => 'Added "http://" to the incomplete URL.',
+
+ # Success
+ 'suc_login' => 'Successfully logged in',
+ 'suc_logout' => 'Successfully logged out',
+ 'suc_password_sent' => 'Successfully sent password to given e-mail address',
+ 'suc_item_deleted' => 'Item successfully deleted',
+ 'suc_item_updated' => 'Item successfully updated',
+ 'suc_item_created' => 'Item successfully created',
},
) ;
@@ -105,4 +192,5 @@
push @{$r -> messages}, $messages{$lang} ;
push @{$r -> default_messages}, $messages{'en'} if ($lang ne 'en') ;
+
1.3 +1 -1 embperl/eg/web/notfound.htm
Index: notfound.htm
===================================================================
RCS file: /home/cvs/embperl/eg/web/notfound.htm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- notfound.htm 22 Oct 2002 05:39:50 -0000 1.2
+++ notfound.htm 20 Nov 2002 06:56:27 -0000 1.3
@@ -1 +1 @@
-The document you requested wasn't found
\ No newline at end of file
+The document you requested wasn't found.
\ No newline at end of file
1.3 +99 -21 embperl/eg/web/db/add.epl
Index: add.epl
===================================================================
RCS file: /home/cvs/embperl/eg/web/db/add.epl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- add.epl 22 Oct 2002 05:39:50 -0000 1.2
+++ add.epl 20 Nov 2002 06:56:27 -0000 1.3
@@ -1,74 +1,152 @@
[-
use File::Basename ;
+use Data::Dumper ;
-$r = shift
--]
+$DBIx::Recordset::Debug = 3;
+$maxrow = 3;
+
+$r = shift ;
+-]
<table width="100%">
<tr bgcolor="#fefcad">
- <td><font size="4">[$ if $r -> {edit} $][= edit1 =] [$else$][= add1 =] [$endif$] [+ $r -> {category_set}{category} +]</font></td>
+ <td><font size="4">[$ if $r -> {edit} $][= edit1 =] [$ else $][= add1 =] [$ endif $] [+ $r -> {category_set}{category} +]</font></td>
</tr>
</table>
+[$ if !$r->{error} $]
<form action="[+ $r -> {action_prefix}?($r->{action_prefix} . dirname($r-> param -> uri) .'/'):'' +]show.epl" method="POST">
[= add2a =]<br>
[= add2b =]<br><br>
-[$if $r -> {category_set}{add_info}$]
+[$ if $r -> {category_set}{add_info}$]
<B>[+ $r -> {category_set}{add_info} +]</b><br><br>
-[$endif$]
+[$ endif $]
[$if $r -> {user_admin} $]
<table>
<tr>
- <td class="cText">[= state =]<td><td class="cInput"><input type="radio" name="state" value="0"> [= display =]</td>
+ <td class="cText" rowspan="2" valign="top">[= state =]: </td><td class="cInput"><input type="radio" name="state" value="1"[$ if ($r->{item_set}{state}) $] CHECKED[$ endif $]>[= display =]</td>
</tr>
<tr>
- <td class="cText">[= state =]<td><td class="cInput"><input type="radio" name="state" value="1"> [= hide =]</td>
+ <td class="cInput"><input type="radio" name="state" value="0"[$ if !$r->{item_set}{state} $] CHECKED[$ endif $]>[= hide =]</td>
</tr>
</table>
[$endif$]
+[-
+ $ct = $r->{category_texts};
+ $cy = $r->{category_types};
+ $cf = $r->{category_fields};
+
+
+-]
<table width="100%">
+ [$while $rec = ${$r -> {language_set}} -> Next $]
<tr bgcolor="#fefcad"><font size="3">
- [- $rec = $r -> {language_set}[$row] -]
<td><font size=3><b>[+ $rec -> {name} +]</b></font></td>
</tr>
<tr>
<td>
+ [$ syntax EmbperlBlocks $]
<table>
- [$foreach $type ('heading', 'url', 'description', 'keywords') $]
- [$ if $txt = $r -> {category_set}{$type . '_text'} $]
+ [$ foreach $type (@$cf) $]
+ [$ if $txt = $ct->{$type . '_text'} $]
<tr>
- [$if $type ne 'description' $]
- <td class="cText">[+ $txt +]:</td><td class="cInput"><input type="text" name="[+ $type +]_[+ $rec -> {id} +]" size=80></td>
- [$else$]
- <td class="cText">[+ $txt +]:</td><td class="cInput"><textarea name="[+ $type +]_[+ $rec -> {id} +]" cols=60 rows=10></textarea></td>
- [$endif$]
+ [$ syntax Embperl $]
+ [# <td class="cText" valign="top" colspan="2">[+ $txt +] / [+ $type +] / [+ $i++ +]</td> #]
+ [$ if $cy->{$type} =~ /textarea/ $]
+ <td class="cText" valign="top">[+ $txt +]: </td>
+ <td class="cInput"><textarea name="[+ $type +]_[+ $rec -> {id} +]" cols="60" rows="10"></textarea> </td>
+ [$ elsif $cy->{$type} =~ /pulldown/ $]
+ <td class="cText" valign="top">[+ $txt +]: </td>
+ <td class="cInput">
+ [-
+ ($table = $type) =~ s/_id$//;
+ $poss = $r->app->get_titles($r,$table);
+ -]
+
+ [# [+ $type +] / [+ $table +] / [+ $r->{category_title_type} +]<PRE>[+ Dumper $poss +]</PRE> #]
+
+ <select name="[+ $type +]_[+ $rec -> {id} +]">
+ [- $item = $poss->[$row] -]
+ <option value="[+ $item->{id} +]">[+ $item->{title} +]</option>
+ </select>
+ </td>
+ [$ else $]
+ <td class="cText" valign="top">[+ $txt +]: </td>
+ <td class="cInput"><input type="text" name="[+ $type +]_[+ $rec -> {id} +]" size="80"> </td>
+ [$ endif $]
+ [$ syntax EmbperlBlocks $]
</tr>
- [$endif$]
- [$endforeach$]
- <input type="hidden" name="id_[+ $rec -> {id} +]">
+ [$ endif $]
+ [$ endforeach $]
</table>
+ [$ syntax Embperl $]
+ <input type="hidden" name="id_[+ $rec -> {id} +]">
</td>
</tr>
+ [$endwhile$]
</table>
<br><br>
[$ if $r -> {edit} $]
<input type="submit" name="-update_item" value="[= update3 =]">
<input type="submit" name="-delete_item" value="[= delete3 =]">
-[$else$]
+[$ else $]
<input type="submit" name="-add_item" value="[= add3 =] [+ $r -> {category_set}{category} +]">
[$endif$]
<input type="hidden" name="category_id">
-<input type="hidden" name="item_id">
+<input type="hidden" name="[+ $r -> {category_set}{table_type} +]_id">
</form>
-
\ No newline at end of file
+[$ endif $]
+
+[#
+<PRE>
+[+
+ Data::Dumper->Dump(
+ [
+ {%fdat},
+ $r->{edit},
+ $r->{category_set}{add_info},
+ $r->{action_prefix},
+ $r->{category_set}{category},
+ $r->{user_admin},
+ [keys %$r],
+ $r->{category_fields},
+ $r->{category_texts},
+$state,
+$item_set,
+# ${$r->{category_set}},
+# ${$r->{language_set}},
+# $r->{item_set},
+ ],[qw[
+ fdat
+ edit
+ add_info
+ action_prefix
+ category
+ user_admin
+ r_keys
+ category_fields
+ category_texts
+ state
+ category_set
+ language_set
+ item_set
+ ]
+ ]
+ )
++]
+</PRE>
+#]
+
+
+
1.3 +10 -1 embperl/eg/web/db/addsel.epl
Index: addsel.epl
===================================================================
RCS file: /home/cvs/embperl/eg/web/db/addsel.epl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- addsel.epl 22 Oct 2002 05:39:50 -0000 1.2
+++ addsel.epl 20 Nov 2002 06:56:27 -0000 1.3
@@ -54,7 +54,7 @@
<ul>
<li>
[- $rec = $r -> {category_set}[$row] -]
- <a href="add.-category_id-[+ $rec -> {category_id} +]-.epl">[+ $rec -> {category} +]</a>
+ <a href="list.-category_id-[+ $rec -> {category_id} +]-.epl">[+ $rec -> {category} +]</a>
</li>
</ul>
@@ -63,6 +63,15 @@
<p class="cHeadline">[= addsel_login1 =] <a href="login.epl">[= addsel_login2 =]</a> [= addsel_login3 =]</p>
[$endif$]
+
+[#
+DEBUGGING:
+
+[! use Data::Dumper; !]
+<PRE>
+[+ Dumper $ENV{SERVER_NAME}, $ENV{SERVER_PORT}, [keys %$r] +]
+</PRE>
+#]
[#
<form action="[+ $r -> {action_prefix}?($r->{action_prefix} . dirname($r-> param -> uri) .'/'):''+]addsel.epl" OnSubmit="">
1.3 +37 -10 embperl/eg/web/db/content.epl
Index: content.epl
===================================================================
RCS file: /home/cvs/embperl/eg/web/db/content.epl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- content.epl 22 Oct 2002 05:39:50 -0000 1.2
+++ content.epl 20 Nov 2002 06:56:27 -0000 1.3
@@ -4,19 +4,46 @@
[- $r = shift -]
-[$if $r -> {error} $]
-<center><font color="red" size=3>[+ $r -> gettext($r -> {error}) +]</font><br></center>
-[$endif$]
+[$ if $r->{error} $]
+ <p align="center"><font color="#ff0000" size="3"><b>
+ [= error =]: [+ $r->gettext($r->{error}) +]
+ [$ if $r->{error_details} $]
+ [= error_reason =]:<BR>
+ [- @err = split("\n", $r->{error_details}); -]
+ [$ foreach $err_line (@err) $]
+ [+ $err_line +]<BR>
+ [$ endforeach $]
+ [$ endif $]
+ </b></font></p>
+[$ endif $]
-[$if $r -> {need_login} $]
- <center>
+[$ if @{$warning = $r->{warning}} $]
+ <p align="center">
+ [= warning =]:
+ </p>
+ <div align="center">
+ <table border="0" cellspacing="0" cellpadding="0"><tr><td align="left">
+ <ul>
+ <li>[- $abbrev = $warning->[$row] -][+ $r->gettext($abbrev) +]
+ </ul>
+ </td></tr></table>
+ </div>
+[$ endif $]
+
+[$ if $r->{success} $]
+ <p align="center">
+ [+ $r->gettext($r->{success}) +]
+ </p>
+[$ endif $]
+
+[$ if $r -> {need_login} $]
+ <div align="center">
<p>[= need_login =]</p>
[- Execute ('loginform.epl', $r -> param -> uri) ; -]
- </center>
-[$else$]
+ </div>
+[$ else $]
[$if $r -> param -> uri !~ /html?$|epl$/ $]<pre>[$endif$]
-
- [- Execute ({inputfile => '*'}) -]
+ [- $x = Execute ({inputfile => '*'}) -]
[$if $r -> param -> uri !~ /html?$|epl$/ $]</pre>[$endif$]
-[$endif$]
+[$ endif $]
1.3 +8 -2 embperl/eg/web/db/data.epd
Index: data.epd
===================================================================
RCS file: /home/cvs/embperl/eg/web/db/data.epd,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- data.epd 22 Oct 2002 05:39:50 -0000 1.2
+++ data.epd 20 Nov 2002 06:56:27 -0000 1.3
@@ -1,6 +1,7 @@
[-
$r = shift ;
$set = $r -> {item_set} ;
+
$escmode = 0 ;
-]
@@ -20,10 +21,15 @@
=head1 [+ $rec -> {heading} +]
+[# Without the if-then-else this goes wrong if description is empty #]
+[$ if $rec -> {description} $]
[+ $rec -> {description} +] [[[+ $date +]]
+[$ else $]
+[[[+ $date +]]
+[$ endif $]
[+ $rec -> {url} +]
-[$if $r -> {user_id} && $r -> {user_id} == $rec -> {user_id} $]L<Edit|../show.epl?item_id=[+ $rec -> {item_id} +]&-edit_item=1> [$endif$]
+[$ if ($r->{user_id} && $r->{user_id} == $rec->{user_id}) || $r->{user_admin} $]L<Edit|../add.epl?item_id=[+ $rec->{item_id} +]&-edit_item=1&category_id=[+ $rec->{category_id} +]> | Status: [+ $r -> gettext ($r->{item_set}{state} ? 'display' : 'hide') +][$ endif $]
-[$endwhile$]
+[$ endwhile $]
1.3 +560 -88 embperl/eg/web/db/epwebapp.pl
Index: epwebapp.pl
===================================================================
RCS file: /home/cvs/embperl/eg/web/db/epwebapp.pl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- epwebapp.pl 22 Oct 2002 05:39:50 -0000 1.2
+++ epwebapp.pl 20 Nov 2002 06:56:27 -0000 1.3
@@ -2,6 +2,7 @@
use DBIx::Recordset ;
use Data::Dumper ;
+use Embperl::Mail ;
BEGIN { Execute ({isa => '../epwebapp.pl', syntax => 'Perl'}) ; }
@@ -11,37 +12,44 @@
my $self = shift ;
my $r = shift ;
+ my $ret ;
+
$self -> SUPER::init ($r) ;
$self -> initdb ($r) ;
my $db = $r -> {db} ;
+ $r->{warning} = [];
+
$self -> checkuser ($r) ;
$r -> {language_set} = DBIx::Recordset -> Search ({'!DataSource' => $db,
'!Table' => 'language'}) ;
+
+ $r -> {error} = $fdat{-error} ;
+ $r -> {success} = $fdat{-success} ;
+
if ($fdat{-add_category})
{
- $self -> add_category ($r) ;
+ $self -> add_category($r) ;
$self -> get_category($r) ;
}
elsif ($fdat{-add_item})
{
- $self -> add_item ($r) ;
$self -> get_category($r) ;
- $self -> get_item_lang($r) ;
+ $ret = $self -> add_item($r) ;
}
elsif ($fdat{-update_item})
{
- $self -> update_item ($r) ;
$self -> get_category($r) ;
- $self -> get_item_lang($r) ;
+ $ret = $self -> update_item ($r) ;
}
elsif ($fdat{-delete_item})
{
- $self -> delete_item ($r) ;
+ $self -> get_category($r) ;
+ $ret = $self -> delete_item($r) ;
}
elsif ($fdat{-edit_item})
{
@@ -54,13 +62,24 @@
$self -> get_category($r) ;
$self -> get_item_lang($r) ;
}
+ elsif ($fdat{-update_user})
+ {
+ $self -> update_user($r) ;
+ }
else
{
$self -> get_category($r) ;
$self -> get_item($r) ;
+ #$self -> get_user($r);
}
- return 0 ;
+
+ #d# if ($r->param->uri =~ m|/user\.epl$|)
+ #d# {
+ # $self -> get_users($r) if $r->{user_admin};
+ # }
+
+ return defined ($ret)?$ret:0 ;
}
@@ -90,6 +109,11 @@
$r -> {db} = $db ;
+ if ($config->{always_need_login} && ($self -> checkuser($r) < 1))
+ {
+ $r -> {need_login} = 1 ;
+ return ;
+ }
}
# ----------------------------------------------------------------------------
@@ -125,12 +149,27 @@
# 2 admin logged in
#
+sub checkuser_light
+ {
+ my $self = shift ;
+ my $r = shift ;
+
+ if ($udat{user_id} && $udat{user_email} && !$fdat{-logout})
+ {
+ $r -> {user_id} = $udat{user_id} ;
+ $r -> {user_email} = $udat{user_email} ;
+ $r -> {user_admin} = $udat{user_admin} ;
+ return $r -> {user_admin}?2:1 ;
+ }
+ return 0;
+ }
+
sub checkuser
{
my $self = shift ;
my $r = shift ;
- if ($udat{user_id} && $udat{user_email})
+ if ($udat{user_id} && $udat{user_email} && !$fdat{-logout})
{
$r -> {user_id} = $udat{user_id} ;
$r -> {user_email} = $udat{user_email} ;
@@ -138,7 +177,8 @@
return $r -> {user_admin}?2:1 ;
}
- if (($fdat{-login} || $fdat{-newuser}) && !$fdat{user_email})
+ if (($fdat{-login} || $fdat{-newuser} || $fdat{-newpassword})
+ && !$fdat{user_email})
{
$r -> {error} = 'err_email_needed' ;
return ;
@@ -159,7 +199,8 @@
{
$r -> {user_id} = $udat{user_id} = $user -> {id} ;
$r -> {user_email} = $udat{user_email} = $user -> {email} ;
- $r -> {user_admin} = $udat{user_admin} = $user -> {admim} ;
+ $r -> {user_admin} = $udat{user_admin} = $user -> {admin} ;
+ $r -> {success} = "suc_login";
return $r -> {user_admin}?2:1 ;
}
@@ -172,12 +213,13 @@
$r -> {user_id} = $udat{user_id} = undef ;
$r -> {user_email} = $udat{user_email} = undef ;
$r -> {user_admin} = $udat{user_admin} = undef ;
+ $r -> {success} = 'suc_logout';
return ;
}
if ($fdat{-newuser} && $user -> {id})
{
- $r -> {error} = 'err_user_exists' ;
+ $r -> {error} = 'err_user_exists';
return ;
}
@@ -187,41 +229,98 @@
return ;
}
+ my $user_password = '' ;
if ($fdat{-newuser} || $fdat{-newpassword})
{
my $chars = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-+$!#*=@1234567890-+$!#*=@' ;
- $fdat{user_password} = '' ;
for (my $i = 0; $i < 6; $i++)
{
- $fdat{user_password} .= substr($chars, rand(length($chars)), 1) ;
+ $user_password .= substr($chars, rand(length($chars)), 1) ;
}
}
+
if ($fdat{-newuser} && $fdat{user_email})
{
+ my @errors_user = ();
+ my @errors_admin = ();
my $set = DBIx::Recordset -> Insert ({'!DataSource' => $r -> {db},
'!Table' => 'user',
- 'password' => $fdat{user_password},
+ 'password' => $user_password,
'email' => $fdat{user_email}}) ;
- #Embperl::Mail::Execute ({inputfile => 'newuser.admin.mail', to => $self -> {config} -> {adminemail}) ;
- #Embperl::Mail::Execute ({inputfile => 'newuser.mail', to => $fdat{user_email}) and $r -> {error} = 'err_mail' ;
+ if (DBIx::Recordset -> LastError)
+ {
+ $r -> {error} = 'err_db';
+ $r -> {error_details} = DBIx::Recordset -> LastError;
+ }
+
+ my $usermail = Embperl::Mail::Execute ({
+ inputfile => 'newuser.mail',
+ to => $fdat{user_email},
+ subject => $r->gettext('mail_subj_newuser'),
+ errors => \@errors_user});
+ if ($usermail)
+ {
+ $r->{error} = 'err_user_mail';
+ $r->{error_details} = join("\n",@errors_user);
+ }
+ else
+ {
+ $r->{success} = 'suc_password_sent';
+ }
+
+ my $adminmail = Embperl::Mail::Execute ({
+ inputfile => 'newuser.admin.mail',
+ to => $r->{config}->{adminemail},
+ subject => ($r->{error} ?
+ "Error while creating new Embperl website user '$fdat{user_email}'" :
+ "New Embperl website user: $fdat{user_email}"),
+ errors => \@errors_admin});
+
+ if ($adminemail)
+ {
+ $r->{error} = 'err_user_admin_mail';
+ $r->{error_details} = join('; ',@errors_admin);
+ }
+
return ;
}
- if ($fdat{-newpasswd} && $fdat{user_email})
+ if ($fdat{-newpassword} && $fdat{user_email})
{
+ my @errors_pw;
my $set = DBIx::Recordset -> Update ({'!DataSource' => $r -> {db},
'!Table' => 'user',
- 'password' => $fdat{user_password},
+ 'password' => $user_password,
'email' => $fdat{user_email}}) ;
- #Embperl::Mail::Execute ({inputfile => 'newpassword.mail', to => $fdat{user_email}) and $r -> {error} = 'err_mail' ;
+
+ my $newpw_mail = Embperl::Mail::Execute ({
+ inputfile => 'newpw.mail',
+ to => $fdat{user_email},
+ subject => $r->gettext('mail_subj_newpw'),
+ errors => \@errors_pw});
+ if ($newpw_mail)
+ {
+ $r->{error} .= 'err_pw_mail';
+ $r->{error_details} .= join("\n",@errors_pw);
+ }
+ else
+ {
+ $r->{success} = 'suc_password_sent';
+ }
+
return ;
}
+ return ;
}
# ----------------------------------------------------------------------------
+###
+### Not yet working with new db-scheme
+###
+
sub add_category
{
my $self = shift ;
@@ -260,37 +359,105 @@
my $self = shift ;
my $r = shift ;
- if (!$self -> checkuser($r))
+ if ($self -> checkuser($r) < $r->{category_set}{edit_level})
{
$r -> {need_login} = 1 ;
return ;
}
+ # Check the URL
+
+ my $tt = $r->{category_set}{table_type};
+ my $cf = $r->{category_fields};
+
+ foreach (@$cf)
+ {
+ next unless $r->{category_types}{$_} =~ /url/;
+
+ if ($fdat{$_} && $fdat{$_} =~ /\s/)
+ {
+ $fdat{$_} =~ s/\s//g;
+ push(@{$r->{warning}}, 'warn_url_removed_white_space');
+ }
+
+ if ($fdat{$_} && $fdat{$_} !~ m{http://})
+ {
+ $fdat{$_} =~ s{^}{http://};
+ push(@{$r->{warning}}, 'warn_url_added_http');
+ }
+
+ }
+
my $set = DBIx::Recordset -> Insert ({'!DataSource' => $r -> {db},
- '!Table' => 'item',
+ '!Table' => $tt,
'!Serial' => 'id',
url => $fdat{url},
category_id => $fdat{category_id},
user_id => $r -> {user_id},
- state => $r ->{user_admin} && $fdat{state}?1:0}) ;
+ state => $r ->{user_admin} ? ($fdat{state}?1:0):0}) ;
+
my $id = $$set -> LastSerial ;
my $langset = $r -> {language_set} ;
my $txtset = DBIx::Recordset -> Setup ({'!DataSource' => $r -> {db},
- '!Table' => 'itemtext'}) ;
+ '!Table' => "${tt}text"}) ;
$$langset -> Reset ;
while ($rec = $$langset -> Next)
{
- $$txtset -> Insert ({item_id => $id,
- language_id => $rec->{id},
- description => $fdat{"description_$rec->{id}"},
- url => $fdat{"url_$rec->{id}"} || $fdat{url},
- heading => $fdat{"heading_$rec->{id}"}}) if ($fdat{"heading_$rec->{id}"} || $fdat{"description_$rec->{id}"}) ;
+ # Check the URL
+
+ my $lang = $rec->{id};
+
+ foreach (@$cf)
+ {
+ next unless $r->{category_types}{$_.'_'.$lang} =~ /url/;
+
+ if ($fdat{$_.'_'.$lang} && $fdat{$_.'_'.$lang} =~ /\s/)
+ {
+ $fdat{$_.'_'.$lang} =~ s/\s//g;
+ push(@{$r->{warning}}, 'warn_url_removed_white_space');
+ }
+
+ if ($fdat{$_.'_'.$lang} && $fdat{$_.'_'.$lang} !~ m{http://})
+ {
+ $fdat{$_.'_'.$lang} =~ s{^}{http://};
+ push(@{$r->{warning}}, 'warn_url_added_http');
+ }
+
+ }
+
+ $$txtset -> Insert ({ (map { $_ => $fdat{$_.'_'.$lang} || $fdat{$_} } @$cf),
+ "${tt}_id" => $id,
+ language_id => $lang })
+ if (grep { $fdat{$_.'_'.$lang} || $fdat{$_} } @$cf) ;
+ }
+
+ $fdat{"${tt}_id"} = $id ;
+
+ $r->{item_set} = undef ;
+ $self->get_item_lang($r);
+
+ if (!$udat{user_admin})
+ {
+ my @errors;
+ my $newitemmail = Embperl::Mail::Execute ({
+ inputfile => 'updateditem.mail',
+ to => $r->{config}->{adminemail},
+ subject => 'New item on Embperl Website (Category '.$r->{category_set}{category}.')'.($udat{user_email}?" by $udat{user_email}":''),
+ errors => \@errors});
+ if ($newitemmail)
+ {
+ $r->{error} = 'err_item_admin_mail';
+ $r->{error_details} = join("\n",@errors);
+
+ return;
+ }
}
- $fdat{item_id} = $id ;
- }
+ $r->{success} = 'suc_item_created';
+ return $self -> redir_to_show ($r) ;
+ }
# ----------------------------------------------------------------------------
@@ -299,55 +466,95 @@
my $self = shift ;
my $r = shift ;
- if (!$self -> checkuser($r))
+ if ($self -> checkuser($r) < $r->{category_set}{edit_level})
{
$r -> {need_login} = 1 ;
return ;
}
+ my $tt = $r->{category_set}{table_type};
+ my $cf = $r->{category_fields};
+
# make sure we have an id
- if ($fdat{item_id})
+ if (!$fdat{"${tt}_id"})
{
- $r -> {error} = 'err_cannot_update' ;
+ $r -> {error} = 'err_cannot_update_no_id';
return ;
}
my $set = DBIx::Recordset -> Setup ({'!DataSource' => $r -> {db},
- '!Table' => 'item'}) ;
+ '!Table' => $tt }) ;
# update the entry, but only if it has the correct user id or the has admin rights
- my $rows = $$set -> Update ({ url => $fdat{url},
- $fdat{category_id}?(category_id => $fdat{category_id}):(),
- $r ->{user_admin}?(state => $fdat{state}):()},
- {id => $fdat{item_id},
- $r ->{user_admin}?():(user_id => $r -> {user_id})}) ;
+ my $rows = $$set -> Update ({ url => $fdat{url},
+ $fdat{category_id} ? (category_id => $fdat{category_id}) : (),
+ $r->{user_admin} ? (state => $fdat{state}) : () },
+ { id => $fdat{"${tt}_id"},
+ $r ->{user_admin} ? () : (user_id => $r->{user_id}) }) ;
if ($rows <= 0)
{ # error if nothing was found (this will happen when the record isdn't owned by the user)
- $r -> {error} = 'err_cannot_update' ;
+ $r -> {error} = 'err_cannot_update_maybe_wrong_user' ;
return ;
}
- my $id = $fdat{item_id} ;
+ my $id = $fdat{"${tt}_id"} ;
my $langset = $r -> {language_set} ;
my $txtset = DBIx::Recordset -> Setup ({'!DataSource' => $r -> {db},
- '!Table' => 'itemtext'}) ;
-
- # Update the texts for every languange, but only if they belong to the item we have delete above
+ '!Table' => "${tt}text"}) ;
+
+ if (DBIx::Recordset->LastError)
+ {
+ $r -> {error} = 'err_update_db' ;
+ return ;
+ }
+
+ # Update the texts for every languange, but only if they belong to
+ # the item we have updated above
+
$$langset -> Reset ;
while ($rec = $$langset -> Next)
{
- $$txtset -> Update ({
- language_id => $rec->{id},
- description => $fdat{"description_$rec->{id}"},
- url => $fdat{"url_$rec->{id}"} || $fdat{url},
- heading => $fdat{"heading_$rec->{id}"},
- },
- { item_id => $id,
- id => $fdat{"id_$rec->{id}"}})
- if ($fdat{"heading_$rec->{id}"} || $fdat{"description_$rec->{id}"}) ;
-
+ my $lang = $rec->{id};
+ $$txtset -> Update ({ (map { $_ => $fdat{$_.'_'.$lang} || $fdat{$_} } @$cf),
+ language_id => $lang,
+ }, {
+ "${tt}_id" => $id,
+ id => $fdat{"id_$lang"}
+ })
+ if (grep { $fdat{$_.'_'.$lang} || $fdat{$_} } @$cf) ;
+
+ if (DBIx::Recordset->LastError)
+ {
+ $r -> {error} = 'err_update_lang_db' ;
+ return ;
+ }
+ }
+
+ $r -> {item_set} = undef ;
+ $self->get_item_lang($r) ;
+
+ if (!$udat{user_admin})
+ {
+ my @errors;
+ $r->{is_update} = 1;
+ my $newitemmail = Embperl::Mail::Execute ({
+ inputfile => 'updateditem.mail',
+ to => $r->{config}->{adminemail},
+ subject => 'Updated item on Embperl Website (Category '.$r->{category_set}{category}.')'.($udat{user_email}?" by $udat{user_email}":''),
+ errors => \@errors});
+ if ($newitemmail)
+ {
+ $r->{error} = 'err_item_admin_mail';
+ $r->{error_details} = join('; ',@errors);
+
+ return;
+ }
}
+
+ $r->{success} = 'suc_item_updated' ;
+
+ return $self -> redir_to_show ($r) ;
}
@@ -364,48 +571,96 @@
return ;
}
+ my $tt = $r->{category_set}{table_type};
+ my $cf = $r->{category_fields};
+
# make sure we have an id
- if ($fdat{item_id})
+ if (!$fdat{"${tt}_id"})
{
- $r -> {error} = 'err_cannot_delete' ;
+ $r -> {error} = 'err_cannot_delete_no_id' ;
return ;
}
# first see if the entry exists and has the correct user_id
- my $set = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
- '!Table' => 'item',
- id => $fdat{item_id},
- $r ->{user_admin}?():(user_id => $r -> {user_id})}) ;
+ my $set = DBIx::Recordset -> Search ({'!DataSource' => $r->{db},
+ '!Table' => $tt,
+ id => $fdat{"${tt}_id"},
+ $r->{user_admin} ? () : (user_id => $r->{user_id}) }) ;
- if (!$set -> MoreRecord())
+ if (!$$set -> MoreRecords())
{ # error if nothing was found (this will happen when the record isdn't owned by the user
- $r -> {error} = 'err_cannot_delete' ;
+ $r -> {error} = 'err_cannot_delete_maybe_wrong_user_or_no_such_item' ;
return ;
}
# delete the entry, but only if it has the correct user id or the has admin rights
- $$set -> Delete ({id => $fdat{item_id},
- $r ->{user_admin}?():(user_id => $r -> {user_id})}) ;
-
+ $$set -> Delete ({id => $fdat{"${tt}_id"},
+ $r ->{user_admin}?():(user_id => $r->{user_id})}) ;
+
+ if (DBIx::Recordset->LastError)
+ {
+ $r->{error} = 'err_cannot_delete_db_error';
+ $r->{error_details} = DBIx::Recordset->LastError;
+ return;
+ }
- my $id = $fdat{item_id} ;
+ my $id = $fdat{"${tt}_id"} ;
my $langset = $r -> {language_set} ;
my $txtset = DBIx::Recordset -> Setup ({'!DataSource' => $r -> {db},
- '!Table' => 'itemtext'}) ;
+ '!Table' => "${tt}text"}) ;
# Delete the texts for every languange, but only if they belong to the item we have delete above
$$langset -> Reset ;
while ($rec = $$langset -> Next)
{
- $$txtset -> Delete ({ item_id => $id,
- id => $fdat{"id_$rec->{id}"}}) ;
+ $$txtset -> Delete ({ "${tt}_id" => $id,
+ id => $fdat{"id_$rec->{id}"}}) ;
+ if (DBIx::Recordset->LastError)
+ {
+ $r->{error} = 'err_cannot_delete_db_error';
+ $r->{error_details} = DBIx::Recordset->LastError;
+ return;
+ }
}
+
+ $r->{success} = 'suc_item_deleted' ;
+
+ return $self -> redir_to_show ($r) ;
+ }
+
+
+# ----------------------------------------------------------------------------
+
+sub redir_to_show
+ {
+ my $self = shift ;
+ my $r = shift ;
+
+ my $tt = $r->{category_set}{table_type};
+
+ my %params =
+ (
+ -show_item => 1,
+ $fdat{category_id} ? (category_id => $fdat{category_id}) : (),
+ $fdat{"${tt}_id"} ? ("${tt}_id" => $fdat{"${tt}_id"}) : (),
+ $r -> {error} ? (-error => $r -> {error}) : (),
+ $r -> {success} ? (-success => $r -> {success}) : (),
+ ) ;
+
+ my $dest = join ('&', map { $_ . '=' . $r -> Escape (ref ($params{$_})?join("\t", @{$params{$_}}):$params{$_} , 2) } keys %params) ;
+
+ #$http_headers_out{'location'} = "show.epl?$dest";
+ Apache -> request -> err_header_out('location', "show.epl?$dest") ;
+
+ return 301 ;
}
+
# ----------------------------------------------------------------------------
+
sub get_category
{
my $self = shift ;
@@ -417,7 +672,45 @@
'language_id' => $r -> param -> language,
$fdat{category_id}?(category_id => $fdat{category_id}):(),
$r -> {user_admin}?():(state => 1)}) ;
-
+
+ *fields = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
+ '!Table' => 'category, categoryfields',
+ '!TabRelation' => 'category_id = category.id',
+ 'language_id' => $r -> param -> language,
+ $fdat{category_id}?(category_id => $fdat{category_id}):(),
+ $r -> {user_admin}?():(state => 1),
+ '$order' => 'position' }) ;
+
+ my %texts = ();
+ my %types = ();
+# my %position = ();
+ my @textfields = ();
+
+ while (my $field = $fields->Next)
+ {
+ push(@textfields, $field->{fieldname});
+ $texts{$field->{fieldname}.'_text'} = $field->{txt};
+ $types{$field->{fieldname}} = $field->{typeinfo};
+# $position{$field->{fieldname}} = $field->{position};
+ }
+
+ $r -> {category_fields} = \@textfields;
+ $r -> {category_texts} = \%texts;
+ $r -> {category_types} = \%types;
+# $r -> {category_position} = \%position;
+
+ my $title_type = 'heading';
+ foreach my $f (@textfields)
+ {
+ if ($types{$f} =~ /title/)
+ {
+ $title_type = $f;
+ last;
+ }
+ }
+
+ $r -> {category_title_type} = $title_type;
+
}
@@ -441,15 +734,16 @@
}
}
+ $tt = $r->{category_set}{table_type};
- $r -> {item_set} = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
- '!Table' => 'item, itemtext',
- '!TabRelation' => 'item_id = item.id',
- 'language_id' => $r -> param -> language,
- '!Order' => 'creationtime desc',
- $fdat{category_id}?(category_id => $fdat{category_id}):(),
- $fdat{item_id}?(item_id => $fdat{item_id}):(),
- %state}) ;
+ $r -> {item_set} = DBIx::Recordset -> Search ({'!DataSource' => $r->{db},
+ '!Table' => "${tt}, ${tt}text",
+ '!TabRelation' => "${tt}_id = ${tt}.id",
+ 'language_id' => $r->param->language,
+ '!Order' => 'creationtime desc',
+ $fdat{category_id} ? (category_id => $fdat{category_id}) : (),
+ $fdat{"${tt}_id"} ? ("${tt}_id" => $fdat{"${tt}_id"}) : (),
+ %state}) ;
}
@@ -474,13 +768,22 @@
}
}
- $r -> {item_set} = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
- '!Table' => 'item, language, itemtext', # itemtext must be last to get it's id
- '!TabRelation' => 'item_id = item.id and language_id = language.id',
- '!Order' => 'creationtime desc',
- $fdat{category_id}?(category_id => $fdat{category_id}):(),
- $fdat{item_id}?(item_id => $fdat{item_id}):(),
- %state}) ;
+ $tt = $r->{category_set}{table_type};
+
+ $r -> {item_set} = DBIx::Recordset -> Search ({'!DataSource' => $r->{db},
+ '!Table' => "${tt}, language, ${tt}text", # ${tt}text must be last to get it's id
+ '!TabRelation' => "${tt}_id = ${tt}.id and language_id = language.id",
+ '!Order' => 'creationtime desc',
+ $fdat{category_id} ? (category_id => $fdat{category_id}) : (),
+ $fdat{"${tt}_id"} ? ("${tt}_id" => $fdat{"${tt}_id"}) : (),
+ %state}) ;
+
+# push(@{$r->{warning}}, 'get_item_lang =>', $tt, @{$r->{item_set}});
+# ${$r->{item_set}}->Reset;
+
+ $r->{item_set} = undef unless ${$r->{item_set}}->MoreRecords;
+ ${$r->{item_set}} -> Reset if ($r->{item_set}) ;
+
}
# ----------------------------------------------------------------------------
@@ -497,20 +800,189 @@
}
my $set = $r -> {item_set} ;
- $fdat{'item_id'} = $set -> {item_id} ;
+
+ unless (defined $set)
+ {
+ $r->{error} = 'err_item_not_found_or_access_denied';
+
+ return;
+ }
+
+ my $tt = $r->{category_set}{table_type};
+ my $cf = $r->{category_fields};
+
+ $fdat{"${tt}_id"} = $set->{"${tt}_id"} if $set->{"${tt}_id"};
$$set -> Reset ;
while ($rec = $$set -> Next)
{
my $lang = $rec -> {language_id} ;
- $fdat{'id_' . $lang} = $rec -> {id} ;
- foreach my $type ('heading', 'url', 'description', 'keywords')
+ $fdat{'id_' . $lang} = $rec -> {id};
+ foreach my $type (@$cf)
{
$fdat{$type . '_' . $lang} = $rec -> {$type} ;
}
}
+ $$set -> Reset ;
$r -> {edit} = 1 ;
}
+# ----------------------------------------------------------------------------
+
+sub get_user
+ {
+ my $self = shift ;
+ my $r = shift ;
+
+ $fdat{user_id} = undef unless $r -> {user_admin};
+
+ $r -> {user_set} = DBIx::Recordset -> Search ({'!DataSource' => $r->{db},
+ '!Table' => "user",
+ id => $fdat{user_id} || $udat{user_id}
+ }) ;
+ $r->{user_set} = undef unless ${$r->{user_set}}->MoreRecords;
+ }
+
+# ----------------------------------------------------------------------------
+
+sub get_users
+ {
+ my $self = shift ;
+ my $r = shift ;
+
+ if ($self -> checkuser_light($r) < 1)
+ {
+ $r -> {need_login} = 1 ;
+ return ;
+ }
+
+ return unless $r -> {user_admin};
+
+ $r -> {users} = DBIx::Recordset -> Search ({'!DataSource' => $r->{db},
+ '!Table' => "user" }) ;
+ $r->{users} = undef unless ${$r->{users}}->MoreRecords;
+ }
+
+
+# ----------------------------------------------------------------------------
+
+sub update_user
+ {
+ my $self = shift ;
+ my $r = shift ;
+
+ if ($self -> checkuser_light($r) < 1)
+ {
+ $r -> {need_login} = 1 ;
+ return ;
+ }
+
+ unless (($fdat{user_id} == $udat{user_id}) or $r->{user_admin})
+ {
+ $r->{error} = 'err_cannot_update_wrong_user_xxx';
+ return;
+ }
+
+ eval { *set = DBIx::Recordset -> Update ({'!DataSource' => $r->{db},
+ '!Table' => "user",
+ 'name' => $fdat{name},
+ 'pid' => $fdat{pid} },
+ { id => $fdat{user_id} || $udat{user_id}}) ; };
+
+
+ if ($@ and $@ =~ 'Duplicate entry')
+ {
+ $r->{error} = 'err_pid_exists';
+ return;
+ }
+
+ if (DBIx::Recordset->LastError)
+ {
+ $r->{error} = 'err_update_db';
+ push(@{$r->{error_details}}, DBIx::Recordset->LastError
+ );
+ }
+
+ $r->{success} = 'suc_user_update';
+
+ }
+
+# ----------------------------------------------------------------------------
+# Warning: This will not yet work as intended if there is more than
+# one category using $table as category type!
+
+sub get_title
+ {
+ my ($self, $r, $col, $id) = @_;
+
+ (my $table = $col) =~ s/_id$// or die "Can't strip '_id'";
+
+ my $config = $r->{config};
+ my $db = DBIx::Database -> new ({'!DataSource' => $config -> {dbdsn},
+ '!Username' => $config -> {dbuser},
+ '!Password' => $config -> {dbpassword},
+ '!DBIAttr' => { RaiseError => 1, PrintError => 1, LongReadLen => 32765, LongTruncOk => 0, }});
+
+
+ # SQL can't handle such kind soft links, so we need two requests
+ *fields = DBIx::Recordset -> Search ({'!DataSource' => $db,
+ '!Table' => 'category, categoryfields',
+ 'table_type' => $table,
+ 'state' => 1,
+ 'typeinfo' => 'title',
+ '*typeinfo' => 'LIKE',
+ '$order' => 'position' }) ;
+
+ *set = DBIx::Recordset -> Search ({'!DataSource' => $db,
+ '!Table' => $table.'text',
+ 'language_id' => $r -> param -> language,
+ $table.'_id' => $id }) ;
+
+ return $set{$fields{fieldname}};
+ }
+
+# ----------------------------------------------------------------------------
+# Warning: This will not yet work as intended if there is more than
+# one category using $table as category type!
+
+sub get_titles
+ {
+ my ($self, $r, $table) = @_;
+
+# *set = DBIx::Recordset -> Search ({'!DataSource' => $r->{db},
+# '!Fields' => "id,$r->{category_title_type} as title",
+# '!Table' => $table, }) ;
+# print OUT Dumper $config;
+#
+# return;
+
+ my $config = $r->{config};
+ my $db = DBIx::Database -> new ({'!DataSource' => $config -> {dbdsn},
+ '!Username' => $config -> {dbuser},
+ '!Password' => $config -> {dbpassword},
+ '!DBIAttr' => { RaiseError => 1, PrintError => 1, LongReadLen => 32765, LongTruncOk => 0, },
+ }) ;
+
+ # SQL can't handle such kind soft links, so we need two requests
+ *fields = DBIx::Recordset -> Search ({'!DataSource' => $db,
+ '!Table' => 'category, categoryfields',
+ 'table_type' => $table,
+ 'state' => 1,
+ 'typeinfo' => 'title',
+ '*typeinfo' => 'LIKE',
+ '$order' => 'position' }) ;
+ my $title_type = $fields{fieldname};
+ #print OUT $title_type;
+
+ *set = DBIx::Recordset -> Search ({'!DataSource' => $db,
+ '!Table' => $table.'text',
+ 'language_id' => $r -> param -> language,
+ '!Fields' => $table."_id as id,$title_type as title",
+ }) ;
+
+ return \@set;
+ }
+
+
1.3 +48 -5 embperl/eg/web/db/show.epl
Index: show.epl
===================================================================
RCS file: /home/cvs/embperl/eg/web/db/show.epl,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- show.epl 22 Oct 2002 05:39:50 -0000 1.2
+++ show.epl 20 Nov 2002 06:56:27 -0000 1.3
@@ -4,27 +4,55 @@
<table width="100%">
<tr bgcolor="#fefcad">
- <td><font size="4">[$ if $fdat{-update_item} $][= edit1 =] [$else$][= add1 =] [$endif$] [+ $r -> {category_set}{category} +]</font></td>
+ <td><font size="4">
+ [$ if $fdat{-update_item} $]
+ [= edit1 =] [+ $r->{category_set}{category} +]
+ [$ elsif $fdat{-delete_item} $]
+ [= del1 =]
+ [$ else $]
+ [= add1 =] [+ $r->{category_set}{category} +]
+ [$ endif $]
+ </font></td>
</tr>
</table>
+[$ if $fdat{-delete_item} && !$r->{error} $]
+<P>[= del2 =]</P>
+<P><A HREF="addsel.epl">[= back_to_index =]</A></P>
+[$ endif $]
+
+[$ if ($item_set = $r->{item_set}) $] [# && (ref ($item_set) ne 'ARRAY' || @$item_set > 0) $]#]
[= show2 =]<br><br>
+Status: [+ eval { $r -> gettext ($item_set->{state} ? 'display' : 'hide') } +]
+
+[-
+ $ct = $r->{category_texts};
+ $cy = $r->{category_types};
+ $cf = $r->{category_fields};
+-]
+
<table width="100%">
<tr bgcolor="#fefcad">
- [- $rec = $r -> {item_set}[$row] -]
+ [- $rec = $item_set->[$row] -]
<td><font size=3><b>[+ $rec -> {name} +]</b></font></td>
</tr>
<tr>
<td>
<table>
- [$foreach $type ('heading', 'url', 'description', 'keywords') $]
- [$ if $txt = $r -> {category_set}{$type . '_text'} $]
+ [$ foreach $type (@$cf) $]
+ [$ if $txt = $ct->{$type . '_text'} $]
<tr>
- <td valign=top>[+ $txt +]:</td><td>[- @txt = split (/\n/, $rec -> {$type}) -][$ foreach $t (@txt) $][+ $t +]<br>[$endforeach$]</td>
+ <td valign=top>[+ $txt +]:</td><td>
+ [$ if $cy->{$type} =~ /pulldown/ $]
+ [+ $r->app->get_title($r,$type,$fdat{$type.'_'.$rec->{language_id}}) +]
+ [$ else $]
+ [- @txt = split (/\n/, $rec -> {$type}) -][$ foreach $t (@txt) $][+ $t +]<br>[$ endforeach $]
+ [$ endif $]
+ </td>
</tr>
[$endif$]
[$endforeach$]
@@ -33,4 +61,19 @@
</tr>
</table>
+[$ if $udat{user_email} $]
+[- $tt = $r->{category_set}{table_type} -]
+<A HREF="add.epl?[+ $tt +]_id=[+ $fdat{"${tt}_id"} +]&-edit_item=1&category_id=[+ $fdat{category_id} +]">Edit</A>
+[$ endif $]
+
+[$ endif $]
+
<br><br>
+
+[#
+[! use Data::Dumper; !]
+[- $DBIx::Recordset::FetchsizeWarn = 0; -]
+<PRE>
+[+ Dumper $r->{error},\%fdat,[keys %$r],[@{$r->{category_fields}}],{%{$r->{category_texts}}},{%{$r->{category_set}}},$r->{item_set} +]
+</PRE>
+#]
1.2 +73 -0 embperl/eg/web/db/list.epl
1.2 +17 -0 embperl/eg/web/db/newpw.mail
1.2 +23 -0 embperl/eg/web/db/newuser.admin.mail
1.2 +20 -0 embperl/eg/web/db/newuser.mail
1.2 +29 -0 embperl/eg/web/db/updateditem.mail
1.3 +174 -39 embperl/eg/webutil/db.schema
Index: db.schema
===================================================================
RCS file: /home/cvs/embperl/eg/webutil/db.schema,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- db.schema 22 Oct 2002 05:39:51 -0000 1.2
+++ db.schema 20 Nov 2002 06:56:28 -0000 1.3
@@ -69,7 +69,7 @@
[
'id' => 'counter',
'item_id' => 'integer',
- 'language_id' => 'char(2)',
+ 'language_id' => 'varchar(2)',
'heading' => 'tinytext',
'keywords' => 'text',
'description' => 'text',
@@ -113,7 +113,7 @@
'!Table' => 'language',
'!Fields' =>
[
- 'id' => 'char(2) not null',
+ 'id' => 'varchar(2) not null',
'name' => 'tinytext',
],
'!PrimKey' => 'id',
@@ -132,16 +132,102 @@
[
'id' => 'counter',
'state' => 'integer',
+ 'table_type' => 'tinytext',
+ 'viev_level' => 'integer',
+ 'edit_level' => 'integer',
],
'!PrimKey' => 'id',
'!Init' =>
[
- { id => 1, state => 1 } ,
- { id => 2, state => 1 } ,
- { id => 3, state => 1 } ,
- { id => 4, state => 1 } ,
- { id => 5, state => 1 } ,
- { id => 6, state => 1 } ,
+ { id => 1, state => 1, 'table_type' => 'item' } ,
+ { id => 2, state => 1, 'table_type' => 'item' } ,
+ { id => 3, state => 1, 'table_type' => 'item' } ,
+ { id => 4, state => 1, 'table_type' => 'item' } ,
+ { id => 5, state => 1, 'table_type' => 'item' } ,
+ { id => 6, state => 1, 'table_type' => 'item' } ,
+ { id => 7, state => 1, 'table_type' => 'foo' } ,
+ ],
+ },
+
+# ----------------------------------------------------------------------
+
+ {
+ '!Table' => 'categoryfields',
+ '!Fields' =>
+ [
+ 'category_id' => 'integer not null',
+ 'language_id' => 'varchar(3) not null',
+ 'fieldname' => 'varchar(32) not null',
+ 'txt' => 'text',
+ 'typeinfo' => 'tinytext',
+ 'position' => 'integer',
+ ],
+ '!PrimKey' => 'category_id,language_id,fieldname',
+ #'!PrimKey' => 'category_id',
+ '!Init' =>
+ [
+ # News
+ { category_id => 1, language_id => 'de', fieldname => 'description', typeinfo => 'textarea', txt => 'Neuigkeit', position => 1 } ,
+ { category_id => 1, language_id => 'en', fieldname => 'description', typeinfo => 'textarea', txt => 'News', position => 1 } ,
+
+ # Emperl Websites
+ { category_id => 2, language_id => 'de', fieldname => 'heading', txt => '�berschrift', position => 1 } ,
+ { category_id => 2, language_id => 'de', fieldname => 'description', typeinfo => 'textarea', txt => 'Beschreibung', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 2, language_id => 'de', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ { category_id => 2, language_id => 'en', fieldname => 'heading', txt => 'Heading', position => 1 } ,
+ { category_id => 2, language_id => 'en', fieldname => 'description', typeinfo => 'textarea', txt => 'Description', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 2, language_id => 'en', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ # Books about Embperl
+ { category_id => 3, language_id => 'de', fieldname => 'heading', txt => 'Titel', position => 1 } ,
+ { category_id => 3, language_id => 'de', fieldname => 'description', typeinfo => 'textarea', txt => 'Beschreibung', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 3, language_id => 'de', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ { category_id => 3, language_id => 'en', fieldname => 'heading', txt => 'Title', position => 1 } ,
+ { category_id => 3, language_id => 'en', fieldname => 'description', typeinfo => 'textarea', txt => 'Description', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 3, language_id => 'en', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ # Embperl articles
+ { category_id => 4, language_id => 'de', fieldname => 'heading', txt => 'Titel', position => 1 } ,
+ { category_id => 4, language_id => 'de', fieldname => 'description', typeinfo => 'textarea', txt => 'Beschreibung', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 4, language_id => 'de', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ { category_id => 4, language_id => 'en', fieldname => 'heading', txt => 'Title', position => 1 } ,
+ { category_id => 4, language_id => 'en', fieldname => 'description', typeinfo => 'textarea', txt => 'Description', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 4, language_id => 'en', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ # Syntax highlighting
+ { category_id => 5, language_id => 'de', fieldname => 'heading', txt => 'Editor', position => 1 } ,
+ { category_id => 5, language_id => 'de', fieldname => 'description', typeinfo => 'textarea', txt => 'Beschreibung', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 5, language_id => 'de', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ { category_id => 5, language_id => 'en', fieldname => 'heading', txt => 'Editor', position => 1 } ,
+ { category_id => 5, language_id => 'en', fieldname => 'description', typeinfo => 'textarea', txt => 'Description', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 5, language_id => 'en', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ # Modules and examples
+ { category_id => 6, language_id => 'de', fieldname => 'heading', txt => 'Name', position => 1 } ,
+ { category_id => 6, language_id => 'de', fieldname => 'description', typeinfo => 'textarea', txt => 'Beschreibung', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 6, language_id => 'de', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ { category_id => 6, language_id => 'en', fieldname => 'heading', txt => 'Name', position => 1 } ,
+ { category_id => 6, language_id => 'en', fieldname => 'description', typeinfo => 'textarea', txt => 'Description', typeinfo => 'textarea', position => 3 } ,
+ { category_id => 6, language_id => 'en', fieldname => 'url', txt => 'URL', typeinfo => 'url', position => 2 } ,
+
+ # Test
+ { category_id => 7, language_id => 'de', fieldname => 'foo', txt => 'Foo!', typeinfo => 'title', position => 1 } ,
+ { category_id => 7, language_id => 'de', fieldname => 'bar', txt => 'Bar!', position => 2 } ,
+ { category_id => 7, language_id => 'de', fieldname => 'fnord', txt => 'Fnord!', position => 3 } ,
+ { category_id => 7, language_id => 'de', fieldname => 'fubar', txt => 'Fubar!', position => 4 } ,
+ { category_id => 7, language_id => 'de', fieldname => 'Baz', txt => 'Bazzz!', typeinfo => 'url', position => 5 } ,
+
+ { category_id => 7, language_id => 'en', fieldname => 'foo', txt => 'foo!', typeinfo => 'title', position => 1 } ,
+ { category_id => 7, language_id => 'en', fieldname => 'bar', txt => 'bar!', position => 2 } ,
+ { category_id => 7, language_id => 'en', fieldname => 'fnord', txt => 'fnord!', position => 3 } ,
+ { category_id => 7, language_id => 'en', fieldname => 'fubar', txt => 'fubar!', position => 4 } ,
+ { category_id => 7, language_id => 'en', fieldname => 'Baz', txt => 'bazzz!', typeinfo => 'url', position => 5 } ,
+
],
},
@@ -153,48 +239,40 @@
[
'id' => 'counter',
'category_id' => 'integer',
- 'language_id' => 'char(2)',
+ 'language_id' => 'varchar(2)',
'category' => 'tinytext',
+ 'add_info' => 'text',
+ # Deprecated:
'heading_text' => 'tinytext',
'keywords_text' => 'tinytext',
'description_text' => 'tinytext',
'url_text' => 'tinytext',
- 'add_info' => 'text',
],
'!PrimKey' => 'id',
'!Init' =>
[
- { id => 1, category_id => 1, language_id => 'de', 'category' => 'Neuigkeiten',
- heading_text => '', keywords_text => '', description_text => 'Neuigkeit', url_text => '' } ,
- { id => 2, category_id => 1, language_id => 'en', 'category' => 'News',
- heading_text => '', keywords_text => '', description_text => 'News', url_text => '' } ,
+ { id => 1, category_id => 1, language_id => 'de', 'category' => 'Neuigkeiten' } ,
+ { id => 2, category_id => 1, language_id => 'en', 'category' => 'News' } ,
{ id => 3, category_id => 2, language_id => 'de', 'category' => 'Websites die Embperl nutzen',
- heading_text => '�berschrift', keywords_text => '', description_text => 'Beschreibung', url_text => 'URL',
- add_info => 'Bitte geben Sie eine Kurzbeschreibung der Site, sowie Informationen zu deren Realisierung ein.' } ,
+ add_info => 'Bitte geben Sie eine Kurzbeschreibung der Site, sowie Informationen zu deren Realisierung ein.' } ,
{ id => 4, category_id => 2, language_id => 'en', 'category' => 'Sites using Embperl',
- heading_text => 'Heading', keywords_text => '', description_text => 'Description', url_text => 'URL',
- add_info => 'Please enter a short description of the Site and some informations how it has been setup.' } ,
+ add_info => 'Please enter a short description of the Site and some informations how it has been setup.' } ,
+
+ { id => 5, category_id => 3, language_id => 'de', 'category' => 'B�cher die Embperl behandeln' } ,
+ { id => 6, category_id => 3, language_id => 'en', 'category' => 'Books that talk about Embperl' } ,
- { id => 5, category_id => 3, language_id => 'de', 'category' => 'B�cher die Embperl behandeln',
- heading_text => 'Titel', keywords_text => '', description_text => 'Beschreibung', url_text => 'URL' } ,
- { id => 6, category_id => 3, language_id => 'en', 'category' => 'Books that talk about Embperl',
- heading_text => 'Title', keywords_text => '', description_text => 'Description', url_text => 'URL' } ,
-
- { id => 7, category_id => 4, language_id => 'de', 'category' => 'Artikel �ber Embperl (on- und offline)',
- heading_text => 'Titel', keywords_text => '', description_text => 'Beschreibung', url_text => 'URL' } ,
- { id => 8, category_id => 4, language_id => 'en', 'category' => 'Article about Embperl (on- and offline)',
- heading_text => 'Title', keywords_text => '', description_text => 'Description', url_text => 'URL' } ,
-
- { id => 9, category_id => 5, language_id => 'de', 'category' => 'Syntaxhervorhebungen f�r Texteditoren',
- heading_text => 'Editor', keywords_text => '', description_text => 'Beschreibung', url_text => 'URL' } ,
- { id => 10, category_id => 5, language_id => 'en', 'category' => 'Syntaxhighlighting for texteditors',
- heading_text => 'Editor', keywords_text => '', description_text => 'Description', url_text => 'URL' } ,
-
- { id => 11, category_id => 6, language_id => 'de', 'category' => 'Module und Beispiele f�r Embperl',
- heading_text => 'Name', keywords_text => '', description_text => 'Beschreibung', url_text => 'URL' } ,
- { id => 12, category_id => 6, language_id => 'en', 'category' => 'Modules and examples for Embperl',
- heading_text => 'Name', keywords_text => '', description_text => 'Description', url_text => 'URL' } ,
+ { id => 7, category_id => 4, language_id => 'de', 'category' => 'Artikel �ber Embperl (on- und offline)' } ,
+ { id => 8, category_id => 4, language_id => 'en', 'category' => 'Article about Embperl (on- and offline)' } ,
+
+ { id => 9, category_id => 5, language_id => 'de', 'category' => 'Syntaxhervorhebungen f�r Texteditoren' } ,
+ { id => 10, category_id => 5, language_id => 'en', 'category' => 'Syntaxhighlighting for texteditors' } ,
+
+ { id => 11, category_id => 6, language_id => 'de', 'category' => 'Module und Beispiele f�r Embperl' } ,
+ { id => 12, category_id => 6, language_id => 'en', 'category' => 'Modules and examples for Embperl' } ,
+
+ { id => 13, category_id => 7, language_id => 'de', 'category' => 'Was ist Foobar?!?' } ,
+ { id => 14, category_id => 7, language_id => 'en', 'category' => 'What is foobar?!?' } ,
],
},
@@ -216,8 +294,65 @@
'!PrimKey' => 'id',
},
-
) ;
+
+
+=pod
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# TEST
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+ {
+ '!Table' => 'foo',
+ '!Fields' =>
+ [
+ 'id' => 'counter',
+ 'url' => 'tinytext',
+ 'category_id' => 'integer',
+ 'state' => 'integer',
+ 'creationtime' => 'datetime',
+ 'modtime' => 'datetime',
+ 'user_id' => 'integer',
+ 'checkcount' => 'integer',
+ ],
+ '!PrimKey' => 'id',
+ '!Init' =>
+ [
+ ]
+ },
+
+# ----------------------------------------------------------------------
+
+ {
+ '!Table' => 'footext',
+ '!Fields' =>
+ [
+ 'id' => 'counter',
+ 'foo_id' => 'integer',
+ 'language_id' => 'varchar(2)',
+ 'foo' => 'tinytext',
+ 'bar' => 'tinytext',
+ 'fnord' => 'tinytext',
+ 'fubar' => 'tinytext',
+ 'baz' => 'tinytext',
+ ],
+ '!PrimKey' => 'id',
+ '!Init' =>
+ [
+ ]
+ },
+
+=cut
+
1 ;
1.3 +184 -11 embperl/podsrc/Config.spod
Index: Config.spod
===================================================================
RCS file: /home/cvs/embperl/podsrc/Config.spod,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- Config.spod 22 Oct 2002 05:45:13 -0000 1.2
+++ Config.spod 20 Nov 2002 06:56:28 -0000 1.3
@@ -1339,9 +1339,9 @@
There are three major objects in Embperl: I<application>, I<request> and I<component>.
Each of these objects can be used to get information about the processing and
control the execution. Each of these objects has a config sub-object, which makes
-the configuration accessable and where possible changeable at runtime. The C<config>
+the configuration accessable and, where possible, changeable at runtime. The C<config>
method of these three objects returns a reference to the configuation object. The methods
-of these configurations objects are decribed in the section L<Configuration>.
+of these configurations objects are described in the section L<Configuration>.
The request and the component object have addtionaly a parameter sub-object, which holds
parameters passed to the current request/component. The C<param> method of these two
objects returns the parameter sub-object. The methods of these parameter objects
@@ -1349,102 +1349,245 @@
Addtionaly each of the three major objects has a set of own methods, which are described
here.
-
-B<more is coming soon...>
-
-
=head2 *METHOD $application / / thread / 2.0b6 / no
+Returns a reference to a object which hold per threads informations. There is only one
+such object per thread.
+
=head2 *METHOD $application / / curr_req / 2.0b6 / no
+Returns a reference to the current request object i.e. the object of the
+request currently running.
+
=head2 *METHOD $application / / config / 2.0b6 / no
+Returns a reference to the configuration object of the application. See section L<Configuration>.
+
=head2 *METHOD $application / / user_session / 2.0b6 / no
+Returns a reference to the user session object.
+
=head2 *METHOD $application / / state_session / 2.0b6 / no
+Returns a reference to the state session object.
+
=head2 *METHOD $application / / app_session / 2.0b6 / no
+Returns a reference to the application session object.
+
=head2 *METHOD $application / / udat / 2.0b6 / no
+Returns a reference to a hash which contains the data of the user session.
+This has can be used to access and modify user session data. It's the same
+as accessing the global L<%udat>.
+
=head2 *METHOD $application / / sdat / 2.0b6 / no
+Returns a reference to a hash which contains the data of the state session.
+This has can be used to access and modify state session data. It's the same
+as accessing the global L<%sdat>.
+
=head2 *METHOD $application / / mdat / 2.0b6 / no
-=head2 *METHOD $application / / debug / 2.0b6 / yes
+Returns a reference to a hash which contains the data of the application session.
+This has can be used to access and modify application session data. It's the same
+as accessing the global L<%mdat>.
+
=head2 *METHOD $application / / errors_count / 2.0b6 / yes
+Contains the number of errors since last time send per mail. See also L<mail_errors_to>.
+
=head2 *METHOD $application / / errors_last_time / 2.0b6 / yes
+Time when the last error has occured. See also L<mail_errors_to>.
+
=head2 *METHOD $application / / errors_last_send_time / 2.0b6 / yes
+Time when the last mail with error messages was sent. See also L<mail_errors_to>.
+
=head2 *METHOD $request / / apache_req / 2.0b6 / no
+Returns a reference to mod_perls Apache request object. In mod_perl 1 this is of
+type C<Apache::> in mod_perl 2 it's a C<Apache::RequestRec>.
+
=head2 *METHOD $request / / config / 2.0b6 / no
+Returns a reference to the configuration object of the request. See section L<Configuration>.
+
=head2 *METHOD $request / / param / 2.0b6 / no
+Returns a reference to the parameter object of the request. See section L<Parameters>.
+
=head2 *METHOD $request / / component / 2.0b6 / no
+Returns a reference to the object of component currently running. See component methods below.
+
=head2 *METHOD $request / / app / 2.0b6 / no
+Returns a reference to the object of application to which the current request belongs.
+See application methods above.
+
+
=head2 *METHOD $request / / thread / 2.0b6 / no
+Returns a reference to a object which hold per threads informations. There is only one
+such object per thread.
+
=head2 *METHOD $request / / request_count / 2.0b6 / no
+Returns the number of request handled so far by this child process.
+
=head2 *METHOD $request / / request_time / 2.0b6 / no
-=head2 *METHOD $request / / session_mgnt ??? / 2.0b6 / no
+Start time of the current request.
+
+=head2 *METHOD $request / / session_mgnt / 2.0b6 / no
+
+Set to true if session management is available.
=head2 *METHOD $request / / session_id / 2.0b6 / no
+Combined id of current user and state session.
+
=head2 *METHOD $request / / session_state_id / 2.0b6 / no
+Id of the current state session as received by the browser, this
+means this method returns C<undef> for a new session.
+
=head2 *METHOD $request / / session_user_id / 2.0b6 / no
+Id of the current user session as received by the browser, this
+means this method returns C<undef> for a new session.
+
=head2 *METHOD $request / / had_exit / 2.0b6 / no
+True if exit was called in one of the components processed so far.
+
=head2 *METHOD $request / / log_file_start_pos / 2.0b6 / no
+File possition of the log file at the time when the request has started.
+
=head2 *METHOD $request / / error / 2.0b6 / yes
+True if there were any error during the request.
+
=head2 *METHOD $request / / errors / 2.0b6 / yes
+Reference to an array which holds all error messages occured so far.
+
=head2 *METHOD $request / / errdat1 / 2.0b6 / yes
+Additional informations passed to the error handler when an error is reported.
+
=head2 *METHOD $request / / errdat2 / 2.0b6 / yes
+Additional informations passed to the error handler when an error is reported.
+
=head2 *METHOD $request / / lastwarn / 2.0b6 / yes
+Last warning message.
+
=head2 *METHOD $request / / cleanup_vars / 2.0b6 / yes
+Reference to an array which is filled with references to variables that should be
+cleaned up after the request. You can add your own variables that needs cleanup here,
+but you should never remove any variables from this array.
+
=head2 *METHOD $request / / cleanup_packages / 2.0b6 / yes
+Refernce to a hash which contains all packages that must be cleaned up after the request.
+
=head2 *METHOD $request / / initial_cwd / 2.0b6 / no
+Working directory when the request started.
+
=head2 *METHOD $request / / messages / 2.0b6 / yes
+Reference to an array of hashs of messages. This is used by Embperl to translate
+message into different languages. When a C<[= =]> block is processed or
+$request -> gettext is called, Embperl searches this array. It starts from the first
+element in the array (each element in the array must be a hashref) and tries to
+lookup the text for the given symbol in hash. When it fails it goes to the
+next array element. This way you can setup multiple translation tables that are search
+for the symbol. Example:
+
+ %messages =
+ (
+ 'de' =>
+ {
+ 'addsel1' => 'Klicken Sie auf die Kategorie zu der Sie etwas hinzuf�gen m�chten:',
+ 'addsel2' => 'oder f�gen Sie eine neue Kategorie hinzu. Bitte geben Sie die Beschreibung in so vielen Sprachen wie Ihnen m�glich ein.',
+ 'addsel3' => 'Falls Sie die �bersetzung nicht wissen, lassen Sie das entsprechende Eingabefeld leer.',
+ 'addsel4' => 'Kategorie hinzuf�gen',
+ },
+ 'en' =>
+ {
+ 'addsel1' => 'Click on the category for wich you want to add a new item:',
+ 'addsel2' => 'or add new category. Please enter the description in as much languages as possible.',
+ 'addsel3' => 'If you don\'t know the translation leave the corresponding input field empty.',
+ 'addsel4' => 'Add category',
+ }
+ ) ;
+
+
+ $lang = $request -> param -> language ;
+ push @{$request -> messages}, $messages{$lang} ;
+ push @{$request -> default_messages}, $messages{'en'} if ($lang ne 'en') ;
+
+C<$request -> param -> language> retrieves the language as given by the browser
+language-accept header (or set before in your program). Then it pushes the german
+or english messages hash onto the message array. Addtionaly it pushes the english
+messages on the default_messages array. Messages will be taken from this array
+if nothing can be found in the messages array.
+
+
=head2 *METHOD $request / / default_messages / 2.0b6 / yes
+Reference to an array with default messages. Messages will be taken from this array
+if nothing can be found in the L<messages> array.
+
+
=head2 *METHOD $component / / config / 2.0b6 / no
+Returns an reference to the configuration object of the component.
+
=head2 *METHOD $component / / param / 2.0b6 / no
+Returns an reference to the parameter object of the component.
+
=head2 *METHOD $component / / req_running / 2.0b6 / no
+True if Embperl is inside of the execution of the request.
+
=head2 *METHOD $component / / sub_req / 2.0b6 / no
+True is this is not the outermost Embperl component, i.e. this component is
+called from within another component.
+
=head2 *METHOD $component / / inside_sub / 2.0b6 / no
+True is we are inside a Embperl subroutine ([$ sub $] ... [$ endsub $])
+
=head2 *METHOD $component / / had_exit / 2.0b6 / no
+True if the exit was called during the excution of the component.
+
=head2 *METHOD $component / / path_ndx / 2.0b6 / no
+Tells Embperl how much parts of the L<path> should be ignored when searching
+throught the path.
+
=head2 *METHOD $component / / cwd / 2.0b6 / no
+Directory of the source file of the component.
+
=head2 *METHOD $component / / sourcefile / 2.0b6 / no
+Source file of the component.
+
+=cut
+
=head2 *METHOD $component / / buf / 2.0b6 / no
=head2 *METHOD $component / / end_pos / 2.0b6 / no
@@ -1469,20 +1612,43 @@
=head2 *METHOD $component / / source_dom_tree / 2.0b6 / no
-=head2 *METHOD $component / / syntax / 2.0b6 / no
+=pod
+
+=head2 *METHOD $component / / syntax / 2.0b6 / yes, before execution
+
+Syntax of the component
+
+=cut
=head2 *METHOD $component / / append_to_main_req / 2.0b6 / no
+=pod
+
=head2 *METHOD $component / / prev / 2.0b6 / no
+Previous component, e.g. the component which called this component.
+
+=cut
+
=head2 *METHOD $component / / strict / 2.0b6 / no
+=pod
+
=head2 *METHOD $component / / import_stash / 2.0b6 / no
-=head2 *METHOD $component / / exports / 2.0b6 / no
+While importing a component this is set to the stash to which symbols are imported.
+C<undef> during normal execution.
+
+=head2 *METHOD $component / / exports / 2.0b6 / yes
+
+Symbols that should be exported by this component.
=head2 *METHOD $component / / curr_package / 2.0b6 / no
+Name of the package the component is executed in.
+
+=cut
+
=head2 *METHOD $component / / eval_package / 2.0b6 / no
=head2 *METHOD $component / / main_sub / 2.0b6 / no
@@ -1493,4 +1659,11 @@
=head2 *METHOD $component / / prog_def / 2.0b6 / no
-=head2 *METHOD $component / / code / 2.0b6 / no
+=pod
+
+=head2 *METHOD $component / / code / 2.0b6 / yes
+
+Only valid during compile phase. Can used to retrive and modify the code
+Embperl is generating. See Embperl::Syntax for more details and Embperl::Syntax::RTF
+for an example.
+
1.2 +14 -0 embperl/test/cmp/hostconfig.htm
1.2 +14 -0 embperl/test/cmp/hostconfig.htm.3
1.2 +14 -0 embperl/test/cmp/hostconfig.htm.4
1.2 +14 -0 embperl/test/cmp/hostconfig.htm.5
1.2 +70 -0 embperl/test/cmp/i18n.htm
1.2 +19 -0 embperl/test/cmp/mail.htm
1.2 +14 -0 embperl/test/cmp/mailformto.htm
1.2 +37 -0 embperl/test/cmp/pod.xml
1.2 +45 -0 embperl/test/cmp/pod.xml.xalan
1.3 +18 -18 embperl/test/cmp2/hidden.htm
Index: hidden.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp2/hidden.htm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- hidden.htm 22 Oct 2002 05:45:13 -0000 1.2
+++ hidden.htm 20 Nov 2002 06:56:28 -0000 1.3
@@ -9,43 +9,43 @@
<p> </p>
a1<input type="hidden" name="feld1" value="Wert1"><input type="hidden" name="feld2" value="Wert2"><input type="hidden" name="feld3" value="Wert3"><input type="hidden" name="feld4" value="Wert4">
- a2<input type="hidden" name="feld1" value="Pfalz"><input type="hidden" name="feld2" value="Rheinhessen">
- a3<input type="hidden" name="feld2" value="Rheinhessen">
- a4<input type="hidden" name="feld2" value="Rheinhessen">
- a5<input type="hidden" name="feld1" value="Pfalz"><input type="hidden" name="feld2" value="Rheinhessen">
- a6<input type="hidden" name="feld2" value="Rheinhessen">
- a7<input type="hidden" name="feld2" value="Rheinhessen">
+ a2<input type="hidden" name="feld1" value="Pfalz"><input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ a3<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ a4<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ a5<input type="hidden" name="feld1" value="Pfalz"><input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ a6<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ a7<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
a8<input type="hidden" name="feld4" value="Wert4"><input type="hidden" name="feld3" value="Wert3"><input type="hidden" name="feld2" value="Wert2"><input type="hidden" name="feld1" value="Wert1">
<input type="text" name="feld1" value="Wert1">
b1<input type="hidden" name="feld2" value="Wert2"><input type="hidden" name="feld3" value="Wert3"><input type="hidden" name="feld4" value="Wert4">
- b2<input type="hidden" name="feld2" value="Rheinhessen">
- b3<input type="hidden" name="feld2" value="Rheinhessen">
- b4<input type="hidden" name="feld2" value="Rheinhessen">
- b5<input type="hidden" name="feld2" value="Rheinhessen">
- b6<input type="hidden" name="feld2" value="Rheinhessen">
+ b2<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ b3<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ b4<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ b5<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ b6<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
<input type="text" name="feld2" value="Wert2">
c1<input type="hidden" name="feld3" value="Wert3"><input type="hidden" name="feld4" value="Wert4">
c2
- c3<input type="hidden" name="feld2" value="Rheinhessen">
- c4<input type="hidden" name="feld2" value="Rheinhessen">
+ c3<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ c4<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
c5
- c6<input type="hidden" name="feld2" value="Rheinhessen">
+ c6<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
<input type="text" name="feld3" value="Wert3">
<input type="text" name="feld4" value="Wert4">
d1
d2
- d3<input type="hidden" name="feld2" value="Rheinhessen">
- d4<input type="hidden" name="feld2" value="Rheinhessen">
+ d3<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ d4<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
d5
- d6<input type="hidden" name="feld2" value="Rheinhessen">
- d7<input type="hidden" name="feld2" value="Rheinhessen">
+ d6<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
+ d7<input type="hidden" name="feld2" value="Rhein"hessen"&Pfalz">
e1<input type="hidden" name="empty1" value=""><input type="hidden" name="empty2" value="">
1.3 +71 -5 embperl/test/cmp2/input.htm
Index: input.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp2/input.htm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- input.htm 22 Oct 2002 05:45:13 -0000 1.2
+++ input.htm 20 Nov 2002 06:56:28 -0000 1.3
@@ -15,8 +15,10 @@
<input name="feld5" value="Wert5">
<input name="feld1" value="Wert1">
<input name="feld5" value="Wert15">
- <input name="feld5a">
- <input name="feld5b">
+ <input name="feld5a" value="a"b">
+ <input name="feld5b" value="a'b&c">
+ <input name="feld5a" value="Wert4'y'r">
+ <input name="feld5b" value=""Wert5"">
<input name="feld1" value="">
<input name="feld5" value="">
<input type="text">
@@ -56,7 +58,7 @@
<input type="checkbox" name="dec" checked value="a & b">
- <input type="checkbox" name="dec" value="a & b">
+ <input type="checkbox" name="dec" checked value="a & b">
<textarea name="feld1"></textarea>
@@ -149,6 +151,30 @@
<option>Wert5\#\\'#''
</select>
+ <select name="feld5b">
+ <option value="1">1</option>
+ <option value="2">2</option>
+ <option value=""Wert5"" selected>3</option>
+ </select>
+
+ <select name="feld5b">
+ <option>Wert3'x</option>
+ <option>Wert4'y'r</option>
+ <option selected>"Wert5"</option>
+ <option>Wert3'x</option>
+ <option selected>"Wert5"</option>
+ <option>Wert3'x</option>
+ </select>
+
+ <select name="feld5b">
+ <option>Wert3'x
+ <option>Wert4'y'r
+ <option>"Wert5"
+ <option>Wert3'x
+ <option>"Wert5"
+ <option>Wert3'x
+ </select>
+
<select name="mult" multiple>
<option value="Wert1">Wert1</option>
<option value="Wert2">Wert2</option>
@@ -171,8 +197,32 @@
<option value="Wert8">Wert8</option>
</select>
+ <select name="escmult" multiple>
+ <option value="Wert1">Wert1</option>
+ <option value="Wert2">Wert2</option>
+ <option value="Wert3" selected>Wert3</option>
+ <option value="Wert4">Wert4</option>
+ <option value="Wert5">Wert5</option>
+ <option value="Wert6">Wert6</option>
+ <option value="Wert7">Wert7</option>
+ <option value="Wert8">Wert8</option>
+ <option value="a>b" selected>a>b</option>
+ </select>
+
+ <select name="escmult" multiple>
+ <option value="Wert1">Wert1</option>
+ <option value="Wert2">Wert2</option>
+ <option value="Wert3" selected>Wert3</option>
+ <option value="Wert4">Wert4</option>
+ <option value="Wert5">Wert5</option>
+ <option value="Wert6">Wert6</option>
+ <option value="Wert7">Wert7</option>
+ <option value="Wert8">Wert8</option>
+ <option value="a>b" selected>a>b</option>
+ </select>
+
- ks = cb1 cb2 cb5 cb6 cb7 cb8 dec feld1 feld2 feld3 feld4 feld5 feld5a feld6 feld7 feld8 mult neu1 neu2 neu3 undef<p>
+ ks = cb1 cb2 cb5 cb6 cb7 cb8 dec escmult feld1 feld2 feld3 feld4 feld5 feld5a feld5b feld6 feld7 feld8 mult neu1 neu2 neu3 undef<p>
<table border=9>
<tr>
@@ -204,6 +254,10 @@
</tr>
<tr>
+ <td>escmult</td><td>a>b</td>
+ </tr>
+
+ <tr>
<td>feld1</td><td>text1</td>
</tr>
@@ -228,6 +282,10 @@
</tr>
<tr>
+ <td>feld5b</td><td>"Wert5"</td>
+ </tr>
+
+ <tr>
<td>feld6</td><td>Wert6</td>
</tr>
@@ -475,7 +533,7 @@
<input type="text" name="feld1" value="">
<input type="text" name="feld1" value="">
</p>
- ks = cb1 cb2 cb5 cb6 cb7 cb8 dec feld1 feld2 feld3 feld4 feld5 feld5a feld6 feld7 feld8 mult neu1 neu2 neu3 ta undef<p>
+ ks = cb1 cb2 cb5 cb6 cb7 cb8 dec escmult feld1 feld2 feld3 feld4 feld5 feld5a feld5b feld6 feld7 feld8 mult neu1 neu2 neu3 ta undef<p>
<table border=10>
<tr>
@@ -507,6 +565,10 @@
</tr>
<tr>
+ <td>escmult</td><td>a>b</td>
+ </tr>
+
+ <tr>
<td>feld1</td><td></td>
</tr>
@@ -528,6 +590,10 @@
<tr>
<td>feld5a</td><td>Wert4'y'r</td>
+ </tr>
+
+ <tr>
+ <td>feld5b</td><td>"Wert5"</td>
</tr>
<tr>
1.2 +19 -0 embperl/test/html/errormismatch.htm
1.2 +23 -0 embperl/test/html/errormismatchcmd.htm
1.2 +7 -0 embperl/test/html/hostconfig.htm
1.2 +31 -0 embperl/test/html/mail.htm
1.2 +35 -0 embperl/test/html/mailformto.htm
1.2 +60 -0 embperl/test/html/app/i18n.htm
---------------------------------------------------------------------
To unsubscribe, e-mail: embperl-cvs-unsubscribe@perl.apache.org
For additional commands, e-mail: embperl-cvs-help@perl.apache.org