Skip to content

Commit 2f8636a

Browse files
iellenbergeriellenberger
committed
Merged Puma from Sourceforge's iTools
Converted Puma to work with the lastest version of iTools, Perl, et al.
1 parent a550be8 commit 2f8636a

40 files changed

+4240
-0
lines changed

‎etc/apache2/mods-available/puma.conf

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
#
2+
# Puma is an HTML rendering engine that allows you to embed Perl
3+
# into your HTML pages, PHP style.
4+
#
5+
# Adjust these to your environment and for your preference.
6+
# Changing the extension is advisable as it provides you an extra
7+
# layer of security through obscurity.
8+
#
9+
10+
# --- set the application type, cgi location and file extension ---
11+
Action application/x-httpd-puma /cgi-bin/puma2.cgi
12+
AddType application/x-httpd-puma .puma
13+
14+
# --- allow index.puma as a directory index ---
15+
DirectoryIndex index.puma

‎etc/puma/puma.xml

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
<?xml version="1.0" encoding="UTF-8"?>
2+
<puma>
3+
<config cascade="on" file=".puma" />
4+
5+
<!-- browser session cookie -->
6+
<cookie name="Global" />
7+
<session context="session" location="/ITOOLS_ROOT/var/state/puma/session" preload="true"
8+
cookie="Global" module="Puma::Object::Session" prefix="session" />
9+
10+
<!-- user cookie, expires 30 days after last access -->
11+
<cookie name="Global30d" expires="+30d" />
12+
<session context="user" location="/ITOOLS_ROOT/var/state/puma/user" preload="true"
13+
cookie="Global30d" module="Puma::Object::User" prefix="user" />
14+
15+
</puma>

‎lib/perl5/Puma.pm

Lines changed: 115 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,115 @@
1+
package Puma;
2+
use base 'Puma::Object::Tag';
3+
4+
use Puma::Core::Engine;
5+
use Puma::Core::Server;
6+
use Puma::Tools::Capture qw(capture);
7+
8+
use strict;
9+
use warnings;
10+
11+
# === Constructor ===========================================================
12+
sub new {
13+
my ($this, %args) = @_;
14+
my $self = bless {}, ref $this || $this;
15+
16+
# --- parse incoming parameters ---
17+
while (my ($key, $value) = each %args) {
18+
lc $key eq 'server' && $self->server($value);
19+
}
20+
21+
return $self;
22+
}
23+
24+
# === Rendering Methods =====================================================
25+
sub include {
26+
my ($self, %args) = @_;
27+
my $retval = $self->render(%args, showHeader => '0');
28+
print $self->html;
29+
return $retval;
30+
}
31+
32+
sub render {
33+
my ($self, %args) = @_;
34+
35+
# --- parse incoming parameters ---
36+
while (my ($key, $value) = each %args) {
37+
lc $key eq 'server' && $self->server($value);
38+
lc $key eq 'file' && $self->file($value);
39+
lc $key eq 'showHeader' && $self->showHeader($value);
40+
}
41+
42+
# --- declare variables in this scope ---
43+
my ($server, $code, @errors);
44+
my $html = '';
45+
46+
# --- generate code from the .puma source ---
47+
my $startup = capture {
48+
# --- capture SIGWARN messages ---
49+
local $SIG{__WARN__} = sub { push @errors, $_[0] };
50+
51+
# --- create the server object (CGI) ---
52+
$server = new Puma::Core::Server(Puma => $self);
53+
54+
# --- parse and codify ---
55+
my $engine = new Puma::Core::Engine(File => $self->file);
56+
$code = $server->getStartCode . $engine->render . $server->getEndCode;
57+
};
58+
# --- capture error messages ---
59+
push @errors, $@ if $@;
60+
push @errors, $startup if $startup;
61+
62+
# --- generate output from the code ---
63+
my $output = capture {
64+
# --- capture SIGWARN messages ---
65+
local $SIG{__WARN__} = sub { push @errors, $_[0] };
66+
eval($code);
67+
};
68+
# --- capture error messages, ignore 'SAFE' die messages ---
69+
push @errors, $@ if $@ && !( $@ =~ /^SAFE/);
70+
71+
# === ERRORS!! ===
72+
if (@errors) {
73+
# --- stop any redirects before spitting out the header ---
74+
$server->redirect('');
75+
$html .= $server->header if $self->showHeader;
76+
77+
# --- show the errors ---
78+
$html .= "<pre>Puma Server Pages Error : ";
79+
foreach my $err (@errors) { $html .= "\n$err"; }
80+
$html .= "</pre><hr>\n";
81+
$html .= "<code>". $server->header ."</code><br><hr>";
82+
83+
# --- add line numbers to the code and display it ---
84+
my $lcode;
85+
my @lines = split /\n/, $code;
86+
my $linenumber = 1;
87+
foreach my $line (@lines) {
88+
$line =~ s/</&lt;/g;
89+
$lcode .= $linenumber++ .": $line\n";
90+
}
91+
$html .= "<pre><code>$lcode</code></pre>\n";
92+
93+
$self->html($html);
94+
95+
return -1;
96+
}
97+
98+
# === Clean Run ===
99+
# --- spit out the header ---
100+
$html .= $server->header if $self->showHeader;
101+
# --- spit out the page unless there was a redirect ---
102+
$html .= $output ."\n" unless $server->redirect;
103+
$self->html($html);
104+
}
105+
106+
# === Accessors =============================================================
107+
# --- value accessors ---
108+
sub file { defined $_[1] ? $_[0]->{_file} = $_[1] : $_[0]->{_file} || $ENV{PATH_TRANSLATED} }
109+
sub html { defined $_[1] ? $_[0]->{_html} = $_[1] : $_[0]->{_html} }
110+
sub showHeader { defined $_[1] ? $_[0]->{_showHeader} = $_[1] : $_[0]->{_showHeader} || 1 }
111+
112+
# --- object accessors ---
113+
sub server { defined $_[1] ? $_[0]->{_server} = $_[1] : $_[0]->{_server} }
114+
115+
1;

