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