Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 612 lines (526 sloc) 20 KB
#!/usr/bin/perl -w
#----------------------------------------------------------------------
# __ __
# /\ \ /\ \
# __ __ __ __\ \ \____\ \ \____ __ _ __
# /\ \/\ \/\ \ /'__`\ \ '__`\\ \ '__`\ /'__`\/\`'__\
# \ \ \_/ \_/ \/\ __/\ \ \L\ \\ \ \L\ \/\ __/\ \ \/
# \ \___x___/'\ \____\\ \_,__/ \ \_,__/\ \____\\ \_\
# \/__//__/ \/____/ \/___/ \/___/ \/____/ \/_/
#
#----------------------------------------------------------------------
# (c) 1996-2015 RedIRIS. The authors may be contacted by the email
# address: webbones@rediris.es
#
# $Id: webber,v 1.19.2.2 2008/07/31 14:33:42 paco Exp $
# Webber 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 (http://www.fsf.org/copyleft/gpl.html).
#
# Webber 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.
#----------------------------------------------------------------------
# paquetes usados
use strict ;
##use POSIX;
use Cwd;
use Getopt::Long qw(:config no_ignore_case bundling );
use File::Path ;
no strict "refs";
our (%var, %wbbDef, @environment ) ;
### OK
## declaración anticipada de algunas funciones
sub debug; # Impresion de mensajes de depuracion
sub push_var; # Se va a tener un entorno (%var) comun, y
# una pila de entornos, esto apila un entorno
sub pop_var; # Y esto recreea el anterior.
sub readVars ;
#
## El entorno solo hace falta cuando procesemos directorios,
#ya que en un fichero solo no hay problema (InitVar limpia el entorno)
$ENV{'PATH'} = "/usr/local/bin:/usr/sbin:/usr/bin";
# stack (pila) de entornos
@environment = () ; # Inicialmente vacio
my @wbbProcLib = ();
my $name="Webber";
my $version="3.0 RC1 beta epsilon" ;
my $copyright="Copyright 1996-2011, RedIRIS";
# Variables de las opciones
my ($opt_help, $opt_C, $opt_f, $opt_hproc, $opt_i, $opt_lp, $opt_r, $opt_t, $opt_nodir , @opt_lazy, $opt_v , $opt_debug, @opt_s) ;
# valores por defecto
$opt_debug = 0 ;
$opt_i =0 ;
$opt_t="" ;
@opt_s = () ;
@opt_lazy = () ;
$opt_C = "/etc/webber/webber.wbb" ;
GetOptions (
"help|ayuda|h|?" => \$opt_help ,
"config|C=s" => \$opt_C ,
"force|f" => \$opt_f ,
"help-proc|H" => \$opt_hproc,
"stdin|i" => \$opt_i ,
"list-proc|I" => \$opt_lp ,
"recurse|r" => \$opt_r,
"template|t=s" => \$opt_t,
"nodir|m" => \$opt_nodir,
"version|v" => \$opt_v,
"debug|d+" => \$opt_debug ,
"set|s=s@" => \@opt_s ,
"lazy-set=s@" => \@opt_lazy
) ;
#getopts ("C:dfhmirHIt:v", \%opt );
# Sets some webber vars
$wbbDef{'wbbRecursive'} = 0 ;
$wbbDef{'wbbForceupdate'} = 0 ;
$wbbDef{'wbbMakedir'} = 1 ;
$wbbDef{'wbbRoot'} = defined $ENV{'WBBROOT'} ? $ENV{'WBBROOT'} : getcwd() ;
$wbbDef{'wbbConfig'} = defined $ENV{'WBBCONFIG'} ? $ENV{'WBBCONFIG'} : (-r "/etc/webber/webber.wbb" ? "/etc/webber/webber.wbb" : "webber.wbb" ) ;
$wbbDef{'wbbConfig'} = ($opt_C ne "") ? $opt_C : $wbbDef{'wbbConfig'} ;
if ( $opt_help) { &showHelp; }
if ($opt_debug > 0 ) { $var{'wbbDebug'} = $opt_debug ; }
#---- Configuracion
# Some defaults values
$wbbDef{'wbbTargetFileMode'} = "0444" ; # FileMode Mask
$wbbDef{'wbbTemplateName'} = "wbbdir.cfg" ;
$wbbDef{'wbbFileNameRegExp'} = '^(.+)\.wbb$' ;
$wbbDef{'wbbExtension'} = ".html" ;
$wbbDef{'wbbVersion'} = "$name $version" ;
# Populate some %def from environment or set it to some values
readVars (NormalizePath( $wbbDef{'wbbConfig'} ) , 'configuration', \%wbbDef ) ;
$wbbDef{'wbbRecursive'} = ($opt_r ) ? 1 : $wbbDef{'wbbRecursive'} ;
$wbbDef{'wbbForceupdate'} = ($opt_f ) ? 1 : $wbbDef{'wbbForceupdate'} ;
$wbbDef{'wbbMakedir'} = ($opt_nodir ) ? 0 :$wbbDef{'wbbMakedir'} ;
$wbbDef{'wbbDebug'} = defined $ENV{'WBBDEBUG'} ? $ENV{'WBBDEBUG'} : defined $wbbDef{'wbbDebug'} ? $wbbDef{'wbbDebug'} : 10 ;
$wbbDef{'wbbDebugFile'} = defined $ENV{'WBBDEBUGFILE'} ? $ENV{'WBBDEBUGFILE'} : defined $wbbDef{'wbbDebugFile'} ? $wbbDef{'wbbDebugFile'} : '' ;
$wbbDef{'wbbexttmp'} = defined $ENV{'WBBEXTTMP'} ? $ENV{'WBBEXTTMP'} : defined $wbbDef{'wbbexttmp'} ? $wbbDef{'wbbexttmp'} : '.tmp' ;
$wbbDef{'wbbTargetRoot'} = defined $ENV{'WBBTARGETROOT'} ? $ENV{'WBBTARGETROOT'} : defined $wbbDef{'wbbTargetRoot'} ? $wbbDef{'wbbTargetRoot'} : "$wbbDef{'wbbRoot'}" . "/html" ;
$wbbDef{'wbbSourceRoot'} = defined $ENV{'WBBSOURCEROOT'} ? $ENV{'WBBSOURCEROOT'} : defined $wbbDef{'wbbSourceRoot'} ? $wbbDef{'wbbSourceRoot'} : "$wbbDef{'wbbRoot'}" . "" ;
@wbbProcLib = split /\s+/, $wbbDef{'wbbProcLib'} ;
use lib @wbbProcLib;
foreach my $path (@wbbProcLib ) {
debug (3, "Debug:(Webber Main) adding $path to \@lib\n") ; push @INC, $path ;
}
print STDERR "Debug:(Webber::Main) Used file $opt_C for config\n" if $opt_debug;
if (defined $opt_v) {
print STDERR "This is $name, v$version\n\n$copyright\n";
exit;
}
if (defined $opt_hproc) {
&proccessors('help',
"There is no help available for this proccesor\n",
"\n------------\n",) ;
}
if (defined $opt_lp ) {
&proccessors('info',
"There is no information available about this proccesor\n",
"=>");
}
debug (3,"Debug:(Webber Main) Calling initvars 1\n" ) ;
&InitVars;
if (@opt_s >0 ) {
debug (3, "Setting vars from commandline\n" ) ;
for (my $i=0 ; $i!= @opt_s ; $i++ ) {
my ($varcmd,$value) = split /=/, $opt_s[$i] ;
debug (4, "Setting var $varcmd to $value") ;
$wbbDef{$varcmd} = $value ;
}
}
debug(1,"Debug:(Webber Main) webber start ..");
if ($opt_t ne "") {
&readVars($opt_t, "source file", \%var);
$var{'wbbInteractive'}="1" ;
}
if ($opt_i eq "1") {
$var{'wbbInteractive'} = 1;
&ReadFile;
# &process($pag,\%var);
&process("") ;
}
else {
runprocs ("wbbRunBefore") ;
while (my $page = shift(@ARGV)) {
my $currentdir = getcwd();
if (-d $page) {
if ($page !~ /^\.\.$/) {
debug (1,"Debug:(Webber Main) go for dir: $page\n") ;
chdir($page);
my $cwd = getcwd();
$cwd =~ /^(.*)\//;
my $tdir = $1;
&InitVars;
# print "cwd =$cwd\ntdir=$tdir\nwbSR=$var{'wbbSourceRoot'}\n" ;
&ReadTemplatesRec($tdir) if ( ($cwd ne $var{'wbbSourceRoot'}) & ($tdir ne "")) ;
chdir($cwd);
&ProcessDir(\%var);
chdir($currentdir);
}
}
elsif (-f $page) {
debug (1 ,"Debug (Webber Main) go for page $page\n") ;
my @page = split /\//, $page;
my $dir = join "/", @page[0..$#page-1];
my $pag = $page[$#page];
debug (1,"Debug (Webber Main) directoriy to change is $dir\n") ;
die "Can't access dir $dir" if "$dir" ne "" and !(chdir ($dir));
my $cwd = getcwd();
debug (1, "cwd es $cwd\n") ;
&InitVars;
&ReadTemplatesRec($cwd);
if ($pag =~ /$var{wbbFileNameRegExp}/ && $pag ne $var{wbbTemplateName}) {
debug (1, "Debug:(Webber Main) go for file: $page\n") ;
&process($pag );
}
else { debug (1,"Debug:(Webber Main) Skip file $cwd/$pag\n"); }
chdir($currentdir);
}
else { die "Directory or file: $page does not exist"; }
}
runprocs ("wbbRunAfter") ;
}
#----------------------------------------------------------------------
# Function: showHelp
#----------------------------------------------------------------------
sub showHelp {
print "Usage: webber [-C <configFile>] [-d] [-f] [-h] [-i] [-I] [-m] [-r] [-t <tmplFile>] [-v] (dir|file) [(dir|file)... ]\n\n";
print "--config| -C set a different config file\n";
print "--debug | -d increase debug level\n";
print "--force | -f force updating of target files\n";
print "--help | -h | --ayuda show this message and exit\n";
print "--proc-help | -H show the help page of installed proccessors\n";
print "--stdin | -i use standard i/o, not file\n";
print "--list-proc | -I list installed proccessors\n";
print "--nodir | -m NOT create target directories if they do not exist\n";
print "--recurse | -r recurse through source directories\n";
print "--template | -t same as -i but uses a template file\n";
print "--version | -v show program name and version\n";
print "--set | -s set webber variable , can be repeat\n" ;
print "<dir> Process the contents of a directory\n";
print "<file> Process an individual source file\n";
print "\nSee also configuration file $wbbDef{'wbbConfig'} \n";
exit;
}
#----------------------------------------------------------------------
# Function: proccessors
#----------------------------------------------------------------------
sub proccessors {
my $comm= $_[0];
my $nocomm = $_[1];
my $output= $_[2];
my ($x,$i,$xx,$val);
my @xx;
foreach $i (@wbbProcLib) {
opendir DIR, $i || die "Can't open directory $i!!\n";
my @temp=readdir (DIR);
closedir DIR;
foreach $x (@temp ) {
next if ($x eq "CVS");
next if ($x =~ /^\./) ;
my @xx= split /\./, $x;
pop @xx;
my $y = join "." , @xx;
require $i. "/$x";
my $com= $y . "::" .$comm;
if (defined &$com) {
print $x, $output;
$val = &$com;
}
else { print $x, $output, $nocomm; }
}
}
exit;
}
#----------------------------------------------------------------------
# Function: untaint
#----------------------------------------------------------------------
sub untaint {
my ($arg) = @_;
$arg =~ m/^(.*)$/;
return $1;
}
#----------------------------------------------------------------------
# Function: readVars
# Change:
# Add a another arguments, the %hash used for storing the information
# So this can be used to initialize not only the %var hash but also
# the %wbbDef .
#----------------------------------------------------------------------
sub readVars {
my ($file, $type,$ref) = @_;
my $varname = "";
my $target= "";
if ($file ne "-") {
$varname = "";
if ($type eq "configuration") { $target=$file ; }
else { $target = getcwd()."/$file"; }
return if ($type eq "template" and not -f $file);
die "Unable to read $target" if (not -r $file);
}
return if ($type ne "template" and $type ne "configuration" and
exists $$ref{"wbbExtParser"} and $$ref{"wbbExtParser"} != 0);
if (defined $$ref{'wbbInteractive'} && ( $$ref{'wbbInteractive'} eq "1") ) { open INFILE ,"-" ; }
else { open INFILE,"<". untaint ("$file") ; }
my $lno = 0;
$varname = "" ;
debug (1,"Debug: (readVars) processing $type: $target\n" ) ;
$var{'wbbActualfile'} = $target ;
while (my $line = <INFILE>) {
if ($line =~ /^##/) {
if ($varname ne "") { debug (2, "Debug:(readVars) $varname := $$ref{$varname}\n") ; }
$varname = "";
}
elsif ($line =~ /^#([\w]+[a-zA-Z0-9_.\-\$]*)\s*\=\s*(.*)$/) {
if ($varname ne "") { debug (2,"Debug:(readVars) $varname := $$ref{$varname}\n") ; }
$$ref{"$1"} = EvaluateVar ($2, $ref );
$varname = "$1";
}
elsif ($line =~ /^#([\w]+[a-zA-Z0-9_.\-\$]*)\s*\+\s*(.*)$/) {
if ($varname ne "") { debug(2, "Debug:(readVars) $varname := $$ref{$varname}\n") ; }
if (exists $$ref{"$1"}) { $$ref{"$1"} .= " " . EvaluateVar($2, $ref) ; }
else { $$ref{"$1"} = EvaluateVar ($2, $ref) ; }
$varname = "$1";
}
elsif ($line =~ /^#([\w]+[a-zA-Z0-9_.\-\$]*)\s*\*\s*(.*)$/) {
if ($varname ne "") { debug(2, "Debug:(readVars) $varname := $$ref{$varname}\n") ; }
if (exists $$ref{"$1"}) { $$ref{"$1"} = EvaluateVar($2, $ref) . " " . $$ref{"$1"}; }
else { $$ref{"$1"} = EvaluateVar ($2, $ref) ; }
$varname = "$1";
}
else {
if ($varname eq "") {
chop $line;
# Ignore blank lines outside variable definitions without error
if ($line !~ /^[\s]*$/) {
print STDERR "Syntax error in $type $target: \"$line\" ignored\n";
}
}
else {
my $lc = chop $line;
$line .= $lc if (ord($lc) ne 10); # Si no es un \n
$$ref{"$varname"} .= "\n" . EvaluateVar($line , $ref) ;
}
}
}
if ($varname ne "") { debug(2, "Debug:(readVars) $varname := $$ref{$varname}\n") ; }
close INFILE;
}
#----------------------------------------------------------------------
# Function: runprocs
# Execute the processors listed in a webber Var, call recursive if
# a "non proc" if found
#----------------------------------------------------------------------
sub runprocs {
my $proclist=$_[0] ;
my $thisp ;
if ((defined ($var{$proclist} )) && ($var{$proclist} ne "")) {
my @tempo = split /\s+/, $var{$proclist};
foreach $thisp (@tempo) {
next unless $thisp =~ /\w+/ ;
if ($thisp =~ /.*::.*/ ) {
debug (1," [$proclist] Using processor $thisp ..." ) ;
my ($package, $sname) = split /::/,$thisp;
require $package .".pm" ;
if ( (defined $var{'wbbEnd'}) && ( $var{'wbbEnd'} == 1)) { debug (1, "wbbEnd is defined ending proc chain"); return ; }
&$thisp( \%var );
debug (1, "\n" ) ;
}
else {
debug (1,"[$proclist] Found another Var , $thisp ..") ;
runprocs ($thisp) ;
debug (1, "\n" ) ;
}
}
}
}
#----------------------------------------------------------------------
# Function: process
#----------------------------------------------------------------------
sub process {
my ($page, $global) = @_;
push_var ;
@INC = @lib::ORIG_INC;
unshift @INC, @wbbProcLib;
#----
$var{"wbbSource"} = $page;
debug 2, "process: file= $var{'wbbSource'} \n" ;
# debug 2, "wbbTargetRoot (Obsolete s $var{'wbbTargetRoot'}\n" ;
## Nota: Esto es todo lo de antes, se supone que teniendo
## Wbbrun = File::SetTarget File::ReadVars wbbPre wbbProc wbbPost File::WriteVars se debería
## tener lo mismo que ahora.
# OK , aquí es donde se procesan los "Lazy" set
if (@opt_lazy >0 ) {
debug (3, "Setting Lazy vars from commandline\n" ) ;
for (my $i=0 ; $i!= @opt_lazy ; $i++ ) {
my ($varcmd,$value) = split /=/, $opt_lazy[$i] ;
debug (4, "Setting var $varcmd to lazy value $value") ;
$var{$varcmd} = $value ;
}
}
runprocs ("wbbRun") ;
# end
pop_var ;
}
#----------------------------------------------------------------------
# Function: InitVars
#----------------------------------------------------------------------
sub InitVars {
%var = () ;
foreach my $k (keys %wbbDef) { $var{$k} = $wbbDef{$k};
# debug (3,"Debug: (InitVars) var{$k} =$main::var{$k}") ;
}}
#----------------------------------------------------------------------
# Function: ReadTemplate
#----------------------------------------------------------------------
sub ReadTemplate {
debug(1, "Debug: looking for template at ", getcwd() . "\n" ) ;
&readVars ($var{wbbTemplateName}, "template", \%var);
}
#----------------------------------------------------------------------
# Function: ReadTemplatesRec
#----------------------------------------------------------------------
sub ReadTemplatesRec {
my($dir) = @_;
debug(1, "Debug: (ReadTemplatesRec) processing recursive templates at \"$dir\" until reach \"$var{'wbbSourceRoot'}\"\n") ;
$dir =~ /^(.*)\//;
my $newdir = $1;
&ReadTemplatesRec($newdir) if (($dir ne $var{'wbbSourceRoot'} || $dir eq "/" || ($dir =~ /.:/)) && ($newdir ne ""));
chdir($dir);
&ReadTemplate;
}
#----------------------------------------------------------------------
# Function: ReadFile
#----------------------------------------------------------------------
sub ReadFile {
&readVars("-","-", \%var);
foreach my $k (keys %wbbDef) { $var{$k} = $wbbDef{$k} unless exists $var{$k}; }
}
#----------------------------------------------------------------------
# Function: ProcessDir
#----------------------------------------------------------------------
sub ProcessDir {
debug (1, "Debug: processing directory at ", getcwd(), "\n" ) ;
push_var ;
&ReadTemplate;
my(@pages,@dirs);
opendir DIR, ".";
while (my $direntry = readdir(DIR)) {
debug 3, "dir entry $direntry" ;
next if (-l $direntry or -p $direntry or -S $direntry or -b $direntry or
-c $direntry or -t $direntry);
# next if (-l $direntry or -p $direntry or -S $direntry or -b $direntry or
# -c $direntry);
debug 3, "pasa por aqui" ;
if (-d $direntry && $direntry !~ /^\.$/ && $direntry !~ /^\.\.$/) {
push @dirs, $direntry;
}
elsif (-f $direntry && $direntry =~ /$var{wbbFileNameRegExp}/ &&
$direntry ne $var{wbbTemplateName}) {
debug ( 3, "pushed $direntry in the proccess queue" ) ;
push @pages, $direntry;
}
else { debug 3, "not pushed $direntry in the process queue";
}
}
foreach my $page (@pages) { process($page); }
if ($var{'wbbRecursive'}) {
foreach my $dir (@dirs) {
chdir("./$dir");
&ProcessDir(\%var);
chdir("..");
}
}
pop_var ;
}
#----------------------------------------------------------------------
# Function: NormalizePath
#----------------------------------------------------------------------
sub NormalizePath {
my $wPath = shift;
# Por si alguien pone
# /Volumes/////repositorio/WWW2/www.rediris.es//src/
$wPath =~ s/\/\/+/\//g ;
# Eliminamos la última barra "/"
$wPath =~ s/\/$//g;
return $wPath;
}
#-------------------------------------------------------------------------
# Function: EvaluateVar
# ------------------------------------------------------------------------
sub EvaluateVar {
my $lin = $_[0] ;
my $ref = $_[1] ;
my $c ;
while ($lin =~ /.*\$var\(([\w]+[a-zA-Z0-9_.\-]*)\).*/ ) {
$c = $$ref{$1} ;
debug (2, "Variaable $c no tiene valor\n" ) unless defined ($c) ;
debug (2, "Var $1 evaluada, valor =$c") ;
$lin =~ s/\$var\($1\)/$c/ ;
}
while ($lin =~ /.*\$env\(([\w]+[a-zA-Z0-9_.\-]*)\).*/ ) {
$c = $ENV{$1} ;
debug 2, "evaluacion de entorno de $1!!\n" ;
$lin =~ s/\$env\($1\)/$c/ ;
}
while ($lin =~ /.*\$orig\(([\w]+[a-zA-Z0-9_.\-]*)\).*/ ) {
$c = $wbbDef{$1} ;
debug 2, "evaluacion de original de $1!!\n" ;
$lin =~ s/\$orig\($1\)/$c/ ;
}
return $lin ;
}
#-------------------------------------------------------------------------
# Function: debug
#-------------------------------------------------------------------------
sub debug {
my @lines = @_ ;
# @lines[0] es el nivel
# print STDERR "wbbDebug es $var{'wbbDebug'}\n" ;
if ((defined ($var{'wbbDebug'})) && ( $var{'wbbDebug'}=~ /\d+/ )) {
if ( ($lines[0] <= $var{'wbbDebug'} )) { debug_print ($name, @lines ) ; }
}
else { debug_print ("NOLEVEL, $name" ,@lines ) ; }
}
# Auxiliar de debug
sub wbbdebug {
debug (@_) ;
}
# Auxiliar de debug de verdad (hace el trabajo
sub debug_print{
my @lines =@_ ;
my $name="Webber" ;
my $level="1" ;
$name= shift @lines if (defined $lines[0] ) ;
$level=shift @lines if (defined $lines[0] ) ;
my $line= "[$name]<$level> :" . join '', @lines ;
chomp $line ;
if ( defined ($var{'wbbDebugFile'}) && ($var{'wbbDebugFile'} !~/stderr/i)) {
open FILE, ">>$var{'wbbDebugFile'}" ;
print FILE "$line\n" ;
#print STDERR "$line\n" ;
close FILE ;
}
else {
$line =" (wbbDebugFile undeffined) " . $line ;
print STDERR "$line\n" if defined $var{'wbbDebug'} ;
}
}
#--------------------------------------------------------------------------
# Function: push_var
# -------------------------------------------------------------------------
# Apila el entorno que esta en %var
sub push_var {
my %hash ;
foreach my $key (keys %var) { $hash{$key} = $var{$key} ; }
push @environment , \%hash ;
}
#--------------------------------------------------------------------------
# Function: pop_var
#--------------------------------------------------------------------------
# Restaura el entorno tal y como estaba
sub pop_var {
my $ref= pop @environment ;
%var =() ; # Nos cargamos todas las variables
foreach my $key (keys %$ref ) { $var{$key} = $$ref{$key} ; }
}