Back to home page
Get LXR Cross Referencer at SourceForge.net. Fast, secure and Free Open Source software downloads

LXR self cross-referenced (under SQLite)

 
 

    


File indexing completed on 2017-01-01 14:49:53

0001 #!/usr/bin/perl -T
0002 ######################################################################
0003 #
0004 # showconfig -- Present LXR configuration as html
0005 #
0006 #   Andre J Littoz <ajlittoz@users.sf.net>
0007 #
0008 #
0009 # This program is free software; you can redistribute it and/or modify
0010 # it under the terms of the GNU General Public License as published by
0011 # the Free Software Foundation; either version 2 of the License, or
0012 # (at your option) any later version.
0013 #
0014 # This program is distributed in the hope that it will be useful,
0015 # but WITHOUT ANY WARRANTY; without even the implied warranty of
0016 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
0017 # GNU General Public License for more details.
0018 #
0019 # You should have received a copy of the GNU General Public License
0020 # along with this program; if not, write to the Free Software
0021 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
0022 #
0023 ######################################################################
0024 
0025 =head1 script showconfig
0026 
0027 This script shows how LXR understood the configuration parameters
0028 from F<lxr.conf> file. They are displayed in tabular form:
0029 
0030 First column: parameter name
0031 
0032 Second column: parameter type (I<string>, I<array>, I<hash>, ...)
0033 
0034 Third column: value from tree-specific parameter group
0035 
0036 Fourth column: value from global parameter group
0037 
0038 With such a layout, it is easy to see if a global value is overridden
0039 by a specific one.
0040 
0041 =cut
0042 
0043 use strict;
0044 use lib do { $0 =~ m{(.*)/} ? "$1/lib" : 'lib' };  # if LXR modules are in ./lib
0045 
0046 use LXR::Common;
0047 use LXR::Template;
0048 
0049 
0050 =head2 C<dumphash ($h, $left)>
0051 
0052 Function C<dumphash> returns the contents of the input hash
0053 as a ready-to-print string.
0054 
0055 The value of a key may be a simple I<string> (displayed surrounded
0056 with quotes), an I<array> (dumped "as is" without checking for further
0057 references) or a I<hash> (recursively dumped surrounded with curly braces).
0058 
0059 =over
0060 
0061 =item 1
0062 
0063 C<$h>
0064 
0065 a reference to the I<hash> to dump
0066 
0067 =item 2
0068 
0069 C<$left>
0070 
0071 the I<number> of spaces at left to indent this hash
0072 
0073 =back
0074 
0075 =cut
0076 
0077 sub dumphash {
0078     my $h = shift;
0079     my $left = shift;
0080     my $d = ' 'x$left . '{ ';
0081 
0082     foreach my $k (sort keys %$h) {
0083         $d .= "'$k' => ";
0084     # Compute left spaces in case we need to recurse
0085         $d =~ m/([^\n]*)$/s;
0086         my $indent = length($1);
0087         my $v = $h->{$k};
0088         if (ref($v) eq 'ARRAY') {
0089             $d .= '[ ' . join("\n".' 'x$indent.', ', @$v);
0090             if (1 < scalar(@$v)) {
0091                 $d .= "\n".' 'x$indent;
0092             } else {
0093                 $d .= ' ';
0094             }
0095             $d .= ']';
0096         } elsif (ref($v) eq 'HASH') {
0097             $d .= "\n";
0098             $d .= dumphash ($v, $indent);
0099         } else {
0100             $d .= "'$v'";
0101         }
0102     # Prepare for next key with initial left spaces and comma
0103         $d .= "\n" . ' 'x$left . ', ';
0104     }
0105     # Replace last comma with closing curly braces
0106     $d =~ s/, $/}\n/;
0107     return $d;
0108 }
0109 
0110 
0111 =head2 C<parmvalue ($parm, $pg)>
0112 
0113 Function C<parmvalue> dumps a parameter value if it exists in this
0114 parameter group.
0115 
0116 After testing for parameter existence, processing is dispatched
0117 according to type value.
0118 
0119 Parameter C<dbpass> is not dumped for security reason.
0120 
0121 =over
0122 
0123 =item 1
0124 
0125 C<$parm>
0126 
0127 a parameter name as a I<string>
0128 
0129 =item 2
0130 
0131 C<$pg>
0132 
0133 a reference to a parameter group
0134 
0135 =back
0136 
0137 =cut
0138 
0139 sub parmvalue {
0140     my $parm = shift;
0141     my $pg = shift;
0142     my $fallback = shift;
0143 
0144     return '' if !exists($pg->{$parm}) && !defined($fallback);
0145     my $val = $pg->{$parm} // $fallback->{$parm};
0146     if (ref($val) eq 'HASH') {
0147         return '<pre>' . dumphash($val, 0) . '</pre>';
0148     } elsif (ref($val) eq 'ARRAY') {
0149         return '<pre>' . join('<br>', @$val) . '</pre>';
0150     } else {
0151         if ('dbpass' eq $parm) {
0152             return '<h4>Hey, that\'s supposed to be a secret!</h4>';
0153         } else {
0154             return "<pre>$val</pre>";
0155         }
0156     }
0157 
0158 }
0159 
0160 
0161 =head2 C<parmexpand ($templ, $who, $pgs, $pgnr)>
0162 
0163 Function C<parmexpand> is a "$function" substitution function.
0164 It returns its block (contained in C<$tmpl>) expanded for each
0165 accessible configuration parameter.
0166 
0167 =over
0168 
0169 =item 1
0170 
0171 C<$templ>
0172 
0173 a I<string> containing the template (i.e. argument)
0174 
0175 =item 2
0176 
0177 C<$who>
0178 
0179 a I<string> containing the script name (i.e. showconfig)
0180 requesting this substitution
0181 
0182 =item 3
0183 
0184 C<$pgs>
0185 
0186 a reference to the parameter group array
0187 
0188 =item 4
0189 
0190 C<$pgnr>
0191 
0192 parameter group index
0193 
0194 =back
0195 
0196 Parameter names are obtained from global C<$config> hash reference
0197 since all parameters end up there.
0198 "I<internal>" parameters C<'confpath'> and C<'parmgroupnr'> are removed
0199 from the set.
0200 
0201 A parameter may be defined in an included file like C<'filetype'>
0202 from C<'filetypeconf'>. In this case, both specific and global columns
0203 are empty.
0204 
0205 A parameter is considered if it belongs in the global section or in the
0206 requested tree section.
0207 
0208 To dump values anyway, force C<$config> usage instead of a parameter
0209 group through query argument C<_confall> with non zero value.
0210 
0211 =cut
0212 
0213 sub parmexpand {
0214     my ($templ, $who, $pgs, $pgnr) = @_;
0215     my $ret;
0216     my @keylist = ();
0217     my $parmgroup = @$pgs[$pgnr];
0218     my $globgroup = @$pgs[0];
0219     my $full = $HTTP->{'param'}{'_confall'} // 0;
0220 
0221     if ($full != 0) {
0222         my %seen;
0223         for (@$pgs) {
0224             while (defined(my $key = each %{$_})) {
0225                 $seen{$key}++;
0226             }
0227         }
0228         if (1 < $full) {
0229             for (keys %$config) {
0230                 $seen{$_}++
0231             }
0232         }
0233         @keylist = keys(%seen);
0234     } else {
0235         @keylist = keys %{{%$parmgroup, %$globgroup}};
0236     }
0237 
0238     for my $parm (sort @keylist) {
0239         next if (   $parm eq 'confpath'
0240                 ||  $parm eq 'parmgroupnr'
0241                 );
0242          my $extra =    !exists($$parmgroup{$parm})
0243                     &&  !exists($$globgroup{$parm});
0244         $ret .= expandtemplate
0245                     ( $templ
0246                     ,   ( 'force' => sub{ $extra ? 'conf_force' : '' }
0247                         , 'parm' => sub{ $parm }
0248                         , 'type' => sub{ 
0249                                         my $t = ref($config->{$parm});
0250                                         if ('' ne $t) {
0251                                             return lc($t);
0252                                         }
0253                                         return 'string';
0254                                     }
0255                         , 'val'  => sub{ parmvalue  ( $parm
0256                                                     , $parmgroup
0257                                                     , ( 1 < $full
0258                                                       ? $config
0259                                                       : undef
0260                                                       )
0261                                                     )
0262                                     }
0263                         , 'global'=> sub{
0264                                     parmvalue($parm, $globgroup)
0265                                         }
0266                         )
0267                     );
0268     }
0269     return $ret;
0270 }
0271 
0272 
0273 =head2 C<parmgrouplink ($pgnr, $pgs)>
0274 
0275 Function C<parmgrouplink> is a "$variable" substitution function.
0276 It returns an C<E<lt> A E<gt>> element invoking
0277 script I<showconfig> to dump the designated parameter group.
0278 
0279 =over
0280 
0281 =item 1
0282 
0283 C<$pgnr>
0284 
0285 parameter group index
0286 
0287 =item 2
0288 
0289 C<$pgs>
0290 
0291 a reference to the parameter group array
0292 
0293 =back
0294 
0295 Link is created only if C<$pgnr> has an acceptable value.
0296 Otherwise, function returns string C<'none'>.
0297 
0298 =cut
0299 
0300 sub parmgrouplink {
0301     my ($pgnr, $pgs) = @_;
0302 
0303     if (0>=$pgnr || $pgnr > $#$pgs) {
0304         return 'none';
0305     } else {
0306         return "#$pgnr <a href='"
0307                 . $config->treeurl($$pgs[$pgnr], $$pgs[0])
0308                 . 'showconfig'
0309                 . ( exists($$pgs[$pgnr]->{'treename'})
0310                   ? '/'.$$pgs[$pgnr]->{'treename'}
0311                   : ''
0312                   )
0313                 . "?_parmgroup=$pgnr'> "
0314                 . ($$pgs[$pgnr]->{'virtroot'} // $$pgs[0]->{'virtroot'})
0315                 . (exists($$pgs[$pgnr]->{'treename'})
0316                   ? '/&hellip;/' . $$pgs[$pgnr]->{'treename'}
0317                   : ''
0318                   )
0319                 . '</a>' ;
0320     }
0321 }
0322 
0323 
0324 =head2 Script entry point
0325 
0326 Output is controlled by a template
0327 
0328 Eventually, a specific parameter group may be dumped by passing
0329 its index in URL argument C<_parmgroup>.
0330 This index may receive a default value through configuration parameter
0331 C<'parmgroupnr'>.
0332 
0333 =cut
0334 
0335 my $errorsig = "<!-- ! -->";
0336 my $templ;
0337 
0338 httpinit();
0339 std_http_headers();
0340 
0341 my $who = 'showconfig';
0342 my @pgs = $config->readconfig();
0343 my $which = $HTTP->{'param'}{'_parmgroup'}
0344             // $config->{'parmgroupnr'}
0345             // 1;
0346 makeheader($who);
0347 $templ = gettemplate    ( 'htmlconfig'
0348                         , $errorsig
0349                         );
0350 if ($templ =~ m/^$errorsig/) {
0351     die "Can't display configuration without 'htmlconfig' template\n";
0352 }
0353 print expandtemplate
0354     ( $templ
0355     ,   ( 'conffile'    => sub { '<em>' . $config->{'confpath'} . '</em>' }
0356         , 'virtroot'    => sub { $pgs[$which]->{'virtroot'} }
0357         , 'parmgroupnr' => sub { $which
0358                                 . (1 < $HTTP->{'param'}{'_confall'}
0359                                   ? ' (apocalyptical)'
0360                                   : ''
0361                                   )
0362                                 }
0363         , 'varbtnaction'=> sub { varbtnaction(@_, $who) }
0364         , 'previous'    => sub { parmgrouplink($which-1, \@pgs) }
0365         , 'next'        => sub { parmgrouplink($which+1, \@pgs) }
0366         , 'conf_parm'   => sub { parmexpand (@_, $who, \@pgs, $which) }
0367         )
0368     );
0369 makefooter($who);
0370 
0371 httpclean;