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