ApacheCon 2002
Gerald Richter
ecos gmbh
http://perl.apache.org/embperl/ or http://www.ecos.de/embperl/
+----------------------------------------------------------+ | base.epl | | +------------------------------------------------------+ | | | header.epl | | | +------------------------------------------------------+ | | | | +--------------+ +------------------------------------+ | | | menuleft.epl | | content.epl | | | | | | +-------------------+ +----------+ | | | | | | | * | | news.epl | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | +-------------------+ +----------+ | | | +--------------+ +------------------------------------+ | | | | +------------------------------------------------------+ | | | footer.epl | | | +------------------------------------------------------+ | +----------------------------------------------------------+
[-
$r = shift ;
$http_headers_out{'content-type'} = 'text/html' ;
-]
<html>
<head>
<title>Embperl</title>
<style type="text/css">
body {font-family: Geneva,Arial,Helvetica; font-size: 12px; }
table {font-family: Geneva,Arial,Helvetica; font-size: 12px; }
</style>
</head>
<body bgcolor="#ffffff">
[- Execute ('header.epl') -]
<table width="100%" cellspacing="0" cellpadding="0" border="0">
<tr>
<td>[- Execute ('menuleft.epl') -]</td>
<td width="2"> </td>
<td height="100%"><img src="/eg/images/frame.jpg" width="1" height="100%"></td>
<td width="10"> </td>
<td width="90%">[- Execute ('content.epl') -]</td>
<td width="2"> </td>
<td height="100%"><img src="/eg/images/frame.jpg" width="1" height="100%"></td>
<td width="10"> </td>
</tr>
</table>
[- Execute ('footer.htm') -]
</body>
</html>
<table width="100%" cellspacing="0" cellpadding="0" border="0">
<tr>
<td valign="top">
<br><br>
<font size="2" face="Verdana, Arial, Helvetica, sans-serif">
[- Execute ({'*') -]</td>
<td width="10"> </td>
<td height="100%"><img src="/eg/images/frame.jpg" width="1" height="100%"></td>
<td width="2"> </td>
<td align="left" width="152"><font size="2" face="Verdana, Arial, Helvetica, sans-serif">
[- Execute ('news.epl') -]
</td>
</tr>
</table>
Makes data about the request avaiable, like URI, HTTP-header, form data
Makes data about the component available, like filename, syntax, recipe
Brings together the data of a set of pages that forms an application. Like session handling, logging and configuration.
Application-File
|
v
Embperl::App
Requested page
|
v
Base template
|
v
Embperl::Req
sub init
{
my $self = shift ;
my $r = shift ;
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}) ;
$pf = map_file ($r) ;
$r -> param -> filename ($pf) ;
Execute ({inputfile => 'messages.pl', syntax => 'Perl'}) ;
return 0 ;
}
BEGIN
{
%messages = (
'de' =>
{
'Introduction' => 'Einführung',
'Documentation' => 'Dokumentation',
'Examples' => 'Beispiele',
'Changes' => 'Änderungen',
'Sites using Embperl' => 'Websites mit Embperl',
'Add info about Embperl' => 'Hinzufügen über Embperl',
}
) ;
@menu = (
{ menu => 'Home', uri => '', file => { en => 'eg/web/index.htm',
de => 'eg/web/indexD.htm'} },
{ menu => 'Features', uri => 'pod/Features.htm', file => 'Features.pod' },
{ menu => 'Introduction', uri => 'pod/intro/', sub =>
[
{ menu => 'Embperl', uri => 'Intro.htm', file => { en => 'Intro.pod',
'de' => 'IntroD.pod'}},
{ menu => 'Embperl::Object', uri => 'IntroEmbperlObject.htm', file => 'IntroEmbperlObject.pod'},
]
},
{ menu => 'Documentation', uri => 'pod/doc/', sub =>
[
{ menu => 'Embperl', uri => 'Embperl.htm', file => { en => 'Embperl.pod',
de => 'EmbperlD.pod'}},
{ menu => 'Embperl::Object', uri => 'EmbperlObject.htm', file => 'Embperl/Object.pm'},
{ menu => 'Embperl::Syntax', uri => 'EmbperlSyntax.htm', file => 'Embperl/Syntax.pm', sub =>
[
{ menu => 'Embperl', uri => 'Embperl.htm', file => 'Embperl/Syntax/Embperl.pm'},
{ menu => 'EmbperlBlocks', uri => 'EmbperlBlocks.htm', file => 'Embperl/Syntax/EmbperlBlks.pm'},
{ menu => 'EmbperlHTML', uri => 'EmbperlHTML.htm', file => 'Embperl/Syntax/EmbperlHTML.pm'},
{ menu => 'HTML', uri => 'HTML.htm', file => 'Embperl/Syntax/HTML.pm'},
{ menu => 'ASP', uri => 'ASP.htm', file => 'Embperl/Syntax/ASP.pm'},
{ menu => 'SSI', uri => 'SSI.htm', file => 'Embperl/Syntax/SSI.pm'},
{ menu => 'Perl', uri => 'Perl.htm', file => 'Embperl/Syntax/Perl.pm'},
{ menu => 'POD', uri => 'POD.htm', file => 'Embperl/Syntax/POD.pm'},
{ menu => 'Text', uri => 'Text.htm', file => 'Embperl/Syntax/Text.pm'},
{ menu => 'RTF', uri => 'RTF.htm', file => 'Embperl/Syntax/RTF.pm'},
{ menu => 'Mail', uri => 'Mail.htm', file => 'Embperl/Syntax/Mail.pm'},
],
},
{ menu => 'Embperl::Recipe', uri => 'EmbperlRecipe.htm', file => 'Embperl/Recipe.pm', sub =>
[
{ menu => 'Embperl', uri => 'Embperl.htm', file => 'Embperl/Recipe/Embperl.pm'},
{ menu => 'EmbperlXSLT', uri => 'EmbperlXSLT.htm', file => 'Embperl/Recipe/EmbperlXSLT.pm'},
{ menu => 'XSLT', uri => 'XSLT.htm', file => 'Embperl/Recipe/XSLT.pm'},
],
},
],
},
{ menu => 'Installation', uri => 'pod/INSTALL.htm', file => 'INSTALL.pod' },
{ menu => 'FAQ', uri => 'pod/Faq.htm', file => 'Faq.pod' },
{ menu => 'Tips & Tricks', uri => 'pod/TipsAndTricks.htm', file => 'TipsAndTricks.pod' },
{ menu => 'Examples', uri => 'examples/' },
{ menu => 'Changes', uri => 'pod/Changes.htm', file => 'Changes.pod' },
{ menu => 'Sites using Embperl', uri => 'pod/Sites.htm', file => 'Sites.pod' },
{ menu => 'News', uri => 'db/news/news.htm', file => 'eg/web/db/data.epd',
fdat => { 'category_id' => 1 } },
{ menu => 'Sites using Embperl', uri => 'db/sites/sites.htm', file => 'eg/web/db/data.epd',
fdat => { 'category_id' => 2 } },
{ menu => 'Add info about Embperl', uri => 'db/addsel.epl', same =>
[
{ menu => 'Select category', uri => 'db/add.epl' },
{ menu => 'Review added info', uri => 'db/show.epl'},
{ menu => 'Show info', uri => 'db/data.epd' },
],
},
) ;
} ;
sub new
{
my ($self, $r) = @_ ;
# The following two values must be changed to meet your local setup
# Additionaly DBI and DBIx::Recordset must be installed
$self -> {dbdsn} = $^O eq 'MSWin32'?'dbi:ODBC:embperl':'dbi:mysql:embperl' ;
$self -> {dbuser} = 'www' ;
$self -> {dbpassword} = undef ;
}
sub get_menu
{
my ($self, $r) = @_ ;
push @{$r -> messages}, $messages{$r -> param -> language} ;
return \@menu ;
}
[$ sub menuitem $]
[*
my ($url, $txt, $state, $tablebg, $ndx) = @_ ;
*]
<tr>
<td [$if $tablebg $]background="[+ $r -> {imageuri} +]/hintergrund-nav.gif"[$endif$]>
<table width="152" border="0" cellspacing="0" cellpadding="0">
<tr>
<td nowrap align=left width=[+ $ndx * 15 + 2 +]>
<img = src="[+ $r -> {imageuri} +]/transp.gif" width="1"></td>
<td nowrap align=left width=15>
<img src="[+ $r -> {imageuri} +]/i-sub-[+ $state>1?($state>2?'on':'open'):'off'
+].gif" width="11" height="11" vspace="6" hspace="5"></td>
<td nowrap align=left>
<a href="[+ $url +]"><b>[+ $r -> gettext ($txt) +]</a></b></td>
</tr>
</table>
</td>
</tr>
[$ endsub $]
[$ sub menu $]
[*
my ($menu, $ndx, $top) = @_ ;
*]
[$ foreach my $item (@{$menu}) $]
[-
if ( $r -> {menuitems}[$ndx] eq $item)
{
menuitem ($item -> {url}, $item -> {menu}, $r -> {menuitems}[$ndx+1]?2:3, $top, $ndx) ;
menu ($item -> {sub}, $ndx + 1, 0) if ($item -> {sub}) ;
}
else
{
menuitem ($item -> {url}, $item -> {menu}, 0, $top, $ndx) ;
}
-]
<tr>
<td><img src="/eg/images/linie-nav.gif" width="152" height="1"></td>
</tr>
[$endforeach $]
[$ endsub $]
[-
$r = shift ;
-]
<table width="152" border="0" cellspacing="0" cellpadding="0">
<tr>
<td><img src="/eg/images/h_content.gif" width="152" height="19"></td>
</tr>
<tr>
<td> </td>
</tr>
[- menu ($r -> {menu} , 0, 1) -]
<tr>
<td> </td>
</tr>
<tr>
<td><img src="/eg/images/h_current-v.gif" width="152" height="19"></td>
</tr>
<tr>
<td> </td>
</tr>
<tr>
<td><img src="/eg/images/linie-nav.gif" width="152" height="1"></td>
</tr>
<tr>
<td bgcolor="#D2E9F5"><b> Stable
1.3.4</b></td>
</tr>
<tr>
<td><img src="/eg/images/linie-nav.gif" width="152" height="1"></td>
</tr>
<tr>
<td><img src="/eg/images/transp.gif" width="152" height="5"></td>
</tr>
<tr>
<td><img src="/eg/images/linie-nav.gif" width="152" height="1"></td>
</tr>
<tr>
<td bgcolor="#D2E9F5"><b>
Beta 2.0b8</b></td>
</tr>
<tr>
<td><img src="/eg/images/linie-nav.gif" width="152" height="1"></td>
</tr>
</table>
[-
use DBIx::Recordset ;
$r = shift ;
*set = DBIx::Recordset -> Search ({'!DataSource' => $r -> {dbdsn},
'!Username' => $r -> {dbuser},
'!Password' => $r -> {dbpassword},
'!DBIAttr' => { RaiseError => 1, PrintError => 1,
LongReadLen => 32765, LongTruncOk => 0, },
'!Table' => 'item, itemtext',
'!TabRelation' => 'item_id = item.id',
'!Order' => 'creationtime desc',
'language_id' => $r -> param -> language,
'category_id' => 1,
'$max' => 15}) ;
-]
<table width="252" border="0" cellspacing="0" cellpadding="0">
<tr>
<td><img src="[+ $r -> {imageuri} +]/h_news.gif" width="152" height="19"/></td>
</tr>
<tr>
<td> </td>
</tr>
<tr>
<td>
[$while ($rec = $set -> Next)$]
<table width="100%" border="0" cellspacing="0" cellpadding="0">
<tr>
<td bgcolor="#327EA7"><font size="1" face="Verdana, Arial, Helvetica, sans-serif"><b>
<font color="#FFFFFF">
[+ $rec -> {heading} +]
</font></b></font></td>
</tr>
<tr>
<td bgcolor="#C2D9E5"><img src="[+ $r -> {imageuri} +]/linie-news.gif" width="152" height="4"/></td>
</tr>
<tr>
<td bgcolor="#D2E9F5">
<table width="100%" border="0" cellspacing="0" cellpadding="3">
<tr>
<td><font size="1" face="Verdana, Arial, Helvetica, sans-serif">
[-
$txt = $rec -> {description} ;
$txt =~ s#<#<#g ;
$txt =~ s#>#>#g ;
$txt =~ s#B<(.*?)>#<B>$1</B>#g ;
$txt =~ s#(http://[-a-zA-Z.]+)#<A HREF="$1">$1</A>#g ;
-]
[+ do { local $escmode = 0 ; $txt } +]
</font></td>
</tr>
</table>
</td>
</tr>
</table>
[$endwhile $]
</td>
</tr>
</table>
Examples: Embperl, ASP, SSI, Perl, Text, POD, RTF
=head1 NAME
Embperl
=head1 Description
Here we have some text
will become
<pod>
<head>
<title>Embperl</title>
</head>
<sect1>
<para>
Here we have some text
</para>
</sect1>
</pod>
This basicly generates the same XML as Pod::XML
[- Execute ({inputfile => '*'}) -]
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) ;
}
use DBIx::Recordset ;
BEGIN { Execute ({isa => '../epwebapp.pl'}) ; }
sub init
{
my $self = shift ;
my $r = shift ;
$self -> SUPER::init ($r) ;
$self -> initdb ($r) ;
my $db = $r -> {db} ;
$r -> {language_set} = DBIx::Recordset -> Search ({'!DataSource' => $db,
'!Table' => 'language'}) ;
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 ;
}
# ----------------------------------------------------------------------------
sub initdb
{
my $self = shift ;
my $r = shift ;
$DBIx::Recordset::Debug = 2 ;
*DBIx::Recordset::LOG = \*STDERR ;
my $db = DBIx::Database -> new ({'!DataSource' => $r -> {dbdsn},
'!Username' => $r -> {dbuser},
'!Password' => $r -> {dbpassword},
'!DBIAttr' => { RaiseError => 1, PrintError => 1,
LongReadLen => 32765, LongTruncOk => 0, },
}) ;
$db -> TableAttr ('*', '!SeqClass', "DBIx::Recordset::FileSeq,$r->{root}/db") if ($^O eq 'MSWin32') ;
$db -> TableAttr ('*', '!Filter',
{
'creationtime' => [\¤t_time, undef, DBIx::Recordset::rqINSERT ],
'modtime' => [\¤t_time, undef, DBIx::Recordset::rqINSERT + DBIx::Recordset::rqUPDATE ],
}) ;
$r -> {db} = $db ;
}
# ----------------------------------------------------------------------------
sub current_time
{
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime(time);
$mon++ ;
$year += 1900 ;
return "$year-$mon-$mday $hour:$min:$sec" ;
}
# ----------------------------------------------------------------------------
sub add_category
{
my $self = shift ;
my $r = shift ;
my $set = DBIx::Recordset -> Insert ({'!DataSource' => $r -> {db},
'!Table' => 'category',
'!Serial' => 'id',
state => 0}) ;
my $id = $$set -> LastSerial ;
my $langset = $r -> {language_set} ;
my $txtset = DBIx::Recordset -> Setup ({'!DataSource' => $r -> {db},
'!Table' => 'categorytext'}) ;
$$langset -> Reset ;
while ($rec = $$langset -> Next)
{
$$txtset -> Insert ({category_id => $id,
language_id => $rec->{id},
category => $fdat{"category_$rec->{id}"}}) if ($fdat{"category_$rec->{id}"}) ;
delete $fdat{"category_$rec->{id}"} ;
}
}
# ----------------------------------------------------------------------------
sub add_item
{
my $self = shift ;
my $r = shift ;
my $set = DBIx::Recordset -> Insert ({'!DataSource' => $r -> {db},
'!Table' => 'item',
'!Serial' => 'id',
url => $fdat{url},
category_id => $fdat{category_id},
state => 0}) ;
my $id = $$set -> LastSerial ;
my $langset = $r -> {language_set} ;
my $txtset = DBIx::Recordset -> Setup ({'!DataSource' => $r -> {db},
'!Table' => 'itemtext'}) ;
$$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{item_id} = $id ;
}
# ----------------------------------------------------------------------------
sub get_category
{
my $self = shift ;
my $r = shift ;
$r -> {category_set} = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
'!Table' => 'category, categorytext',
'!TabRelation' => 'category_id = category.id',
'language_id' => $r -> param -> language,
$fdat{category_id}?(category_id => $fdat{category_id}):()}) ;
}
# ----------------------------------------------------------------------------
sub get_item
{
my $self = shift ;
my $r = shift ;
$r -> {item_set} = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
'!Table' => 'item, itemtext',
'!TabRelation' => 'item_id = item.id',
'language_id' => $r -> param -> language,
$fdat{category_id}?(category_id => $fdat{category_id}):(),
$fdat{item_id}?(item_id => $fdat{item_id}):()}) ;
}
# ----------------------------------------------------------------------------
sub get_item_lang
{
my $self = shift ;
my $r = shift ;
$r -> {item_set} = DBIx::Recordset -> Search ({'!DataSource' => $r -> {db},
'!Table' => 'item, itemtext, language',
'!TabRelation' => 'item_id = item.id and language_id = language.id',
$fdat{category_id}?(category_id => $fdat{category_id}):(),
$fdat{item_id}?(item_id => $fdat{item_id}):()}) ;
}
[- $r = shift -]
[= addsel1 =]
<ul>
<li>
[- $rec = $r -> {category_set}[$row] -]
<a href="add.epl?category_id=[+ $rec -> {category_id} +]">[+ $rec -> {category} +]</a>
</li>
</ul>
<form action="[+ $r -> param -> uri +]">
[= addsel2 =]<br>
[= addsel3 =]<br><br>
<table>
<tr>
[- $rec = $r -> {language_set}[$row] -]
<td>[+ $rec -> {name} +]:</td><td><input type="text" name="category_[+ $rec -> {id} +]" size=80></td>
</tr>
</table>
<br><br>
<input type="submit" name="-add_category" value="[=addsel4=]">
</form>
$r = shift ;
%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 ein.',
'addsel3' => 'Falls Sie die Übersetzung nicht wissen, lassen Sie das entsprechende Eingabefeld leer.',
'addsel4' => 'Kategorie hinzufügen',
'add1' => 'Hinzufügen eines neuen Eintrages zu',
'add2' => 'Bitte geben Sie die Beschreibung in so vielen Sprachen wie Ihnen möglich ein.',
'add3' => 'Hinzufügen zu',
'heading' => 'Überschrift',
'url' => 'URL',
'description' => 'Beschreibung',
'show2' => 'Folgender Eintrag wurde erfolgreich der Datenbank hinzugefügt',
},
'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',
'add1' => 'Add a new item to',
'add2' => 'Please enter the description in as much languages as possible.',
'add3' => 'Add to',
'heading' => 'Heading',
'url' => 'URL',
'description' => 'Description',
'show2' => 'The following entry has been sucessfully added to the database',
},
) ;
$lang = $r -> param -> language ;
push @{$r -> messages}, $messages{$lang} ;
push @{$r -> default_messages}, $messages{'en'} if ($lang ne 'en') ;
gettext('foo') to get the matching text