lib/TWiki/Configure/UI.pm
changeset 0 414e01d06fd5
equal deleted inserted replaced
-1:000000000000 0:414e01d06fd5
       
     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;