ref-changes: implement "done" functionality
[girocco.git] / Girocco / CGI.pm
blobcffd02a66b7fd9696afc4b289f223273e163b5de
1 package Girocco::CGI;
3 use strict;
4 use warnings;
6 use Girocco::Config;
7 use Girocco::Util;
9 BEGIN {
10 our $VERSION = '0.1';
11 our @ISA = qw(Exporter);
12 our @EXPORT = qw(html_esc);
14 use CGI qw(:standard :escapeHTML -nosticky);
15 use CGI::Util qw(unescape);
16 use CGI::Carp qw(fatalsToBrowser);
17 eval 'sub CGI::multi_param {CGI::param(@_)}'
18 unless CGI->can("multi_param");
21 my @_randlens;
22 my @_randchars;
23 BEGIN {
24 @_randlens = (
25 # the prime numbers >= 1024 and < 2048
26 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, 1087, 1091, 1093, 1097, 1103,
27 1109, 1117, 1123, 1129, 1151, 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213,
28 1217, 1223, 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, 1297,
29 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, 1381, 1399, 1409, 1423,
30 1427, 1429, 1433, 1439, 1447, 1451, 1453, 1459, 1471, 1481, 1483, 1487, 1489,
31 1493, 1499, 1511, 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583,
32 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, 1663, 1667, 1669,
33 1693, 1697, 1699, 1709, 1721, 1723, 1733, 1741, 1747, 1753, 1759, 1777, 1783,
34 1787, 1789, 1801, 1811, 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879,
35 1889, 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987, 1993, 1997,
36 1999, 2003, 2011, 2017, 2027, 2029, 2039
38 @_randchars = (
39 # IMPORTANT: The '-' MUST be the last character in the array so we can
40 # use one less than the array length to randomly replace the second '-'
41 # in any generated '--' sequence.
42 9, 10, 13, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 46, 47, 48, 49,
43 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
44 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89,
45 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107,
46 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123,
47 124, 125, 126, 45 # '-' (45/0x2D) MUST be last
51 sub _randpad {
52 # return 1K - 2K of random padding that is a random length which
53 # happens to be prime and is suitable for inclusion as an XHTML comment
54 # (the comment delimiters are NOT added)
55 use bytes;
56 my $len = $_randlens[int(rand(@_randlens))];
57 my $ccnt = @_randchars;
58 my $str = '';
59 for (my $i=1; $i<$len; ++$i) {
60 $str .= chr($_randchars[int(rand($ccnt))]);
62 $str =~ s/--/'-'.chr($_randchars[int(rand($ccnt-1))])/gse;
63 return $str;
66 sub _vulnpad {
67 # Return suitably commented vulnerability mitigation padding if applicable
69 # If https is enabled (HTTPS == "on") attempt to avoid the compression
70 # vulnerability as described in VU#987798/CVE-2013-3587 (aka BREACH).
71 # This only need be done for POST requests as nothing else has sensitive data.
72 # See http://www.kb.cert.org/vuls/id/987798 for further information.
74 my $vulnrandpad = "";
75 if (($ENV{'HTTPS'} && lc($ENV{'HTTPS'}) eq 'on') &&
76 ($ENV{'REQUEST_METHOD'} && lc($ENV{'REQUEST_METHOD'}) eq 'post')) {
77 # Add some random padding to mitigate the vulnerability
78 $vulnrandpad = "<!-- Mitigate VU#987798/CVE-2013-3587 with random padding -->\n";
79 $vulnrandpad .= "<!-- " . _randpad . " -->\n";
81 return $vulnrandpad;
84 sub new {
85 my $class = shift;
86 my ($heading, $section, $extraheadhtml, $sectionlink) = @_;
87 my $gcgi = {};
88 my $vulnrandpad = _vulnpad;
90 $heading = CGI::escapeHTML($heading || '');
91 $section = CGI::escapeHTML($section || 'administration');
92 $section = "<a href=\"$sectionlink\">$section</a>" if $sectionlink;
93 # $extraheadhtml is optional RAW html code to include, DO NOT escapeHTML it!
94 $extraheadhtml = $extraheadhtml || '';
95 my $name = CGI::escapeHTML($Girocco::Config::name || '');
97 $gcgi->{cgi} = CGI->new;
99 my $cgiurl = $gcgi->{cgi}->url(-absolute => 1);
100 ($gcgi->{srcname}) = ($cgiurl =~ m#^.*/\([a-zA-Z0-9_.\/-]+?\.cgi\)$#); #
101 $gcgi->{srcname} = "cgi/".$gcgi->{srcname} if $gcgi->{srcname};
103 print $gcgi->{cgi}->header(-type=>'text/html', -charset => 'utf-8');
105 print <<EOT;
106 <?xml version="1.0" encoding="utf-8"?>
107 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
108 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US" lang="en-US">
110 <head>
111 <title>$name :: $heading</title>
112 <link rel="stylesheet" type="text/css" href="@{[url_path($Girocco::Config::gitwebfiles)]}/gitweb.css"/>
113 <link rel="stylesheet" type="text/css" href="@{[url_path($Girocco::Config::gitwebfiles)]}/girocco.css"/>
114 <link rel="shortcut icon" href="@{[url_path($Girocco::Config::gitwebfiles)]}/git-favicon.png" type="image/png"/>
115 <script src="@{[url_path($Girocco::Config::gitwebfiles)]}/mootools.js" type="text/javascript"></script>
116 <script src="@{[url_path($Girocco::Config::gitwebfiles)]}/girocco.js" type="text/javascript"></script>
117 $extraheadhtml$vulnrandpad</head>
119 <body>
121 <div class="page_header">
122 <a href="http://git-scm.com/" title="Git homepage"><img src="@{[url_path($Girocco::Config::gitwebfiles)]}/git-logo.png" width="72" height="27" alt="git" style="float:right; border-width:0px;"/></a>
123 <a href="@{[url_path($Girocco::Config::gitweburl,1)]}">$name</a> / $section / $heading
124 </div>
128 bless $gcgi, $class;
131 sub DESTROY {
132 my $self = shift;
133 my $vulnrandpad = _vulnpad;
134 if ($self->{srcname} and $Girocco::Config::giroccourl) {
135 my $hb = $Girocco::Config::giroccobranch ?
136 "hb=$Girocco::Config::giroccobranch;" : "";
137 print <<EOT;
138 <div align="right">
139 <a href="@{[url_path($Girocco::Config::giroccourl)]}?a=blob;${hb}f=$self->{srcname}">(view source)</a>
140 </div>
143 print <<EOT;
144 </body>
145 $vulnrandpad</html>
149 sub cgi {
150 my $self = shift;
151 $self->{cgi};
154 # return previous value of $self->{errprelude}
155 # if at least one argument is given, then set $self->{errprelude} to the first arg
156 # if $self->{errprelude} is non-empty at the time the first err call happens then
157 # $self->{errprelude} will be output just before the first error message
158 sub err_prelude {
159 my $self = shift;
160 my $result = $self->{errprelude};
161 $self->{errprelude} = $_[0] if @_ >= 1;
162 return $result;
165 sub err {
166 my $self = shift;
167 print $self->{errprelude} if !$self->{err} && defined($self->{errprelude});
168 print "<p style=\"color: #c00000; word-wrap: break-word\">@_</p>\n";
169 $self->{err}++;
172 sub ok {
173 my $self = shift;
174 my $err = $self->{err}||0;
175 return $err == 0;
178 sub err_check {
179 my $self = shift;
180 my $err = $self->{err}||0;
181 my $s = $err == 1 ? '' : 's';
182 $err and print "<p style=\"font-weight: bold\">Operation aborted due to $err error$s.</p>\n";
183 $err;
186 sub wparam {
187 my $self = shift;
188 my ($param) = @_;
189 my $val = $self->{cgi}->param($param);
190 defined $val and $val =~ s/^\s*(.*?)\s*$/$1/;
191 $val;
194 sub srcname {
195 my $self = shift;
196 my ($srcname) = @_;
197 $self->{srcname} = $srcname if $srcname;
198 $self->{srcname};
201 sub html_esc($;$) {
202 my $str = shift;
203 my $charentityokay = shift;
204 defined($str) or $str = '';
205 if ($charentityokay) {
206 $str =~ s/&(?!#(?:[xX][a-fA-F0-9]+|\d+);)/&amp;/g;
207 } else {
208 $str =~ s/&/&amp;/g;
210 $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g;
211 $str =~ s/[""]/&quot;/g; $str =~ s/['']/&apos;/g;
212 $str;
215 sub print_form_fields {
216 my $self = shift;
217 my ($fieldmap, $valuemap, @fields) = @_;
219 foreach my $field (map { $fieldmap->{$_} } @fields) {
220 defined($field->[2]) && $field->[2] ne 'placeholder' or next;
221 my $title='';
222 if (defined($field->[3]) && $field->[3] ne '') {
223 $title=' title="'.html_esc($field->[3], 1).'"'
225 print '<tr'.$title.'><td class="formlabel">'.$field->[0].':</td>';
226 if ($field->[2] eq 'text') {
227 print '<td><input type="text" name="'.$field->[1].'" size="80"';
228 print ' value="'.$valuemap->{$field->[1]}.'"' if $valuemap;
229 print ' />';
230 } elsif ($field->[2] eq 'checkbox') {
231 print '<td class="formdatatd"><input type="checkbox" name="'.$field->[1].'"';
232 print ' checked="checked"' if $valuemap && $valuemap->{$field->[1]};
233 printf ' value="%s"', ($valuemap && $valuemap->{$field->[1]} ? $valuemap->{$field->[1]} : "1");
234 print ' />';
235 } else {
236 print '<td><textarea name="'.$field->[1].'" rows="5" cols="80">';
237 print $valuemap->{$field->[1]} if $valuemap;
238 print '</textarea>';
240 print "</td></tr>\n";