1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/lib/TWiki/Configure/UI.pm Sat Jan 26 15:50:53 2008 +0100
1.3 @@ -0,0 +1,267 @@
1.4 +#
1.5 +# TWiki Enterprise Collaboration Platform, http://TWiki.org/
1.6 +#
1.7 +# Copyright (C) 2000-2006 TWiki Contributors.
1.8 +#
1.9 +# This program is free software; you can redistribute it and/or
1.10 +# modify it under the terms of the GNU General Public License
1.11 +# as published by the Free Software Foundation; either version 2
1.12 +# of the License, or (at your option) any later version. For
1.13 +# more details read LICENSE in the root of this distribution.
1.14 +#
1.15 +# This program is distributed in the hope that it will be useful,
1.16 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1.17 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
1.18 +#
1.19 +# As per the GPL, removal of this notice is prohibited.
1.20 +#
1.21 +# This is both the factory for UIs and the base class of UI constructors.
1.22 +# A UI is the V part of the MVC model used in configure.
1.23 +#
1.24 +# Each structural entity in a configure screen has a UI type, either
1.25 +# stored directly in the entity or indirectly in the type associated
1.26 +# with a value. The UI type is used to guide a visitor which is run
1.27 +# over the structure to generate the UI.
1.28 +#
1.29 +package TWiki::Configure::UI;
1.30 +
1.31 +use strict;
1.32 +use File::Spec;
1.33 +use FindBin;
1.34 +
1.35 +use vars qw ($totwarnings $toterrors);
1.36 +
1.37 +sub new {
1.38 + my ($class, $item) = @_;
1.39 +
1.40 + Carp::confess unless $item;
1.41 +
1.42 + my $this = bless( { item => $item }, $class);
1.43 + $this->{item} = $item;
1.44 +
1.45 + $this->{bin} = $FindBin::Bin;
1.46 + my @root = File::Spec->splitdir($this->{bin});
1.47 + pop(@root);
1.48 + $this->{root} = File::Spec->catfile(@root, '');
1.49 +
1.50 + return $this;
1.51 +}
1.52 +
1.53 +sub findRepositories {
1.54 + my $this = shift;
1.55 + unless (defined($this->{repositories})) {
1.56 + my $replist = '';
1.57 + $replist .= $TWiki::cfg{ExtensionsRepositories}
1.58 + if defined $TWiki::cfg{ExtensionsRepositories};
1.59 + $replist .= "$ENV{TWIKI_REPOSITORIES};" # DEPRECATED
1.60 + if defined $ENV{TWIKI_REPOSITORIES}; # DEPRECATED
1.61 + $replist = ";$replist;";
1.62 + while ($replist =~ s/[;\s]+(.*?)=\((.*?),(.*?)(?:,(.*?),(.*?))?\)\s*;/;/) {
1.63 + push(@{$this->{repositories}},
1.64 + { name => $1, data => $2, pub => $3});
1.65 + }
1.66 + }
1.67 +}
1.68 +
1.69 +sub getRepository {
1.70 + my ($this, $reponame) = @_;
1.71 + foreach my $place (@{$this->{repositories}}) {
1.72 + return $place if $place->{name} eq $reponame;
1.73 + }
1.74 + return undef;
1.75 +}
1.76 +
1.77 +# Static UI factory
1.78 +# UIs *must* exist
1.79 +sub loadUI {
1.80 + my ($id, $item) = @_;
1.81 + $id = 'TWiki::Configure::UIs::'.$id;
1.82 + my $ui;
1.83 +
1.84 + eval "use $id; \$ui = new $id(\$item);";
1.85 +
1.86 + return undef if (!$ui && $@);
1.87 +
1.88 + return $ui;
1.89 +}
1.90 +
1.91 +# Static checker factory
1.92 +# Checkers *need not* exist
1.93 +sub loadChecker {
1.94 + my ($id, $item) = @_;
1.95 + $id =~ s/}{/::/g;
1.96 + $id =~ s/[}{]//g;
1.97 + $id =~ s/'//g;
1.98 + $id =~ s/-/_/g;
1.99 + my $checkClass = 'TWiki::Configure::Checkers::'.$id;
1.100 + my $checker;
1.101 +
1.102 + eval "use $checkClass; \$checker = new $checkClass(\$item);";
1.103 + # Can't locate errors are OK
1.104 + die $@ if ($@ && $@ !~ /Can't locate /);
1.105 +
1.106 + return $checker;
1.107 +}
1.108 +
1.109 +# Returns a response object as described in TWiki::Net
1.110 +sub getUrl {
1.111 + my ($this, $url) = @_;
1.112 +
1.113 + require TWiki::Net;
1.114 + my $tn = new TWiki::Net();
1.115 + my $response = $tn->getExternalResource($url);
1.116 + $tn->finish();
1.117 + return $response;
1.118 +}
1.119 +
1.120 +# STATIC Used by a whole bunch of things that just need to show a key-value row
1.121 +# (called as a method, i.e. with class as first parameter)
1.122 +sub setting {
1.123 + my $this = shift;
1.124 + my $key = shift;
1.125 + return CGI::Tr(CGI::td({class=>'firstCol'}, $key).
1.126 + CGI::td({class=>'secondCol'}, join(' ', @_)))."\n";
1.127 +}
1.128 +
1.129 +# Generate a foldable block (twisty). This is a DIV with a table in it
1.130 +# that contains the settings and doc rows.
1.131 +sub foldableBlock {
1.132 + my( $this, $head, $attr, $body ) = @_;
1.133 + my $headText = $head . CGI::span({ class => 'blockLinkAttribute' }, $attr);
1.134 + $body = CGI::start_table({width => '100%', -border => 0, -cellspacing => 0, -cellpadding => 0}).$body.CGI::end_table();
1.135 + my $mess = $this->collectMessages($this->{item});
1.136 +
1.137 + my $anchor = $this->_makeAnchor( $head );
1.138 + my $id = $anchor;
1.139 + my $blockId = $id;
1.140 + my $linkId = 'blockLink'.$id;
1.141 + my $linkAnchor = $anchor.'link';
1.142 + return CGI::a({ name => $linkAnchor }).
1.143 + CGI::a({id => $linkId,
1.144 + class => 'blockLink blockLinkOff',
1.145 + href => '#'.$linkAnchor,
1.146 + rel => 'nofollow',
1.147 + onclick => 'foldBlock("' . $id . '"); return false;'
1.148 + },
1.149 + $headText.$mess).
1.150 + CGI::div( {id => $blockId,
1.151 + class=> 'foldableBlock foldableBlockClosed'
1.152 + }, $body ).
1.153 + "\n";
1.154 +}
1.155 +
1.156 +# encode a string to make an HTML anchor
1.157 +sub _makeAnchor {
1.158 + my ($this, $str) = @_;
1.159 +
1.160 + $str =~ s/\s(\w)/uc($1)/ge;
1.161 + $str =~ s/\W//g;
1.162 + return $str;
1.163 +}
1.164 +
1.165 +sub NOTE {
1.166 + my $this = shift;
1.167 + return CGI::p({class=>"info"}, join("\n",@_));
1.168 +}
1.169 +
1.170 +# a warning
1.171 +sub WARN {
1.172 + my $this = shift;
1.173 + $this->{item}->inc('warnings');
1.174 + $totwarnings++;
1.175 + return CGI::div(CGI::span({class=>'warn'},
1.176 + CGI::strong('Warning: ').join("\n",@_)));
1.177 +}
1.178 +
1.179 +# an error
1.180 +sub ERROR {
1.181 + my $this = shift;
1.182 + $this->{item}->inc('errors');
1.183 + $toterrors++;
1.184 + return CGI::div(CGI::span({class=>'error'},
1.185 + CGI::strong('Error: ').join("\n",@_)));
1.186 +}
1.187 +
1.188 +# Used in place of CGI::hidden, which is broken in some versions.
1.189 +# Assumes $name does not need to be encoded
1.190 +# HTML encodes the value
1.191 +sub hidden {
1.192 + my ($this, $name, $value) = @_;
1.193 + $value ||= '';
1.194 + $value =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|])/'&#'.ord($1).';'/ge;
1.195 + return '<input type="hidden" name="'.$name.'" value="'.$value.'" />';
1.196 +}
1.197 +
1.198 +# Invoked to confirm authorisation, and handle password changes. The password
1.199 +# is changed in $TWiki::cfg, a change which is then detected and written when
1.200 +# the configuration file is actually saved.
1.201 +sub authorised {
1.202 + my $pass = $TWiki::query->param('cfgAccess');
1.203 +
1.204 + # The first time we get here is after the "next" button is hit. A password
1.205 + # won't have been defined yet; so the authorisation must fail to force
1.206 + # a prompt.
1.207 + if (!defined($pass)) {
1.208 + return 0;
1.209 + }
1.210 +
1.211 + # If we get this far, a password has been given. Check it.
1.212 + if (!$TWiki::cfg{Password} && !$TWiki::query->param('confCfgP')) {
1.213 + # No password passed in, and TWiki::cfg doesn't contain a password
1.214 + print CGI::div({class=>'error'}, <<'HERE');
1.215 +WARNING: You have not defined a password. You must define a password before
1.216 +you can save.
1.217 +HERE
1.218 + return 0;
1.219 + }
1.220 +
1.221 + # If a password has been defined, check that it has been used
1.222 + if ($TWiki::cfg{Password} &&
1.223 + crypt($pass, $TWiki::cfg{Password}) ne $TWiki::cfg{Password}) {
1.224 + print CGI::div({class=>'error'}, "Password incorrect");
1.225 + return 0;
1.226 + }
1.227 +
1.228 + # Password is correct, or no password defined
1.229 + # Change the password if so requested
1.230 + my $newPass = $TWiki::query->param('newCfgP');
1.231 +
1.232 + if ($newPass) {
1.233 + my $confPass = $TWiki::query->param('confCfgP') || '';
1.234 + if ($newPass ne $confPass) {
1.235 + print CGI::div({class=>'error'},
1.236 + 'New password and confirmation do not match');
1.237 + return 0;
1.238 + }
1.239 + $TWiki::cfg{Password} = _encode($newPass);
1.240 + print CGI::div({class=>'error'}, 'Password changed');
1.241 + }
1.242 +
1.243 + return 1;
1.244 +}
1.245 +
1.246 +
1.247 +sub collectMessages {
1.248 + my $this = shift;
1.249 + my ($item) = @_;
1.250 +
1.251 + my $warnings = $item->{warnings} || 0;
1.252 + my $errors = $item->{errors} || 0;
1.253 + my $errorsMess = "$errors error" . (($errors > 1) ? 's' : '');
1.254 + my $warningsMess = "$warnings warning" . (($warnings > 1) ? 's' : '');
1.255 + my $mess = '';
1.256 + $mess .= ' ' . CGI::span({class=>'error'}, $errorsMess) if $errors;
1.257 + $mess .= ' ' . CGI::span({class=>'warn'}, $warningsMess) if $warnings;
1.258 +
1.259 + return $mess;
1.260 +}
1.261 +
1.262 +sub _encode {
1.263 + my $pass = shift;
1.264 + my @saltchars = ( 'a'..'z', 'A'..'Z', '0'..'9', '.', '/' );
1.265 + my $salt = $saltchars[int(rand($#saltchars+1))] .
1.266 + $saltchars[int(rand($#saltchars+1)) ];
1.267 + return crypt($pass, $salt);
1.268 +}
1.269 +
1.270 +1;