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