‎lib/perl5/Puma/Cookie/Session.pm

Lines changed: 96 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,96 @@
1+
package Puma::Cookie::Session;
2+
use base Puma::Object::Serial;
3+
4+
use Storable qw( dclone );
5+
6+
use strict;
7+
use warnings;
8+
9+
# === Constructor ===========================================================
10+
# --- empty constructor for convenience ---
11+
sub new {
12+
my ($this, %args) = @_;
13+
my $self = bless {}, ref($this) || $this;
14+
15+
# --- get params ---
16+
while (my ($key, $value) = each %args) {
17+
lc $key eq 'location' && $self->location($value);
18+
lc $key eq 'cookie' && $self->cookie($value);
19+
lc $key eq 'context' && $self->context($value);
20+
lc $key eq 'server' && $self->server($value);
21+
}
22+
23+
# --- get the cookie's UID ---
24+
$self->uid($self->server->getCookie($self->cookie)->value)
25+
if defined $self->server && defined $self->cookie;
26+
27+
# --- unserialize the object if it exists and return it ---
28+
return $self->load;
29+
}
30+
31+
# === Accessors =============================================================
32+
# --- fields hidden from serialization ---
33+
sub hidden { defined $_[1] ? $_[0]->{_hide} = $_[1] : $_[0]->{_hide} }
34+
sub cookie { defined $_[1] ? $_[0]->{_hide}->{cookie} = $_[1] : $_[0]->{_hide}->{cookie} }
35+
sub context { defined $_[1] ? $_[0]->{_hide}->{context} = $_[1] : $_[0]->{_hide}->{context} }
36+
sub location { defined $_[1] ? $_[0]->{_hide}->{location} = $_[1] : $_[0]->{_hide}->{location} }
37+
sub server { defined $_[1] ? $_[0]->{_hide}->{server} = $_[1] : $_[0]->{_hide}->{server} }
38+
sub uid { defined $_[1] ? $_[0]->{_hide}->{uid} = $_[1] : $_[0]->{_hide}->{uid} }
39+
40+
# --- generate the filename for the serialized object ---
41+
sub filename {
42+
my $self = shift;
43+
my $filename = $self->location .'/'. $self->context .'.'. $self->uid;
44+
$filename =~ s|/+|/|g; # trim multiple '/'s
45+
return $filename;
46+
}
47+
48+
sub load {
49+
my $self = shift;
50+
my $file = shift || $self->filename;
51+
if (-e $file) {
52+
my $hidden = $self->hidden; # store hidden fields
53+
$self = $self->unserialize($file); # reload self from file
54+
$self->hidden($hidden); # restore hidden fields
55+
}
56+
return $self;
57+
}
58+
59+
sub save {
60+
my $self = shift;
61+
my $file = shift || $self->filename;
62+
$self->serialize($file);
63+
}
64+
65+
66+
67+
68+
69+
70+
71+
72+
# === Method Extended from Puma::Object::Serial =============================
73+
# --- make a clone of self and remove all data we don't want to serialize ---
74+
sub serial {
75+
my $self = dclone(shift);
76+
delete $self->{_hide};
77+
return $self;
78+
}
79+
80+
1;
81+
82+
__END__
83+
84+
sub construct {
85+
my ($self, %args) = @_;
86+
87+
$args{UID} = $args{Server}->getCookie($args{UseCookie})->value()
88+
if exists $args{Server} && defined $args{Server} &&
89+
exists $args{UseCookie} && defined $args{UseCookie};
90+
91+
%args = $self->SUPER::construct(%args);
92+
93+
$self->load();
94+
95+
return %args;
96+
}

