/[clipping]/bin/clipping.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /bin/clipping.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Fri Jan 16 22:46:52 2004 UTC (20 years, 2 months ago) by dpavlin
Branch: MAIN, phperl
CVS Tags: r20040116, HEAD
Changes since 1.1: +0 -0 lines
File MIME type: text/plain
initial import of downloaded version

1 #!/usr/bin/perl -w
2
3 # Project: Clipping
4 # Author: Nelson Ferraz <nferraz@phperl.com>
5 # Date: 2003-08-14
6
7 use strict;
8
9 use vars qw( %conf %action %event
10 $conn $cgi $in $out $template $source $result
11 );
12
13 # TO-DO: use the following modules
14 # use Apache::RequestNotes; # Access to Cookie and Form Data
15 # use Apache::Session; # Maintain session state
16 # use Apache::DBI; # Initiate a persistent database connection
17
18 # Meanwhile: use the following ones
19 use CGI ':cgi-lib'; # Request form data
20 use Template; # Template Toolkit
21 use Pg; # PostgreSQL
22
23 # Stop this kind of warning
24 $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /Use of uninitialized value/ };
25
26 # autoflush (disable output buffering)
27 $|=1;
28
29 # import form fields
30 $cgi = new CGI;
31 $in = $cgi->Vars;
32
33 # template
34 $template = Template->new({ INCLUDE_PATH => '../templates' }); # FIXME: use absolute path?
35
36 # variable 'script_name' contains the complete URL
37 my $SERVER_PORT = ":$ENV{SERVER_PORT}" if $ENV{SERVER_PORT} <=> 80;
38 $out->{'script_name'} = ($ENV{HTTPS}!~/ON/i?'http':'https')."://$ENV{SERVER_NAME}$SERVER_PORT$ENV{SCRIPT_NAME}";
39
40 eval {
41 # configuration
42 do 'clipping.pm';
43 die "Error in clipping.pm:\n'$@'" if $@;
44
45 # database connection (in clipping.pm)
46 $conn = Pg::connectdb($conf{db});
47
48 &Main;
49 };
50
51 if ($@) { # error handling
52 #$out->{'error'} = "$@";
53 #template->process ("error.tt2", $out);
54 print "Content-type: text/plain\n\n";
55 print $@;
56 }
57
58 exit;
59
60 #######
61
62 sub Main {
63 # copy input ($in) to output ($out)
64 foreach my $key (keys %{$in}) {
65 $out->{$key} = $in->{$key};
66 }
67
68 # Do action(s)
69 my @action = split (/\+/, $in->{'action'});
70 &Do_action ($_) foreach (@action);
71
72 # Print template(s)
73 $in->{'template'} ||= 'pg_sel_c_customer'; # 'menu';
74 my @template = split (/\+/, $in->{'template'});
75 &Print_template ($_) foreach (@template);
76 }
77
78 #######
79
80 sub Do_action {
81 my $action = shift;
82
83 # verify actions (from clipping.conf)
84 if (defined $action{$action}) {
85 # Do it!
86 eval ($action{$action});
87 if ($@) { # Exception
88 die "Error in action '$action':\n'$@'";
89 }
90 } else {
91 die "Invalid action '$action'.\n";
92 }
93
94 return;
95 }
96
97 #######
98
99 sub Print_template {
100 my $filename = shift; # template name, without extension
101
102 my ($clean_filename);
103 if ($filename =~ /^(\w+)$/) {
104 $clean_filename = $1;
105 } else {
106 die "Invalid characters in template name '$filename'.\n";
107 }
108
109 # Event(s)
110 if (defined $event{"before_$clean_filename"}) {
111 eval($event{"before_$clean_filename"});
112 if ($@) {
113 die "Error in event before_$clean_filename:\n'$@'";
114 }
115 }
116
117 $template->process ("$clean_filename.tt2",$out,\$result) or die $template->error();
118
119 eval { &beforePrint }; # useful to change $result before printing
120 if ($@) {
121 die "Error in event beforePrint:\n'$@'";
122 }
123
124 print "Content-type: text/html\n\n";
125 print $result;
126 }
127
128 ###
129
130 sub beforePrint {
131 return if $in->{'template'} !~ /^pg_(sel|detail)_/;
132
133 # Wikify
134 while ($result =~ /(\[\[.+?\]\])/g) {
135 my $wiki_word = $1;
136 my ($label) = $wiki_word =~ /\[\[(.+?)\]\]/;
137 my $new_link = "<a href=\"$out->{'script_name'}?template=pg_sel_wiki&wiki_titulo=$label\">$label</a>";
138 $result =~ s/\Q$wiki_word\E/$new_link/;
139 }
140
141 # Squeeze multiple blank lines
142 undef $/;
143 $result =~ s/\s*\n+/\n/g;
144 }
145
146 __END__
147
148 Clipping - Copyright 2003 PhPerl.com
149
150 This program is free software; you can redistribute it and/or
151 modify it under the terms of the GNU General Public License
152 as published by the Free Software Foundation; either version 2
153 of the License, or (at your option) any later version.
154
155 This program is distributed in the hope that it will be useful,
156 but WITHOUT ANY WARRANTY; without even the implied warranty of
157 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
158
159 See the GNU General Public License for more details:
160
161 http://www.gnu.org/copyleft/gpl.html

  ViewVC Help
Powered by ViewVC 1.1.26