lib/TWiki/Configure/Types/SELECTCLASS.pm
changeset 0 414e01d06fd5
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/lib/TWiki/Configure/Types/SELECTCLASS.pm	Sat Jan 26 15:50:53 2008 +0100
     1.3 @@ -0,0 +1,94 @@
     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 +package TWiki::Configure::Types::SELECTCLASS;
    1.21 +
    1.22 +use strict;
    1.23 +
    1.24 +use TWiki::Configure::Types::SELECT;
    1.25 +
    1.26 +use base 'TWiki::Configure::Types::SELECT';
    1.27 +
    1.28 +# generate an input field for SELECTCLASS types
    1.29 +# Takes a comma-separated list of options
    1.30 +# Each option must be either 'none' or a wildcard expression that matches classes e.g.
    1.31 +# TWiki::Plugins::*Plugin
    1.32 +# * is the only wildcard supported
    1.33 +# Finds all classes that match in @INC
    1.34 +sub prompt {
    1.35 +    my( $this, $id, $opts, $value ) = @_;
    1.36 +    my @ropts;
    1.37 +    $opts =~ s/\s.*$//; # remove e.g. EXPERT
    1.38 +    foreach my $opt (split( /,/, $opts)) {
    1.39 +        if ($opt eq 'none') {
    1.40 +            push(@ropts, 'none');
    1.41 +        } else {
    1.42 +            push(@ropts, @{$this->findClasses($opt)});
    1.43 +        }
    1.44 +    }
    1.45 +    return $this->SUPER::prompt($id, join(',', @ropts), $value);
    1.46 +}
    1.47 +
    1.48 +# $pattern is a wildcard expression that matches classes e.g.
    1.49 +# TWiki::Plugins::*Plugin
    1.50 +# * is the only wildcard supported
    1.51 +# Finds all classes that match in @INC
    1.52 +sub findClasses {
    1.53 +    my ($this, $pattern) = @_;
    1.54 +
    1.55 +    $pattern =~ s/\*/.*/g;
    1.56 +    my @path = split(/::/, $pattern);
    1.57 +
    1.58 +    my $places = \@INC;
    1.59 +
    1.60 +    while (scalar(@path) > 1 && @$places) {
    1.61 +        my $pathel = shift(@path);
    1.62 +        eval "\$pathel = qr/^$pathel\$/";
    1.63 +        my @newplaces;
    1.64 +
    1.65 +        foreach my $place (@$places) {
    1.66 +            if( opendir( DIR, $place ) ) {
    1.67 +                foreach my $subplace ( readdir DIR ) {
    1.68 +                    next unless $subplace =~ $pathel;
    1.69 +                    push(@newplaces, $place.'/'.$subplace);
    1.70 +                }
    1.71 +            }
    1.72 +        }
    1.73 +        $places = \@newplaces;
    1.74 +    }
    1.75 +
    1.76 +    my @list;
    1.77 +    my $leaf = shift(@path);
    1.78 +    eval "\$leaf = qr/$leaf\.pm\$/";
    1.79 +    my %known;
    1.80 +    foreach my $place (@$places) {
    1.81 +        if (opendir( DIR, $place )) {
    1.82 +            foreach my $file ( readdir DIR ) {
    1.83 +                next unless $file =~ $leaf;
    1.84 +                $file =~ /^(.*)\.pm$/;
    1.85 +                my $module = "$place/$1";
    1.86 +                $module =~ s./.::.g;
    1.87 +                $module =~ /($pattern)$/;
    1.88 +                push(@list, $1) unless $known{$1};
    1.89 +                $known{$1} = 1;
    1.90 +            }
    1.91 +        }
    1.92 +    }
    1.93 +
    1.94 +    return \@list;
    1.95 +}
    1.96 +
    1.97 +1;