‎lib/perl5/Puma/Cookie/User.pm

Lines changed: 89 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,89 @@
1+
package Puma::Cookie::User;
2+
use base Puma::Cookie::Session;
3+
4+
# --- test whether this user is known ---
5+
sub isKnown {
6+
my $self = shift;
7+
$self->expandKnown;
8+
9+
# --- fail if all fields do not exist ---
10+
return 0 unless
11+
exists $self->{FullName} && $self->{FullName} &&
12+
exists $self->{FirstName} && $self->{FirstName} &&
13+
exists $self->{LastName} && $self->{LastName} &&
14+
exists $self->{EMail} && $self->{EMail} &&
15+
exists $self->{Login} && $self->{Login};
16+
17+
# --- everything's OK ---
18+
return 1;
19+
}
20+
21+
# --- expand known fields to fill unknown fields ---
22+
sub expandKnown {
23+
my $self = shift;
24+
25+
# --- if we have a FullName, split it into first and last names ---
26+
if (exists $self->{FullName} && defined $self->{FullName}) {
27+
$self->{FirstName} = ($self->{FullName} =~ /^(\S*)\s/)[0] || ''
28+
unless defined $self->{FirstName};
29+
$self->{LastName} = ($self->{FullName} =~ /\s(\S*)$/)[0] || ''
30+
unless defined $self->{LastName};
31+
}
32+
33+
# --- extract the Login name from the EMail address ---
34+
if (exists $self->{EMail} && defined $self->{EMail}) {
35+
$self->{Login} = ($self->{EMail} =~ /^([^@]*)/)[0] || ''
36+
unless defined $self->{Login};
37+
}
38+
}
39+
40+
1;
41+
42+
43+
=copyright
44+
45+
Puma - Perl Universal Markup
46+
Copyright (c) 2001, 2002 by Ingmar Ellenberger.
47+
48+
Distributed under The Artistic License. For the text of this license,
49+
see http://puma.site42.com/license.psp or read the file LICENSE in the
50+
root of the distribution.
51+
52+
=description
53+
54+
The Stateful User Object
55+
56+
This package is an extension of the Session object and provides a number
57+
of methods for user management and verification.
58+
59+
To implement this object, an entry similar to the following must be added to
60+
the config.xml:
61+
62+
<puma>
63+
<serverpages ... >
64+
<cookie name="Global30d" expires="+30d"/>
65+
<session Context="user" Location="state" UseCookie="Global30d"
66+
module="Puma::ServerPages::User" prefix="user"/>
67+
...
68+
</serverpages>
69+
...
70+
</puma>
71+
72+
This example shows a user object (named $user) that maintains state for 30
73+
days from the last access.
74+
75+
=cut
76+
77+
78+
=Known Users ================================================================
79+
80+
A known user whose full name and e-mail address are stored in this
81+
object.
82+
83+
The FullName and EMail fields are required.
84+
If FirstName, LastName and Login are not given, an attempt to set these
85+
values will be made by the expandKnown() method.
86+
87+
=cut
88+
89+

0 commit comments

Comments
 (0)