[Lxr-commits] CVS: lxr/scripts ContextMgr.pm, NONE, 1.1 LCLInterpreter.pm, NONE, 1.1 configure-lxr.
Brought to you by:
ajlittoz
Menu
▾
▴
[Lxr-commits] CVS: lxr/scripts ContextMgr.pm, NONE, 1.1 LCLInterpreter.pm, NONE, 1.1 configure-lxr.pl, 1.5, 1.6 recreatedb.pl, 1.4, 1.5
|
From: Andre-Littoz <ajl...@us...> - 2013-01-11 11:53:17
|
Update of /cvsroot/lxr/lxr/scripts In directory sfp-cvs-1.v30.ch3.sourceforge.com:/tmp/cvs-serv30839/scripts Modified Files: configure-lxr.pl recreatedb.pl Added Files: ContextMgr.pm LCLInterpreter.pm Log Message: Configuration process: part 1/5 New LXR control language Create LCLInterpreter.pm for LCL mangement and interpretation, offering a common module to configure-lxr.pl and recreatedb.pl Common factor context management for use by configure-lxr.pl and recreatedb.pl ExpandHash.pm & ExpandSlashStar.pm no longer needed (replaced by LCLInterpreter.pm), will be erased in next update --- NEW FILE: ContextMgr.pm --- # -*- tab-width: 4 -*- ############################################### # # $Id: ContextMgr.pm,v 1.1 2013/01/11 11:53:13 ajlittoz Exp $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ############################################### package ContextMgr; use strict; use lib do { $0 =~ m{(.*)/}; "$1" }; use QuestionAnswer; use VTescape; ############################################################## # # Define global parameters # ############################################################## require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw( $cardinality $dbengine $dbenginechanged $dbpolicy $dbname $dbuser $dbpass $dbprefix $nodbuser $nodbprefix &contextReload &contextSave &contextDB ); our $cardinality; our $dbengine; our $dbenginechanged = 0; our $dbpolicy; our $dbname; our $dbuser; our $dbpass; our $dbprefix; our $nodbuser; our $nodbprefix; # WARNING: remember to increment this number when changing the # set of state variables and/or their meaning. my $context_version = 1; ############################################################## # # Reload context file # ############################################################## sub contextReload { my ($verbose, $ctxtfile) = @_; my $reloadstatus = 0; if (my $c=open(SOURCE, '<', $ctxtfile)) { print "Initial context $ctxtfile is reloaded\n" if $verbose; # Default record separator # changed to read full file content at once and restored afterwards my $oldsep = $/; $/ = undef; my $context = <SOURCE>; $/ = $oldsep; close(SOURCE); my ($confout) =~ m/\n# Context .* with (.*?)\n/g; my $context_created; eval($context); if (!defined($context_created)) { print "${VTred}ERROR:${VTnorm} saved context file probably damaged!\n"; print "Check variable not found\n"; print "Delete or rename file $ctxtfile to remove lock.\n"; exit 1; } if ($context_created != $context_version) { print "${VTred}ERROR:${VTnorm} saved context file probably too old!\n"; print "Recorded state version = $context_created while expecting version = $context_version\n"; print "It is wise to 'quit' now and add manually the new tree or reconfigure from scratch.\n"; print "You can however try to restore the initial context at your own risk.\n"; print "\n"; print "${VTyellow}WARNING:${VTnorm} inconsistent answers can lead to LXR malfunction.\n"; print "\n"; if ('q' eq get_user_choice ( 'Do you want to quit or manually restore context?' , 1 , [ 'quit', 'restore' ] , [ 'q', 'r' ] ) ) { exit 1; } $reloadstatus = 1; }; if ($dbpolicy eq 't') { print "Your DB engine was: ${VTbold}"; if ("m" eq $dbengine) { print "MySQL"; } elsif ("o" eq $dbengine) { print "Oracle"; } elsif ("p" eq $dbengine) { print "PostgreSQL"; } elsif ("s" eq $dbengine) { print "SQLite"; } else { print "???${VTnorm}\n"; print "${VTred}ERROR:${VTnorm} saved context file damaged or tampered with!\n"; print "Unknown database code '$dbengine'\n"; print "Delete or rename file $ctxtfile to remove lock.\n"; if ('q' eq get_user_choice ( 'Do you want to quit or manually restore context?' , 1 , [ 'quit', 'restore' ] , [ 'q', 'r' ] ) ) { exit 1; } $reloadstatus = 1; }; } } else { print "${VTyellow}WARNING:${VTnorm} could not reload context file ${VTbold}$ctxtfile${VTnorm}!\n"; print "You may have deleted the context file or you moved the configuration\n"; print "file out of the user-configuration directory without the\n"; print "context companion file ${VTyellow}$ctxtfile${VTnorm}.\n"; print "\n"; print "You can now 'quit' to think about the situation or try to restore\n"; print "the parameters by answering the following questions\n"; print "(some clues can be gathered from reading configuration file).\n"; print "\n"; print "${VTyellow}WARNING:${VTnorm} inconsistent answers can lead to LXR malfunction.\n"; print "\n"; if ('q' eq get_user_choice ( 'Do you want to quit or manually restore context?' , 1 , [ 'quit', 'restore' ] , [ 'q', 'r' ] ) ) { exit 1; }; $reloadstatus = 1; } return $reloadstatus; } ############################################################## # # Save context for future additions # ############################################################## sub contextSave { my ($ctxtfile, $confout) = @_; if (open(DEST, '>', $ctxtfile)) { print DEST "# -*- mode: perl -*-\n"; print DEST "# Context file associated with $confout\n"; my @t = gmtime(time()); my ($sec, $min, $hour, $mday, $mon, $year) = @t; my $date_time = sprintf ( "%04d-%02d-%02d %02d:%02d:%02d" , $year + 1900, $mon + 1, $mday , $hour, $min, $sec ); print DEST "# Created $date_time UTC\n"; print DEST "# Strictly internal, do not play with content\n"; print DEST "\$context_created = $context_version;\n"; print DEST "\n"; print DEST "\$cardinality = '$cardinality';\n"; print DEST "\$dbpolicy = '$dbpolicy';\n"; print DEST "\$dbengine = '$dbengine';\n"; if ("g" eq $dbpolicy) { print DEST "\$dbname = '$dbname';\n"; } if ($nodbuser) { print DEST "\$nodbuser = 1;\n"; } else { print DEST "\$dbuser = '$dbuser';\n"; print DEST "\$dbpass = '$dbpass';\n"; } if ($nodbprefix) { print DEST "\$nodbprefix = 1;\n"; } else { print DEST "\$dbprefix = '$dbprefix'\n"; } close(DEST) or print "${VTyellow}WARNING:${VTnorm} error $! when closing context file ${VTbold}$confout${VTnorm}!\n"; } else { print "${VTyellow}WARNING:${VTnorm} could not create context file ${VTbold}$confout${VTnorm}, autoreload disabled!\n"; } } ############################################################## # # Describe database context # ############################################################## sub contextDB { my ($verbose) = @_; $dbengine = get_user_choice ( 'Database engine?' , 1 , [ 'mysql', 'oracle', 'postgres', 'sqlite' ] , [ 'm', 'o', 'p', 's' ] ); # Are we configuring for single tree or multiple trees? $cardinality = get_user_choice ( 'Configure for single/multiple trees?' , 1 , [ 's', 'm' ] , [ 's', 'm' ] ); if ($cardinality eq 's') { if ('y' eq get_user_choice ( 'Do you intend to add other trees later?' , 2 , [ 'yes', 'no' ] , [ 'y', 'n'] ) ) { $cardinality = 'm'; print "${VTyellow}NOTE:${VTnorm} installation switched to ${VTbold}multiple${VTnorm} mode\n"; print " but describe just a single tree.\n"; } else { $dbpolicy = 't'; $nodbuser = 1; $nodbprefix = 1; } } if ($cardinality eq 'm') { if ('o' ne $dbengine) { if ($verbose > 1) { print "The safest option is to create one database per tree.\n"; print "You can however create a single database for all your trees with a specific set of\n"; print "tables for each tree (though this is not recommended).\n"; } $dbpolicy = get_user_choice ( 'How do you setup the databases?' , 1 , [ 'per tree', 'global' ] , [ 't', 'g' ] ); if ($dbpolicy eq 'g') { # Single global database if ('s' eq $dbengine) { $dbname = get_user_choice ( 'Name of global SQLite database file? (e.g. /home/myself/SQL-databases/lxr' , -2 , [] , [] ); } else { $dbname = get_user_choice ( 'Name of global database?' , -1 , [] , [ 'lxr' ] ); } $nodbprefix = 1; } } else { if ($verbose > 1) { print "There is only one global database under Oracle.\n"; print "The tables for each tree are identified by a unique prefix.\n"; } $dbpolicy = 'g'; $nodbprefix = 1; } if ($verbose > 1) { print "All databases can be accessed with the same username and\n"; print "can also be described under the same names.\n"; } if ('n' eq get_user_choice ( 'Will you share database characteristics?' , 1 , [ 'yes', 'no' ] , [ 'y', 'n'] ) ) { $nodbuser = 1; $nodbprefix = 1; } } elsif ('o' eq $dbengine) { $dbpolicy = 'g'; $nodbuser = undef; } if (!defined($nodbuser)) { if ( $dbpolicy eq 'g' || 'y' eq get_user_choice ( 'Will you use the same username and password for all DBs?' , 1 , [ 'yes', 'no' ] , [ 'y', 'n'] ) ) { $dbuser = get_user_choice ( '--- DB user name?' , -1 , [] , [ 'lxr' ] ); $dbpass = get_user_choice ( '--- DB password ?' , -1 , [] , [ 'lxrpw' ] ); } else { $nodbuser = 1; } } if (!defined($nodbprefix)) { if ('y' eq get_user_choice ( 'Will you give the same prefix to all tables?' , 1 , [ 'yes', 'no' ] , [ 'y', 'n'] ) ) { $dbprefix = get_user_choice ( '--- Common table prefix?' , -1 , [] , [ 'lxr_' ] ); }else { $nodbprefix = 1; } } } 1; --- NEW FILE: LCLInterpreter.pm --- # -*- tab-width: 4 -*- ############################################### # # $Id: LCLInterpreter.pm,v 1.1 2013/01/11 11:53:13 ajlittoz Exp $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ############################################### # $Id: LCLInterpreter.pm,v 1.1 2013/01/11 11:53:13 ajlittoz Exp $ package LCLInterpreter; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw( &expand_hash &expand_slash_star &pass2_hash &pass2_slash_star ); use strict; # use File::Path; use lib do { $0 =~ m{(.*)/}; "$1" }; use QuestionAnswer; use VTescape; ############################################################## # # LXR Control Language Interpreter # ############################################################## # LCL is embedded inside file comments. The exact nature of a # 'comment' is defined by the derived classes which hand over # the comment content for interpretation. # A comment is an LCL candidate if it has the following form: # 1. Comment starts in column 1 # This allows to have arbitrary comment anywhere else, # even if it looks like an LCL statement. # 2. @ immediately follows the starting comment delimiter # 3. The rest of the comment will be scanned by the interpreter. # *** LCL statements *** # == Syntax == # = Comment = # Beware that the parser is very very simple. The commands cannot contain # any form of comment. This would severely disturb the expression scanner. # = Label: @<label>:[<label:] = # <label> is a string of a-zA-Z0-9_ followed by a colon, without # intervening whitespace. If more than one label is needed, repeat the # construct without intervening whitespace. # NOTE: in the present implementation, labels cannot prefix a command. # In context where labels are meaningful (i.e. @CASE blocks), the # line containing the label is eaten up by skipping code. When # control is returned to the interpreter, this line is lost. # It can no longer trigger any action. # = Statement: @<name> [<arguments>] # <name> is an alphanumeric string. Case is indifferent. # The following sections list the known statements. # An error is issued for an unknown statement . # == Message display == # @LOG message # @MSG message # @REMIND message # @ERROR message # These statements print their argument depending on "verbosity". # @ERROR and @REMIND are always displayed, @LOG is displayed under moderate # verbosity and @MSG under full verbosity. # Note that message does not require delimiters. Everything after the # whitespace following command name is part of the message. # == Conditional commands == # Conditional blocks may be nested. # @IF <expr> # @ELSEIF <expr> # @ELSE # @ENDIF # @CASE <variable> # <Label> # @ENDC # == User interaction == # Single shot, with input kept in <var>: # @ASK[,<var>] <question>; <kind>; <choices>; <answers> # Continuous until empty answer, with input kept in <var>: # @KEEPON[,<var>] <question>[; -2] # @ON first # @ENDON # @ON last # @ENDON # @ON none # @ENDON # @ENDK # By convention, <var> name is a single uppercase letter. # kind defines the expected answer: # -3 any, empty string allowed # -2 any but empty string is not allowed # -1 any, empty string implies default answer # 0 one among choices, empty string not allowed # i>0 one among choices, empty string means choice number i # choices is empty for -2 and -3 # answers provides "normalised" answers corresponding to choices. # If kind=-1, must define a default answer (possibly empty). # choices and answers are comma-separated lists. # Answer to question is stored for use in <var>, by default A. # The lines between @KEEPON and @ENDK are repetitively interpreted # with <var> containing the most recent "answer" from the user. # @KEEPON implicitly uses a -3 "kind" since it is necessary to allow a # "bare" empty answer to exit the loop. # @KEEPON blocks may be nested in other conditional blocks and may # contain arbitrary content, including other @KEEPON blocks. # == Variable definition == # @DEFINE <var>=<expr> # Define a %marker% (% characters are internally added) equal to the # value of an expression. # Afterwards, %marker% can be used for substitution. # NOTE: since the simple parser only allows for A-Za-z0-9_ characters # in both marker and option, a translation is needed between the # shell option name and the #@D option name. # This is done through the hash reference $option_trans, i.e. # $$option_trans{'option'} gives the value to use. # == Shell command insertion == # @XQT <shell command> # Insert <shell command> into the output stream when generating for a # shell (i.e. marker %_shell% defined and non zero). # == File inclusion == # @ADD <filename> # Interpretation continues inside <filename> which may itself contain # other @ADD commands. # Limitations: # 1. @ADD is effective only when met while interpreting. @ADD is not # taken into account when it appears inside skipped blocks (inactive # branch of @IF/@ELSE/@ENDIF or unselected case of @CASE/@ENDK, ...) # 2. Consequence of 1., do not open any block (@CASE, @IF, @KEEPON, # @PASS2) in one file and put the closing command in another file. # Due to the possible skip of intervening statements, the @ADD # containing the opening orclosing statement might be not # interpreted and the stream will appear incorrectly bracketed. # File name path: the current directory is the one in effect when the # configurator is launched. It might be better to use OS-absolute paths. # == Delayed interpretation == # @PASS2 <label> # @ENDP2 # Mark a block for later interpretation (mainly used to add tree # specific sections into the output stream). # @PASS2 blocks cannot be nested. # During pass 1, add label <label> into the output stream and skip # interpretation of block. # During pass 2 and following, template is read sequentially for @PASS2. # When one is found, output stream is advanced up to the corresponding # label which is replaced by the interpreted content of block and <label> # is written again. Other @PASS2 blocks are looked for until EOF. # NOTE: Due to the scanning difference between pass 1 and 2, statements # @PASS2 and @ENDP2 must not be coded inside @ADD'ed files or # nested in @IF, @CASE or @KEEPON blocks. # @PASS2 blocks may contain @ASK or @KEEPON statements, but this # is not recommended unless they are preceded by explicit @LOG # or @MSG clearly showing we are in pass 2. ############################################################## # # Part 1: template file expansion # ############################################################## sub expand_hash { my @args = @_; expand ( @args , '#', '' , '~~~TO~EOF~~~' # Hope this is never used as a label! ); } sub expand_slash_star { my @args = @_; expand ( @args , qr(/\*), qr(\*/) , '~~~TO~EOF~~~' # Hope this is never used as a label! ); } sub expand { my ($source, $dest, $markers, $verbose, $comstart, $comend, $end_label) = @_; my $line; SCAN: while ($line = &$source()) { # Are we done? return parse_statement ($line, $comstart, $comend) if $line =~ m/^${comstart}\@$end_label/; # Suppress erasable comments if ($comend eq '') { if ( $line =~ s/${comstart}-.*// && $line =~ m/^\s*\n$/ ) { next; } } else { if ($line =~ m:${comstart}-:) { $line =~ s:(.*?)${comstart}-::; my $linehead = $1; if ($line =~ s:.*?-${comend}::) { $line = $linehead . $line; redo SCAN if $line !~ m/^\s*\n$/; } else { if ($linehead !~ m/^\s*$/) { print $dest $linehead, "\n"; } while ($line = &$source()) { if ($line =~ m:-${comend}:) { $line =~ s:.*?-${comend}::; redo SCAN if $line !~ m/^\s*\n$/; last; } } } next; } } ############################################# # # Statement interpreter # ############################################# # Is this an LCL statement? if ($line =~ m/^${comstart}@/) { my ($args, $var, $command, @labels) = parse_statement($line, $comstart, $comend); if ($command eq '') { # Label only? # Keep it in output file (NOTE: should not occur) # Fault-tolerant substitution line } elsif ($command eq 'U') { # Is processed below # Shell command } elsif ($command eq 'XQT') { if ($$markers{'%_shell%'}) { $line =~ s:^${comstart}\@${command}\s(.*)\s*${comend}\s*\n:$1\n:; } #else { # Uncomment to remove line from output # next; #} # Is further processed below # Messages } elsif ($command eq 'ERROR') { print "${VTred}ERROR:${VTnorm} $args\n"; next; } elsif ($command eq 'REMIND') { print "${VTyellow}Reminder:${VTnorm} $args\n"; next; } elsif ($command eq 'LOG') { print "${VTyellow}***${VTnorm} $args\n" if $verbose; next; } elsif ($command eq 'MSG') { print "${VTyellow}***${VTnorm} $args\n" if $verbose > 1; next; # User interaction } elsif ( $command eq 'ASK') { substitute_markers (\$args, $markers, $comstart, $comend); $$markers{"%$var%"} = ask_question($args); next; } elsif ($command eq 'KEEPON') { my %keep; if ($args =~ s/;\s*(-\d+)$//) { if ($1 != -2 && $1 != -3) { print "${VTred}ERROR:${VTnorm} illegal type $1 question for \@KEEPON!\n"; $args .= ';-3'; } else { $args .= ";$1"; } } else { $args .= ';-3'; } substitute_markers (\$args, $markers, $comstart, $comend); $keep{'q'} = $args; $keep{'v'} = $var; my @kbody; while ($command ne 'ENDK') { $line = &$source(); if ($line =~ m/${comstart}\@/) { ($args, $var, $command, @labels) = parse_statement($line, $comstart, $comend); last if $command eq 'ENDK'; if ($command eq 'ON') { my ($type) = $args =~ m/^(\w+)(?:\s|$)/; $type = lc($type); if ( $type ne 'first' && $type ne 'last' && $type ne 'none' ) { print "${VTred}ERROR:${VTnorm} unknown $type KEEPON action type!\n"; skip_until ( $source , qr/ENDON\b/i , 'KEEPON', 'ENDK' , $comstart, $comend ) } else { $keep{$type} = [ grab_block ( $source , qr/ENDON\b/i , 'KEEPON', 'ENDK' , $comstart, $comend ) ]; } } elsif ($command eq 'KEEP') { push ( @kbody , grab_block ( $source , qr/ENDK\b/i , 'KEEPON', 'ENDK' , $comstart, $comend ) ); } else { push (@kbody, $line); } } else { push (@kbody, $line); } } $keep{'body'} = [ @kbody ]; my $answer = ask_question($keep{'q'}); $$markers{"%${keep{'v'}}%"} = $answer; $keep{'q'} =~ s/;-2$/;-3/; # Ensure loop can be left if ($answer eq '') { # initial answer is empty, block is skipped. # See if action 'none' should be triggered. if (exists($keep{'none'})) { @kbody = @{$keep{'none'}}; expand ( sub { pop(@kbody) } , $dest , $markers , $verbose , $comstart, $comend , '~~~TO~EOF~~~' ); } next; } if (exists($keep{'first'})) { @kbody = @{$keep{'first'}}; expand ( sub { pop(@kbody) } , $dest , $markers , $verbose , $comstart, $comend , '~~~TO~EOF~~~' ); } while ($answer ne '') { @kbody = @{$keep{'body'}}; expand ( sub { pop(@kbody) } , $dest , $markers , $verbose , $comstart, $comend , '~~~TO~EOF~~~' ); $answer = ask_question($keep{'q'}); $$markers{"%${keep{'v'}}%"} = $answer; } if (exists($keep{'last'})) { @kbody = @{$keep{'last'}}; expand ( sub { pop(@kbody) } , $dest , $markers , $verbose , $comstart, $comend , '~~~TO~EOF~~~' ); } next; # Conditional block } elsif ($command eq 'IF') { while ($command ne 'ENDIF') { if ( $command eq 'ELSE' || evaluate_expr($args, $markers) ) { ($args, $var, $command, @labels) = expand ( $source, $dest , $markers , $verbose , $comstart, $comend , qr/\s*(ELSE(IF)?|ENDIF)\b/i ) ; if ($command ne 'ENDIF') { skip_until ( $source , qr/ENDIF\b/i , 'IF', 'ENDIF' , $comstart, $comend ) } ; last } ; ($args, $var, $command, @labels) = skip_until ( $source , qr/(ELSE(IF)?|ENDIF)\b/i , 'IF', 'ENDIF' , $comstart, $comend ) } next; # Selection block } elsif ($command eq 'CASE') { my $thecase = evaluate_expr($args, $markers); while (1) { ($args, $var, $command, @labels) = skip_until ( $source , qr/(\w+):/ , 'CASE', 'ENDC' , $comstart, $comend ) ; if ($command eq 'ENDC') { print "${VTred}ERROR:${VTnorm} no '$thecase' case label!\n"; ; last } ; if (grep {$thecase eq $_} @labels) { ($args, $var, $command, @labels) = expand ( $source, $dest , $markers , $verbose , $comstart, $comend , qr/((\w+):|((?i)\s*ENDC\b))/ ) ; if ($command ne 'ENDC') { skip_until ( $source , qr/ENDC\b/i , 'CASE', 'ENDC' , $comstart, $comend ) } ; last } } next; # Symbol definition } elsif ( $command eq 'DEFINE') { my ($var, $string) = ($args =~ m/^(\w+)\s*=\s*(.+)/); if (substr($var, 0, 1) eq '_') { print "${VTred}ERROR:${VTnorm} can't set read-only variable $var!\n"; } else { $$markers{"\%$var\%"} = evaluate_expr($string, $markers); } next; # Include a file } elsif ($command eq 'ADD') { if (!defined($args)) { print "${VTred}ERROR:${VTnorm} no file target on ADD!\n"; next; } my ($string) = ($args =~ m/^["']?(.+)["']?$/); $string = evaluate_expr("\"$string\"", $markers); if (open(ADD, '<', $string)) { expand ( sub { <ADD> } , $dest , $markers , $verbose , $comstart, $comend , '~~~TO~EOF~~~' ); } else { print "${VTred}ERROR:${VTnorm} couldn't open ADD'ed file \"${string}\"\n"; } close ADD; next; # Block for pass 2 } elsif ($command eq 'PASS2') { if (!defined($args)) { print "${VTred}ERROR:${VTnorm} PASS2 must define a label replacement for the block!\n"; $args = 'courtesy_label'; } # Replace the block with a label $line =~ s/^(${comstart}\@).+(${comend})\s*\n/$1${args}:$3\n/; skip_until ( $source , qr/ENDP2\b/i , '~~~TO~EOF~~~', '~~~TO~EOF~~~' , $comstart, $comend ) } elsif ( $command eq 'ELSE' || $command eq 'ELSEIF' || $command eq 'ENDIF' || $command eq 'ENDC' || $command eq 'ENDK' || $command eq 'ON' || $command eq 'ENDON' || $command eq 'PASS2' ) { print "${VTred}ERROR:${VTnorm} spurious $command!\n"; next; } else { # Unknown LCL statement print "${VTred}ERROR:${VTnorm} unknown command $command!\n"; next; } } # Substitute marker value substitute_markers (\$line, $markers, $comstart, $comend); print $dest $line; } } ############################################################## # # Part 2: special block expansion/insertion for # second and eventual subsequent passes # ############################################################## sub pass2_hash { my @args = @_; pass2 (@args, '#', ''); } sub pass2_slash_star { my @args = @_; pass2 (@args, qr(/\*), qr(\*/)); } sub pass2 { my ($source, $dest, $markers, $verbose, $comstart, $comend) = @_; my $line; unless (open(DESTIN, '<', $dest)) { die("${VTred}ERROR:${VTnorm} couldn't reread output file \"$dest\"\n"); } unless (open(DESTOUT, '>', "$dest.LXR")) { die("${VTred}ERROR:${VTnorm} couldn't open temporary file \"$dest\"\n"); } while ($line = <$source>) { if ($line =~ m/^${comstart}\@\s*PASS2\b/) { my ($args, $var, $command, @labels) = parse_statement($line, $comstart, $comend); if (!defined($args)) { print "${VTred}Warning:${VTnorm} using a courtesy label for missing PASS2 label!\n"; $args = 'courtesy_label'; } my $mark_label = $line; $mark_label =~ s/^(${comstart}\@).+(${comend})\s*\n/$1${args}:$2\n/; # Position destination file on corresponding label while (<DESTIN>) { last if m/^${comstart}\@$args:/; print DESTOUT $_; } if (!defined($line)) { print "${VTred}Error:${VTnorm} label $args not found in destination file!\n"; return; } # Expand dedicated block expand ( sub { <$source> }, \*DESTOUT , $markers , $verbose , $comstart, $comend , qr/s*ENDP2\b/i ); # Rewrite lable for eventual other passes print DESTOUT $mark_label; } } # Copy rest of destination file while (<DESTIN>) { print DESTOUT $_; } # Switch files close(DESTIN); close(DESTOUT); unlink $dest; rename "$dest.LXR", $dest; } ############################################################## # # Auxiliary routines # ############################################################## # parse_statement splits an LCL statement into components # Command name is uppercased to ease processing independent of # case. If no variable is defined, a default A is provided. sub parse_statement { my ($line, $comstart, $comend) = @_; $line =~ s/^${comstart}@//; # Get rid of prefix my @labels; while ($line =~ s/^(\w+)://g) { # Grab labels push @labels, $1; } $line =~ s/^\s*(\w+)//; # Grab command name my $command = uc($1); my $var = 'A'; # Grab var name $var = $1 if $line =~ s/^,(\w+)//; my ($args) = ($line =~ m/^\s+(.*)\s*${comend}\s*\n/); return ($args, $var, $command, @labels); } # substitute_markers replaces %xxx% occurrences by value of # marker xxx. If original string is prefixed by LCL command # @U, no error is issued for unknown marker and command prefix is # left in place (so that the string looks like a comment), # otherwise the @U command is transformed into a common string. sub substitute_markers { my ($line, $markers, $comstart, $comend) = @_; if ($$line =~ m/%\w+%/) { my $line_sub; my $failure = 0; my $optional_subst = $$line =~ m/^${comstart}\@U/; while ($$line =~ s/^(.*?)(%\w+%)//) { $line_sub .= $1; if (exists($$markers{$2})) { $line_sub .= $$markers{$2}; } else { $line_sub .= $2; $failure = 1; if (!$optional_subst) { print "${VTred}ERROR:${VTnorm} unknown $2 substitution marker!\n"; } } } $$line = $line_sub . $$line; if ( !$failure && $optional_subst && $$line =~ s/^${comstart}\@U// ) { $$line =~ s/\s*${comend}\s*\n/\n/; } } } # evaluate_expr evaluate its argument as a Perl expression # (mainly string comparisons). # Occurrences of %xxx% are transformed into local string variables. # NOTE: do not abuse expression complexity! The configurator may # some day be rewritten in another language where expression # evaluation will have to be programmed. Its power will certainly # be limited to basic needs such as string comparison and logical # combination. sub evaluate_expr { my ($expr, $markers) = @_; my %exprvars; my $theeval; # List used variables and check for illegal computation # NOTE: $op can be extended for more complex valid expressions my $op = qr/(?:eq|ne)/; while ($expr =~ m/($op\s*)?%(\w+)%(\s*$op)?/g) { # Make a difference between test for existence/definedness and # usage in a comparison/computation where value is needed if ( (defined($1) || defined($3)) && !exists($$markers{"\%$2\%"})) { print "${VTred}ERROR:${VTnorm} unknown $2 substitution marker!\n"; } }; my @allvars = ($expr =~ m/%(\w+)%/g); for (@allvars) { $exprvars{$_} = 1; } # Build the expression to evaluate $expr =~ s/%(\w+)%/\$\{_${1}_\}/g; foreach my $newvar (keys %exprvars) { $theeval .= 'my $_' . $newvar . '_ = "' . $$markers{"\%$newvar\%"} . '"; '; } $theeval .= $expr; my $res = eval($theeval); if ($@) { print "${VTred}ERROR:${VTnorm} bad expression: $@"; print "${VTyellow}$expr${VTnorm}\n"; return undef; } return $res; } # skip_until skips lines until a matching sentinel # is found. It takes care of nested blocks. sub skip_until { my ($source, $sentinel, $begin, $end, $comstart, $comend) = @_; my $stop; if ($sentinel =~ m/\):/) { $stop = qr/^${comstart}\@${sentinel}/; } else { $stop = qr/^${comstart}\@\s*${sentinel}/; } my $start_block = qr/^${comstart}\@\s*${begin}\b\s/i; my $end_block = qr/^${comstart}\@\s*${end}\b/i; my $nesting = 0; while (my $line = &$source()) { if ($line =~ m/$end_block/) { return parse_statement($line, $comstart, $comend) if $nesting == 0; $nesting--; next; } if ($line =~ m/$start_block/) { $nesting++; next; } if ( $nesting == 0 && $line =~ m/$stop/ ) { return parse_statement($line, $comstart, $comend); } } print "${VTred}ERROR:${VTnorm} improper nesting of conditional block!\n"; print "${VTred}ERROR:${VTnorm} still expecting $stop sentinel!\n"; die "Conditional block overflow"; } # grab_block stores lines until a matching sentinel # is found. It takes care of nested blocks. sub grab_block { my ($source, $sentinel, $begin, $end, $comstart, $comend) = @_; my @blocklines; my $stop; if ($sentinel =~ m/\):/) { $stop = qr/^${comstart}\@${sentinel}/; } else { $stop = qr/^${comstart}\@\s*${sentinel}/; } my $start_block = qr/^${comstart}\@\s*${begin}\s/i; my $end_block = qr/^${comstart}\@\s*${end}\b/i; my $nesting = 0; while (my $line = &$source()) { if ($line =~ m/$end_block/) { # Finding an end-of-block sentinel before the correct termination # is an error when recording sample code. This will be catched # at EOF (or, at least, I hope). # return @blocklines if $nesting == 0; $nesting--; next; } if ($line =~ m/$start_block/) { $nesting++; next; } if ( $nesting == 0 && $line =~ m/$stop/ ) { return @blocklines; } push @blocklines, $line; } print "${VTred}ERROR:${VTnorm} improper sample block limits!\n"; print "${VTred}ERROR:${VTnorm} still expecting $sentinel sentinel!\n"; die "Sample block overflow"; } # ask_question requests an answer from user. # This is an interface to get_user_choice in QuestionAnswer.pm sub ask_question { my ($qtext, $qdeft, $choices, $answer); my (@choices, @answers); $#choices = -1; $#answers = -1; ($qtext, $qdeft, $choices, $answer) = split(/;/, shift); if (defined($choices)) { @choices = map({s/^\s*(.*)\s*$/$1/; $_} split(/,/, $choices)); } if (defined($answer)) { @answers = map({s/^\s*(.*)\s*$/$1/; $_} split(/,/, $answer)); } $answer = get_user_choice ( $qtext , $qdeft , defined($choices) ? \@choices : undef , defined($answer) ? \@answers : undef ); return $answer; } 1; Index: configure-lxr.pl =================================================================== RCS file: /cvsroot/lxr/lxr/scripts/configure-lxr.pl,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- configure-lxr.pl 30 Sep 2012 07:27:06 -0000 1.5 +++ configure-lxr.pl 11 Jan 2013 11:53:13 -0000 1.6 @@ -26,8 +26,9 @@ use Getopt::Long qw(:config gnu_getopt); use File::Path qw(make_path); use lib do { $0 =~ m{(.*)/}; "$1" }; -use ExpandHash; -use ExpandSlashStar; + +use ContextMgr; +use LCLInterpreter; use QuestionAnswer; use VTescape; @@ -81,7 +82,8 @@ , 'root-dir=s' => \$rootdir , 'script-out=s'=> \$scriptout , 'tmpl-dir=s' => \$tmpldir - , 'verbose|v' => \$verbose + , 'verbose:2' => \$verbose + , 'v+' => \$verbose , 'version' ) ) { @@ -232,60 +234,14 @@ if ($verbose) { print "\n"; } - -my $cardinality; -my $dbengine; -my $dbenginechanged = 0; -my $dbpolicy; -my $dbname; -my $dbuser; -my $dbpass; -my $dbprefix; -my $nodbuser; -my $nodbprefix; my %users; # Cumulative list of all user/password -# WARNING: remember to increment this number when changing the -# set of state variables and/or their meaning. -my $context_version = 1; - if ($addtree) { if ($verbose) { print "== ${VTyellow}ADD MODE${VTnorm} ==\n"; print "\n"; } - if (my $c=open(SOURCE, '<', "$confdir/$contextfile")) { - print "Initial context $confdir/$contextfile is reloaded\n" if $verbose; - $/ = undef; - my $context = <SOURCE>; - $/ = $oldsep; - close(SOURCE); - my $context_created; - eval($context); - if (!defined($context_created)) { - print "${VTred}ERROR:${VTnorm} saved context file probably damaged!\n"; - print "Check variable not found\n"; - print "Delete or rename file $confdir/$contextfile to remove lock.\n"; - exit 1; - } - if ($context_created != $context_version) { - print "${VTred}ERROR:${VTnorm} saved context file probably too old!\n"; - print "Recorded state version = $context_created while expecting version = $context_version\n"; - print "It is wise to 'quit' now and add manually the new tree or reconfigure from scratch.\n"; - print "You can however try to restore the initial context at your own risk.\n"; - print "\n"; - print "${VTyellow}WARNING:${VTnorm} inconsistent answers can lead to LXR malfunction.\n"; - print "\n"; - if ('q' eq get_user_choice - ( 'Do you want to quit or manually restore context?' - , 1 - , [ 'quit', 'restore' ] - , [ 'q', 'r' ] - ) ) { - exit 1; - } - $addtree = 2; - }; + $addtree += contextReload ($verbose, "$confdir/$contextfile"); if ($cardinality eq 's') { print "${VTred}ERROR:${VTnorm} initial configuration was done for a single tree!\n"; print "This is not compatible with the present web server configuration.\n"; @@ -293,30 +249,6 @@ exit 1; } if ($dbpolicy eq 't') { - print "Your DB engine was: ${VTbold}"; - if ("m" eq $dbengine) { - print "MySQL"; - } elsif ("o" eq $dbengine) { - print "Oracle"; - } elsif ("p" eq $dbengine) { - print "PostgreSQL"; - } elsif ("s" eq $dbengine) { - print "SQLite"; - } else { - print "???${VTnorm}\n"; - print "${VTred}ERROR:${VTnorm} saved context file damaged or tampered with!\n"; - print "Unknown database code '$dbengine'\n"; - print "Delete or rename file $confdir/$contextfile to remove lock.\n"; - if ('q' eq get_user_choice - ( 'Do you want to quit or manually restore context?' - , 1 - , [ 'quit', 'restore' ] - , [ 'q', 'r' ] - ) ) { - exit 1; - } - $addtree = 2; - }; print "${VTnorm}\n"; print "Advanced users can configure different DB engines for different trees.\n"; print "This is not recommended for average users.\n"; @@ -335,32 +267,10 @@ $dbenginechanged = 1; } } - } else { - print "${VTyellow}WARNING:${VTnorm} could not reload context file ${VTbold}$confout${VTnorm}!\n"; - print "You may have deleted the context file or you moved the configuration\n"; - print "file out of the ${VTbold}${confdir}${VTnorm} user-configuration directory without the\n"; - print "context companion file ${VTyellow}$contextfile${VTnorm}.\n"; - print "\n"; - print "You can now 'quit' to think about the situation or try to restore\n"; - print "the parameters by answering the following questions\n"; - print "(some clues can be gathered from reading configuration file ${VTbold}$confout${VTnorm}).\n"; - print "\n"; - print "${VTyellow}WARNING:${VTnorm} inconsistent answers can lead to LXR malfunction.\n"; - print "\n"; - if ('q' eq get_user_choice - ( 'Do you want to quit or manually restore context?' - , 1 - , [ 'quit', 'restore' ] - , [ 'q', 'r' ] - ) ) { - exit 1; - }; - $addtree = 2; - } } if ($addtree != 1) { - if ($verbose) { + if ($verbose > 1) { print "The choice of the database engine can make a difference in indexing performance,\n"; print "but resource consumption is also an important factor.\n"; print " * For a small personal project, try ${VTbold}SQLite${VTnorm} which do not\n"; @@ -376,132 +286,9 @@ print " of bigger databases.\n"; print " * Take also in consideration the number of connected users.\n"; } - $dbengine = get_user_choice - ( 'Database engine?' - , 1 - , [ 'mysql', 'oracle', 'postgres', 'sqlite' ] - , [ 'm', 'o', 'p', 's' ] - ); - - # Are we configuring for single tree or multiple trees? - $cardinality = get_user_choice - ( 'Configure for single/multiple trees?' - , 1 - , [ 's', 'm' ] - , [ 's', 'm' ] - ); - - if ($cardinality eq 's') { - if ('y' eq get_user_choice - ( 'Do you intend to add other trees later?' - , 2 - , [ 'yes', 'no' ] - , [ 'y', 'n'] - ) - ) { - $cardinality = 'm'; - print "${VTyellow}NOTE:${VTnorm} installation switched to ${VTbold}multiple${VTnorm} mode\n"; - print " but describe just a single tree.\n"; - } else { - $dbpolicy = 't'; - $nodbuser = 1; - $nodbprefix = 1; - } - } - - if ($cardinality eq 'm') { - if ('o' ne $dbengine) { - print "The safest option is to create one database per tree.\n"; - print "You can however create a single database for all your trees with a specific set of\n"; - print "tables for each tree (though this is not recommended).\n"; - $dbpolicy = get_user_choice - ( 'How do you setup the databases?' - , 1 - , [ 'per tree', 'global' ] - , [ 't', 'g' ] - ); - if ($dbpolicy eq 'g') { # Single global database - if ('s' eq $dbengine) { - $dbname = get_user_choice - ( 'Name of global SQLite database file? (e.g. /home/myself/SQL-databases/lxr' - , -2 - , [] - , [] - ); - } else { - $dbname = get_user_choice - ( 'Name of global database?' - , -1 - , [] - , [ 'lxr' ] - ); - } - $nodbprefix = 1; - } - } else { - print "There is only one global database under Oracle.\n"; - print "The tables for each tree are identified by a unique prefix.\n"; - $dbpolicy = 'g'; - $nodbprefix = 1; - } - print "All databases can be accessed with the same username and\n"; - print "can also be described under the same names.\n"; - if ('n' eq get_user_choice - ( 'Will you share database characteristics?' - , 1 - , [ 'yes', 'no' ] - , [ 'y', 'n'] - ) - ) { - $nodbuser = 1; - $nodbprefix = 1; - } - } - - if (!defined($nodbuser)) { - if ( $dbpolicy eq 'g' - || 'y' eq get_user_choice - ( 'Will you use the same username and password for all DBs?' - , 1 - , [ 'yes', 'no' ] - , [ 'y', 'n'] - ) - ) { - $dbuser = get_user_choice - ( '--- DB user name?' - , -1 - , [] - , [ 'lxr' ] - ); - $dbpass = get_user_choice - ( '--- DB password ?' - , -1 - , [] - , [ 'lxrpw' ] - ); - $users{$dbuser} = $dbpass; # Record global user/password - } else { - $nodbuser = 1; - } - } - - if (!defined($nodbprefix)) { - if ('y' eq get_user_choice - ( 'Will you give the same prefix to all tables?' - , 1 - , [ 'yes', 'no' ] - , [ 'y', 'n'] - ) - ) { - $dbprefix = get_user_choice - ( '--- Common table prefix?' - , -1 - , [] - , [ 'lxr_' ] - ); - }else { - $nodbprefix = 1; - } + contextDB ($verbose); + if ($dbuser) { + $users{$dbuser} = $dbpass; # Record global user/password } } @@ -512,41 +299,7 @@ ############################################################## if (!$addtree) { - if (open(DEST, '>', "$confdir/$contextfile")) { - print DEST "# -*- mode: perl -*-\n"; - print DEST "# Context file associated with $confout\n"; - my @t = gmtime(time()); - my ($sec, $min, $hour, $mday, $mon, $year) = @t; - my $date_time = sprintf ( "%04d-%02d-%02d %02d:%02d:%02d" - , $year + 1900, $mon + 1, $mday - , $hour, $min, $sec - ); - print DEST "# Created $date_time UTC\n"; - print DEST "# Strictly internal, do not play with content\n"; - print DEST "\$context_created = $context_version;\n"; - print DEST "\n"; - print DEST "\$cardinality = '$cardinality';\n"; - print DEST "\$dbpolicy = '$dbpolicy';\n"; - print DEST "\$dbengine = '$dbengine';\n"; - if ("g" eq $dbpolicy) { - print DEST "\$dbname = '$dbname';\n"; - } - if ($nodbuser) { - print DEST "\$nodbuser = 1;\n"; - } else { - print DEST "\$dbuser = '$dbuser';\n"; - print DEST "\$dbpass = '$dbpass';\n"; - } - if ($nodbprefix) { - print DEST "\$nodbprefix = 1;\n"; - } else { - print DEST "\$dbprefix = '$dbprefix'\n"; - } - close(DEST) - or print "${VTyellow}WARNING:${VTnorm} error $! when closing context file ${VTbold}$confout${VTnorm}!\n"; - } else { - print "${VTyellow}WARNING:${VTnorm} could not create context file ${VTbold}$confout${VTnorm}, autoreload disabled!\n"; - } + contextSave ("$confdir/$contextfile", $confout); } ############################################################## @@ -555,27 +308,34 @@ # ############################################################## -my %option_trans = - ( 'add' => $addtree - , 'context' => $cardinality - , 'createglobals' => $cardinality eq 'm' +# %markers contains value for "options" (or their equivalent) +# which are not meant for substitution in the templates (this +# is indicated by the _ prefix, but not checked), +# and "substitution markers". +# From release 1.1 on, both are stuffed in the same hash since +# it simplifies processing in the macro interpreter. +my %markers = + ( '%_add%' => $addtree + , '%_singlecontext%' => $cardinality eq 's' + , '%_createglobals%' => $cardinality eq 'm' && ( 0 == $addtree || 1 == $dbenginechanged ) - , 'dbengine'=> $dbengine - , 'dbpass' => $dbpass - , 'dbpolicy'=> $dbpolicy - , 'dbprefix'=> $dbprefix - , 'dbuser' => $dbuser - , 'dbuseroverride' => 0 - , 'nodbuser'=> $nodbuser - , 'nodbprefix' => $nodbprefix + , '%_dbengine%' => $dbengine + , '%_dbpass%' => $dbpass + , '%_dbprefix%' => $dbprefix + , '%_dbuser%' => $dbuser + , '%_dbuseroverride%' => 0 + , '%_globaldb%' => $dbpolicy eq 'g' + , '%_nodbuser%' => $nodbuser + , '%_nodbprefix%' => $nodbprefix ); - -my %markers; my $sample; +$markers{'%LXRconfUser%'} = getlogin; # OS-user running configuration $markers{'%LXRroot%'} = $rootdir; +$markers{'%LXRtmpldir%'} = $tmpldir; +$markers{'%LXRconfdir%'} = $confdir; $sample = `command -v glimpse 2>/dev/null`; chomp($sample); $markers{'%glimpse%'} = $sample if $sample; @@ -687,6 +447,27 @@ # ############################################################## +sub copy_and_configure_template { + my ($fin, $fout, $target) = @_; + + unless (open(SOURCE, '<', $fin)) { + die("${VTred}ERROR:${VTnorm} couldn't open template file \"$fin\"\n"); + } + unless (open(DEST, '>', $fout)) { + die("${VTred}ERROR:${VTnorm} couldn't open output file \"$fout\n"); + } + expand_hash ( sub{ <SOURCE> } + , \*DEST + , \%markers + , $verbose + ); + close(DEST); + close(SOURCE); + if ($target && $verbose) { + print "file ${VTbold}$target${VTnorm} written into configuration directory\n" + } +} + if (!$addtree) { print "\n" if $verbose; @@ -696,87 +477,46 @@ } my $target; - my $target_contents; # Apache: per-directory access control file $target = '.htaccess'; `cp ${tmpldir}/Apache/htaccess-generic ${rootdir}/$target`; chmod(0775, "${rootdir}/$target"); - if ($verbose) { + if ($target && $verbose) { print "file ${VTbold}$target${VTnorm} written into LXR root directory\n" } # Apache: mod_perl startup file $target = 'apache2-require.pl'; - unless (open(SOURCE, '<', "${tmpldir}/Apache/$target")) { - die("${VTred}ERROR:${VTnorm} couldn't open template file \"${tmpldir}/Apache/$target\"\n"); - } - $/ = undef; - $target_contents = <SOURCE>; - $/ = $oldsep; - close(SOURCE); - $target_contents =~ s/%LXRroot%/$rootdir/g; - unless (open(DEST, '>', "${confdir}/${target}")) { - die("${VTred}ERROR:${VTnorm} couldn't open output file \"${confdir}/$target\n"); - } - print DEST $target_contents; - close(DEST); - if ($verbose) { - print "file ${VTbold}$target${VTnorm} written into configuration directory\n" - } + copy_and_configure_template ( "${tmpldir}/Apache/$target" + , "${confdir}/${target}" + , $target + ); # Apache: LXR server configuration file $target = 'apache-lxrserver.conf'; - unless (open(SOURCE, '<', "${tmpldir}/Apache/$target")) { - die("${VTred}ERROR:${VTnorm} couldn't open template file \"${tmpldir}/Apache/$target\"\n"); - } - $/ = undef; - $target_contents = <SOURCE>; - $/ = $oldsep; - close(SOURCE); - $target_contents =~ s/%LXRroot%/$rootdir/g; - $target_contents =~ s/#=$cardinality=//g; - unless (open(DEST, '>', "${confdir}/${target}")) { - die("${VTred}ERROR:${VTnorm} couldn't open output file \"${confdir}/$target\n"); - } - print DEST $target_contents; - close(DEST); - if ($verbose) { - print "file ${VTbold}$target${VTnorm} written into configuration directory\n" - } + copy_and_configure_template ( "${tmpldir}/Apache/$target" + , "${confdir}/${target}" + , $target + ); # lighttpd: LXR server configuration file $target = 'lighttpd-lxrserver.conf'; - unless (open(SOURCE, '<', "${tmpldir}/lighttpd/$target")) { - die("${VTred}ERROR:${VTnorm} couldn't open template file \"${tmpldir}/lighttpd/$target\"\n"); - } - unless (open(DEST, '>', "${confdir}/${target}")) { - die("${VTred}ERROR:${VTnorm} couldn't open output file \"${confdir}/$target\"\n"); - } - # Expand initial part - expand_hash ( \*SOURCE - , \*DEST - , 'begin_virtroot' - , \%markers - , \%option_trans - , $verbose - ); - # Skip virtroot section template - while (<SOURCE>) { - last if m/^#\@end_virtroot/; - } - # Expand rest of model - expand_hash ( \*SOURCE - , \*DEST - , '~~~TO~EOF~~~' # Hope this is never used as a label! - , \%markers - , \%option_trans - , $verbose - ); - close(SOURCE); - close(DEST); - if ($verbose) { - print "file ${VTbold}$target${VTnorm} written into configuration directory\n" + copy_and_configure_template ( "${tmpldir}/lighttpd/$target" + , "${confdir}/${target}" + , $target + ); + + # Mercurial: extension and configuration file + if (-d "${tmpldir}/Mercurial") { + `cp ${tmpldir}/Mercurial/lxr-hg-ls.py ${confdir}/`; + $target = 'hg.rc'; + copy_and_configure_template ( "${tmpldir}/Mercurial/$target" + , "${confdir}/${target}" + ); + if ($verbose) { + print "${VTbold}Mercurial{VTnorm} support files written into configuration directory\n" + } } } ############################################################## @@ -792,35 +532,9 @@ print " Global section part\n"; print "\n"; } - - my $line; - - open(SOURCE, '<', "${tmpldir}/$lxrtmplconf") - or die("${VTred}ERROR:${VTnorm} couldn't open template file \"${tmpldir}/$lxrtmplconf\"\n"); - open(DEST, '>', "${confdir}/${confout}") - or die("${VTred}ERROR:${VTnorm} couldn't open output file \"${confdir}/$confout\"\n"); - - # Expand global section - expand_hash ( \*SOURCE - , \*DEST - , 'begin_tree' - , \%markers - , \%option_trans - , $verbose - ); - - # Skip tree section template - while (<SOURCE>) { - last if m/^#\@end_tree/; - } - - # Copy rest of model - while (<SOURCE>) { - print DEST; - } - - close(SOURCE); - close(DEST); + copy_and_configure_template ( "${tmpldir}/$lxrtmplconf" + , "${confdir}/${confout}" + ); } elsif ($dbenginechanged && !$nodbuser) { if ('n' eq get_user_choice ( 'Do you want to create the global DB user?' @@ -829,7 +543,7 @@ , [ 'y', 'n'] ) ) { - $option_trans{'createglobals'} = 0; + $markers{'%_createglobals%'} = 0; } } @@ -850,100 +564,33 @@ while (1) { # Start each iteration in default configuration - $option_trans{'add'} = $addtree; - $option_trans{'dbuseroverride'} = 0; + $markers{'%_add%'} = $addtree; + $markers{'%_dbuseroverride%'} = 0; delete $markers{'%DB_tree_user%'}; - delete $markers{'%DB_tree_password'}; + delete $markers{'%DB_tree_password%'}; delete $markers{'%DB_tbl_prefix%'}; unless (open(SOURCE, '<', "${tmpldir}/$lxrtmplconf")) { die("${VTred}ERROR:${VTnorm} couldn't open template file \"${tmpldir}/$lxrtmplconf\"\n"); } - unless (open(DEST, '+<', "${confdir}/${confout}")) { - die("${VTred}ERROR:${VTnorm} couldn't open output file \"${confdir}/$confout\"\n"); - } - - my $destpos = 0; - while (<DEST>) { - if (m/#\@here_tree\n/) { - last; - } - $destpos = tell; - } - my @deststat = stat(DEST); - if ($deststat[7] == $destpos) { - die("${VTred}ERROR:${VTnorm} couldn't find tree section before EOF in \"${confdir}/$lxrtmplconf\n"); - } - seek(DEST, $destpos, 0); # Position for write - $destpos = tell; - # Skip global section model - while (<SOURCE>) { - if (m/#\@begin_tree\n/) { - last; - } - } - - # Expand tree section - expand_hash ( \*SOURCE - , \*DEST - , 'end_tree' + pass2_hash ( \*SOURCE + , "${confdir}/${confout}" , \%markers - , \%option_trans , $verbose ); - # Copy rest of model - while (<SOURCE>) { - print DEST; - } - close(SOURCE); - close(DEST); # Update lighttpd configuration with the new 'virtroot' open(SOURCE, '<', "${tmpldir}/lighttpd/lighttpd-lxrserver.conf") or die("${VTred}ERROR:${VTnorm} couldn't open template file \"${tmpldir}/lighttpd/lighttpd-lxrserver.conf\"\n"); - open(DEST, '+<', "${confdir}/lighttpd-lxrserver.conf") - or die("${VTred}ERROR:${VTnorm} couldn't open configuration file \"${confdir}/lighttpd-lxrserver.conf\"\n"); - # Position output to variable section - my $destpos = 0; - while (<DEST>) { - if (m/#\@here_virtroot\n/) { - last; - } - $destpos = tell; - } - my @deststat = stat(DEST); - if ($deststat[7] == $destpos) { - die("${VTred}ERROR:${VTnorm} couldn't find 'virtroot' section before EOF in \"${confdir}/lighttpd-lxrserver.conf\n"); - } - seek(DEST, $destpos, 0); # Position for write - $destpos = tell; - # Skip fixed section model - while (<SOURCE>) { - if (m/#\@begin_virtroot\n/) { - last; - } - } - # Expand virtroot section of model - expand_hash ( \*SOURCE - , \*DEST - , 'end_virtroot' - , \%markers - , \%option_trans - , $verbose - ); - # Expand rest of model - expand_hash ( \*SOURCE - , \*DEST - , '~~~TO~EOF~~~' # Hope this is never used as a label! + pass2_hash ( \*SOURCE + , "${confdir}/lighttpd-lxrserver.conf" , \%markers - , \%option_trans , $verbose ); close(SOURCE); - close(DEST); # Have new DB user and password been defined? if (exists($markers{'%DB_tree_user%'})) { @@ -955,7 +602,7 @@ } } else { # Tell other templates something changed - $option_trans{'dbuseroverride'} = 1; + $markers{'%_dbuseroverride%'} = 1; $users{$markers{'%DB_tree_user%'}} = $markers{'%DB_tree_password'}; } } @@ -985,15 +632,13 @@ # This is why the 'shell' pseudo-option is created. # Of course, this statement would be better outside the loop, # but this comment would be far from expand_slash_star invocation. - $option_trans{'shell'} = 1; + $markers{'%_shell%'} = 1; # Expand script model - expand_slash_star ( \*SOURCE - , \*DEST - , '~~~TO~EOF~~~' # Hope this is never used as a label! - , \%markers - , \%option_trans - , $verbose - ); + expand_slash_star ( sub{ <SOURCE> } + , \*DEST + , \%markers + , $verbose + ); close(SOURCE); close(DEST); @@ -1012,7 +657,7 @@ } # Prevent doing one-time actions more than once $addtree = 1; # Same as adding a new tree - $option_trans{'createglobals'} = 0; + $markers{'%_createglobals%'} = 0; } ############################################################## Index: recreatedb.pl =================================================================== RCS file: /cvsroot/lxr/lxr/scripts/recreatedb.pl,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- recreatedb.pl 29 Sep 2012 20:30:46 -0000 1.4 +++ recreatedb.pl 11 Jan 2013 11:53:13 -0000 1.5 @@ -34,7 +34,8 @@ use LXR::Index; use LXR::Common; -use ExpandSlashStar; +use ContextMgr; +use LCLInterpreter; use QuestionAnswer; use VTescape; @@ -230,6 +231,7 @@ ############################################################## if ($verbose) { + $verbose = 2; # Force max verbosity in support routines print "${VTyellow}***${VTnorm} ${VTred}L${VTblue}X${VTgreen}R${VTnorm} DB initialisation reconstruction (version: $version) ${VTyellow}***${VTnorm}\n"; print "\n"; print "LXR root directory is ${VTbold}$rootdir${VTnorm}\n"; @@ -252,17 +254,6 @@ if ($verbose) { print "\n"; } - -my $cardinality; -my $dbengine; -my $dbenginechanged = 1; -my $dbpolicy; -my $dbname; -my $dbuser; -my $dbpass; -my $dbprefix; -my $nodbuser; -my $nodbprefix; my %users; # Cumulative list of all user/password # Flags for first use of DB engine my %dbengine_seen = @@ -279,91 +270,7 @@ # ############################################################## -# WARNING: remember to keep this number in sync with -# configure-lxr.pl. -my $context_version = 1; -my $manualreload = 0; - -if (my $c=open(SOURCE, '<', $lxrctx)) { - print "Initial context $lxrctx is reloaded\n" if $verbose; - $/ = undef; - my $context = <SOURCE>; - $/ = $oldsep; - close(SOURCE); - my $context_created; - eval($context); - if (!defined($context_created)) { - print "${VTred}ERROR:${VTnorm} saved context file probably damaged!\n"; - print "Check variable not found\n"; - print "Delete or rename file $lxrctx to remove lock.\n"; - exit 1; - } - if ($context_created != $context_version) { - print "${VTred}ERROR:${VTnorm} saved context file probably too old!\n"; - print "Recorded state version = $context_created while expecting version = $context_version\n"; - print "It is wise to 'quit' now and add manually the new tree or reconfigure from scratch.\n"; - print "You can however try to restore the initial context at your own risk.\n"; - print "\n"; - print "${VTyellow}WARNING:${VTnorm} inconsistent answers can lead to LXR malfunction.\n"; - print "\n"; - if ('q' eq get_user_choice - ( 'Do you want to quit or manually restore context?' - , 1 - , [ 'quit', 'restore' ] - , [ 'q', 'r' ] - ) ) { - exit 1; - } - $manualreload = 1; - }; - if ($dbpolicy eq 't') { - print "Your DB engine was: ${VTbold}" if $verbose; - if ("m" eq $dbengine) { - print "MySQL\n" if $verbose; - } elsif ("o" eq $dbengine) { - print "Oracle\n" if $verbose; - } elsif ("p" eq $dbengine) { - print "PostgreSQL\n" if $verbose; - } elsif ("s" eq $dbengine) { - print "SQLite\n" if $verbose; - } else { - print "???${VTnorm}\n" if $verbose; - print "${VTred}ERROR:${VTnorm} saved context file damaged or tampered with!\n"; - print "Unknown database code '$dbengine'\n"; - print "Delete or rename file $lxrctx to remove lock.\n"; - if ('q' eq get_user_choice - ( 'Do you want to quit or manually restore context?' - , 1 - , [ 'quit', 'restore' ] - , [ 'q', 'r' ] - ) ) { - exit 1; - } - $manualreload = 1; - }; - } -} else { - print "${VTyellow}WARNING:${VTnorm} could not reload context file ${VTbold}$lxrctx${VTnorm}!\n"; - print "You may have deleted the context file or you moved the configuration\n"; - print "file out of the ${VTbold}${confdir}${VTnorm} user-configuration directory without the\n"; - print "context companion file ${VTyellow}$lxrctx${VTnorm}.\n"; - print "\n"; - print "You can now 'quit' to think about the situation or try to restore\n"; - print "the parameters by answering the following questions\n"; - print "(some clues can be gathered from reading configuration file ${VTbold}$lxrconf${VTnorm}).\n"; - print "\n"; - print "${VTyellow}WARNING:${VTnorm} inconsistent answers can lead to LXR malfunction.\n"; - print "\n"; - if ('q' eq get_user_choice - ( 'Do you want to quit or manually restore context?' - , 1 - , [ 'quit', 'restore' ] - , [ 'q', 'r' ] - ) ) { - exit 1; - }; - $manualreload = 1; -} +my $manualreload = contextReload ($verbose, $lxrctx); if ($manualreload) { print "\n"; @@ -373,132 +280,9 @@ print "trees. Answer with the choices you made previously,\n"; print "otherwise your DB will not be what LXR expects.\n"; } - $dbengine = get_user_choice - ( 'Default database engine?' - , 1 - , [ 'mysql', 'oracle', 'postgres', 'sqlite' ] - , [ 'm', 'o', 'p', 's' ] - ); - - # Are we configuring for single tree or multiple trees? - $cardinality = get_user_choice - ( 'Configured for single/multiple trees?' - , 2 - , [ 's', 'm' ] - , [ 's', 'm' ] - ); - - if ($cardinality eq 's') { - if ('y' eq get_user_choice - ( 'Do you intend to add other trees later?' - , 2 - , [ 'yes', 'no' ] - , [ 'y', 'n'] - ) - ) { - $cardinality = 'm'; - print "${VTyellow}NOTE:${VTnorm} installation switched to ${VTbold}multiple${VTnorm} mode\n"; - print " but describe just a single tree.\n"; - } else { - $dbpolicy = 't'; - $nodbuser = 1; - $nodbprefix = 1; - } - } - - if ($cardinality eq 'm') { - if ('o' ne $dbengine) { - print "The safest option is to create one database per tree.\n"; - print "You can however create a single database for all your trees with a specific set of\n"; - print "tables for each tree (though this is not recommended).\n"; - $dbpolicy = get_user_choice - ( 'How did you setup the databases?' - , 1 - , [ 'per tree', 'global' ] - , [ 't', 'g' ] - ); - if ($dbpolicy eq 'g') { # Single global database - if ('s' eq $dbengine) { - $dbname = get_user_choice - ( 'Name of global SQLite database file? (e.g. /home/myself/SQL-databases/lxr' - , -2 - , [] - , [] - ); - } else { - $dbname = get_user_choice - ( 'Name of global da... [truncated message content] |
