1# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
2#
3# Copyright (C) 2000-2018 Peter Thoeny, peter[at]thoeny.org
4# and TWiki Contributors. All Rights Reserved. TWiki Contributors
5# are listed in the AUTHORS file in the root of this distribution.
6# NOTE: Please extend that file, not this notice.
7#
8# Additional copyrights apply to some or all of the code in this
9# file as follows:
10#
11# This program is free software; you can redistribute it and/or
12# modify it under the terms of the GNU General Public License
13# as published by the Free Software Foundation; either version 3
14# of the License, or (at your option) any later version. For
15# more details read LICENSE in the root of this distribution.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
20#
21# As per the GPL, removal of this notice is prohibited.
22#
23# This is both the factory for UIs and the base class of UI constructors.
24# A UI is the V part of the MVC model used in configure.
25#
26# Each structural entity in a configure screen has a UI type, either
27# stored directly in the entity or indirectly in the type associated
28# with a value. The UI type is used to guide a visitor which is run
29# over the structure to generate the UI.
30
31package TWiki::Configure::UI;
32
33use strict;
34use Carp;
35use File::Spec;
36use FindBin;
37
38use vars qw ($totwarnings $toterrors);
39
40sub new {
41    my ($class, $item) = @_;
42
43    Carp::confess unless $item;
44
45    my $this = bless( { item => $item }, $class);
46    $this->{item} = $item;
47
48    $FindBin::Bin =~ /(.*)/;
49    $this->{bin} = $1;
50    my @root = File::Spec->splitdir($this->{bin});
51    pop(@root);
52    $this->{root} = File::Spec->catfile(@root, '');
53
54    return $this;
55}
56
57sub findRepositories {
58    my $this = shift;
59    unless (defined($this->{repositories})) {
60        my $replist = '';
61        $replist .= $TWiki::cfg{ExtensionsRepositories}
62          if defined $TWiki::cfg{ExtensionsRepositories};
63        $replist .= "$ENV{TWIKI_REPOSITORIES};" # DEPRECATED
64          if defined $ENV{TWIKI_REPOSITORIES};  # DEPRECATED
65        $replist = ";$replist;";
66        while ($replist =~ s/[;\s]+(.*?)=\((.*?),(.*?)(?:,(.*?),(.*?))?\)\s*;/;/) {
67            push(@{$this->{repositories}},
68                 { name => $1, data => $2, pub => $3});
69        }
70    }
71}
72
73sub getRepository {
74    my ($this, $reponame) = @_;
75    foreach my $place (@{$this->{repositories}}) {
76        return $place if $place->{name} eq $reponame;
77    }
78    return undef;
79}
80
81# Static UI factory
82# UIs *must* exist
83sub loadUI {
84    my ($id, $item) = @_;
85    $id = 'TWiki::Configure::UIs::'.$id;
86    my $ui;
87
88    eval "use $id; \$ui = new $id(\$item);";
89
90    return undef if (!$ui && $@);
91
92    return $ui;
93}
94
95# Static checker factory
96# Checkers *need not* exist
97sub loadChecker {
98    my ($keys, $item) = @_;
99    my $id = $keys;
100    $id =~ s/}\{/::/g;
101    $id =~ s/[}{]//g;
102    $id =~ s/'//g;
103    $id =~ s/-/_/g;
104    my $checkClass = 'TWiki::Configure::Checkers::'.$id;
105    my $checker;
106
107    eval "use $checkClass; \$checker = new $checkClass(\$item);";
108    # Can't locate errors are OK
109    if ($@) {
110	die $@ unless ($@ =~ /Can't locate /);
111	# See if type can generate a generic checker
112	if ($item->can('getType' )) {
113	    my $type = $item->getType();
114	    if ($type && $type->can('makeChecker')) {
115		$checker = $type->makeChecker($item, $keys);
116	    }
117	}
118    }
119    return $checker;
120}
121
122# Returns a response object as described in TWiki::Net
123sub getUrl {
124    my ($this, $url) = @_;
125
126    require TWiki::Net;
127    my $tn = new TWiki::Net();
128    my $response = $tn->getExternalResource($url);
129    $tn->finish();
130    return $response;
131}
132
133# STATIC Used by a whole bunch of things that just need to show a key-value row
134# (called as a method, i.e. with class as first parameter)
135sub setting {
136    my $this = shift;
137    my $key = shift;
138    return CGI::Tr(CGI::td({class=>'firstCol'}, $key).
139                   CGI::td({class=>'secondCol'}, join(' ', @_)))."\n";
140}
141
142# Generate a foldable block (twisty). This is a DIV with a table in it
143# that contains the settings and doc rows.
144sub foldableBlock {
145    my( $this, $head, $attr, $body ) = @_;
146    my $headText = $head . CGI::span({ class => 'blockLinkAttribute' }, $attr);
147    $body = CGI::start_table({width => '100%', -border => 0, -cellspacing => 0, -cellpadding => 0}).$body.CGI::end_table();
148    my $mess = $this->collectMessages($this->{item});
149
150    my $anchor = $this->_makeAnchor( $head );
151    my $id = $anchor;
152    my $blockId = $id;
153    my $linkId = 'blockLink'.$id;
154    my $linkAnchor = $anchor.'link';
155    return CGI::a({ name => $linkAnchor }).
156      CGI::a({id => $linkId,
157              class => 'blockLink blockLinkOff',
158              href => '#'.$linkAnchor,
159              rel => 'nofollow',
160              onclick => 'foldBlock("' . $id . '"); return false;'
161             },
162             $headText.$mess).
163               CGI::div( {id => $blockId,
164                          class=> 'foldableBlock foldableBlockClosed'
165                         }, $body ).
166                           "\n";
167}
168
169# encode a string to make an HTML anchor
170sub _makeAnchor {
171    my ($this, $str) = @_;
172
173    $str =~ s/\s(\w)/uc($1)/ge;
174    $str =~ s/\W//g;
175    return $str;
176}
177
178sub NOTE {
179    my $this = shift;
180    return CGI::p({class=>"info"}, join("\n",@_));
181}
182
183# a warning
184sub WARN {
185    my $this = shift;
186    $this->{item}->inc('warnings');
187    $totwarnings++;
188    return CGI::div(CGI::span({class=>'warn'},
189                              CGI::strong('Warning: ').join("\n",@_)));
190}
191
192# an error
193sub ERROR {
194    my $this = shift;
195    $this->{item}->inc('errors');
196    $toterrors++;
197    return CGI::div(CGI::span({class=>'error'},
198                              CGI::strong('Error: ').join("\n",@_)));
199}
200
201# Used in place of CGI::hidden, which is broken in some versions.
202# Assumes $name does not need to be encoded
203# HTML encodes the value
204sub hidden {
205    my ($this, $name, $value) = @_;
206    $value ||= '';
207    $value =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|])/'&#'.ord($1).';'/ge;
208	return '<input type="hidden" name="'.$name.'" value="'.$value.'" />';
209}
210
211# Invoked to confirm authorisation, and handle password changes. The password
212# is changed in $TWiki::cfg, a change which is then detected and written when
213# the configuration file is actually saved.
214sub authorised {
215    my $pass = $TWiki::query->param('cfgAccess');
216    my $newPass = $TWiki::query->param('newCfgP');
217
218    # The first time we get here is after the "next" button is hit. A password
219    # won't have been defined yet; so the authorisation must fail to force
220    # a prompt.
221    if (defined ($newPass)) {
222          $pass = $newPass;
223    }
224
225    if (!defined($pass)) {
226        return 0;
227    }
228
229    # If we get this far, a password has been given. Check it.
230    if (!$TWiki::cfg{Password} && !$TWiki::query->param('confCfgP')) {
231        # No password passed in, and TWiki::cfg doesn't contain a password
232        print CGI::div({class=>'error'}, <<'HERE');
233WARNING: You have not defined a password. You must define a password before
234you can enter the configuration screen.
235HERE
236        return 0;
237    }
238
239    # If a password has been defined, check that it has been used
240    if ($TWiki::cfg{Password} &&
241        crypt($pass, $TWiki::cfg{Password}) ne $TWiki::cfg{Password}) {
242        print CGI::div({class=>'error'}, "Password incorrect");
243        return 0;
244    }
245
246    # Password is correct, or no password defined
247    # Change the password if so requested
248
249    if ($newPass) {
250        my $confPass = $TWiki::query->param('confCfgP') || '';
251        if ($newPass ne $confPass) {
252            print CGI::div({class=>'error'},
253              'New password and confirmation do not match');
254            return 0;
255        }
256        $TWiki::cfg{Password} = _encode($newPass);
257        print CGI::div({class=>'error'}, 'Password changed');
258    }
259
260    return 1;
261}
262
263
264sub collectMessages {
265    my $this = shift;
266    my ($item)  =  @_;
267
268    my $warnings      =  $item->{warnings} || 0;
269    my $errors        =  $item->{errors} || 0;
270    my $errorsMess    =  "$errors error"     .  (($errors   > 1) ? 's' : '');
271    my $warningsMess  =  "$warnings warning" .  (($warnings > 1) ? 's' : '');
272    my $mess          =  '';
273    $mess .= ' ' . CGI::span({class=>'error'}, $errorsMess) if $errors;
274    $mess .= ' ' . CGI::span({class=>'warn'}, $warningsMess) if $warnings;
275
276    return $mess;
277}
278
279sub _encode {
280    my $pass = shift;
281    my @saltchars = ( 'a'..'z', 'A'..'Z', '0'..'9', '.', '/' );
282    my $salt = $saltchars[int(rand($#saltchars+1))] .
283      $saltchars[int(rand($#saltchars+1)) ];
284    return crypt($pass, $salt);
285}
286
2871;
288