lib/TWiki/Configure/UI.pm
changeset 0 414e01d06fd5
     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;