pf-tools commit: r902 [parmelan-guest] - in /trunk: ./ debian/ doc/ filters/ lib/PFTools/ lib/PFTools/Compat/ lib/PFTools/Conf/ lib/PFTools/Update/ sbin/ templates/ tools/

parmelan-guest at users.alioth.debian.org parmelan-guest at users.alioth.debian.org
Wed Sep 8 19:28:30 UTC 2010


Author: parmelan-guest
Date: Wed Sep  8 19:28:28 2010
New Revision: 902

URL: http://svn.debian.org/wsvn/pf-tools/?sc=1&rev=902
Log:
Move back next-gen to the trunk (svn merge --reintegrate svn+ssh://svn.debian.org/svn/pf-tools/branches/next-gen)

Added:
    trunk/README.coding.style
      - copied unchanged from r901, branches/next-gen/README.coding.style
    trunk/doc/
      - copied from r901, branches/next-gen/doc/
    trunk/lib/PFTools/Compat/
      - copied from r901, branches/next-gen/lib/PFTools/Compat/
    trunk/lib/PFTools/Conf/
      - copied from r901, branches/next-gen/lib/PFTools/Conf/
    trunk/lib/PFTools/Logger.pm
      - copied unchanged from r901, branches/next-gen/lib/PFTools/Logger.pm
    trunk/lib/PFTools/Parser.pm
      - copied unchanged from r901, branches/next-gen/lib/PFTools/Parser.pm
    trunk/lib/PFTools/Structqueries.pm
      - copied unchanged from r901, branches/next-gen/lib/PFTools/Structqueries.pm
    trunk/lib/PFTools/Update/
      - copied from r901, branches/next-gen/lib/PFTools/Update/
    trunk/lib/PFTools/Utils.pm
      - copied unchanged from r901, branches/next-gen/lib/PFTools/Utils.pm
    trunk/lib/PFTools/VCS.pm
      - copied unchanged from r901, branches/next-gen/lib/PFTools/VCS.pm
    trunk/sbin/mk_sitezone
      - copied unchanged from r901, branches/next-gen/sbin/mk_sitezone
    trunk/templates/sources.list
      - copied unchanged from r901, branches/next-gen/templates/sources.list
    trunk/templates/standard-preseed
      - copied unchanged from r901, branches/next-gen/templates/standard-preseed
    trunk/templates/ubuntu-preseed
      - copied unchanged from r901, branches/next-gen/templates/ubuntu-preseed
    trunk/templates/ubuntu-sources.list
      - copied unchanged from r901, branches/next-gen/templates/ubuntu-sources.list
    trunk/tools/Display_IP_config
      - copied unchanged from r901, branches/next-gen/tools/Display_IP_config
    trunk/tools/Translate_old_config
      - copied unchanged from r901, branches/next-gen/tools/Translate_old_config
Removed:
    trunk/debian/pf-tools.links
    trunk/filters/filter_filename
    trunk/filters/filter_systemmap
    trunk/sbin/mk_grub2opt
    trunk/sbin/mk_packages
    trunk/sbin/mk_privatezone
    trunk/sbin/update-links
    trunk/templates/pf-tools
    trunk/templates/sources.list.tpl
    trunk/templates/standard-preseed.tpl
    trunk/templates/ubuntu-preseed.tpl
    trunk/templates/ubuntu-sources.list.tpl
Modified:
    trunk/   (props changed)
    trunk/Makefile
    trunk/TODO
    trunk/debian/changelog
    trunk/debian/compat
    trunk/debian/control
    trunk/filters/filter_distrib
    trunk/filters/filter_privateresolve
    trunk/filters/filter_vlan2if
    trunk/lib/PFTools/Bridge.pm
    trunk/lib/PFTools/Conf.pm
    trunk/lib/PFTools/Disk.pm
    trunk/lib/PFTools/Net.pm
    trunk/lib/PFTools/Packages.pm
    trunk/lib/PFTools/Update.pm
    trunk/sbin/fix_hosts
    trunk/sbin/mk_dhcp
    trunk/sbin/mk_grubopt
    trunk/sbin/mk_interfaces
    trunk/sbin/mk_pxelinuxcfg
    trunk/sbin/mk_resolvconf
    trunk/sbin/mk_sourceslist
    trunk/sbin/update-config
    trunk/templates/standard-installer
    trunk/templates/ubuntu-installer
    trunk/tools/dumpiplist.pl
    trunk/tools/kvmlaunch   (contents, props changed)
    trunk/tools/pflaunch
    trunk/tools/umlaunch
    trunk/tools/xenlaunch

Propchange: trunk/
------------------------------------------------------------------------------
    svn:mergeinfo = /branches/next-gen:761-901

Modified: trunk/Makefile
URL: http://svn.debian.org/wsvn/pf-tools/trunk/Makefile?rev=902&op=diff
==============================================================================
--- trunk/Makefile (original)
+++ trunk/Makefile Wed Sep  8 19:28:28 2010
@@ -40,7 +40,8 @@
 install_tools: $(LIB) $(SBIN)
 	# PFTools modules
 	mkdir -p $(LIB_DIR)
-	install --mode=0644 $(LIB) $(LIB_DIR)
+	cp -r $(LIB) $(LIB_DIR)
+	find $(LIB_DIR) -name "*.pm" -exec chmod 0644 {} \;
 	
 	# PFTools utils
 	mkdir -p $(SBIN_DIR)
@@ -52,11 +53,11 @@
 	
 	# PFTools PXE template files
 	mkdir -p $(TPL_DIR)
-	install -o root -g root -m 600 $(TPL) $(TPL_DIR)
+	install -o root -g root -m 0600 $(TPL) $(TPL_DIR)
 
 	# PFTools Config file
 	mkdir -p $(CONF_DIR)
-	install -o root -g root -m 600 $(CONF) $(CONF_DIR)/pf-tools.conf.new
+	install -o root -g root -m 0600 $(CONF) $(CONF_DIR)/pf-tools.conf.new
 
 install_host: $(TOOLS)
 	# PFHost tools

Modified: trunk/TODO
URL: http://svn.debian.org/wsvn/pf-tools/trunk/TODO?rev=902&op=diff
==============================================================================
--- trunk/TODO (original)
+++ trunk/TODO Wed Sep  8 19:28:28 2010
@@ -1,24 +1,39 @@
 /--Priority: Low/Medium/Urgent
 |/-Difficulty: Easy/Medium/Hard
 ||
-UE check that all mandatory entries are defined (ie: tag)
-UM use Net::IP for ipstart.* and check it is ok wrt the subnet declaration
-MM [Need validation] source = CVS:config/%HOST_TYPE%/%SECTIONNAME%
-LE Add %SERIAL% in addition to %CONSOLE% for PXE, if it is really interesting ("serial 0 115200" by default)
-LE Obsolete mk_packages and update-links (just have to be sure no one uses them anymore)
-MH Adding an abstract layer on package installation method for interfacing other than deb package like RPM
-MH Adding scope for networks. Needed for using same subnets on different site
-MH IPv6 support
+LH implementing udev rules for naming iface accordingly with hostfile definition
+   if a key mac is defined for the specified hostname
+MH implementing scope for network when building zones
+    - the IPs of hosts which are into a private scope network appear only into the site
+    where there are defined
+    - the IPs of hosts which are into a public scope network appear on all sites
+LH finishing IPv6 implementation and testing it for zones and DHCP handlers
+LH implementing strong authentication like X509 when accessing to repository instead
+   of hostname vlaue, with CA and all functions for adding or revoking new hosts
+NH definition of group actions e.g. reloading a server like postfix or apache only once
+MH creating into the sort funtion for update-* file the actiongroup trigger which
+   check the dependances validity with the following rules :
+    - a section is able to depend of another section into the same actiongroup
+    - a section is able to depend of an actiongroup which is different of his own
+    - an actiongroup is able to depend of another actiongroup
+	- abort if a section into actiongroup A is depending of a section into actiongroup B
+    - abort if A -> B -> C -> A where -> is a dependancy link
+LH adding a keyring for handling SSH keys for servers
+LH specifying and rewriting code with devel rules like fix indent and PERL best practices
+LH adding a mechanism of zone delegation inside a zone e.g. between ROOT and EDGE sites
+LM creating a tool to see vlan mapping e.g. all hosts defined for a specified vlan
+   on a given site (including empty range into this vlan)
+LH alias definition like CONFIG: in pf-tools.conf file for using in Get_source
+LH implementing a web interface for building pf-tools configurator
+NM permit interface with no IP in promisc mode (ex: for probing hosts)
+NH implementing monitoring as defined in hostfile-syntax with PFTools::Monitoring
 
+MH rewrite pflaunch and other tools
 UH br0/trunk sur uml (2e couche bridge?)
-NM Pouvoir forcer une version particulière d'un paquet (apt-get install paquet=version)
 NM apc/serial/yasser dans private-network
-NM interface 0.0.0.0 promisc pour uml (ex: sondes)
 NM detection reutilisation disque autre machine (-> reinstall par defaut)
-NH conf nagios/rrdtool dans private-network
 NH mtu 1500 partout -> 1504 en trunk (tuntap > 1500?)
 LM umlshutdown
-NH Actions groupees (ex reload postfix)
 NM #if et #define
 NH Variables dans private-network (ex %KERNEL_LVS%)
 NH Outils reseaux: Listes occupation vlans, graphes, detection libres contigues

Modified: trunk/debian/changelog
URL: http://svn.debian.org/wsvn/pf-tools/trunk/debian/changelog?rev=902&op=diff
==============================================================================
--- trunk/debian/changelog (original)
+++ trunk/debian/changelog Wed Sep  8 19:28:28 2010
@@ -1,3 +1,231 @@
+pf-tools (1.0.1~WIP) unstable; urgency=low
+
+  [ Thomas Parmelan ]
+  * WORK IN PROGRESS, DO NOT RELEASE!
+
+  * debian/changelog: use native versioning, since we maintain the debian/
+    directory ourselves in the same repository.
+  * Start using perltidy --perl-best-practices
+  * Use English
+  * Don't call mkdir, use File::Path's make_path() instead.
+
+  [ Christophe Caillet ]
+  * use remove_tree with keep_root option instead of remove_tree + make_path
+  * use remove_tree only if $co_dir exists
+  * fix Get_source: hostname IS NOT mandatory
+  * use IO::File in sbin/*
+
+ -- Christophe Caillet <quadchris at free.fr>  Wed, 08 Sep 2010 15:00:52 +0200
+
+pf-tools (1.0-1) unstable; urgency=low
+
+  * new upstream release
+  [Christophe Caillet]
+  * lib/PFTools/Conf.pm
+    - correctly handle hosttype into Init_SUBST
+  * lib/PFTools/Update/*.pm
+    - fix Installpkg_depends
+    - fix dirname to avoid empty string return
+    - fix some *_depends for not adding "." as a dependancy
+    - fix Removedir and Removefile for correctly handle diff option
+  * lib/PFTools/Utils.pm
+    - correctly handle pf_config_file into Init_TOOLS
+    - adding hosttype parameter where calling Init_SUBST function 
+    - comment the check for checking if a depend exists
+    - renaming call to VCS_checkout instead of VCS_update
+  * lib/PFTools/VCS.pm
+    - renaming *_update into *_checkout which is better according to the
+    functionality
+
+ -- Christophe Caillet <tof at sitadelle.com>  Tue, 07 Sep 2010 15:34:28 +0200
+
+pf-tools (0.99.99-1) unstable; urgency=low
+
+  * RC2 : validation
+  [Christophe Caillet]
+  * sbin/update-config :
+    - feat: adding check for update in pf-tools.conf, deactivate if not present
+    or if his value is 0
+    - introducing the force-reload parameter for rebuilding the global
+    - some cosmectics
+    configuration from VCS repository even if a storable file exists
+  * sbin/mk_pxelinuxcfg
+    - fix: correctly handle the site parameter if it is not defined on CLI 
+  * sbin/mk_dhcp
+    - fix: correctly handle the site parameter if it is not defined on CLI 
+  * sbin/mk_sitezone
+    - fix: correctly handle the site parameter if it is not defined on CLI 
+  * lib/PFTools/Conf.pm
+    - small fixes on Get_source for order and substitution regex
+    - rollback for CONFIG: alias with the 0.33-stable substitution value
+    - optims : sorting sections according to the types in Init_GLOBAL_NETCONFIG
+    - using named backreference from PFTools::Conf::Syntax
+  * lib/PFTools/Conf/Syntax.pm
+    - extracting syntax checks from PFTools::Conf to PFTools::Conf::Syntax
+    - using named backreference for using into Init_SUBST function
+    which is more flexible for future evolutions
+    - fix regex for mode directive in misc sections
+  * lib/PFTools/Conf/Host.pm
+    - moving PFTools::Host to PFTools::Conf::Host because functions are
+    dedicated to configuration structure building
+  * lib/PFTools/Conf/Network.pm
+    - extracting structure functions from PFTools::Net to PFTools::Conf::Net
+    which is dedicated to configuration structure building
+  * lib/PFTools/Utils.pm
+    - fix on Ini_TOOLS : if storable file doesn't exist we need to parse
+    - cosmetic for building zone in __Mk_zoneheader and Mk_zone_for_site
+    - adding some keys into substitution hash when updating configuration
+  * lib/PFTools/Update.pm
+    - splitting $FUNCTION and $DEPENDS to perl package under PFTools::Update::*
+    - privatizing __Trie_prio and fix for action installpkg or purgepkg
+    - aborting when a depend is explicited but not defined
+    - parameter for order sections list is now passed with an array ref instead
+    of an array
+    - renaming __Trie_prio and Trie_dependances
+  * lib/PFTools/VCS.pm
+    - basic SVN implementation, need to write documentation about his usage
+  * lib/PFTools/Update/Common.pm
+    - extracting common functions from Update.pm which are used by $FUNCTION
+    and $DEPENDS in lib/PFTools/Update.pm
+  * lib/PFTools/Update/Addfile.pm
+    - extrating addfile functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Installpkg.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Purgepkg.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Mkdir.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Addmount.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Creatfile.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Addlink.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Removefile.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Update/Removedir.pm
+    - extrating apt-get functions (action and depends) from Update.pm
+  * lib/PFTools/Structqueries.pm
+    - library for getting informations from global structure
+  * debian/control
+    - adding libtext-diff-perl as depends for pf-tools package
+    - adding libconfig-inifiles-perl as depends for pf-tools package
+  * doc/updatefile-syntax
+    - basic documentation about update file
+  * TODO
+    - adding more TODOs :)
+  * lib/PFTools/Compat/Parser.pm
+    - extracting from PFTools::Parser functions for parsing old syntax format
+  * lib/PFTools/Compat/Translation.pm
+    - library for translating old configuration (pf-tools 0.X) to new syntax
+  * tools/Translate_old_config
+    - tools for translating old configuration (pf-tools 0.XX) into new syntax
+  * Makefile : fix installations
+  * removing useless symlinks
+
+ -- Christophe Caillet <quadchris at free.fr>  Wed, 01 Sep 2010 16:51:37 +0200
+
+pf-tools (0.99.98-1) unstable; urgency=low
+
+  * The road to RC1 release for Next-Gen pf-tools
+  [Christophe Caillet]
+  * doc/hostfile-syntax : adding file describing the new grammar for host
+  definition
+  * doc/networkfile-syntax : adding file describing the new grammar for
+  network and zone definitions
+  * doc/updatefile-syntax : TODO
+  * lib/PF-Tools/Conf.pm
+    - adding __Merge_conf_includes for merging include part or model part from
+    configuration files
+    - adding __Chk_section_struct for checking the content of sections
+    (basic checks) this function is also used for old syntax files
+    - modifying Load_conf
+    - using PFTools::Parser and PFTools::Logger
+    - adding __Translate_old2new_host for translating Parser_pftools result
+    to Parser_ini hash result with new syntax file
+    - Init_GLOBAL_NETCONFIG : similar to old function Init_lib_net
+    - Init_PF_CONFIG : function for parsing new style pf-tools.conf
+    - Get_config_for_hostname_on_site : function for getting and parsing
+    configuration for a specified hostname on site. Similar to old Get_conf
+    which was on lib/PFTools/Update.pm
+  * lib/PFTools/Disk.pm
+    - adding Build_fstab_from_structure for building fstab file from a defined
+    hash structure
+    - adding Build_structure_from_fstab for building hash structure from fstab
+    or assimilated file like /proc/mounts. This struture is equal to the 
+    addmount structure in configuration file
+  * lib/PFTools/Parser.pm
+    - introducing this package from splitting Conf.pm function with old parser
+    - adding parsing with ini standard parser based on Config::IniFiles
+    - remove allowedcommentchars parameter when callinf ini parser
+    - adding allowcontinue which permits to have muliline value for keys.
+    The separator is \.
+  * lib/PFTools/Logger.pm
+    - created by the functions extracted from Conf.pm and Update.pm
+    - all logging functions are now defined here
+    - better when deferredlog* functions were really imported into package
+  * lib/PFTools/Net.pm
+    - using new packages Parser.pm et Logger.pm
+    - adding entries in new global structure build the DNS zone for sites
+    - Add_zone : adding zone into the new global structure
+    - Add_site : adding sites into the new global structure
+    - Add_network : adding network into the new global structure
+    - removing dead or useless code
+    - moving functions into script when they're only used into it
+  * lib/PFTools/Host.pm
+    - creating new package for handling hosts part of the global structure
+    - Check_host_interfaces : checking interfaces for host definition
+    - Add_server : adding server (hosts defined into pf-tools only for IPs
+    and name accessing by filters)
+    - Add_host : adding pf-tools host configuration
+  * lib/PFTools/Packages.pm
+    - using new packages Parser.pm et Logger.pm
+  * lib/PFTools/Update.pm
+    - using new packages Parser.pm et Logger.pm
+    - removing cvs part which are moved to lib/PFTools/VCS.pm
+    - rewrite all functions $FUNCTIONS and $DEPENDS
+    - adding a wrapper which is exported for other packages instead of
+    $FUNCTIONS and $DEPENDS
+  * lib/PFTools/Utils.pm
+    - new library for handling functions used by scripts, filters, and tools
+  * lib/PFTools/VCS.pm
+    - new package for VCS handler(s) for now only CVS is supported
+  * sbin/mk_interfaces : rewrite according with new global structure, using
+  Getopt::Long for handling command line option(s)
+  * sbin/mk_sitezone : rewrite from mk_privatezone according to global structure
+  and site definition, using Getopt::Long for handling command line option(s)
+  * sbin/mk_dhcp : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s)
+  * sbin/mk_pxelinuxcfg : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s) and Template::Tiny for
+  handling templates
+  * sbin/fix_hosts : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s)
+  * sbin/mk_sourceslist : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s) and Template::Tiny for
+  handling templates
+  * sbin/mk_grubopt : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s) and Template::Tiny for
+  handling templates
+  * sbin/mk_grub2opt : removing useless code : one script to rule them all !
+  * sbin/update-config : rewrite with new structures and packages
+  * debian/control
+    - deps update according to usage of NetAddr::IP, Net::DNS, Template::Tiny
+    - uploaders and maintainers update
+  * debian/compat
+    - update level for avoiding warning during package build
+  * filter/filter_privateresolve : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s) 
+  * filter/filter_vlan2if : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s) 
+  * filter/filter_distrib : rewrite according to new global structure, using
+  Getopt::Long for handling command line option(s)
+  * removing filters/filter_filname and fiilters/filter_systemmap which are
+  useless and deprecated
+  * tools/Display_IP_list : rewrite of dumpiplist.pl
+
+ -- Christophe Caillet <quadchris at free.fr>  Fri, 06 Aug 2010 12:18:59 +0200
+
 pf-tools (0.34.0-0WIP) unstable; urgency=low
 
   [ Christophe Caillet ]

Modified: trunk/debian/compat
URL: http://svn.debian.org/wsvn/pf-tools/trunk/debian/compat?rev=902&op=diff
==============================================================================
--- trunk/debian/compat (original)
+++ trunk/debian/compat Wed Sep  8 19:28:28 2010
@@ -1,1 +1,1 @@
-4
+7

Modified: trunk/debian/control
URL: http://svn.debian.org/wsvn/pf-tools/trunk/debian/control?rev=902&op=diff
==============================================================================
--- trunk/debian/control (original)
+++ trunk/debian/control Wed Sep  8 19:28:28 2010
@@ -1,14 +1,14 @@
 Source: pf-tools
 Section: perl
 Priority: optional
-Maintainer: Damien Clermonte <damien at sitadelle.com>
-Uploaders: Thomas Parmelan <tom+pf-tools at ankh.fr.EU.org>
+Maintainer: Christophe Caillet <quadchris at free.fr>
+Uploaders: Thomas Parmelan <tom+pf-tools at ankh.fr.EU.org>, Christophe Caillet <quadchris at free.fr>
 Build-Depends-Indep: perl
 Standards-Version: 3.0.1
 
 Package: pf-tools
 Architecture: all
-Depends: perl, perl (>= 5.10.0) | libmd5-perl, cvs, ssh, iproute, debconf, psmisc
+Depends: perl, perl (>= 5.10.0) | libmd5-perl, libconfig-inifiles-perl, libnetaddr-ip-perl, libnet-dns-perl, libtemplate-tiny-perl, libtext-diff-perl, cvs, ssh, iproute, debconf, psmisc
 Description: Outils de gestion de la plateforme
  Mise a jour automatique et generation de conf.
  Deploiement de machines.

Modified: trunk/filters/filter_distrib
URL: http://svn.debian.org/wsvn/pf-tools/trunk/filters/filter_distrib?rev=902&op=diff
==============================================================================
--- trunk/filters/filter_distrib (original)
+++ trunk/filters/filter_distrib Wed Sep  8 19:28:28 2010
@@ -2,7 +2,7 @@
 ##
 ##  $Id$
 ##
-##  Copyright (C) 2007-2008 Christophe Caillet <quadchris at free.fr>
+##  Copyright (C) 2007-2010 Christophe Caillet <quadchris at free.fr>
 ##
 ##  This program is free software; you can redistribute it and/or
 ##  modify it under the terms of the GNU General Public License
@@ -22,83 +22,112 @@
 use strict;
 use warnings;
 
-use PFTools::Conf ;
-use PFTools::Net;
-use PFTools::Update;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
+
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+#################################
+# VARS
+my $HELP              = 0;
+my $HOSTNAME          = hostname;
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $INPUT_FILE        = '';
+my $OUTPUT_FILE       = '';
+my $GLOBAL_STRUCT     = {};
 
 my $program = $0;
-$program =~ s%.*/%%; # cheap basename
+$program =~ s%.*/%%;    # cheap basename
 
-my $version = sprintf("svn-r%s", q$Revision$ =~ /([\d.]+)/);
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
 
-sub Usage () {
+###################################
+# Funtions
 
-	print <<EOF
+sub Do_help {
+    print STDERR << "# ENDHELP";
+    $program - version $version
 
-$program - version $version
-
-Synopsis : $program <src> <hostname> <dst>
-
-	This filter permits to replace the variables %DISTRIB% and %DISTSRC% according to
-	the values extract from <hostname> definition on private-network
-
-	<src>		Define here the source file on which you want to search and replace
-
-	<hostname>	Specify here the hostname
-
-	<dst>		Define here the destination file which receive the filtered datas
-
-EOF
-
+Usage:	$program [options]
+	--help		: print help and exit
+	-h --host	: hostname for which we want to filter input
+	-s --site	: site on which hostname is defined (optional)
+	-c --config	: file where pf-tools configuration is stored e.g. /etc/pf-tools.conf (optional)
+	--store		: file where global structure datas are in storable format (optional)
+	-i --input	: input file
+	-o --output	: output file
+    
+# ENDHELP
 }
 
-my ( $src, $host, $dst ) = @ARGV;
-unless ( $src and $host and $dst ) {
-	warn "You MUST define <src>, <host> and <destination>\n" ;
-	Usage () ;
-	exit 1 ;
+##################################
+### MAIN
+
+GetOptions(
+    'help'       => \$HELP,
+    'host|h=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'input|i=s'  => \$INPUT_FILE,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
+
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-my $PF_NET = Init_lib_net( Get_source("GLOBAL:private-network") );
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
-Init_SUBST( \%SUBST, $host, 'private' ); # does an Abort if $host is not parsable
-
-my $host_type = $SUBST{'HOSTTYPE'};
-
-unless ($PF_NET->{'SERVERS'}->{'BY_NAME'}->{$host_type}) {
-    die "FATAL: unable to find config for host type $host_type";
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
 }
 
-unless ($PF_NET->{'SERVERS'}->{'BY_NAME'}->{$host_type}->{'SRVLIST'}->{$host}) {
-    die "FATAL: unable to find config for host $host";
+if ( $INPUT_FILE eq '' || $OUTPUT_FILE eq '' ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Source and/or destination file is(are) not defined on CLI" );
 }
 
-my ($host_distrib, $host_distsrc) =
-    @{ $PF_NET->{'SERVERS'}->{'BY_NAME'}->{$host_type}->{'SRVLIST'}->{$host} }{ qw(distrib deploymode) };
+my $filtered_src
+    = Search_and_replace( $HOSTNAME, $SITE, $INPUT_FILE, 'distrib',
+    $PF_CONFIG, "", $GLOBAL_STRUCT );
 
-unless ($host_distrib) {
-    die "FATAL: unable do find distrib for host $host";
+unless ( open( OUTPUT, ">" . $OUTPUT_FILE ) ) {
+    Abort( $CODE->{'OPEN'},
+        "Unable to open destination file " . $OUTPUT_FILE . " : $OS_ERROR" );
 }
 
-unless ($host_distsrc) {
-    die "FATAL: unable do find deploymode for host $host";
-}
+print OUTPUT join( "", @{$filtered_src} );
+close(OUTPUT);
 
-$host_distsrc =~ s/^(debian|ubuntu)-installer$/$1/;
-
-open SRC, "<$src" or die "open: $src: $!\n";
-open DST, ">$dst" or die "open: $dst: $!\n";
-
-while (<SRC>) {
-	my $line = $_;
-	my $pos  = length $line;
-
-	$line	=~ s/%DISTSRC%/$host_distsrc/gs ;
-	$line	=~ s/%DISTRIB%/$host_distrib/gs ;
-	
-	print DST $line;
-}
-
-close DST;
-close SRC;
-
+exit 0;

Modified: trunk/filters/filter_privateresolve
URL: http://svn.debian.org/wsvn/pf-tools/trunk/filters/filter_privateresolve?rev=902&op=diff
==============================================================================
--- trunk/filters/filter_privateresolve (original)
+++ trunk/filters/filter_privateresolve Wed Sep  8 19:28:28 2010
@@ -2,6 +2,7 @@
 ##
 ##  $Id$
 ##
+##  Copyright (C) 2010 Christophe Caillet <quadchris at free.fr>
 ##  Copyright (C) 2003-2005 Damien Clermonte <damien at sitadelle.com>
 ##  Copyright (C) 2001-2003 Olivier Molteni <olivier at molteni.net>
 ##
@@ -23,78 +24,145 @@
 use strict;
 use warnings;
 
-use PFTools::Conf;
-use PFTools::Net;
-use PFTools::Update;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use IO::File;
+use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
 
-my ( $src, $host, $dst, $sep ) = @ARGV;
-unless ( $src and $host and $dst ) {
-    die "Usage: $0 src host dst [sep]\n";
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+#<<< please, perltidy, don't mess with this (keep each entry on its own line)
+my @options_specifications = (
+    'config-file|config|c=s',
+    'help',
+    'hostname|host|h=s',
+    'input-file|input|i=s',
+    'output-file|output|o=s',
+    'separator|sep=s',
+    'site|s=s',
+    'store-file|store=s',
+    'type-resolve|type|t=s',
+    'zone|z=s',
+);
+#>>>
+# default values
+my $options = {
+    'help'         => 0,
+    'hostname'     => hostname,
+    'separator'    => ' ',
+    'type-resolve' => 'cnf',
+};
+
+my $program = $0;
+$program =~ s%.*/%%;    # cheap basename
+
+###################################
+# Funtions
+
+sub Do_help {
+    print STDERR << "# ENDHELP";
+Usage: $program [options]
+
+    --help                 : print help and exit
+ -h --hostname             : hostname for which we want to filter input
+ -s --site                 : site on which hostname is defined (optional)
+ -c --config-file          : file where pf-tools configuration is stored
+                             e.g. /etc/pf-tools.conf (optional)
+    --store-file           : file where global structure datas are in
+                             storable format (optional)
+ -z --zone                 : zone on which we want to filter input
+ -t --type-resolve         : type for resolution. Allowed values are cnf
+                             (from global configuration structure) and dns
+    --separator            : separator between resolved IPs [default: space]
+ -i --input                : input file
+ -o --output               : output file
+    
+# ENDHELP
 }
 
-$sep = ' ' unless defined $sep;
+##################################
+### MAIN
 
-my $Z = Init_lib_net( Get_source("GLOBAL:private-network") );
-my %subst;
-Init_SUBST ( \%subst, $host, "private" );
+GetOptions( $options, @options_specifications )
+    or die "Didn't grok options (see --help).\n";
 
-open SRC, "<$src" or die "open: $src: $!\n";
-open DST, ">$dst" or die "open: $dst: $!\n";
-
-while (<SRC>) {
-    my $line = $_;
-    my $pos  = length $line;
-    while (
-	substr( $line, 0, $pos )
-	=~ m/^(.*[^A-Za-z0-9.-])?([A-Za-z0-9.-]+)(\\?)(\.$Z->{SOA}->{name})([^A-Za-z0-9.-].*)?$/
-	)
-    {
-	my $before    = $1;
-	my $back      = $3;
-	my $match     = $2 . $3 . $4;
-	my $matchback = $2 . $4;
-	my $after     = $5;
-
-	my $lengthbefore = defined $before ? length $before : 0;
-
-	if ( $back ne '\\' ) {
-
-	    my $match2 = $match;
-	    $match2 =~ s/HOSTNAME/$host/;
-	    $match2 =~ s/POPNAME/$subst{'POPNAME'}/g;
-
-	    my @resolved = Resolv( $match2, $Z );
-
-	    if ( @resolved and defined $resolved[0] ) {
-		if ( $sep eq "DUPLICATE" ) {
-		    my $templine = "";
-		    my $templine2;
-		    foreach my $res (@resolved) {
-			$templine2 = $line;
-			substr( $templine2, $lengthbefore, length $match )
-			    = $res;
-			$templine .= $templine2;
-		    }
-		    $line = $templine;
-		}
-		else {
-		    substr( $line, $lengthbefore, length $match )
-			= join( $sep, @resolved );
-		}
-		$pos = $lengthbefore;
-	    }
-	    else {
-		$pos = $lengthbefore;
-	    }
-	}
-	else {
-	    substr( $line, $lengthbefore, length $match ) = $matchback;
-	    $pos = $lengthbefore;
-	}
-    }
-    print DST $line;
+if ( $options->{'help'} ) {
+    Do_help();
+    exit 0;
 }
 
-close DST;
-close SRC;
+unless ( $options->{'input-file'} and $options->{'output-file'} ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Source and/or destination file is(are) not defined on CLI" );
+}
 
+my ( $PF_CONFIG, $GLOBAL_STRUCT ) = Init_TOOLS(
+    $options->{'hostname'},
+    $options->{'config-file'},
+    $options->{'store-file'}
+);
+
+# FIXME: make a (private) function to handle this?
+unless ( $options->{'site'} ) {
+    my $site = $PF_CONFIG->{'location'}->{'site'};
+    unless ($site) {
+        my $site_list = Get_site_from_hostname( $options->{'hostname'},
+            $GLOBAL_STRUCT );
+        unless ($site_list) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                "Unable to retrieve site for hostname $options->{'hostname'}: hostname not defined"
+            );
+        }
+        if ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                "Unable to retrieve site for hostname $options->{'hostname'}: hostname appeared in multiple sites: "
+                    . join( ',', @{$site_list} )
+                    . ".\nPlease relaunch this command with the right site" );
+        }
+        ($site) = @{$site_list};
+    }
+
+    $options->{'site'} = $site;
+}
+
+$options->{'zone'}
+    = Get_zone_from_site_GLOBAL( $options->{'site'}, $GLOBAL_STRUCT )
+    unless $options->{'zone'};
+
+my $filtered_src = Search_and_replace(
+    $options->{'hostname'},   $options->{'site'},
+    $options->{'input-file'}, 'resolver',
+    $PF_CONFIG,               $options->{'separator'},
+    $GLOBAL_STRUCT,           $options->{'type-resolve'}
+);
+
+# FIXME: functions with too many parameters should be converted
+# to named parameters, like this :
+#my $args_ref = {
+#    hostname       => $options->{'hostname'},
+#    site           => $options->{'site'},
+#    'input-file'   => $options->{'input-file'},
+#    resolver       => 'resolver',
+#    pf_config      => $PF_CONFIG,
+#    separator      => $options->{'separator'},
+#    global_struct  => $GLOBAL_STRUCT,
+#    'resolve-type' => $options->{'type-resolve'},
+#};
+#my $filtered_src = search_and_replace($args_ref);
+
+my $output_fh = IO::File->new("> $options->{'output-file'}")
+    or Abort( $CODE->{'OPEN'},
+    "Unable to open destination file $options->{'output-file'}: $OS_ERROR" );
+
+$output_fh->print( join '', @{$filtered_src} )
+    or Abort( $CODE->{'OPEN'},
+    "Unable to write to destination file $options->{'output-file'}: $OS_ERROR"
+    );
+
+$output_fh->close()
+    or Abort( $CODE->{'OPEN'},
+    "Unable to close destination file $options->{'output-file'}: $OS_ERROR" );
+
+exit 0;

Modified: trunk/filters/filter_vlan2if
URL: http://svn.debian.org/wsvn/pf-tools/trunk/filters/filter_vlan2if?rev=902&op=diff
==============================================================================
--- trunk/filters/filter_vlan2if (original)
+++ trunk/filters/filter_vlan2if Wed Sep  8 19:28:28 2010
@@ -27,63 +27,112 @@
 use strict;
 use warnings;
 
-use PFTools::Conf;
-use PFTools::Net;
-use PFTools::Update;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
 
-my ( $src, $host, $dst ) = @ARGV;
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
 
-unless ( $src and $host and $dst ) {
-    die "Usage: $0 src host dst\n";
+#################################
+# VARS
+my $HELP              = 0;
+my $HOSTNAME          = hostname;
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $INPUT_FILE        = '';
+my $OUTPUT_FILE       = '';
+my $GLOBAL_STRUCT     = {};
+
+my $program = $0;
+$program =~ s%.*/%%;    # cheap basename
+
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
+
+###################################
+# Funtions
+
+sub Do_help {
+    print STDERR << "# ENDHELP";
+    $program - version $version
+
+Usage:	$program [options]
+	--help		: print help and exit
+	-h --host	: hostname for which we want to filter input
+	-s --site	: site on which hostname is defined (optional)
+	-c --config	: file where pf-tools configuration is stored e.g. /etc/pf-tools.conf (optional)
+	--store		: file where global structure datas are in storable format (optional)
+	-i --input	: input file
+	-o --output	: output file
+    
+# ENDHELP
 }
 
-my $Z = Init_lib_net( Get_source("GLOBAL:private-network") );
-my %subst;
-Init_SUBST ( \%subst, $host, "private" );
+##################################
+### MAIN
 
-open SRC, "<$src" or die "open: $src: $!\n";
-open DST, ">$dst" or die "open: $dst: $!\n";
+GetOptions(
+    'help'       => \$HELP,
+    'host|h=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'input|i=s'  => \$INPUT_FILE,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
 
-while (<SRC>) {
-    my $line = $_;
-    my $pos  = length $line;
-    while (
-	substr( $line, 0, $pos )
-	=~ m/^(.*[^A-Za-z0-9.-])?(eth([-.:])([A-Za-z0-9-]+))([^A-Za-z0-9.-].*)?$/
-	)
-    {
-	my $before = $1;
-	my $match  = $2;
-	my $type   = $3;
-	my $vlan   = $4;
-	my $after  = $5;
-
-	my $lengthbefore = defined $before ? length $before : 0;
-
-	my $vlan2 = $vlan;
-	$vlan2 =~ s/POPNAME/$subst{'POPNAME'}/;
-
-	my $eth = Get_If( $Z, $host, $vlan2 );
-
-	if ( defined $eth ) {
-	    my $neweth = $eth;
-	    if ( $type eq '.' ) {
-		$neweth =~ s/:.*$//;
-	    }
-	    elsif ( $type eq '-' ) {
-		$neweth =~ s/[.:].*$//;
-	    }
-
-	    substr( $line, $lengthbefore, length $match ) = $neweth;
-	    $pos = $lengthbefore;
-	}
-	else {
-	    $pos = $lengthbefore;
-	}
-    }
-    print DST $line;
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-close DST;
-close SRC;
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
+}
+
+if ( $INPUT_FILE eq '' || $OUTPUT_FILE eq '' ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Source and/or destination file is(are) not defined on CLI" );
+}
+
+my $filtered_src
+    = Search_and_replace( $HOSTNAME, $SITE, $INPUT_FILE, 'iface', $PF_CONFIG,
+    "", $GLOBAL_STRUCT );
+
+unless ( open( OUTPUT, ">" . $OUTPUT_FILE ) ) {
+    Abort( $CODE->{'OPEN'},
+        "Unable to open destination file " . $OUTPUT_FILE . " : $OS_ERROR" );
+}
+
+print OUTPUT join( "", @{$filtered_src} );
+close(OUTPUT);
+
+exit 0;

Modified: trunk/lib/PFTools/Bridge.pm
URL: http://svn.debian.org/wsvn/pf-tools/trunk/lib/PFTools/Bridge.pm?rev=902&op=diff
==============================================================================
--- trunk/lib/PFTools/Bridge.pm (original)
+++ trunk/lib/PFTools/Bridge.pm Wed Sep  8 19:28:28 2010
@@ -1,4 +1,4 @@
-package PFTools::Bridge ;
+package PFTools::Bridge;
 ##
 ##  $Id$
 ##
@@ -19,18 +19,19 @@
 ##  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
 ##
 
-use strict ;
-use warnings ;
-use Data::Dumper ;
+use strict;
+use warnings;
+
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 
 BEGIN {
-	if (   `which vconfig 2>/dev/null` eq ""
-		|| `which brctl 2>/dev/null`  eq ""
-		|| `which tunctl 2>/dev/null` eq ""
-		|| `which ip 2>/dev/null` eq "" )
-	{
-		die "Sorry, I need vlan, bridge-utils, uml-utilities and iproute2" ;
-	}
+    if (   `which vconfig 2>/dev/null` eq ""
+        || `which brctl 2>/dev/null`  eq ""
+        || `which tunctl 2>/dev/null` eq ""
+        || `which ip 2>/dev/null`     eq "" )
+    {
+        die "Sorry, I need vlan, bridge-utils, uml-utilities and iproute2";
+    }
 }
 
 use Exporter;
@@ -38,246 +39,317 @@
 our @ISA = ('Exporter');
 
 our @EXPORT = qw(
-	Get_all_bridges
-	Check_host_bridge
-	
-	Bridge_primary_exist
-	Bridge_exist
-	
-	Mk_primary_bridge
-	Rm_primary_bridge
-	
-	Attach_host_bridge
-	Detach_host_bridge
-	Add_host_bridge
-	Del_host_bridge
+    Get_all_bridges
+    Check_host_bridge
+
+    Bridge_primary_exist
+    Bridge_exist
+
+    Mk_primary_bridge
+    Rm_primary_bridge
+
+    Attach_host_bridge
+    Detach_host_bridge
+    Add_host_bridge
+    Del_host_bridge
 );
 
 our @EXPORT_OK = qw();
 
-
-my $brctl_cmd	= '/usr/sbin/brctl' ;
-my $tunctl_cmd	= '/usr/sbin/tunctl' ;
-my $ip_cmd	= '/sbin/ip' ;
-my $vconf_cmd	= '/sbin/vconfig' ;
-
-my $DEBUG	= 1 ;
-my $IFNAMSIZ	= 16 ;
-my $VLAN_MTU	= 1496 ;
-my $ETHTRUNK	= 'eth1' ;
-my $XEN_CFG_DIR = '' ;
-my $XEN_USER	= 'root' ;
+my $brctl_cmd  = '/usr/sbin/brctl';
+my $tunctl_cmd = '/usr/sbin/tunctl';
+my $ip_cmd     = '/sbin/ip';
+my $vconf_cmd  = '/sbin/vconfig';
+
+my $DEBUG       = 1;
+my $IFNAMSIZ    = 16;
+my $VLAN_MTU    = 1496;
+my $ETHTRUNK    = 'eth1';
+my $XEN_CFG_DIR = '';
+my $XEN_USER    = 'root';
 
 sub Sysexec ($) {
-	my ( $cmd ) = @_ ;
-	
-	print "DEBUG --> Executing command ".$cmd."\n" ;
-	system ( $cmd ) if ( ! $DEBUG );
-	if ( $? ) {
-		if ( $? == -1 ) {
-			warn "failed to execute: $!\n" ;
-			return 0 ;
-		} elsif ( $? & 127 ) {
-			printf STDERR "child died with signal %d, %s coredump\n", ( $? & 127 ), ( $? & 128 ) ? 'with' : 'without' ;
-			return 0 ;
-		} else {
-			printf STDERR "child exited with value %d\n", $? >> 8 ;
-			return 0 ;
-		}
-	}
-	return 1 ;
+    my ($cmd) = @_;
+
+    print "DEBUG --> Executing command " . $cmd . "\n";
+    system($cmd ) if ( !$DEBUG );
+    if ($CHILD_ERROR) {
+        if ( $CHILD_ERROR == -1 ) {
+            warn "failed to execute: $OS_ERROR\n";
+            return 0;
+        }
+        elsif ( $CHILD_ERROR & 127 ) {
+            printf STDERR "child died with signal %d, %s coredump\n",
+                ( $CHILD_ERROR & 127 ),
+                ( $CHILD_ERROR & 128 ) ? 'with' : 'without';
+            return 0;
+        }
+        else {
+            printf STDERR "child exited with value %d\n", $CHILD_ERROR >> 8;
+            return 0;
+        }
+    }
+    return 1;
 }
 
 sub Sanitize_bridge_name ($) {
-	my ( $br_name ) = @_ ;
-	
-	if ( length ( $br_name ) > $IFNAMSIZ - 1 ) {
-		print "Sanitizing bridge name from ".$br_name." to " if ( $DEBUG ) ;
-		$br_name = substr ( $br_name, length ( $br_name ) - $IFNAMSIZ + 1 );
-		print $br_name."\n" if ( $DEBUG ) ;
-	}
-	return $br_name ;
+    my ($br_name) = @_;
+
+    if ( length($br_name) > $IFNAMSIZ - 1 ) {
+        print "Sanitizing bridge name from " . $br_name . " to " if ($DEBUG);
+        $br_name = substr( $br_name, length($br_name) - $IFNAMSIZ + 1 );
+        print $br_name. "\n" if ($DEBUG);
+    }
+    return $br_name;
 }
 
 sub Get_all_bridges () {
-	my $res = {} ;
-	my ( $cur_br, $brlist ) ;
-	
-	unless ( open ( $brlist, $brctl_cmd.' show |' ) ) {
-		die "Unable top execute command /usr/sbin/brctl show\n" ;
-	}
-	while ( <$brlist> ) {
-		chomp ;
-		if ( /^br([\d]+)/ ) {
-			my ( $brname, $br_id, $stp, $iface ) = split ( /\s+/, $_ ) ;
-			$cur_br = $brname ;
-			push ( @{$res->{$cur_br}->{'iface'}}, $iface ) ;
-		} elsif ( /^bridge/ ) {
-			next ;
-		} else {
-			/^\s*([\S]+)\s*$/ ;
-			push ( @{$res->{$cur_br}->{'iface'}}, $1 ) ;
-		}
-	}
-	close ( $brlist ) ;
-	return $res ;
+    my $res = {};
+    my ( $cur_br, $brlist );
+
+    unless ( open( $brlist, $brctl_cmd . ' show |' ) ) {
+        die "Unable top execute command /usr/sbin/brctl show\n";
+    }
+    while (<$brlist>) {
+        chomp;
+        if (/^br([\d]+)/) {
+            my ( $brname, $br_id, $stp, $iface ) = split( /\s+/, $_ );
+            $cur_br = $brname;
+            push( @{ $res->{$cur_br}->{'iface'} }, $iface );
+        }
+        elsif (/^bridge/) {
+            next;
+        }
+        else {
+            /^\s*([\S]+)\s*$/;
+            push( @{ $res->{$cur_br}->{'iface'} }, $1 );
+        }
+    }
+    close($brlist);
+    return $res;
 }
 
 sub Bridge_primary_exist ($) {
-	my ( $br_name, $br_list ) = @_ ;
-	
-	( defined $br_list->{$br_name} ) ? return 1 : return 0 ;
+    my ( $br_name, $br_list ) = @_;
+
+    ( defined $br_list->{$br_name} ) ? return 1 : return 0;
 }
 
 sub Bridge_exist ($$) {
-	my ( $br_name, $br_list ) = @_ ;
-
-	my ( $hostname, $tag ) = split ( /\./, $br_name ) ;
-	return grep /^$br_name$/, @{$br_list->{'br'.$tag}->{'iface'}} ;
+    my ( $br_name, $br_list ) = @_;
+
+    my ( $hostname, $tag ) = split( /\./, $br_name );
+    return grep /^$br_name$/, @{ $br_list->{ 'br' . $tag }->{'iface'} };
 }
 
 sub Mk_primary_bridge ($) {
-	my ( $primary ) = @_ ;
-	$primary	=~ /^br([\d]+)$/ ;
-	my $tag		= $1 ;
-
-	# Adding bridge
-	print "Creating primary bridge ".$primary."\n" if ( $DEBUG ) ;
-	my $cmd = $brctl_cmd." addbr ".$primary ;
-	if ( ! Sysexec ( $cmd ) ) {
-		warn "Unable to add primary bridge ".$primary."\n" ;
-		return 0 ;
-	}
-	# Setting spanning tree on bridge off
-	print "Setting up sapnning tree off for primary bridge ".$primary."\n" if ( $DEBUG ) ;
-	if ( ! Sysexec ( $brctl_cmd." stp ".$primary." off " ) ) {
-		warn "Unable to deactivate spanning tree protocol on ".$primary."\n" ;
-	}
-	# Setting some timeout on bridge
-	print "Setting up some timeout on primary bridge ".$primary."\n" if ( $DEBUG ) ;
-	foreach my $act ( 'setfd', 'sethello' ) {
-		if ( ! Sysexec ( $brctl_cmd." ".$act." ".$primary." 1" ) ) {
-			warn "Unablr to set timeout for action ".$act." on bridge ".$primary."\n" ;
-		}
-	}
-	print "Checking if TRUNK is configured for vlan tagged as ".$tag."\n" if ( $DEBUG ) ;
-	if ( ! Sysexec ( $ip_cmd." addr show dev ".$ETHTRUNK.".".$tag ) ) {
-		if ( ! Sysexec ( $vconf_cmd."set_name_type DEV_PLUS_VID_NO_PAD" ) ) {
-			warn "Unable to set_name_type for vconfig creation\n" ;
-		}
-		print "Adding vlan tagged as ".$tag." on trunk interface ".$ETHTRUNK."\n" if ( $DEBUG ) ;
-		if ( ! Sysexec ( $vconf_cmd." add ".$ETHTRUNK." ".$tag ) ) {
-			warn "Unable to add vlan tagged as ".$tag." on ".$ETHTRUNK."\n" ;
-			return 0 ;
-		}
-		print "Activating promiscuous mode for ".$ETHTRUNK.".".$tag."\n" if ( $DEBUG ) ;
-		if ( ! Sysexec ( $ip_cmd." link set ".$ETHTRUNK.".".$tag." up promisc on mtu ".$VLAN_MTU ) ) {
-			warn "Unable to set promiscuous mode and mtu on interface ".$ETHTRUNK.".".$tag."\n" ;
-			return 0 ;
-		}
-		print "Setting ip address for ".$ETHTRUNK.".".$tag."\n" if ( $DEBUG ) ;
-		if ( ! Sysexec ( $ip_cmd." addr add 0.0.0.0 dev ".$ETHTRUNK.".".$tag ) ) {
-			warn "Unable to set ip address for ".$ETHTRUNK.".".$tag."\n" ;
-			return 0 ;
-		}
-	}
-	print "Attaching primary bridge ".$primary." to ".$ETHTRUNK.".".$tag."\n" if ( $DEBUG ) ;
-	return Sysexec ( $brctl_cmd." addif ".$primary." ".$ETHTRUNK.".".$tag ) ;
+    my ($primary) = @_;
+    $primary =~ /^br([\d]+)$/;
+    my $tag = $1;
+
+    # Adding bridge
+    print "Creating primary bridge " . $primary . "\n" if ($DEBUG);
+    my $cmd = $brctl_cmd . " addbr " . $primary;
+    if ( !Sysexec($cmd) ) {
+        warn "Unable to add primary bridge " . $primary . "\n";
+        return 0;
+    }
+
+    # Setting spanning tree on bridge off
+    print "Setting up sapnning tree off for primary bridge " . $primary . "\n"
+        if ($DEBUG);
+    if ( !Sysexec( $brctl_cmd . " stp " . $primary . " off " ) ) {
+        warn "Unable to deactivate spanning tree protocol on " . $primary
+            . "\n";
+    }
+
+    # Setting some timeout on bridge
+    print "Setting up some timeout on primary bridge " . $primary . "\n"
+        if ($DEBUG);
+    foreach my $act ( 'setfd', 'sethello' ) {
+        if ( !Sysexec( $brctl_cmd . " " . $act . " " . $primary . " 1" ) ) {
+            warn "Unablr to set timeout for action " 
+                . $act
+                . " on bridge "
+                . $primary . "\n";
+        }
+    }
+    print "Checking if TRUNK is configured for vlan tagged as " . $tag . "\n"
+        if ($DEBUG);
+    if ( !Sysexec( $ip_cmd . " addr show dev " . $ETHTRUNK . "." . $tag ) ) {
+        if ( !Sysexec( $vconf_cmd . "set_name_type DEV_PLUS_VID_NO_PAD" ) ) {
+            warn "Unable to set_name_type for vconfig creation\n";
+        }
+        print "Adding vlan tagged as " 
+            . $tag
+            . " on trunk interface "
+            . $ETHTRUNK . "\n"
+            if ($DEBUG);
+        if ( !Sysexec( $vconf_cmd . " add " . $ETHTRUNK . " " . $tag ) ) {
+            warn "Unable to add vlan tagged as " 
+                . $tag . " on "
+                . $ETHTRUNK . "\n";
+            return 0;
+        }
+        print "Activating promiscuous mode for "
+            . $ETHTRUNK . "."
+            . $tag . "\n"
+            if ($DEBUG);
+        if (!Sysexec(
+                      $ip_cmd
+                    . " link set "
+                    . $ETHTRUNK . "."
+                    . $tag
+                    . " up promisc on mtu "
+                    . $VLAN_MTU
+            )
+            )
+        {
+            warn "Unable to set promiscuous mode and mtu on interface "
+                . $ETHTRUNK . "."
+                . $tag . "\n";
+            return 0;
+        }
+        print "Setting ip address for " . $ETHTRUNK . "." . $tag . "\n"
+            if ($DEBUG);
+        if (!Sysexec(
+                $ip_cmd . " addr add 0.0.0.0 dev " . $ETHTRUNK . "." . $tag
+            )
+            )
+        {
+            warn "Unable to set ip address for "
+                . $ETHTRUNK . "."
+                . $tag . "\n";
+            return 0;
+        }
+    }
+    print "Attaching primary bridge " 
+        . $primary . " to "
+        . $ETHTRUNK . "."
+        . $tag . "\n"
+        if ($DEBUG);
+    return Sysexec(
+        $brctl_cmd . " addif " . $primary . " " . $ETHTRUNK . "." . $tag );
 }
 
 sub Rm_primary_bridge ($;$) {
-	my ( $primary, $ref_brlist ) = @_ ;
-	
-	if ( ! defined $ref_brlist ) {
-		print "Need to retrieve bridges configuration on host\n" if ( $DEBUG ) ;
-		$ref_brlist = Get_all_bridges () ;
-		if ( ! defined $ref_brlist ) {
-			warn "Unable to retrieve briges list : unable to remove primary bridge ".$primary."\n" ;
-			return 0 ;
-		}
-	}
-	if ( ! defined $ref_brlist->{$primary} ) {
-		warn "No such primary bridge ".$primary."\n" ;
-		return 0 ;
-	}
-	foreach my $iface ( @{$ref_brlist->{$primary}} ) {
-		if ( ! Detach_host_bridge ( $iface, $primary ) ) {
-			warn "Unable to detach interface ".$iface." from primary bridge ".$primary." before removing it\n" ;
-			return 0 ;
-		}
-	}
-	return Sysexec ( $brctl_cmd." delbr ".$primary ) ;
+    my ( $primary, $ref_brlist ) = @_;
+
+    if ( !defined $ref_brlist ) {
+        print "Need to retrieve bridges configuration on host\n" if ($DEBUG);
+        $ref_brlist = Get_all_bridges();
+        if ( !defined $ref_brlist ) {
+            warn
+                "Unable to retrieve briges list : unable to remove primary bridge "
+                . $primary . "\n";
+            return 0;
+        }
+    }
+    if ( !defined $ref_brlist->{$primary} ) {
+        warn "No such primary bridge " . $primary . "\n";
+        return 0;
+    }
+    foreach my $iface ( @{ $ref_brlist->{$primary} } ) {
+        if ( !Detach_host_bridge( $iface, $primary ) ) {
+            warn "Unable to detach interface " 
+                . $iface
+                . " from primary bridge "
+                . $primary
+                . " before removing it\n";
+            return 0;
+        }
+    }
+    return Sysexec( $brctl_cmd . " delbr " . $primary );
 }
 
 sub Detach_host_bridge ($$) {
-	my ( $br_name, $primary ) = @_ ;
-	
-	print "Detaching bridge ".$br_name." from primary ".$primary."\n" if ( $DEBUG ) ;
-	my $cmd = $brctl_cmd." delif ".$primary." ".$br_name ;
-	return Sysexec ( $cmd ) ;
+    my ( $br_name, $primary ) = @_;
+
+    print "Detaching bridge " . $br_name . " from primary " . $primary . "\n"
+        if ($DEBUG);
+    my $cmd = $brctl_cmd . " delif " . $primary . " " . $br_name;
+    return Sysexec($cmd);
 }
 
 sub Attach_host_bridge ($$) {
-	my ( $br_name, $primary ) = @_ ;
-	
-	print "Attaching bridge ".$br_name." to primary bridge ".$primary."\n" if ( $DEBUG ) ;
-	my $cmd = $brctl_cmd." addif ".$primary." ".$br_name ;
-	return Sysexec ( $cmd ) ;
+    my ( $br_name, $primary ) = @_;
+
+    print "Attaching bridge " 
+        . $br_name
+        . " to primary bridge "
+        . $primary . "\n"
+        if ($DEBUG);
+    my $cmd = $brctl_cmd . " addif " . $primary . " " . $br_name;
+    return Sysexec($cmd);
 }
 
 sub Add_host_bridge ($$) {
-	my ( $hostname, $tag ) = @_ ;
-	my $primary = "br".$tag ;
-
-	my $br_name = Sanitize_bridge_name ( $hostname.".".$tag ) ;
-	my $cmd = $tunctl_cmd." -b -u ".$XEN_USER." -t ".$br_name ;
-	if ( ! Bridge_primary_exist ( $primary ) ) {
-		if ( ! Mk_primary_bridge ( $primary ) ) {
-			warn "Unable to create primary bridge ".$primary."\n" ;
-			return undef ;
-		}
-	}
-	print "Adding host TUN/TAP interface ".$br_name."\n" if ( $DEBUG ) ;
-	if ( ! Sysexec ( $cmd ) ) {
-		warn "Unable to add host bridge ".$br_name."\n" ;
-		return undef ;
-	}
-	return $br_name ;
+    my ( $hostname, $tag ) = @_;
+    my $primary = "br" . $tag;
+
+    my $br_name = Sanitize_bridge_name( $hostname . "." . $tag );
+    my $cmd     = $tunctl_cmd . " -b -u " . $XEN_USER . " -t " . $br_name;
+    if ( !Bridge_primary_exist($primary) ) {
+        if ( !Mk_primary_bridge($primary) ) {
+            warn "Unable to create primary bridge " . $primary . "\n";
+            return undef;
+        }
+    }
+    print "Adding host TUN/TAP interface " . $br_name . "\n" if ($DEBUG);
+    if ( !Sysexec($cmd) ) {
+        warn "Unable to add host bridge " . $br_name . "\n";
+        return undef;
+    }
+    return $br_name;
 }
 
 sub Del_host_bridge ($$) {
-	my ( $hostname, $tag ) = @_ ;
-	my $primary = "br".$tag ;
-
-	if ( ! Detach_host_bridge ( $hostname.".".$tag, $primary ) ) {
-		warn "Unable to detach ".$hostname.".".$tag." from ".$primary."\n" ;
-		return 0 ;
-	}
-	print "Deleting host bridge ".$hostname.".".$tag."\n" if ( $DEBUG ) ;
-	return Sysexec ( $tunctl_cmd." -b -d ".$hostname.".".$tag ) ;
+    my ( $hostname, $tag ) = @_;
+    my $primary = "br" . $tag;
+
+    if ( !Detach_host_bridge( $hostname . "." . $tag, $primary ) ) {
+        warn "Unable to detach "
+            . $hostname . "."
+            . $tag
+            . " from "
+            . $primary . "\n";
+        return 0;
+    }
+    print "Deleting host bridge " . $hostname . "." . $tag . "\n" if ($DEBUG);
+    return Sysexec( $tunctl_cmd . " -b -d " . $hostname . "." . $tag );
 }
 
 sub Check_host_bridge ($$$) {
-	my ( $ref_net, $hostname, $ref_brlist ) = @_ ;
-	
-	my $hosttype	= $hostname ;
-	$hosttype	=~ s/[\d]+$// ;
-	
-	print "$hosttype\n" ;
-	if ( ! defined ( $ref_net->{'SERVERS'}->{'BY_NAME'}->{$hosttype}->{'SRVLIST'}->{$hostname} ) ) {
-		die "Hostname ".$hostname." doesn't exist\n" ;
-	}
-	my $HOST = $ref_net->{'SERVERS'}->{'BY_NAME'}->{$hosttype}->{'SRVLIST'}->{$hostname} ;
-	foreach my $vlan ( keys %{$HOST->{'ifup'}} ) {
-		$vlan =~ s/^$hostname\.// ;
-		die "No tag defined for vlan ".$vlan."\n" if ( ! defined ( $ref_net->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'tag'} ) ) ;
-		my $tag = $ref_net->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'tag'} ;
-		if ( ! Bridge_exist ( $hostname.'.'.$tag, $ref_brlist ) ) {
-			print "Need to create bridge ".$hostname.".".$tag."\n" ;
-			Add_host_bridge ( $hostname, $tag ) ;
-			Attach_host_bridge ( 'br'.$tag, $hostname.".".$tag ) ;
-		} else {
-			print "Bridge ".$hostname.".".$tag." already exists\n" ;
-		}
-	}
-}
+    my ( $ref_net, $hostname, $ref_brlist ) = @_;
+
+    my $hosttype = $hostname;
+    $hosttype =~ s/[\d]+$//;
+
+    print "$hosttype\n";
+    if (!defined(
+            $ref_net->{'SERVERS'}->{'BY_NAME'}->{$hosttype}->{'SRVLIST'}
+                ->{$hostname}
+        )
+        )
+    {
+        die "Hostname " . $hostname . " doesn't exist\n";
+    }
+    my $HOST = $ref_net->{'SERVERS'}->{'BY_NAME'}->{$hosttype}->{'SRVLIST'}
+        ->{$hostname};
+    foreach my $vlan ( keys %{ $HOST->{'ifup'} } ) {
+        $vlan =~ s/^$hostname\.//;
+        die "No tag defined for vlan " . $vlan . "\n"
+            if (
+            !defined( $ref_net->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'tag'} )
+            );
+        my $tag = $ref_net->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'tag'};
+        if ( !Bridge_exist( $hostname . '.' . $tag, $ref_brlist ) ) {
+            print "Need to create bridge " . $hostname . "." . $tag . "\n";
+            Add_host_bridge( $hostname, $tag );
+            Attach_host_bridge( 'br' . $tag, $hostname . "." . $tag );
+        }
+        else {
+            print "Bridge " . $hostname . "." . $tag . " already exists\n";
+        }
+    }
+}

Modified: trunk/lib/PFTools/Conf.pm
URL: http://svn.debian.org/wsvn/pf-tools/trunk/lib/PFTools/Conf.pm?rev=902&op=diff
==============================================================================
--- trunk/lib/PFTools/Conf.pm (original)
+++ trunk/lib/PFTools/Conf.pm Wed Sep  8 19:28:28 2010
@@ -2,7 +2,7 @@
 ##
 ##  $Id$
 ##
-##  Copyright (C) 2007-2009 Christophe Caillet <quadchris at free.fr>
+##  Copyright (C) 2007-2010 Christophe Caillet <quadchris at free.fr>
 ##  Copyright (C) 2005-2007 Thomas Parmelan <tom+pf-tools at ankh.fr.EU.org>
 ##  Copyright (C) 2003-2005 Damien Clermonte <damien at sitadelle.com>
 ##  Copyright (C) 2001-2003 Olivier Molteni <olivier at molteni.net>
@@ -25,639 +25,589 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Exporter;
+use Fcntl ':mode';
+use Storable;
+use Sys::Hostname;
+
+use PFTools::Conf::Host;
+use PFTools::Conf::Network;
+use PFTools::Conf::Syntax;
+use PFTools::Logger;
+use PFTools::Net;
+use PFTools::Parser;
+use PFTools::Structqueries;
 
 our @ISA = ('Exporter');
 
 our @EXPORT = qw(
-    $ERR_OPEN
-    $ERR_SYNTAX
-    $PFTOOLS_VARS
-    $DEFERREDLOG
-    %SUBST
-
+    Subst_vars
     Init_SUBST
-    Subst_vars
+    Init_PF_CONFIG
+    Init_GLOBAL_NETCONFIG
     Load_conf
-    deferredlogsystem
-    deferredlogpipe
-    FlushLog
-    DelLog
-    Abort
-    Warn
-    Debug
-    Log
+    Flush2disk_GLOBAL
+    Retrieve_GLOBAL
+    Get_source
+    Get_config_for_hostname_on_site
 );
 
 our @EXPORT_OK = qw();
 
-# Error code
-our $ERR_OPEN   = 1;
-our $ERR_SYNTAX = 2;
-
-my $DEBUG	= 0 ;
-
-# Vars needed by pf-launch
-my $sortie;
-my $tmpfile = "/tmp/update-config.log";
-
-# Table de substitution globale
-our %SUBST;
-
-my $FAKEHOSTNAME;
-my $FAKEDOMAINNAME;
-our $DEFERREDLOG = 0;
-
-sub Init_SUBST ($;$$) {
-	my ( $ref_subst, $fakehost, $fakedomain ) = @_ ;
-	
-	if ( defined $fakehost && ! defined $fakedomain ) {
-		warn "Unable to init substitution hash for hostname ".$fakehost."\n" ;
-		return ;
-	}
-	elsif ( defined $fakehost ) {
-		$ref_subst->{'HOSTNAME'}	= $fakehost ;
-		$ref_subst->{'DOMAINNAME'}	= $fakedomain ;
-	}
-	else {
-		chomp ( $ref_subst->{'HOSTNAME'} = `/bin/hostname -s 2>>/dev/null` ) ;
-		if ( -x "/bin/domainname" ) {
-			chomp( $ref_subst->{'DOMAINNAME'} = `/bin/domainname 2>>/dev/null` );
-		}
-		elsif ( -x "/bin/dnsdomainname" ) {
-			chomp( $ref_subst->{'DOMAINNAME'} = `/bin/dnsdomainname 2>>/dev/null` );
-		}
-		else {
-			$ref_subst->{'DOMAINNAME'} = "";
-		}
-	}
-	chomp ( $ref_subst->{'OS_RELEASE'} = `/bin/uname -r` ) ;
-	my $host_regex = qr{
-	    \A
-	    (				# HOSTTYPE
-		(
-		    (			# POPNAME (optional)
-			[a-z]{3}\d{1}
-		    )
-		    -
-		)?
-		(
-		    [a-z0-9-]+[a-z-]	# host type (without the POP name)
-		)
-	    )
-	    (\d*)			# HOSTDIGITS (optional)
-	    ([a-z]*)			# HOSTNODEINDEX (optional)
-	    \z
-	}xms;
-
-	unless ($ref_subst->{'HOSTNAME'} =~ m/$host_regex/) {
-	    Abort( $ERR_OPEN, "Init_SUBST failed: invalid hostname $ref_subst->{'HOSTNAME'}" );
-	}
-	$ref_subst->{'HOSTTYPE'}	= $1 ;
-	$ref_subst->{'HOSTDIGITS'}	= $5 ;
-	$ref_subst->{'HOSTCLUSTER'}	= $4.$5 ;
-	$ref_subst->{'HOSTNODEINDEX'}	= $6 || "" ;
-	$ref_subst->{'POPNAME'}		= $3 || "" ;
-	$ref_subst->{'HOSTNUM'}		= $ref_subst->{'HOSTDIGITS'} ;
-	$ref_subst->{'HOSTNUM'}		=~ s/^0*// ;
-	if ( $ref_subst->{'HOSTNUM'} eq "" ) {
-		$ref_subst->{'HOSTNUM'} = 0 ;
-	}
-	$ref_subst->{'HOSTMINUTE'} = $ref_subst->{'HOSTNUM'} % 60 ;
-	$ref_subst->{'HOSTHOUR'} = $ref_subst->{'HOSTNUM'} % 24 ;
-}
-
-Init_SUBST ( \%SUBST ) ;
-
-# PFTools variables define in configuration files
-our $PFTOOLS_VARS = {} ;
-$PFTOOLS_VARS->{'VMWARE'}	= 0 ;
-$PFTOOLS_VARS->{'UML'}		= 0 ;
-
+#################################
+### Constants
+
+my $DEBUG = 0;
+
+#############################################################
+### Default value for configuration with new method
+our $PF_CONFIG = {
+    'path' => {
+        'status_dir'     => '/var/lib/pftools',
+        'distrib_dir'    => '/distrib',
+        'tftp_dir'       => '/distrib/tftpboot',
+        'pxefiles_dir'   => '/distrib/tftpboot/pxelinux.cfg',
+        'global_struct'  => '/var/lib/pf-tools/global_struct.stor',
+        'deploy_docroot' => '/var/www',
+        'preseed_dir'    => '/var/www/preseed',
+        'checkout_dir'   => '/var/lib/cvsguest',
+        'templates_dir'  => '/usr/share/pf-tools/templates',
+        'common_config'  => 'update-common',
+        'start_file'     => 'private-network',
+    },
+    'features' => {
+        'ipv4'   => 1,
+        'ipv6'   => 0,
+        'update' => 1,
+    },
+    'vcs' => {
+        'type'     => 'cvs',
+        'user'     => 'cvsguest',
+        'password' => '',
+        'method'   => 'rsh',
+        'rsh'      => '/usr/local/sbin/cvs_rsh',
+        'server'   => 'cvs.private',
+        'vcsroot'  => '/var/lib/cvs/repository',
+        'module'   => 'config',
+        'umask'    => '0077',
+        'command'  => '',
+        'branche'  => '',
+    },
+    'debian' => {
+        'preseed'          => 'standard-preseed',
+        'pxe'              => 'standard-installer',
+        'sources_list'     => 'sources.list',
+        'default_sections' => 'main contrib non-free',
+        'custom-sections'  => 'common',
+        'grub'             => '/boot/grub/menu.lst',
+        'grub2'            => '/etc/default/grub',
+    },
+    'ubuntu' => {
+        'preseed'          => 'ubuntu-preseed',
+        'pxe'              => 'ubuntu-installer',
+        'sources_list'     => 'ubuntu-sources.list',
+        'default_sections' => 'main universe restricted',
+        'custom-sections'  => 'common',
+        'grub'             => '/boot/grub/menu.lst',
+        'grub2'            => '/etc/default/grub',
+    },
+    'regex' => {
+        'hostname_model' => $MODEL_CONFIG_REGEX,
+        'hostname'       => $HOST_CONFIG_REGEX,
+        'hosttype'       => $HOSTTYPE_CONFIG_REGEX,
+        'deploy_hosts'   => $DEPLOY_CONFIG_REGEX,
+        'network_fstype' => '(nfs|cifs)',
+    },
+    'location' => {
+        'site' => '',
+        'zone' => '',
+    },
+};
 
 # Subst_vars
 sub Subst_vars {
-    my ($str) = @_;
-
-#     while ( $str =~ s/%([^%\s]*)%/$SUBST{"$1"}/ ) { }
-    foreach my $elt ( split ( '%', $str ) ) {
-        next if ( $elt eq '' );
-        if ( defined $SUBST{$elt} ) {
-            $str =~ s/%$elt%/$SUBST{$elt}/;
-        }
-    }
-    return ($str);
-}
-
-my $deferbuffer;
-my $deferredlogbuffer    = '';
-my @rotatecursortemplate = ( '-', '\\', '|', '/' );
-my $rotatecursorcount    = 0;
-
-sub RotateCursor {
-    print STDERR $rotatecursortemplate[$rotatecursorcount], "\r";
-    $rotatecursorcount
-	= ( $rotatecursorcount + 1 ) % ( $#rotatecursortemplate + 1 );
-}
-
-sub DeferOutput {
-
-    local *REAL_STDOUT;
-    local *REAL_STDERR;
-
-    open( REAL_STDOUT, ">&STDOUT" );
-    open( REAL_STDERR, ">&STDERR" );
-
-    close STDOUT;
-    close STDERR;
-
-    $sortie->{'_stdout'} = *REAL_STDOUT;
-    $sortie->{'_stderr'} = *REAL_STDERR;
-
-    open( STDOUT, "+>$tmpfile" ) or warn "Can't open tmp file for stdout";
-    open( STDERR, ">&STDOUT" )   or warn "Can't open tmp file for stderr";
-    unlink $tmpfile;
-
-    select STDERR;
-    $| = 1;
-    select STDOUT;
-    $| = 1;
-
-}
-
-sub UndeferOutput {
-
-    seek( STDOUT, 0, 0 );
-    local $/;
-    $deferbuffer = <STDOUT>;
-
-    if ( defined( $sortie->{'_stdout'} ) ) {
-	local *REAL_STDOUT;
-	*REAL_STDOUT = $sortie->{'_stdout'};
-	open( STDOUT, ">&REAL_STDOUT" ) or warn "Can't restore STDOUT: $!
-    +";
-	undef( $sortie->{'_stdout'} );
-    }
-    if ( defined( $sortie->{'_stderr'} ) ) {
-	local *REAL_STDERR;
-	*REAL_STDERR = $sortie->{'_stderr'};
-	open( STDERR, ">&REAL_STDERR" ) or warn "Can't restore STDERR: $!
-    +";
-	undef( $sortie->{'_stderr'} );
-    }
-    select STDERR;
-    $| = 1;
-    select STDOUT;
-    $| = 1;
-
-}
-
-# Returns undef on error
-sub deferredlogpipe {
-    my $ret = '';
-
-    DeferOutput() if $DEFERREDLOG;
-
-    unless ( open DEFERREDLOGPIPE, '-|', @_ ) {
-	Warn( $ERR_OPEN, "Unable to open pipe @_: $!" );
-	return;
-    }
-
-    while (<DEFERREDLOGPIPE>) {
-	chomp;
-	$ret .= $_;
-    }
-    close DEFERREDLOGPIPE;
-
-    UndeferOutput() if $DEFERREDLOG;
-
-    if ($deferbuffer) {
-	$deferredlogbuffer .= $deferbuffer;
-	$deferbuffer = undef;
-    }
-
-    RotateCursor() if $DEFERREDLOG;
-
-    return $ret;
-}
-
-sub deferredlogsystem {
-    my $ret;
-
-    DeferOutput() if ($DEFERREDLOG);
-
-    $ret = system(@_);
-
-    UndeferOutput() if ($DEFERREDLOG);
-
-    if ( defined $deferbuffer && $deferbuffer ne '' ) {
-	$deferredlogbuffer .= $deferbuffer;
-	$deferbuffer = undef;
-    }
-
-    RotateCursor() if ($DEFERREDLOG);
-
-    return $ret;
-}
-
-sub DelLog {
-    $deferredlogbuffer = '';
-}
-
-sub FlushLog {
-    print STDERR $deferredlogbuffer;
-    DelLog();
-}
-
-# Log
-sub Log {
-    my @words = split( /\s+/, join( '', @_ ) );
-    my $col   = 0;
-    my $sup   = "";
-    my $word;
-
-    foreach $word (@words) {
-	my $len = length($word);
-	if ( defined($word) && $len > 0 ) {
-	    if ( $col != 0 ) {
-		$sup = " ";
-	    }
-
-	    if ( $word eq "\n" || $word eq "\r" ) {
-		$deferredlogbuffer .= "\n";
-		$col = 0;
-	    }
-	    elsif ( $col + $len + length($sup) < 80 ) {
-		$deferredlogbuffer .= $sup . $word;
-		$col = $col + length($sup) + $len;
-	    }
-	    else {
-		$deferredlogbuffer .= "\n... " . $word;
-		$col = 4 + $len;
-	    }
-	}
-    }
-
-    $deferredlogbuffer .= "\n";
-
-    if ( !$DEFERREDLOG ) {
-	FlushLog();
+    my ( $str, $hash_subst ) = @_;
+
+    return unless $str and $hash_subst;
+
+    $str =~ s/%([^\%]+)%/$hash_subst->{$1}/gm;
+    return $str;
+}
+
+sub Init_PF_CONFIG {
+    my ($config_file) = @_;
+
+    return $PF_CONFIG unless $config_file;
+
+    if ( !-e $config_file ) {
+        Abort( $CODE->{'UNDEF_KEY'},
+                  "Unable to proceed with configuration file "
+                . $config_file
+                . " : no such file or directory" );
+    }
+    my ( $dev, $ino, $mode, $nlink, $uid, $gid, @lstat_vars )
+        = lstat($config_file);
+
+# 		unless ( $uid == 0 && $gid == 0 && S_IMODE($mode) == 0600 && S_ISREG($mode) ) {
+    unless ( S_IMODE($mode) == 0600 && S_ISREG($mode) ) {
+        Abort( $CODE->{'RIGHTS'},
+                  "Ignoring weak rights for configuration file "
+                . $config_file
+                . " (check owner/group/mode)" );
+    }
+
+    my $conf_parsed = Parser_ini($config_file);
+    Abort( $CODE->{'SYNTAX'},
+        "Unable to parse configuration file " . $config_file )
+        if ( !defined $conf_parsed );
+    foreach my $section ( keys %{$PF_CONFIG} ) {
+        next if ( !defined $conf_parsed->{$section} );
+        foreach my $key ( keys %{ $PF_CONFIG->{$section} } ) {
+            if ( defined $conf_parsed->{$section}->{$key} ) {
+                $PF_CONFIG->{$section}->{$key}
+                    = $conf_parsed->{$section}->{$key};
+            }
+        }
+    }
+    return $PF_CONFIG;
+}
+
+sub Init_SUBST {
+    my ( $host, $hosttype, $pf_config, $domain ) = @_;
+
+    unless ($host) {
+        Abort( $CODE->{'UNDEF_KEY'},
+            "Unable to init substitution hash (undefined hostname).\n" );
+    }
+    unless ($pf_config) {
+        $pf_config = Init_PF_CONFIG();
+    }
+
+    my $ref_subst = {};
+    $ref_subst->{'HOSTNAME'} = ( $host ne "" ) ? $host : hostname;
+    $ref_subst->{'DOMAINNAME'} 
+        = $domain
+        || $pf_config->{'location'}->{'zone'}
+        || "";
+    if ( $ref_subst->{'DOMAINNAME'} eq "" ) {
+        if ( -x "/bin/domainname" ) {
+            chomp( $ref_subst->{'DOMAINNAME'}
+                    = `/bin/domainname 2>>/dev/null` );
+        }
+        elsif ( -x "/bin/dnsdomainname" ) {
+            chomp( $ref_subst->{'DOMAINNAME'}
+                    = `/bin/dnsdomainname 2>>/dev/null` );
+        }
+    }
+    chomp( $ref_subst->{'OS_RELEASE'} = `/bin/uname -r` );
+
+    my $host_regex = $pf_config->{'regex'}->{'hostname'}
+        || $HOST_CONFIG_REGEX;
+    unless ( $ref_subst->{'HOSTNAME'} =~ m/$host_regex/ ) {
+        Abort( $CODE->{'OPEN'},
+            "Init_SUBST failed: invalid hostname $ref_subst->{'HOSTNAME'}" );
+    }
+
+    $ref_subst->{'HOSTTYPE'}    = $hosttype || $+{HOSTTYPE};
+    $ref_subst->{'HOSTDIGITS'}  = $+{HOSTDIGITS};
+    $ref_subst->{'HOSTCLUSTER'} = $+{HOSTDIGITS} . $+{HOSTNODEINDEX}
+        if defined $+{HOSTDIGITS} and defined $+{HOSTNODEINDEX};
+    $ref_subst->{'HOSTNODEINDEX'} = $+{HOSTNODEINDEX} || '';
+    $ref_subst->{'POPNAME'}       = $+{POPNAME}       || '';
+    $ref_subst->{'HOSTNUM'}       = $ref_subst->{'HOSTDIGITS'};
+    $ref_subst->{'HOSTNUM'} =~ s/^0*//;
+
+    if ( $ref_subst->{'HOSTNUM'} eq '' ) {
+        $ref_subst->{'HOSTNUM'} = 0;
+    }
+    $ref_subst->{'HOSTMINUTE'} = $ref_subst->{'HOSTNUM'} % 60;
+    $ref_subst->{'HOSTHOUR'}   = $ref_subst->{'HOSTNUM'} % 24;
+    return $ref_subst;
+}
+
+sub Get_source {
+    my ( $source, $hostname, $hash_subst, $pf_config ) = @_;
+
+    return unless $source;
+
+    unless ($hash_subst) {
+        $hash_subst = Init_SUBST( $hostname, $pf_config );
+    }
+    unless ($pf_config) {
+        $pf_config = $PF_CONFIG;
+    }
+
+    my $vcs_work_dir = $pf_config->{'path'}->{'checkout_dir'};
+    my $module       = $pf_config->{'vcs'}->{'module'};
+    $source =~ s!^MODSITE_([^:]+):!$vcs_work_dir/$module/SITE/$1/MODEL!;
+    $source =~ s!^MOD:!$vcs_work_dir/$module/MODEL!;
+    $source =~ s!^CONFSITE_([^:]+):!$vcs_work_dir/$module/SITE/$1/CONFIG!;
+    $source =~ s!^CONF:!$vcs_work_dir/$module/CONFIG!;
+    $source =~ s!^SITE_([^:]+):!$vcs_work_dir/$module/SITE/$1!;
+    $source =~ s!^SITE:!$vcs_work_dir/$module/SITE!;
+    $source
+        =~ s!^HOSTSITE_([^:]+):!$vcs_work_dir/$module/SITE/$1/$hash_subst->{'HOSTTYPE'}!;
+    $source =~ s!^HOST:!$vcs_work_dir/$module/$hash_subst->{'HOSTTYPE'}!;
+    $source =~ s!^COMMON:!$vcs_work_dir/$module/COMMON!;
+    $source =~ s!^CONFIG:!$vcs_work_dir/$module/!;
+    $source =~ s!^CVS:!$vcs_work_dir/!;
+    $source =~ s!^GLOBAL:!$vcs_work_dir/$module/GLOBAL!;
+    return $source;
+}
+
+sub __Get_config_path {
+    my ( $hostvalue, $pf_config, $site ) = @_;
+
+    return unless $hostvalue and $pf_config and $site;
+
+    my $site_conf_file = Get_source( "CONFSITE_${site}:/update-${hostvalue}",
+        $hostvalue, {}, $pf_config );
+    return $site_conf_file
+        if -e $site_conf_file;
+
+    my $default_conf_file
+        = Get_source( "CONFIG:/update-${hostvalue}", $hostvalue, {},
+        $pf_config );
+    return $default_conf_file
+        if -e $default_conf_file;
+
+    return;
+}
+
+sub __Merge_host_config {
+    my ( $hash_to_merge, $hash_subst ) = @_;
+
+    return unless $hash_to_merge and $hash_subst;
+
+    my $merge = {};
+    if ( $hash_to_merge->{'hostgroup'}->{'__model'} ) {
+        $merge = $hash_to_merge->{'hostgroup'}->{'__model'};
+    }
+
+    foreach my $section ( @{ $hash_to_merge->{'__sections_order'} } ) {
+        if ( defined $merge->{$section} ) {
+            foreach my $key ( keys %{ $hash_to_merge->{$section} } ) {
+                next if $section eq 'hostgroup' and $key eq '__model';
+
+                # Adding key if not defined into model else overriding it
+                if ( $key =~ /^\@/ ) {
+                    push @{ $merge->{$section}->{$key} },
+                        @{ $hash_to_merge->{$section}->{$key} };
+                }
+                else {
+                    $merge->{$section}->{$key}
+                        = $hash_to_merge->{$section}->{$key};
+                }
+            }
+        }
+        else {
+            push @{ $merge->{'__sections_order'} }, $section;
+            $merge->{$section} = $hash_to_merge->{$section};
+        }
+    }
+    return $merge;
+}
+
+# sub __Merge_other_context
+
+sub __Merge_conf_includes {
+    my ( $hash_to_merge, $hash_subst, $context ) = @_;
+
+    return unless $hash_to_merge and $hash_subst and $context;
+
+    if ( $context =~ /^host|model$/ ) {
+        return __Merge_host_config( $hash_to_merge, $hash_subst );
+    }
+
+    my $global_parsed = {};
+
+    my $select = ( $context eq 'config' ) ? 'action' : 'type';
+    foreach my $section ( @{ $hash_to_merge->{'__sections_order'} } ) {
+        if ( $hash_to_merge->{$section}->{$select} ne 'include' ) {
+            push @{ $global_parsed->{'__sections_order'} }, $section;
+            $global_parsed->{$section} = $hash_to_merge->{$section};
+            next;
+        }
+        my $tmp_merged
+            = __Merge_conf_includes(
+            $hash_to_merge->{$section}->{'__content'},
+            $hash_subst, $context );
+        foreach my $tomerge_section ( @{ $tmp_merged->{'__sections_order'} } )
+        {
+            if ( defined $global_parsed->{$tomerge_section} ) {
+                if ( !defined $tmp_merged->{$tomerge_section}->{'override'}
+                    || $tmp_merged->{$tomerge_section}->{'override'} ne
+                    'replace' )
+                {
+                    Warn( $CODE->{'WARNING'},
+                        "Section $tomerge_section from file $section already defined ... skipping it\n"
+                    );
+                    next;
+                }
+                else {
+                    Warn( $CODE->{'WARNING'},
+                        "Section $tomerge_section already defined but override is set to replace ... overriding it\n"
+                    );
+
+         # Need to evalute if order must be changed
+         # push ( @{$global_parsed->{'__sections_order'}}, $tomerge_section );
+                }
+            }
+            else {
+                push @{ $global_parsed->{'__sections_order'} },
+                    $tomerge_section;
+            }
+            $global_parsed->{$tomerge_section}
+                = $tmp_merged->{$tomerge_section};
+        }
+    }
+
+    return $global_parsed;
+}
+
+sub Load_conf {
+    my ( $file, $hash_subst, $context, $pf_config ) = @_;
+
+    return unless $file and $hash_subst and $context and $pf_config;
+
+    if ( $context !~ m/^$ALLOWED_PARSING_CONTEXT$/ ) {
+        Abort( $CODE->{'INVALID_CONTEXT'},
+            "Context $context for file $file doesn't match $ALLOWED_PARSING_CONTEXT"
+        );
+    }
+
+    my $parsed = Parser_ini($file);
+    if ( !defined $parsed ) {
+        Abort( $CODE->{'PARSING'}, "Parsing error for file $file" );
+    }
+
+    if ( $context =~ /^(model|host)$/ ) {
+        if ( defined $parsed->{'hostgroup'}->{'model'} ) {
+            $parsed->{'hostgroup'}->{'__model'} = Load_conf(
+                Get_source(
+                    $parsed->{'hostgroup'}->{'model'},
+                    "", $hash_subst, $pf_config
+                ),
+                $hash_subst,
+                'model',
+                $pf_config
+            );
+        }
     }
     else {
-	RotateCursor();
-    }
-}
-
-# Debug
-sub Debug ($) {
-    my (@msg) = @_;
-
-    # FIXME à faire une bonne fois pour toutes !
-    my $basename = ( split( '/', $0 ) )[-1];
-    Log( $basename . ": DEBUG: ", @msg );
-}
-
-# Warn
-sub Warn {
-    my ( $err, @msg ) = @_;
-    my $basename;
-
-    $basename = ( split( '/', $0 ) )[-1];
-
-    Log( $basename . ": WARN: ", @msg );
-}
-
-# Abort
-sub Abort {
-    my ( $err, @msg ) = @_;
-    my $basename;
-
-    $basename = ( split( '/', $0 ) )[-1];
-
-    Log( $basename . ": ERR: ", @msg );
-    FlushLog();
-    exit $err;
-}
-
-# Load_conf
-sub Load_conf {
-    my ( $fic_conf, $substdestvars ) = @_;
-
-    my $CONF     = {};
-    my $LOCATION	= {} ;
-    my $current  = ']';
-    my @FIC_CONF = ();
-    my @ALL_CONF = ();
-    my @FH	= () ;
-    my @line     = ();
-    my @cond     = ();
-
-    unshift @FIC_CONF, $fic_conf;
-    unshift @ALL_CONF, $fic_conf;
-    unshift @line,     0;
-    print "Opening $FIC_CONF[0]\n" if ( $DEBUG );
-    open( $FH[0], $FIC_CONF[0] )
-	|| Abort( $ERR_OPEN, "Impossible d'ouvrir " . $FIC_CONF[0] );
-    print "Filehandles --> @FH\n"  if ( $DEBUG );
-    while ( $#FH >= 0 ) {
-	my $fh = $FH[0];    # Perl gruik, ne pas simplifier!!!
-    LOADCONFLINE: while (<$fh>) {
-# 		print "Using fh --> $fh\n" ;
-	    # Compter les lignes
-	    $line[0]++;
-
-	    # Eliminer les commentaires et les espaces inutiles
-	    chomp;
-	    s/^\s*//;
-	    s/\s*$//;
-	    s/\s*#.*$//;
-
-	    # Ne pas traiter les lignes vides
-	    next if (/^$/);
-
-	    # Traitement des directives IF (0 param)
-	    if (/^\@([^\s]+)$/) {
-		if ( $1 eq "else" ) {
-		    if ( $#cond < 0 ) {
-			Abort ( $ERR_SYNTAX,
-			          $FIC_CONF[0] . ":"
-				. $line[0]
-				. ": else sans if" );
-		    }
-		    $cond[0] = ( $#cond > 0 && !$cond[1] ) ? 0 : !$cond[0];
-		    next;
-		}
-		elsif ( $1 eq "endif" ) {
-		    if ( $#cond < 0 ) {
-			Abort( $ERR_SYNTAX,
-			          $FIC_CONF[0] . ":"
-				. $line[0]
-				. ": endif sans if" );
-		    }
-		    shift @cond;
-		    next;
-		}
-	    }
-
-	    # Traitement des directives IF (1 param)
-	    if (/^\@([^\s]+)\s+([^\s]+)$/) {
-		if ( $1 eq "ifdef" ) {
-		    if ( defined $PFTOOLS_VARS->{$2} ) {
-			unshift @cond, ( $#cond > 0 && !$cond[1] ) ? 0 : 1;
-		    }
-		    else {
-			unshift @cond, 0;
-		    }
-		    next;
-		}
-		elsif ( $1 eq "ifndef" ) {
-		    if ( not defined $PFTOOLS_VARS->{$2} ) {
-			unshift @cond, 0;
-		    }
-		    else {
-			unshift @cond, ( $#cond > 0 && !$cond[1] ) ? 0 : 1;
-		    }
-		    next;
-		}
-		elsif ( $1 eq "if" ) {
-		    if ( defined $PFTOOLS_VARS->{$2} && $PFTOOLS_VARS->{$2} ) {
-			unshift @cond, ( $#cond > 0 && !$cond[1] ) ? 0 : 1;
-		    }
-		    else {
-			unshift @cond, 0;
-		    }
-		    next;
-		}
-		elsif ( $1 eq "ifnot" ) {
-		    if ( defined $PFTOOLS_VARS->{$2} && ! $PFTOOLS_VARS->{$2} ) {
-			unshift @cond, 0;
-		    }
-		    else {
-			unshift @cond, ( $#cond > 0 && !$cond[1] ) ? 0 : 1;
-		    }
-		    next;
-		}
-	    }
-
-	    # Seulement les directives IF si condition fausse
-	    next if ( $#cond >= 0 && !$cond[0] );
-
-	    if (/^\@([^\s]+)\s+([^\s]+)$/) {
-		if ( $1 eq "include" ) {
-		    my $fic_conf = $2;
-		    my $oldficconf;
-
-		    if ( $fic_conf =~ m|/| ) {
-			Abort( $ERR_OPEN,
-			          $FIC_CONF[1] . ":"
-				. $line[1]
-				. ": Include avec chemin interdit" );
-		    }
-
-		    if ( $FIC_CONF[0] =~ m|^(.*)/[^/]*$| ) {
-			$fic_conf = $1 . '/include-' . $fic_conf;
-		    }
-		    else {
-			$fic_conf = "include-" . $fic_conf;
-		    }
-
-		    foreach $oldficconf (@ALL_CONF) {
-			if ( $fic_conf eq $oldficconf ) {
-			    Warn( $ERR_OPEN,
-				      $FIC_CONF[0] . ":"
-				    . $line[0] . ": "
-				    . $fic_conf
-				    . " deja inclus ligne "
-				    . $LOCATION->{'include'}->{$fic_conf}->{'line'}
-				    . " dans "
-				    . $LOCATION->{'include'}->{$fic_conf}->{'source'} );
-			    next LOADCONFLINE;
-			}
-		    }
-			$LOCATION->{'include'}->{$fic_conf}->{'line'} = $line[0] ;
-			$LOCATION->{'include'}->{$fic_conf}->{'source'} = $FIC_CONF[0] ;
-		    unshift @FIC_CONF, $fic_conf;
-		    unshift @ALL_CONF, $fic_conf;
-		    unshift @line,     0;
-		    print "Opening $FIC_CONF[0]\n"  if ( $DEBUG );
-		    my $newfh ;
-		    open( $newfh, $FIC_CONF[0] )
-			|| Abort( $ERR_OPEN,
-			      $FIC_CONF[1] . ":"
-			    . $line[1]
-			    . ": Impossible d'inclure "
-			    . $FIC_CONF[0] );
-		    ;    # Perl gruik, ne pas simplifier!!!
-		    print "File list after including $FIC_CONF[0] ".join ( " ", @ALL_CONF )."\n"  if ( $DEBUG );
-		    unshift @FH, $newfh ;
-		    $fh = $newfh ;
-		    print "Filehandles list after inclusion --> @FH\n" if ( $DEBUG );
-		}
-		elsif ( $1 eq "define" ) {
-		    if ( defined( $PFTOOLS_VARS->{$2} ) ) {
-			Warn( $ERR_OPEN,
-			          $FIC_CONF[0] . ":"
-				. $line[0] . ": "
-				. $2
-				. " deja defini" );
-		    }
-		    else {
-			$PFTOOLS_VARS->{$2} = 1;
-		    }
-		}
-		elsif ( $1 eq "undef" ) {
-		    if ( not defined( $PFTOOLS_VARS->{$2} ) ) {
-			Warn( $ERR_OPEN,
-			          $FIC_CONF[0] . ":"
-				. $line[0] . ": "
-				. $2
-				. " deja non defini" );
-		    }
-		    else {
-			undef $PFTOOLS_VARS->{$2};
-		    }
-		}
-		else {
-		    Abort( $ERR_SYNTAX,
-			      $FIC_CONF[0] . ":"
-			    . $line[0]
-			    . ": Directive "
-			    . $1
-			    . " inconnue" );
-		}
-		next;
-	    }
-
-	    # Detection des sections
-	    if (/^\[([^\]]+)\]$/) {
-		if ( defined $substdestvars && $substdestvars ) {
-		    $current = Subst_vars($1);
-		}
-		else {
-		    $current = $1;
-		}
-		if ( defined( $CONF->{$current} ) ) {
-		    Abort( $ERR_SYNTAX,
-			      $FIC_CONF[0] . ":"
-			    . $line[0] . ": ["
-			    . $current
-			    . "] dupliquee (precedente a "
-			    . $LOCATION->{$current}->{_location}
-			    . ")" );
-		}
-		else {
-		    $CONF->{$current} = {};
-		    $LOCATION->{$current}->{_location}
-			= $FIC_CONF[0] . ":" . $line[0];
-		}
-		next;
-	    }
-
-	    # Traitement des variables
-	    if (/^([^\s]+)\s*=\s*(.+)$/) {
-	    	my ( $var, $val ) = ( $1, $2 ) ;
-		if ( defined( $CONF->{$current}->{$var} ) ) {
-		    Abort( $ERR_SYNTAX,
-			      $FIC_CONF[0] . ":"
-			    . $line[0] . ": "
-			    . $var
-			    . " dupliquee (precedente a "
-			    . $LOCATION->{$current}->{$var}->{_location}
-			    . ")" );
-		}
-		else {
-
-		    if ( Add_var( $CONF->{$current}, $var, $val ) == $ERR_SYNTAX )
-		    {
-			Abort( $ERR_SYNTAX,
-			          $FIC_CONF[0] . ":"
-				. $line[0] . ": "
-				. $var
-				. " dupliquee (precedente a "
-				. $LOCATION->{$current}->{$var}->{_location}
-				. ")" );
-		    }
-		    $LOCATION->{$current}->{$var}->{_location}
-			= $FIC_CONF[0] . ":" . $line[0];
-		}
-	    }
-	    else {
-		Abort( $ERR_SYNTAX,
-		    $FIC_CONF[0] . ":" . $line[0] . ": Erreur de syntaxe" );
-	    }
-	}
-	close( $FH[0] ) ;
-	print "Closing $FIC_CONF[0] -- $FH[0]\n"  if ( $DEBUG );
-	shift @FH;
-	print "Filehandles after closing --> @FH\n"  if ( $DEBUG );
-	shift @line;
-	shift @FIC_CONF;
-    }
-
-    # Conditions non fermees
-    if ( $#cond >= 0 ) {
-	Abort( $ERR_SYNTAX, "EOC: endif manquant" );
-    }
-
-    return ($CONF);
-}
-
-# Add_var
-sub Add_var {
-    my ( $V, $var, $val ) = @_;
-
-    if ( $var =~ /^((\\\.|[^.])*[^\\])\./ ) {
-	my $esc1  = $1;
-	my $quote = $';
-	$esc1 =~ s/\\\././g;
-	if ( !defined( $V->{$esc1} ) ) {
-	    $V->{$esc1} = {};
-	}
-	if ( !ref( $V->{$esc1} ) ) {
-	    return ($ERR_SYNTAX);
-	}
-	Add_var( $V->{$esc1}, $quote, $val );
-    }
-    else {
-	$var =~ s/\\\././g;
-	if ( defined( $V->{$var} ) ) {
-#		print "Syntax error\n" ;
-	    return ($ERR_SYNTAX);
-	}
-	$V->{$var} = $val;
-	return (0);
-    }
-}
-
-# Print_conf
-sub Print_conf {
-    my ($C) = @_;
-
-    my $s;
-    my $v;
-
-    foreach $s ( keys %$C ) {
-	print "[" . $s . "]\n";
-	Print_v( $C->{$s}, "" );
-	print "\n";
-    }
-}
-
-sub Print_v {
-    my ( $o, $var ) = @_;
-    my $v;
-
-    foreach $v ( keys %$o ) {
-	if ( ref( $o->{$v} ) ) {
-	    Print_v( $o->{$v}, $var . $v . "." );
-	}
-	else {
-	    print $var. $v . " = ", $o->{$v}, "\n";
-	}
-    }
-}
-
-#Print_conf (Load_conf ("/config/config/network")) ;
+        my $select = ( $context eq 'config' ) ? 'action' : 'type';
+        foreach my $section ( keys %{$parsed} ) {
+            next if ( $section =~ /^__/ );
+            if ( !defined $parsed->{$section}->{$select} ) {
+                Abort( $CODE->{'UNDEF_KEY'},
+                    "Key $select on section $section from file $file MUST BE defined"
+                );
+            }
+            my $sect_type = $parsed->{$section}->{$select};
+            if ( $sect_type eq 'include' ) {
+                # We need to dive into deep ...
+                $parsed->{$section}->{'__content'}
+                    = Load_conf(
+                    Get_source( $section, "", $hash_subst, $pf_config ),
+                    $hash_subst, $context, $pf_config );
+            }
+        }
+    }
+
+    # Merging if needed
+    $parsed = __Merge_conf_includes( $parsed, $hash_subst, $context );
+
+    # Basic checks
+    foreach my $section ( keys %{$parsed} ) {
+        next if $section =~ /^__/;
+        my $sect_type;
+        if ( $context =~ /^(host|model)$/ ) {
+            $section =~ /^([^:]+)(::(.+))?$/;
+            $sect_type = $1;
+
+            # $iface_name = $3;
+        }
+        else {
+            my $select = ( $context eq 'config' ) ? 'action' : 'type';
+            if ( !defined $parsed->{$section}->{$select} ) {
+                Abort( $CODE->{'UNDEF_KEY'},
+                    "Key  $select on section $section from file $file MUST BE defined"
+                );
+            }
+            $sect_type = $parsed->{$section}->{$select};
+        }
+        my ( $code, $msg )
+            = Chk_section_struct( $section, $sect_type, $parsed->{$section},
+            $context );
+        if ( $code > 1 ) {
+            Warn( $code,
+                "Errors occur during parsing model from file $file" );
+            Abort( $code, $msg );
+        }
+    }
+
+    return $parsed;
+}
+
+### Like old Init_lib_net
+sub __Sort_net_prio {
+
+    #my ( $type, $section ) = @_;
+    my ($type) = @_;
+
+    my $prio = 0;
+
+    foreach my $prio_type ( 'zone', 'site', 'network', 'server', 'service' ) {
+        return $prio if $type eq $prio_type;
+        $prio++;
+    }
+
+    return $prio;
+}
+
+sub __Sort_net_section {
+    my ( $net_parsed, $a, $b ) = @_;
+
+    return __Sort_net_prio( $net_parsed->{$a}->{'type'}, $a )
+        <=> __Sort_net_prio( $net_parsed->{$b}->{'type'}, $b );
+}
+
+sub Init_GLOBAL_NETCONFIG {
+    my ( $start_file, $hash_subst, $pf_config ) = @_;
+
+    return unless $start_file and $hash_subst;
+
+    if ( !defined $pf_config ) {
+        $pf_config = $PF_CONFIG;
+    }
+
+    my $GLOBAL = { 'SITE' => { 'BY_NAME' => {}, } };
+    foreach my $ip_type ( 'ipv4', 'ipv6' ) {
+        next if !$pf_config->{'features'}->{$ip_type};
+        my $zone_key = ( $ip_type eq 'ipv6' ) ? 'ZONE6' : 'ZONE';
+        my $dhcp_key = ( $ip_type eq 'ipv6' ) ? 'DHCP6' : 'DHCP';
+        $GLOBAL->{$zone_key} = {
+            'BY_NAME' => {},
+            'BY_SITE' => {}
+        };
+        $GLOBAL->{$dhcp_key} = { 'BY_SITE' => {} };
+    }
+
+    my $net_parsed
+        = Load_conf( $start_file, $hash_subst, 'network', $pf_config );
+    my @sortnetkeys = sort { __Sort_net_section( $net_parsed, $a, $b ) }
+        @{ $net_parsed->{'__sections_order'} };
+    foreach my $section (@sortnetkeys) {
+        if ( $net_parsed->{$section}->{'type'} eq 'zone' ) {
+            Add_zone( $start_file, $section, $net_parsed->{$section},
+                $GLOBAL, $pf_config );
+        }
+        elsif ( $net_parsed->{$section}->{'type'} eq 'site' ) {
+            Add_site( $start_file, $section, $net_parsed->{$section},
+                $GLOBAL, $pf_config );
+        }
+        elsif ( $net_parsed->{$section}->{'type'} eq 'network' ) {
+            Add_network( $start_file, $section, $net_parsed->{$section},
+                $GLOBAL, $pf_config );
+        }
+        elsif ( $net_parsed->{$section}->{'type'} eq 'server' ) {
+            Add_server( $start_file, $section, $net_parsed->{$section},
+                $GLOBAL, $pf_config );
+        }
+        elsif ( $net_parsed->{$section}->{'type'} eq 'service' ) {
+            my $site_list = Get_site_list( $net_parsed->{$section}, $GLOBAL );
+            foreach my $site ( @{$site_list} ) {
+                my $service_part
+                    = $GLOBAL->{'SITE'}->{'BY_NAME'}->{$site}->{'SERVICE'}
+                    ->{'BY_NAME'};
+                foreach my $host ( @{ $net_parsed->{$section}->{'@host'} } ) {
+                    my $hostfile
+                        = Get_source( $host, "", $hash_subst, $pf_config );
+                    my $host_parsed
+                        = Load_conf( $hostfile, $hash_subst, 'host',
+                        $pf_config );
+                    Add_host( $hostfile, $host_parsed, $GLOBAL, $pf_config );
+                    push @{ $service_part->{$section} }, $host;
+                }
+            }
+        }
+    }
+
+    return $GLOBAL;
+}
+
+sub Flush2disk_GLOBAL {
+    my ( $global_config, $pf_config, $path_global_file ) = @_;
+
+    return unless $global_config and $pf_config;
+
+    my $flush_file = $path_global_file
+        || $pf_config->{'path'}->{'global_struct'};
+    if ( !store( $global_config, $flush_file ) ) {
+        Warn( $CODE->{'STORABLE'},
+            "An error occured when trying to flush global structure to file $flush_file"
+        );
+        return;
+    }
+
+    return 1;
+}
+
+sub Retrieve_GLOBAL {
+    my ($path_global_file) = @_;
+
+    return unless $path_global_file;
+
+    if ( !-e $path_global_file ) {
+        Abort( $CODE->{'OPEN'},
+            "Unable to open global configuration storable file $path_global_file: no such file or directory"
+        );
+    }
+
+    return retrieve($path_global_file);
+}
+
+sub Get_config_for_hostname_on_site {
+    my ( $hostname, $site, $hash_subst, $global_config, $pf_config ) = @_;
+
+    # Common configuration file e.g. update-common
+    my $global_host_conf = Load_conf(
+        Get_source(
+            'COMMON:/' . $pf_config->{'path'}->{'common_config'},
+            $hostname, $hash_subst, $pf_config
+        ),
+        $hash_subst,
+        'config',
+        $pf_config
+    );
+    my $hosttype
+        = Get_hosttype_from_hostname( $hostname, $global_config, $site );
+    if ( !defined $hosttype ) {
+        Abort( $CODE->{'UNDEF_KEY'},
+            "Unable to get hosttype from hostname $hostname for getting hosttype configuration file"
+        );
+    }
+
+    # Hosttype configuration file e.g. update-<hosttype>
+    my $hosttype_conf_file
+        = __Get_config_path( $hosttype, $pf_config, $site );
+
+    # Hostname configuration file e.g. update-<hostname>
+    my $hostname_conf_file
+        = __Get_config_path( $hostname, $pf_config, $site );
+
+    foreach my $file ( $hosttype_conf_file, $hostname_conf_file ) {
+        next if !defined $file;
+        my $config = Load_conf( $file, $hash_subst, 'config', $pf_config );
+        foreach my $section ( @{ $config->{'__sections_order'} } ) {
+            push @{ $global_host_conf->{'__sections_order'} }, $section
+                if !defined $global_host_conf->{$section};
+            $global_host_conf->{$section} = $config->{$section};
+        }
+    }
+
+    return $global_host_conf;
+}
 
 1;
-

Modified: trunk/lib/PFTools/Disk.pm
URL: http://svn.debian.org/wsvn/pf-tools/trunk/lib/PFTools/Disk.pm?rev=902&op=diff
==============================================================================
--- trunk/lib/PFTools/Disk.pm (original)
+++ trunk/lib/PFTools/Disk.pm Wed Sep  8 19:28:28 2010
@@ -1,4 +1,4 @@
-package PFTools::Disk ;
+package PFTools::Disk;
 ##
 ##  $Id$
 ##
@@ -22,611 +22,866 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Exporter;
 
-our @ISA = ( 'Exporter' ) ;
+use PFTools::Logger;
+
+our @ISA = ('Exporter');
 
 our @EXPORT = qw(
-	$DEBUG
+    Build_structure_from_fstab
+    Build_fstab_from_structure
 );
 
 our @EXPORT_OK = qw();
 
+######################################
+### Constants
+
+my @FSTAB_FIELDS_ORDER
+    = ( 'source', 'dest', 'fstype', 'options', 'dump', 'pass' );
+
 #
 # Global(s) var(s)
 #
 
 ### Command vars
-my $MDADM	= '/sbin/mdadm' ;
-my $DRBDADM	= '/sbin/drbdadm' ;
-my $MKFS	= '/sbin/mkfs.' ;
-my $FSCK	= '/sbin/fsck.' ;
-my $SFDISK	= '/sbin/sfdisk' ;
-my $FDISK	= '/sbin/fdisk' ;
-my $HALT	= '/sbin/halt' ;
-my $ECHO	= '/bin/echo' ;
+my $MDADM   = '/sbin/mdadm';
+my $DRBDADM = '/sbin/drbdadm';
+my $MKFS    = '/sbin/mkfs.';
+my $FSCK    = '/sbin/fsck.';
+my $SFDISK  = '/sbin/sfdisk';
+my $FDISK   = '/sbin/fdisk';
+my $HALT    = '/sbin/halt';
+my $ECHO    = '/bin/echo';
 
 ### Env vars
-our $DEBUG	= 0 ;
-my $VERBOSE	= 0 ;
-my $FOLLOW	= '' ;
-my $SIZE	= '' ;
-
-if ( $DEBUG ) { $VERBOSE = 1 ; }
+our $DEBUG = 0;
+my $VERBOSE = 0;
+my $FOLLOW  = '';
+my $SIZE    = '';
+
+if ($DEBUG) { $VERBOSE = 1; }
 
 # Checking if all commands vars exists
-foreach my $cmd ( $MDADM, $MKFS, $SFDISK, $FDISK, $HALT, $ECHO ) {
-	if ( ! -e $cmd ) {
-		warn "Command ".$cmd." doesn't exist\n" if ( $VERBOSE ) ;
-		exit 1 ;
-	}
-}
+# foreach my $cmd ( $MDADM, $MKFS, $SFDISK, $FDISK, $HALT, $ECHO ) {
+# 	if ( ! -e $cmd ) {
+# 		warn "Command ".$cmd." doesn't exist\n" if ( $VERBOSE ) ;
+# 		exit 1 ;
+# 	}
+# }
 
 ### /proc definitions for different files
-my $PROC_PART		= '/proc/partitions' ;
-my $PROC_RAID		= '/proc/mdstat' ;
-my $PROC_SCSI		= '/proc/scsi/scsi' ;
-my $PROC_DRBD		= '/proc/drbd' ;
+my $PROC_PART = '/proc/partitions';
+my $PROC_RAID = '/proc/mdstat';
+my $PROC_SCSI = '/proc/scsi/scsi';
+my $PROC_DRBD = '/proc/drbd';
 
 ### Pattern(s) for misc checks
-my $DISK_DEV_PATTERN	= '\/dev\/(h|s)d[a-z]([\d]+)?' ;
-my $RAID_DEV_PATTERN	= '\/dev\/md([\d]+)' ;
-my $RAID_DEV		= 'md0' ;
-my $RAID_DEV_STATUS	= '(active sync|removed|faulty)' ;
-my $RAID_DEV_PART	= '\/dev\/(h|s)d[a-z]4' ;
-my $RAID_PART_NUM	= '4' ;
-my $RAID_PART_TYPE	= 'fd' ;
-my $RAID_FS		= 'ext3' ;
-my $DRBD_DEV_PATTERN	= '\/dev\/drbd' ;
-my $DRBD_DEV		= 'drbd0' ;
+# FIXME qr{} + hash
+my $DISK_DEV_PATTERN = '\/dev\/(h|s)d[a-z]([\d]+)?';
+my $RAID_DEV_PATTERN = '\/dev\/md([\d]+)';
+my $RAID_DEV         = 'md0';
+my $RAID_DEV_STATUS  = '(active sync|removed|faulty)';
+my $RAID_DEV_PART    = '\/dev\/(h|s)d[a-z]4';
+my $RAID_PART_NUM    = '4';
+my $RAID_PART_TYPE   = 'fd';
+my $RAID_FS          = 'ext3';
+my $DRBD_DEV_PATTERN = '\/dev\/drbd';
+my $DRBD_DEV         = 'drbd0';
 
 ### Misc files
-my $DUMP_PART_FILE	= '/tmp/device_part.dmp' ;
-my $TPL_SPARC_PART	= '' ;
+my $DUMP_PART_FILE = '/tmp/device_part.dmp';    # FIXME File::Temp ?
+my $TPL_SPARC_PART = '';
 
 #
 # Misc functions
 #
 
-sub Exec_cmd ($;$) {
-	my ( $cmd, $msg ) = @_ ;
-
-	if ( $DEBUG ) {
-		print 'Exec :'.$cmd."\n" ;
-	} else {
-		system ( $cmd ) ;
-		if ( $? ) {
-			if ( ! defined ( $msg ) ) {
-				$msg = "Problem when executing command ".$cmd." with the following error(s)\n" ;
-			}
-			warn $msg if ( $VERBOSE ) ;
-			if ( $? == -1 ) {
-				warn "failed to execute: $!\n" if ( $VERBOSE ) ;
-			} elsif ( $? & 127 ) {
-				printf STDERR "child died with signal %d, %s coredump\n", ( $? & 127 ), ( $? & 128 ) ? 'with' : 'without' if ( $VERBOSE ) ;
-			} else {
-				printf STDERR "child exited with value %d\n", $? >> 8 if ( $VERBOSE ) ;
-			}
-			return 0 ;
-		}
-	}
-	return 1 ;
+sub Build_structure_from_fstab {
+    my ($fstab_file) = @_;
+
+    return unless $fstab_file;
+
+    # FIXME IO::File or File::Slurp or Perl6::Slurp
+    if ( !open( FSTAB, $fstab_file ) ) {
+        Warn( $CODE->{'OPEN'}, "Unable to open $fstab_file: $OS_ERROR" );
+        return;
+    }
+    my @current_fstab = <FSTAB>;
+    close(FSTAB);
+
+    print join @current_fstab;
+
+    my $struct = {};
+    foreach my $line (@current_fstab) {
+
+        # Skip comments
+        next if $line =~ m/^#/;
+
+        # Removing trailing spaces
+        $line =~ s/^\s*//;
+        $line =~ s/\s*$//;
+
+        # Skipping empty lines
+        next if $line =~ m/^$/;
+        my ( $src_mnt, $mnt_pt, $type, $opt_mnt, $dump, $pass )
+            = split /\s+/, $line;
+        push @{ $struct->{'__mnt_order'} }, $mnt_pt;
+        $struct->{$mnt_pt} = {
+            'source'  => $src_mnt,
+            'dest'    => $mnt_pt,
+            'fstype'  => $type,
+            'options' => join( ',', sort split ',', $opt_mnt ),
+            'dump'    => $dump,
+            'pass'    => $pass,
+        };
+    }
+
+    return $struct;
+}
+
+sub Build_fstab_from_structure {
+    my ($struct) = @_;
+
+    return unless $struct;
+
+    my @fstab = ();
+
+    push @fstab, '###################################################';
+    push @fstab, '# Fstab generated by Build_fstab_from_structure';
+    push @fstab, "#\n";
+    foreach my $entry ( @{ $struct->{'__mnt_order'} } ) {
+        my @line;
+        foreach my $field (@FSTAB_FIELDS_ORDER) {
+            push @line, $struct->{$entry}->{$field};
+        }
+        push @fstab, join( "\t", @line );
+    }
+    push @fstab, '';
+
+    return \@fstab;
+}
+
+# FIXME: duplicate code?
+sub Exec_cmd {
+    my ( $cmd, $msg ) = @_;
+
+    return unless $cmd;
+    $msg = "Problem when executing command $cmd:\n"
+        unless $msg;
+
+    if ($DEBUG) {
+        print 'Exec :' . $cmd . "\n";
+        return 1;
+    }
+
+    system($cmd);
+    if ($CHILD_ERROR) {
+        warn $msg if $VERBOSE;
+        if ( $CHILD_ERROR == -1 ) {
+            warn "failed to execute: $OS_ERROR\n"
+                if $VERBOSE;    # FIXME carp or Warn
+        }
+        elsif ( $CHILD_ERROR & 127 ) {
+            warn "child died with signal %d, %s coredump\n"
+                ,               # FIXME carp or Warn
+                ( $CHILD_ERROR & 127 ),
+                ( $CHILD_ERROR & 128 ) ? 'with' : 'without'
+                if $VERBOSE;
+        }
+        else {
+            warn "child exited with value %d\n",    # FIXME carp or Warn
+                $CHILD_ERROR >> 8
+                if $VERBOSE;
+        }
+
+        return;
+    }
+
+    return 1;
 }
 
 #
 # System check and analysis ...
 #
 
-sub GetDiskDevice () {
-	# Call parameter(s)
-	
-	# Local(s) var(s)
-	my $part ;
-	my $result = {};
-	
-	if ( ! open ( $part, $PROC_PART ) ) {
-		warn "GetDiskDevice -- Unable to parse ".$PROC_PART." for analysing disk structures\n" if ( $VERBOSE ) ;
-		return undef ;
-	} else {
-		# Parsing /proc/partitions file
-		while ( <$part> ) {
-			next if ( /^$/ ) ;
-			if ( /^\s*([\d]+)\s+([\d]+)\s+([\d]+)\s+([^\s]+)$/ ) {
-				my ( $major, $minor, $block_size, $name ) = ( $1, $2, $3, $4 ) ;
-				if ( $name =~ /^$DISK_DEV_PATTERN$/ ) {
-					push ( @{$result->{'disk'}}, $name ) ;
-					if ( ! defined $result->{$name} ) { $result->{$name} = 0 ; }
-				}
-				if ( $name =~ /^$DISK_DEV_PATTERN$/ ) { $result->{$name} +=1 }
-				if ( $name =~ /^$RAID_DEV_PATTERN$/ ) { push ( @{$result->{'raid'}}, $name ) ; }
-				if ( $name =~ /^$DRBD_DEV_PATTERN$/ ) { push ( @{$result->{'drbd'}}, $name ) ; }
-			}
-		}
-		close ( $part ) ;
-	}
-	return $result ;
-}
-
-sub GetDiskGeometry ($;$) {
-	# Call parameter(s)
-	my ( $device, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $geo = {} ;
-	my ( $pad, $cyls, $heads, $sectors ) ;
-	
-	if ( $device !~ /^$DISK_DEV_PATTERN$/ ) {
-		warn "GetDiskGeometry -- Wrong device name ".$device." : unable to get geometry\n" if ( $VERBOSE ) ;
-		return undef ;
-	}
-	$geo->{'name'} = $device ;
-	if ( ! defined ( $arch ) || $arch eq 'i386' ) {
-		# Retrieving geometry by sfdisk command
-		my $cmd = $SFDISK.' -f -g '.$device ;
-		( $pad, $cyls, $pad, $heads, $pad, $sectors ) = split ( /\s+/, `$cmd` ) ;
-		if ( $cyls == 0 || $heads == 0 || $sectors == 0 ) {
-			warn "GetDiskGeometry -- Invalid values retriveved by sfdisk for device ".$device."\n" if ( $VERBOSE ) ;
-			return undef ;
-		}
-		$geo->{'cyls'} = $cyls ;
-		$geo->{'heads'} = $heads ;
-		$geo->{'sectors'} = $sectors ;
-		return $geo ;
-	} elsif ( $arch eq 'sparc' ) {
-		my $cmd = $FDISK. ' -l /dev/'.$device ;
-		# Disk /dev/sda: 160.0 GB, 160041885696 bytes
-		# 255 heads, 63 sectors/track, 19457 cylinders
-		# Units = cylinders of 16065 * 512 = 8225280 bytes
-		# Disk identifier: 0xf98d6e74
-
-		if ( ! open ( FDL, $cmd ) ) {
-			warn "GetDiskGeometry -- Unable to get geometry with command ".$cmd."\n" if ( $VERBOSE ) ;
-			return undef ;
-		}
-		while ( <FDL> ) {
-			if ( /^([\d]+) heads, ([\d]+) sectors\/track, ([\d]+) cylinders$/ ) {
-				$geo->{'cyls'}		= $3 ;
-				$geo->{'heads'}		= $1 ;
-				$geo->{'sectors'}	= $2 ;
-			}
-		}
-		close ( FDL ) ;
-		return $geo ;
-	} else {
-		warn "GetDiskGeometry -- Wrong architecture specified ".$arch." : unable to get geometry\n" if ( $VERBOSE ) ;
-		return undef ;
-	}
-}
-	
-sub GetAllGeometry ($;$) {
-	# Call parameter(s)
-	my ( $dev_list, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $geo = {} ;
-
-	foreach my $disk ( @{$dev_list->{'disk'}} ) {
-		$geo->{$disk} = GetDiskGeometry ( $disk, $arch ) ;
-		if ( ! defined ( $geo->{$disk} ) ) {
-			warn "GetAllGeometry -- Cannot retrieve geometry for all disks : see message bellow\n" if ( $VERBOSE ) ;
-			return undef ;
-		}
-	}
-	return $geo ;
-}
-
-sub CheckDiskGeometry ($$;$) {
-	# Call parameter(s)
-	my ( $device, $ref_wanted, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $ref_geo_device = {} ;
-	my ( $check_name, $wanted_name ) ;
-	
-	if ( ref ( $device ) ne 'HASH' ) {
-		# $device is not an HASHREF on disk geometry
-		if ( $device !~ /^$DISK_DEV_PATTERN$/ ) {
-			warn "CheckDiskGeometry -- Wrong device name ".$device." : unable to check geometry\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-		$ref_geo_device = GetDiskGeometry ( $device, $arch ) ;
-		if ( ! defined ( $ref_geo_device ) ) {
-			warn "CheckDiskGeometry -- Unable to retrive geometry for device ".$device."\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-	} else {
-		$ref_geo_device = $device ;
-	}
-	$check_name	= $ref_geo_device->{'name'} ;
-	$wanted_name	= $ref_wanted->{'name'} ;
-	foreach my $char ( keys %{$ref_wanted} ) {
-		if ( $ref_geo_device->{$char} != $ref_wanted->{$char} ) {
-			warn "CheckDiskGeometry --  Device ".$check_name." and reference device ".$wanted_name." have not the same geometry\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-	}
-	return 1 ;
-}
-
-sub CheckAllGeometry ($;$) {
-	# Call parameter(s)
-	my ( $ref_wanted, $arch ) = @_ ;
-	# Local(s) var(s)
-	my ( $dev_list, $all_geo_dev ) ;
-	
-	$dev_list	= GetDiskDevice () ;
-	if ( ! defined ( $dev_list ) ) {
-		warn "CheckAllGeometry -- Unable to get devices list on host\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	$all_geo_dev = GetAllGeometry ( $dev_list, $arch ) ;
-	if ( ! defined ( $all_geo_dev ) ) {
-		warn "CheckAllGeometry -- Unable to retrieve one ore more geometry : see error bellow\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	
-	foreach my $disk ( keys %{$all_geo_dev} ) {
-		if ( ! CheckDiskGeometry ( $disk, $ref_wanted, $arch ) ) {
-			warn "CheckAllGeometry -- One ore more disk(s) has not the same geometry see error bellow\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-	}
-	return 1 ;
-}
-
-sub CheckRaidArray ($) {
-	# Call parameter(s)
-	my ( $raid_dev ) = @_ ;
-	# Local(s) var(s)
-	my $part ;
-	my $stat = {} ;
-	
-	if ( ! open ( $part, $MDADM.' -D '.$raid_dev ) ) {
-		warn "Unable to analyse raid status for RAID array ".$raid_dev."\n" ;
-		return undef ;
-	}
-	$stat->{'failed'} = 0 ;
-	while ( <$part> ) {
-		if ( /^\s*Failed Devices : ([\d]+)$/ && $1 > 0 ) {
-			$stat->{'failed'} = $1 ;
-		} elsif ( $stat->{'failed'} ) {
-			if ( /^\s*([\d]+)\s([\d]+)\s*([\d]+)\s*([\d]+)\s*([$RAID_DEV_STATUS])\s*(\Q$RAID_DEV_PART\E)$/ ) {
-				my ( $number, $major, $minor, $raid_num, $status, $device ) = ( $1, $2, $3, $4, $5, $6 ) ;
-				if ( $status !~ /^fault|failed$/ ) {
-					next ;
-				} else {
-					$device =~ s/[\d]$// ;
-					push ( @{$stat->{'failed_dev'}}, $device ) ;
-				}
-			} elsif ( /^\s*UUID : ([^\s]+)$/ ) {
-				$stat->{'uid'} = $1 ;
-			}
-		}
-	}
-	close ( $part ) ;
-	return $stat ;
-}
-
-sub CheckArrayRecovery ($) {
-	# Call parameter(s)
-	my ( $raid_dev ) = @_ ;
-	# Local(s) var(s)
-	my ( $proc, $build, $active, $check, $fail, $last_size ) ;
-	
-	$active = $fail = $last_size = $check = 0 ;
-	$build = 1 ;
-	while ( ! $active ) {
-		if ( ! open ( $proc, $PROC_RAID ) ) {
-			warn "Unable to open proc file ".$PROC_RAID." for checking Raid ARRAY status\n" ;
-			return 0 ;
-		}
-		# [>....................]  recovery =  0.1% (90880/56998528) finish=93.9min speed=10097K/sec
-		while ( <$proc> ) {
-			if ( /^$raid_dev : .*$/) { $check = 1 ; }
-			if ( /^\s*(\[[^\]]+\])\s*recovery =\s*([\d]+.[\d+]%) \(([\d]+)\/[\d]+\).+$/ && $check ) {
-				if ( ! $last_size ) {
-					$last_size = $3 ;
-				} elsif ( $last_size == $3 ) {
-					if ( $fail == 3 ) {
-						warn "Failure during array RAID operation\n" ;
-						return 0 ;
-					} else {
-						$fail += 1 ;
-					}
-				} else {
-					$fail = 0 ;
-				}
-				print $1.' '.$2."\r" ;
-				sleep 1 ;
-				$build = 1 ;
-			}
-			if ( /^unused devices: .*$/ && $build ){
-				$build = 0 ;
-			} else {
-				$active = 1 ;
-			}
-		}
-	}
-	return 1 ;
-}
-
-sub CheckDrbdSyncer ($) {
-	# Call parameter(s)
-	my ( $drbd_dev ) = @_ ;
-	# Local(s) var(s)
-	my ( $proc, $num_drbd, $build, $active, $check, $fail, $last_size ) ;
-	
-	$drbd_dev =~ /^$DRBD_DEV_PATTERN([\d])$/ ;
-	
-	$num_drbd = $1 ;
-	$active = $fail = $last_size = $check = 0 ;
-	$build = 1 ;
-	while ( ! $active ) {
-		if ( ! open ( $proc, $PROC_DRBD ) ) {
-			warn "Unable to open file ".$PROC_DRBD." for checking DRBD syncer status\n" ;
-			return 0 ;
-		}
-		# 0: cs:SyncSource st:Primary/Secondary ld:Consistent
-		#    ns:38460 nr:0 dw:0 dr:38460 al:0 bm:10431 lo:0 pe:18 ua:0 ap:0
-		#        [>...................] sync'ed:  0.1% (166822/166859)M
-		#        finish: 4:56:34 speed: 9,596 (9,596) K/sec
-		while ( <$proc> ) {
-			if ( /^\s([\d]): cs:([^\s]+) st:([^\/]+)\/([^\s]+) ld:([^\s]+)$/ ) {
-				next if ( $1 != $num_drbd ) ;
-				if ( $2 eq 'SyncSource' ) {
-					$check = 1 ;
-				} elsif ( $2 eq 'Connected' ) {
-					$active = 1 ;
-				}
-			} elsif ( /^\s*(\[[^\]]+\]) sync'ed: ([\d]+\.[\d]+\%) \(([\d]+)\/[\d]+\)+$/ && $check ) {
-				if ( ! $last_size ) {
-					$last_size = $3 ;
-				} elsif ( $last_size == $3 ) {
-					if ( $fail == 3 ) {
-						print STDERR "Failure during array RAID operation\n" ;
-						return 0 ;
-					} else {
-						$fail += 1 ;
-					}
-				} else {
-					$fail = 0 ;
-				}
-				print $1.' '.$2."\r" ;
-				$check = 0 ;
-				sleep 1 ;
-			}
-		}
-	}
-	return 1 ;
+sub GetDiskDevice {
+
+    my $part;
+
+    # FIXME IO::File
+    if ( !open( $part, $PROC_PART ) ) {
+        warn "GetDiskDevice -- Unable to parse "
+            . $PROC_PART
+            . " for analysing disk structures\n"
+            if $VERBOSE;
+        return;
+    }
+
+    # Parsing /proc/partitions file
+    my $result = {};
+    while (<$part>) {
+        next if /^$/;
+        next unless /^\s*([\d]+)\s+([\d]+)\s+([\d]+)\s+([^\s]+)$/;
+
+        my ( $major, $minor, $block_size, $name ) = ( $1, $2, $3, $4 );
+        if ( $name =~ /^$DISK_DEV_PATTERN$/ ) {
+            push @{ $result->{'disk'} }, $name;
+            $result->{$name} = 0
+                unless defined $result->{$name};
+        }
+        if ( $name =~ /^$DISK_DEV_PATTERN$/ ) {
+            $result->{$name} += 1;
+        }
+        if ( $name =~ /^$RAID_DEV_PATTERN$/ ) {
+            push @{ $result->{'raid'} }, $name;
+        }
+        if ( $name =~ /^$DRBD_DEV_PATTERN$/ ) {
+            push @{ $result->{'drbd'} }, $name;
+        }
+    }
+    close($part);
+
+    return $result;
+}
+
+sub GetDiskGeometry {
+    my ( $device, $arch ) = @_;
+
+    return unless $device;
+    $arch = 'i386' unless $arch;    # default
+
+    if ( $device !~ /^$DISK_DEV_PATTERN$/ ) {
+        warn
+            "GetDiskGeometry -- device name $device doesn't match $DISK_DEV_PATTERN\n" # FIXME carp or Warn
+            if $VERBOSE;
+        return;
+    }
+
+    # Local(s) var(s)
+    my $geo = { name => $device };
+    my ( $pad, $cyls, $heads, $sectors );
+
+    if ( $arch eq 'i386' ) {
+
+        # Retrieving geometry by sfdisk command
+        my $cmd = $SFDISK . ' -f -g ' . $device;
+        ( $pad, $cyls, $pad, $heads, $pad, $sectors )
+            = split( /\s+/, `$cmd` );    # FIXME no `` ever!
+        if ( $cyls == 0 || $heads == 0 || $sectors == 0 ) {
+            warn
+                "GetDiskGeometry -- Invalid values retriveved by sfdisk for device $device\n"
+                if $VERBOSE;
+            return;
+        }
+        $geo->{'cyls'}    = $cyls;
+        $geo->{'heads'}   = $heads;
+        $geo->{'sectors'} = $sectors;
+
+        return $geo;
+    }
+
+    if ( $arch eq 'sparc' ) {
+        my $cmd = $FDISK . ' -l /dev/' . $device;
+
+        # Disk /dev/sda: 160.0 GB, 160041885696 bytes
+        # 255 heads, 63 sectors/track, 19457 cylinders
+        # Units = cylinders of 16065 * 512 = 8225280 bytes
+        # Disk identifier: 0xf98d6e74
+
+        if ( !open( FDL, $cmd ) ) {
+            warn "GetDiskGeometry -- Unable to get geometry with command "
+                . $cmd . "\n"
+                if ($VERBOSE);
+            return undef;
+        }
+        while (<FDL>) {
+            if (/^([\d]+) heads, ([\d]+) sectors\/track, ([\d]+) cylinders$/)
+            {
+                $geo->{'cyls'}    = $3;
+                $geo->{'heads'}   = $1;
+                $geo->{'sectors'} = $2;
+            }
+        }
+        close(FDL);
+
+        return $geo;
+    }
+
+    warn
+        "GetDiskGeometry -- Unsupported architecture $arch: unable to get geometry\n"
+        if $VERBOSE;
+    return;
+}
+
+sub GetAllGeometry {
+    my ( $dev_list, $arch ) = @_;
+
+    my $geo = {};
+    foreach my $disk ( @{ $dev_list->{'disk'} } ) {
+        $geo->{$disk} = GetDiskGeometry( $disk, $arch );
+        if ( !defined( $geo->{$disk} ) ) {
+            warn
+                "GetAllGeometry -- Cannot retrieve geometry for all disks: see message below\n"
+                if $VERBOSE;
+            return;
+        }
+    }
+    return $geo;
+}
+
+sub CheckDiskGeometry {
+    my ( $device, $ref_wanted, $arch ) = @_;
+
+    # Local(s) var(s)
+    my $ref_geo_device = {};
+    my ( $check_name, $wanted_name );
+
+    $ref_geo_device
+        = ref($device) eq 'HASH'
+        ? $device
+        : GetDiskGeometry( $device, $arch );
+    if ( !defined($ref_geo_device) ) {
+        warn "CheckDiskGeometry -- Unable to retrive geometry for device "
+            . $device . "\n"
+            if $VERBOSE;
+        return;
+    }
+
+    $check_name  = $ref_geo_device->{'name'};
+    $wanted_name = $ref_wanted->{'name'};
+    foreach my $char ( keys %{$ref_wanted} ) {
+        if ( $ref_geo_device->{$char} != $ref_wanted->{$char} ) {
+            warn "CheckDiskGeometry --  Device "
+                . $check_name
+                . " and reference device "
+                . $wanted_name
+                . " have not the same geometry\n"
+                if $VERBOSE;
+            return;
+        }
+    }
+
+    return 1;
+}
+
+sub CheckAllGeometry {
+    my ( $ref_wanted, $arch ) = @_;
+
+    my $dev_list = GetDiskDevice();
+    if ( !defined($dev_list) ) {
+        warn "CheckAllGeometry -- Unable to get devices list on host\n"
+            if $VERBOSE;
+        return;
+    }
+
+    my $all_geo_dev = GetAllGeometry( $dev_list, $arch );
+    if ( !defined($all_geo_dev) ) {
+        warn
+            "CheckAllGeometry -- Unable to retrieve one ore more geometry : see error bellow\n"
+            if $VERBOSE;
+        return;
+    }
+
+    foreach my $disk ( keys %{$all_geo_dev} ) {
+        if ( !CheckDiskGeometry( $disk, $ref_wanted, $arch ) ) {
+            warn
+                "CheckAllGeometry -- One ore more disk(s) has not the same geometry see error bellow\n"
+                if $VERBOSE;
+            return;
+        }
+    }
+
+    return 1;
+}
+
+sub CheckRaidArray {
+    my ($raid_dev) = @_;
+
+    my $part;
+    if ( !open( $part, $MDADM . ' -D ' . $raid_dev ) ) {
+        warn "Unable to analyse raid status for RAID array "
+            . $raid_dev . "\n";
+        return;
+    }
+
+    my $stat = { failed => 0 };
+    while (<$part>) {
+        if ( /^\s*Failed Devices : ([\d]+)$/ && $1 > 0 ) {
+            $stat->{'failed'} = $1;
+        }
+        elsif ( $stat->{'failed'} ) {
+            if (/^\s*([\d]+)\s([\d]+)\s*([\d]+)\s*([\d]+)\s*([$RAID_DEV_STATUS])\s*(\Q$RAID_DEV_PART\E)$/
+                )
+            {
+                my ( $number, $major, $minor, $raid_num, $status, $device )
+                    = ( $1, $2, $3, $4, $5, $6 );
+                if ( $status !~ /^fault|failed$/ ) {
+                    next;
+                }
+                else {
+                    $device =~ s/[\d]$//;
+                    push( @{ $stat->{'failed_dev'} }, $device );
+                }
+            }
+            elsif (/^\s*UUID : ([^\s]+)$/) {
+                $stat->{'uid'} = $1;
+            }
+        }
+    }
+    close($part);
+
+    return $stat;
+}
+
+sub CheckArrayRecovery {
+    my ($raid_dev) = @_;
+
+    my ( $active, $check, $fail, $last_size ) = ( 0, 0, 0, 0 );
+    my $build = 1;
+    my $proc;
+    while ( !$active ) {
+        if ( !open( $proc, $PROC_RAID ) ) {
+            warn "Unable to open proc file "
+                . $PROC_RAID
+                . " for checking Raid ARRAY status\n";
+            return;
+        }
+
+# [>....................]  recovery =  0.1% (90880/56998528) finish=93.9min speed=10097K/sec
+        while (<$proc>) {
+            if (/^$raid_dev : .*$/) { $check = 1; }
+            if (/^\s*(\[[^\]]+\])\s*recovery =\s*([\d]+.[\d+]%) \(([\d]+)\/[\d]+\).+$/
+                && $check
+                )
+            {
+                if ( !$last_size ) {
+                    $last_size = $3;
+                }
+                elsif ( $last_size == $3 ) {
+                    if ( $fail == 3 ) {
+                        warn "Failure during array RAID operation\n";
+                        return;
+                    }
+                    else {
+                        $fail += 1;
+                    }
+                }
+                else {
+                    $fail = 0;
+                }
+                print $1. ' ' . $2 . "\r";
+                sleep 1;
+                $build = 1;
+            }
+            if ( /^unused devices: .*$/ && $build ) {
+                $build = 0;
+            }
+            else {
+                $active = 1;
+            }
+        }
+    }
+
+    return 1;
+}
+
+sub CheckDrbdSyncer {
+    my ($drbd_dev) = @_;
+
+    unless ( $drbd_dev =~ /^$DRBD_DEV_PATTERN([\d])$/ ) {
+        warn "Unsupported drbd device name $drbd_dev\n";
+        return;
+    }
+    my $num_drbd = $1;
+
+    my ( $proc, $build, $active, $check, $fail, $last_size );
+    $active = $fail = $last_size = $check = 0;
+    $build = 1;
+    while ( !$active ) {
+        if ( !open( $proc, $PROC_DRBD ) ) {
+            warn "Unable to open file "
+                . $PROC_DRBD
+                . " for checking DRBD syncer status\n";
+            return;
+        }
+
+        # 0: cs:SyncSource st:Primary/Secondary ld:Consistent
+        #    ns:38460 nr:0 dw:0 dr:38460 al:0 bm:10431 lo:0 pe:18 ua:0 ap:0
+        #        [>...................] sync'ed:  0.1% (166822/166859)M
+        #        finish: 4:56:34 speed: 9,596 (9,596) K/sec
+        while (<$proc>) {
+            if (/^\s([\d]): cs:([^\s]+) st:([^\/]+)\/([^\s]+) ld:([^\s]+)$/) {
+                next if ( $1 != $num_drbd );
+                if ( $2 eq 'SyncSource' ) {
+                    $check = 1;
+                }
+                elsif ( $2 eq 'Connected' ) {
+                    $active = 1;
+                }
+            }
+            elsif (
+                /^\s*(\[[^\]]+\]) sync'ed: ([\d]+\.[\d]+\%) \(([\d]+)\/[\d]+\)+$/
+                && $check
+                )
+            {
+                if ( !$last_size ) {
+                    $last_size = $3;
+                }
+                elsif ( $last_size == $3 ) {
+                    if ( $fail == 3 ) {
+                        warn "Failure during array RAID operation\n";
+                        return;
+                    }
+                    else {
+                        $fail += 1;
+                    }
+                }
+                else {
+                    $fail = 0;
+                }
+                print $1. ' ' . $2 . "\r";
+                $check = 0;
+                sleep 1;
+            }
+        }
+    }
+
+    return 1;
 }
 
 #
 # Managing scsi disk(s) (add, remove)
 #
 
-sub ManageScsiDevice ($$) {
-	# Call parameter(s)
-	my ( $ref_device, $action ) = @_ ;
-	# Local(s) var(s)
-	my $cmd ;
-
-	if ( ref ( $ref_device ) ne 'ARRAY' ) {
-		warn "ManageScsiDevice -- Wrong device definition for managing SCSI channel(s)\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	if ( $action eq 'add' ) {
-		$cmd = $ECHO.' "scsi add-single-device '.join ( " ", @{$ref_device} ).'" > '.$PROC_SCSI ;
-	} elsif ( $action eq 'mod' ) {
-		$cmd = $ECHO.' "scsi remove-single-device '.join ( " ", @{$ref_device} ).'" > '.$PROC_SCSI ;
-	} else {
-		warn "ManageScsiDevice -- Wrong action parameter ".$action."\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	
-	return Exec_cmd ( $cmd, "Problem when managing SCSI device with command ".$cmd." and with the following error(s)\n" ) ;
+sub ManageScsiDevice {
+    my ( $ref_device, $action ) = @_;
+
+    unless ( $ref_device and $action ) {
+
+        #FIXME confess "BUG: invalid arguments";
+        return;
+    }
+
+    my $cmd;
+
+    if ( ref($ref_device) ne 'ARRAY' ) {
+        warn
+            "ManageScsiDevice -- Wrong device definition for managing SCSI channel(s)\n"
+            if $VERBOSE;
+        return;
+    }
+    if ( $action eq 'add' ) {
+        $cmd
+            = $ECHO
+            . ' "scsi add-single-device '
+            . join( " ", @{$ref_device} ) . '" > '
+            . $PROC_SCSI;
+    }
+    elsif ( $action eq 'mod' ) {
+        $cmd
+            = $ECHO
+            . ' "scsi remove-single-device '
+            . join( " ", @{$ref_device} ) . '" > '
+            . $PROC_SCSI;
+    }
+    else {
+        warn "ManageScsiDevice -- Wrong action parameter " . $action . "\n"
+            if $VERBOSE;
+        return;
+    }
+
+    return Exec_cmd(
+        $cmd,
+        "Problem when managing SCSI device with command "
+            . $cmd
+            . " and with the following error(s)\n"
+    );
 }
 
 #
 # Managing partitions (dump, restore, ...)
 #
 
-sub AddRaidPartition ($;$) {
-	# Call parameter(s)
-	my ( $device, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $cmd ;
-
-	if ( ! defined ( $arch ) || $arch eq 'i386' ) {
-		$cmd = $SFDISK.' -f '.$device.' << EOF '.$FOLLOW.','.$SIZE.','.$RAID_PART_TYPE.' EOF' ;
-		return Exec_cmd ( $cmd, "Unable to add raid partition on device ".$device." with command ".$cmd." and with the following error(s)\n" ) ;
-	} elsif ( $arch eq 'sparc' ) {
-		if ( ! open ( CMD, "| ".$FDISK." ".$device ) ) {
-			warn "Unable to add raid partition on device ".$device." with fdisk command\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-		print CMD "n\n4\n\n\nt\n4\n$RAID_PART_TYPE\nw\n" ;
-		close ( CMD ) ;
+sub AddRaidPartition {
+    my ( $device, $arch ) = @_;
+
+    return unless $device;
+    $arch = 'i386' unless $arch;
+
+    my $cmd;
+
+    if ( $arch eq 'i386' ) {
+        $cmd
+            = $SFDISK . ' -f '
+            . $device
+            . ' << EOF '
+            . $FOLLOW . ','
+            . $SIZE . ','
+            . $RAID_PART_TYPE . ' EOF';
+        return Exec_cmd(
+            $cmd,
+            "Unable to add raid partition on device "
+                . $device
+                . " with command "
+                . $cmd
+                . " and with the following error(s)\n"
+        );
+    }
+    elsif ( $arch eq 'sparc' ) {
+        if ( !open( CMD, "| " . $FDISK . " " . $device ) ) {
+            warn "Unable to add raid partition on device "
+                . $device
+                . " with fdisk command\n"
+                if $VERBOSE;
+            return;
+        }
+        print CMD "n\n4\n\n\nt\n4\n$RAID_PART_TYPE\nw\n";
+        close(CMD);
+
 # 		$cmd = "echo \"n\\n4t\\n4\\n$RAID_PART_TYPE\\nw\\n\" | ".$FDISK." ".$device. ;
-	} else {
-		warn "Invalid architecture for platform : unable to add raid partition on device ".$device."\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	
-	return Exec_cmd ( $cmd, "Unable to add raid partition on device ".$device." with command ".$cmd." and with the following error(s)\n" ) ;
+    }
+    else {
+        warn
+            "Unsupported architecture $arch: unable to add raid partition on device $device\n"
+            if $VERBOSE;
+        return;
+    }
+
+    # FIXME: notreached?
+    return Exec_cmd(
+        $cmd,
+        "Unable to add raid partition on device "
+            . $device
+            . " with command "
+            . $cmd
+            . " and with the following error(s)\n"
+    );
 }
 
 # This function must be used with sparc architecture
-sub EraseAllpartitions ($;$) {
-	# Call parameter(s)
-	my ( $device, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $cmd ;
-	my @actions = () ;
-	
-	my $disk_list = GetDiskDevice () ;
-	if ( ! defined ( $disk_list ) ) {
-		warn "Unable to retrieve partitions for device ".$device."\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	foreach my $part ( @{$disk_list->{'disk'}} ) {
-		next if ( $part !~ /^\Q$device\E[\d]+$/ ) ;
-		$part =~ /^\Q$device\E([\d]+)$/ ;
-		push ( @actions, "d\n$1\n" ) ;
-	}
-	push ( @actions, "w\n" ) ;
-	if ( ! open ( ERASE, "|".$FDISK." ".$device ) ) {
-		warn "Unable to erase partition table for device ".$device."\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	foreach my $action ( @actions ) {
-		print ERASE $action ;
-	}
-	close ( ERASE ) ;
-	return 1 ;
-}
-
-sub DumpAllPartitions ($;$) {
-	# Call parameter(s)
-	my ( $device, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $cmd ;
-	
-	if ( ! defined ( $arch ) || $arch eq 'i386' ) {
-		$cmd = $SFDISK.' -d '.$device.' > '.$DUMP_PART_FILE ;
-		return Exec_cmd ( $cmd, "Unable to dump partiotion table from device ".$device." with command ".$cmd." and with the following error(s)\n" ) ;
-	} elsif ( $arch eq 'sparc' ) {
-		my @actions = () ;
-		# Dumping partition via command $cmd
-		$cmd = $FDISK.' -l '.$device ;
-		# 	Device Boot      Start         End      Blocks   Id  System
-		# /dev/sda1               1         893     7168000   1c  Hidden W95 FAT32 (LBA)
-		# Partition 1 does not end on cylinder boundary.
-		# /dev/sda2   *         894        4717    30716280    7  HPFS/NTFS
-		# /dev/sda3            4718        7149    19535040   83  Linux
-		# /dev/sda4            7150       19457    98864010    5  Extended
-		# /dev/sda5            7150        7392     1951866   82  Linux swap / Solaris
-		# /dev/sda6            7393       19457    96912081   83  Linux
-		if ( ! open ( DUMP, $cmd."|" ) ) {
-			warn "Unable to dump partitions table for device ".$device."\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-		push ( @actions, "n\n3\n\nt\n3\n5\n" ) ;
-		while ( <DUMP> ) {
-			my ( $part, $bootable, $first, $last, $type, $type_name ) ;
-			next if ( /\Q$device\E\3.*Whole disk.*$/ ) ;
-			# Fetching partition description line(s)
-			if ( /^$device([\d]+)\s*(\*)?\s*([\d]+)\s*([\d+])\s*[\d]+([^\s]+)\s*(.)*$/ ) {
-				( $part, $bootable, $first, $last, $type, $type_name ) = ( $1, $2, $3, $4, $5, $6 ) ;
-			}
-			# Create the actions to do with fdisk command for creating partition which is parsed on this line
-			push ( @actions, "n\n$part\n$first\n$last\nt\n$part\n$type\n" ) ;
-		}
-		close ( DUMP ) ;
-		# Command for writing changes to disk and exit
-		push ( @actions, "w\n" ) ;
-		# Initialize dumpfile with sparc template ;
-		if ( ! open ( TPL, $TPL_SPARC_PART ) ) {
-			warn "Unable to initialize dump file for sparc device ".$device."\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-		@actions = <TPL> ;
-		close ( TPL ) ;
-		# Adding partitions retrieved by command $cmd
-		if ( ! open ( DUMP, ">".$DUMP_PART_FILE ) ) {
-			warn "Unable to write dump partition for device ".$device." on file ".$DUMP_PART_FILE."\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-		foreach my $action ( @actions ) {
-			print DUMP $action ;
-		}
-		close ( DUMP ) ;
-	} else {
-		warn "Invalid architecture for platform : unable to dump partition table for device ".$device."\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	return 1 ;
-}
-
-sub RestoreAllPartitions ($;$$) {
-	# Call parameter(s)
-	my ( $device, $dumpfile, $arch ) = @_ ;
-	# Local(s) var(s)
-	my $cmd ;
-	
-	if ( ! defined ( $dumpfile ) ) {
-		$dumpfile = $DUMP_PART_FILE ;
-	}
-	if ( ! -e $dumpfile ) {
-		warn "Dump file for partition table ".$dumpfile." doesn't exist\n" if ( $VERBOSE ) ;
-		return 0 ;
-	} elsif ( -z $dumpfile ) {
-		warn "Dump file for partition table ".$dumpfile." is an empty file\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	
-	if ( ! defined ( $arch ) || $arch eq 'i386' ) {
-		$cmd = $SFDISK.' '.$device.' < '.$dumpfile ;
-	} elsif ( $arch eq 'sparc' ) {
-		if ( ! Erase_disk_partition ( $device ) ) {
-			warn "Unable to erase partition table before restoring from dump file ".$dumpfile."\n" if ( $VERBOSE ) ;
-			return 0 ;
-		}
-		$cmd = $FDISK.' '.$device.' < '.$dumpfile ;
-	} else {
-		warn "Invalid architecture for platform : unable to restore partition table for device ".$device."\n" if ( $VERBOSE ) ;
-		return 0 ;
-	}
-	return Exec_cmd ( $cmd, "Unable to restore partition table for ".$device." with command ".$cmd." and with the following error(s)\n" ) ;
+sub EraseAllpartitions {
+    my ( $device, $arch ) = @_;
+
+    return unless $device;
+
+    my $disk_list = GetDiskDevice();
+    if ( !defined($disk_list) ) {
+        warn "Unable to retrieve partitions for device $device\n"
+            if $VERBOSE;
+        return;
+    }
+
+    my @actions = ();
+    foreach my $part ( @{ $disk_list->{'disk'} } ) {
+        next if $part !~ /^\Q$device\E[\d]+$/;
+        $part =~ /^\Q$device\E([\d]+)$/;
+        push @actions, "d\n$1\n";
+    }
+    push @actions, "w\n";
+
+    if ( !open( ERASE, "|" . $FDISK . " " . $device ) ) {
+        warn "Unable to erase partition table for device $device\n"
+            if $VERBOSE;
+        return;
+    }
+    foreach my $action (@actions) {
+        print ERASE $action;
+    }
+    close(ERASE);
+
+    return 1;
+}
+
+sub DumpAllPartitions {
+    my ( $device, $arch ) = @_;
+
+    return unless $device;
+    $arch = 'i386' unless $arch;
+
+    my $cmd;
+    if ( $arch eq 'i386' ) {
+        $cmd = $SFDISK . ' -d ' . $device . ' > ' . $DUMP_PART_FILE;
+        return Exec_cmd(
+            $cmd,
+            "Unable to dump partiotion table from device "
+                . $device
+                . " with command "
+                . $cmd
+                . " and with the following error(s)\n"
+        );
+    }
+    elsif ( $arch eq 'sparc' ) {
+        my @actions = ();
+
+        # Dumping partition via command $cmd
+        $cmd = $FDISK . ' -l ' . $device;
+
+# 	Device Boot      Start         End      Blocks   Id  System
+# /dev/sda1               1         893     7168000   1c  Hidden W95 FAT32 (LBA)
+# Partition 1 does not end on cylinder boundary.
+# /dev/sda2   *         894        4717    30716280    7  HPFS/NTFS
+# /dev/sda3            4718        7149    19535040   83  Linux
+# /dev/sda4            7150       19457    98864010    5  Extended
+# /dev/sda5            7150        7392     1951866   82  Linux swap / Solaris
+# /dev/sda6            7393       19457    96912081   83  Linux
+        if ( !open( DUMP, $cmd . "|" ) ) {
+            warn "Unable to dump partitions table for device $device\n"
+                if $VERBOSE;
+            return;
+        }
+        push @actions, "n\n3\n\nt\n3\n5\n";
+        while (<DUMP>) {
+            my ( $part, $bootable, $first, $last, $type, $type_name );
+            next if /\Q$device\E\3.*Whole disk.*$/;
+
+            # Fetching partition description line(s)
+            if (/^$device([\d]+)\s*(\*)?\s*([\d]+)\s*([\d+])\s*[\d]+([^\s]+)\s*(.)*$/
+                )
+            {
+                ( $part, $bootable, $first, $last, $type, $type_name )
+                    = ( $1, $2, $3, $4, $5, $6 );
+            }
+
+# Create the actions to do with fdisk command for creating partition which is parsed on this line
+            push @actions, "n\n$part\n$first\n$last\nt\n$part\n$type\n";
+        }
+        close(DUMP);
+
+        # Command for writing changes to disk and exit
+        push @actions, "w\n";
+
+        # Initialize dumpfile with sparc template ;
+        if ( !open( TPL, $TPL_SPARC_PART ) ) {
+            warn "Unable to initialize dump file for sparc device $device\n"
+                if $VERBOSE;
+            return;
+        }
+        @actions = <TPL>;
+        close(TPL);
+
+        # Adding partitions retrieved by command $cmd
+        if ( !open( DUMP, ">" . $DUMP_PART_FILE ) ) {
+            warn
+                "Unable to write dump partition for device $device on file $DUMP_PART_FILE\n"
+                if $VERBOSE;
+            return;
+        }
+        foreach my $action (@actions) {
+            print DUMP $action;
+        }
+        close(DUMP);
+    }
+    else {
+        warn
+            "Unsupported architecture $arch: unable to dump partition table for device $device\n"
+            if $VERBOSE;
+        return;
+    }
+
+    return 1;
+}
+
+sub RestoreAllPartitions {
+    my ( $device, $dumpfile, $arch ) = @_;
+
+    return unless $device;
+    $dumpfile = $DUMP_PART_FILE unless $dumpfile;
+    $arch     = 'i386'          unless $arch;
+
+    # Local(s) var(s)
+    my $cmd;
+
+    if ( !-e $dumpfile ) {
+        warn "Dump file for partition table $dumpfile doesn't exist\n"
+            if $VERBOSE;
+        return;
+    }
+    elsif ( -z $dumpfile ) {
+        warn "Dump file for partition table $dumpfile is empty\n"
+            if $VERBOSE;
+        return;
+    }
+
+    if ( $arch eq 'i386' ) {
+        $cmd = $SFDISK . ' ' . $device . ' < ' . $dumpfile;
+    }
+    elsif ( $arch eq 'sparc' ) {
+        if ( !Erase_disk_partition($device) ) {
+            warn
+                "Unable to erase partition table before restoring from dump file $dumpfile\n"
+                if $VERBOSE;
+            return;
+        }
+        $cmd = $FDISK . ' ' . $device . ' < ' . $dumpfile;
+    }
+    else {
+        warn
+            "Unsupported architecture $arch: unable to restore partition table for device $device\n"
+            if $VERBOSE;
+        return;
+    }
+    return Exec_cmd(
+        $cmd,
+        "Unable to restore partition table for "
+            . $device
+            . " with command "
+            . $cmd
+            . " and with the following error(s)\n"
+    );
 }
 
 #
 # Managing RAID array(s) (create, add a disk ...)
 #
 
-sub MakeRaidArray ($$$) {
-	my ( $raid_dev, $raid_level, $dev_list ) = @_ ;
-	
-	my ( $cmd, $stat ) ;
-	$cmd = $MDADM.' -C '.$raid_dev.' -l '.$raid_level.' -n '.scalar ( @{$dev_list} ).' '.join ( " ", @{$dev_list} ) ;
-	if ( $DEBUG ) {
-		print 'Exec : '.$cmd."\n" ;
-	} else {
-		if ( ! Exec_cmd ( $cmd, "Unable to create RAID array level ".$raid_level." with command ".$cmd." and with the following error(s)\n" ) ) {
-			return 0 ;
-		}
-	}
-	return CheckArrayRecovery ( $raid_dev ) ;
-}
-
-sub AddDeviceOnArray ($$) {
-	# Variables en parametres d'appel
-	my ( $raid_dev, $device ) = @_ ;
-	# Variables locales a la fonction
-	my $cmd ;
-
-	$cmd = $MDADM.' '.$raid_dev.' -a '.$device ;
-	if ( $DEBUG ) {
-		print 'Exec : '.$cmd."\n" ;
-	} else {
-		if ( ! Exec_cmd ( $cmd, "Problem when adding device ".$device." on ARRAY ".$raid_dev." with command ".$cmd." and with the following error(s)\n" ) ) {
-			return 0 ;
-		}
-	}
-	return CheckArrayRecovery ( $raid_dev ) ;
-}
-
-sub DelDeviceOnArray ($$) {
-	# Variables en parametres d'appel
-	my ( $raid_dev, $device ) = @_ ;
-	# Variables locales a la fonction
-	my $cmd ;
-
-	$cmd = $MDADM.' '.$raid_dev.' -r '.$device ;
-	if ( $DEBUG ) {
-		print 'Exec : '.$cmd."\n" ;
-	} else {
-		if ( ! Exec_cmd ( $cmd, "Problem when deleting device ".$device." on ARRAY ".$raid_dev." with command ".$cmd." and with the following error(s)\n" ) ) {
-			return 0 ;
-		}
-	}
-	return 1 ;
+sub MakeRaidArray {
+    my ( $raid_dev, $raid_level, $dev_list ) = @_;
+
+    return unless $raid_dev and $raid_level;
+
+    my $cmd
+        = $MDADM . ' -C '
+        . $raid_dev . ' -l '
+        . $raid_level . ' -n '
+        . scalar( @{$dev_list} ) . ' '
+        . join( ' ', @{$dev_list} );
+
+    return
+        unless Exec_cmd(
+        $cmd,
+        "Unable to create RAID array level $raid_level with command $cmd and with the following error(s)\n"
+        );
+
+    return CheckArrayRecovery($raid_dev);
+}
+
+sub AddDeviceOnArray {
+    my ( $raid_dev, $device ) = @_;
+
+    return unless $raid_dev and $device;
+
+    my $cmd = "$MDADM $raid_dev -a $device";
+    return unless Exec_cmd(
+        $cmd,
+        "Problem when adding device $device on ARRAY $raid_dev with command $cmd and with the following error(s)\n"
+    );
+
+    return CheckArrayRecovery($raid_dev);
+}
+
+sub DelDeviceOnArray {
+    my ( $raid_dev, $device ) = @_;
+
+    return unless $raid_dev and $device;
+
+    my $cmd = "$MDADM $raid_dev -r $device";
+    return Exec_cmd(
+        $cmd,
+        "Problem when deleting device $device on ARRAY $raid_dev with command $cmd and with the following error(s)\n"
+    );
 }
 
 #
@@ -637,25 +892,26 @@
 # Managing filesystems ( formatting, checking ...)
 #
 
-sub ManageFilesystem ($$) {
-	# Variables en parametres d'appel
-	my ( $device, $fs_type, $action ) = @_ ;
-	# Variables locales a la fonction
-	my $cmd ;
-
-	if ( $action eq 'make' ) {
-		$cmd = $MKFS.$fs_type.' '.$device ;
-	} elsif ( $action eq 'check' ) {
-		$cmd = $FSCK.$fs_type.' -y '.$device ;
-	} else {
-		warn "ManageFilesystem -- Unknown action ".$action." : allowed actions are make and check\n" ;
-		return 0 ;
-	}
-	if ( $DEBUG ) {
-		print 'Exec : '.$cmd."\n" ;
-	} else {
-		return Exec_cmd ( $cmd, "Unable to manage filesystem with command ".$cmd." and with the following error(s)\n" ) ;
-	}
-}
-
-1;
+sub ManageFilesystem {
+    my ( $device, $fs_type, $action ) = @_;
+
+    return unless $device and $fs_type and $action;
+
+    my $cmd;
+    if ( $action eq 'make' ) {
+        $cmd = $MKFS . $fs_type . ' ' . $device;
+    }
+    elsif ( $action eq 'check' ) {
+        $cmd = $FSCK . $fs_type . ' -y ' . $device;
+    }
+    else {
+        warn "ManageFilesystem -- Unknown action " . $action
+            . " : allowed actions are make and check\n";
+        return;
+    }
+    return Exec_cmd( $cmd,
+        "Unable to manage filesystem with command $cmd and with the following error(s)\n"
+    );
+}
+
+1;

Modified: trunk/lib/PFTools/Net.pm
URL: http://svn.debian.org/wsvn/pf-tools/trunk/lib/PFTools/Net.pm?rev=902&op=diff
==============================================================================
--- trunk/lib/PFTools/Net.pm (original)
+++ trunk/lib/PFTools/Net.pm Wed Sep  8 19:28:28 2010
@@ -25,2141 +25,93 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Exporter;
+use Net::DNS;
+use NetAddr::IP;
+
+use PFTools::Logger;
+use PFTools::Structqueries;
 
 our @ISA = ('Exporter');
 
 our @EXPORT = qw(
-
-    Init_lib_net
-
-    Get_Active_Filename
-    Get_Active_Systemmap
-    Get_PXE_Filename
-    Get_Ordered_Filtered_Hosts
-    Get_dns_from_hostname
-    Get_dns_from_zone
-    Get_If
-    Get_UM_If
-    Get_Dhcp_Infos
-    Get_Cmdline
-    Get_Initrd_Filename
-    Get_Ramdisk_size_from_Initrd
-    Resolv
-
-    Mk_interfaces
-    Mk_zone
-    Parse_routing_table
-    Cmp_routing_table
-    
-    cmpif
-    Host_class
+    Get_netblock_from_vlan
+    Resolv_hostname_from_DNS
 );
 
 our @EXPORT_OK = qw();
 
-use Fcntl ':mode';
-use POSIX qw(ceil floor);
+#########################################################################
+### Rewrite with new syntax
+### Enhancement : creating DNS entries when adding network or hosts
+### Enhancement : creating DHCP entries when adding hosts
 
-use PFTools::Conf;
+#########################################################################
+#
+# NetAddr::IP Get_netblock_from_vlan ( STR , HASHREF )
+#
+# This function build a NetAddr::IP object, in the same time permits the control
+# of IP values defined for a given network definition
+# Inputs :
+#  - $sect_hash		: hashref containing the section where site key is defined
+#  - $global_config	: hashref where is stored global configuration
+#
+# Output :
+#  Return a NetAddr::IP object containing the netblock for a specifed network definition
+#
+sub Get_netblock_from_vlan ($$) {
+    my ( $type, $net_hash ) = @_;
 
-#use Data::Dumper;
-#$Data::Dumper::Sortkeys = 1;
-#$Data::Dumper::Useperl = 1;
-
-my @DEFAULTDHCPVLAN = ('vlan-7');
-
-my $UMLTRUNKINGWORKS  = 0;
-my $UMLTRUNKFACTORIZE = 1;
-
-my $NOETH3 = 0;
-
-# Error code
-my $ERR_OPEN   = 1;
-my $ERR_SYNTAX = 2;
-
-# Allowed architecture
-my $ALLOWED_ARCH = 'i386|amd64' ;
-# Allowed deploymode
-my $ALLOWED_DEPLOYMODE = 'pf-tools|(debian|ubuntu)-installer' ;
-
-
-sub node2index {
-    my ( $node, $pad ) = @_;
-    my $index = '';
-
-    while ( $node > 0 ) {
-	$index = chr( ord('a') + $node % 26 ) . $index;
-	$node  = floor( $node / 26 );
+    my $suffix = ( $type eq 'ipv6' ) ? '6' : '';
+    my @net_def;
+    my $msg;
+    if ( $net_hash->{ 'network' . $suffix } =~ /\/\d+$/ ) {
+        @net_def = ( $net_hash->{ 'network' . $suffix } );
+        $msg
+            = "Invalid network "
+            . $net_hash->{ 'network' . $suffix } . " "
+            . $type
+            . " defintion";
     }
-
-    if ( defined $pad && $pad > length($index) ) {
-	$index .= 'a' x ( $pad - length($index) );
+    else {
+        @net_def = (
+            $net_hash->{ 'network' . $suffix },
+            $net_hash->{ 'netmask' . $suffix }
+        );
+        $msg
+            = "Invalid network "
+            . $net_hash->{ 'network' . $suffix }
+            . " and/or netmask "
+            . $net_hash->{ 'netmask' . $suffix } . " "
+            . $type
+            . " defintion";
     }
-
-    return ($index);
+    my $block = new NetAddr::IP(@net_def);
+    if ( !defined $block ) {
+        Abort( $CODE->{'UNDEF_KEY'}, $msg );
+    }
+    return $block;
 }
 
-sub rotate {
-    my ( $array, $num ) = @_;
+sub Resolv_hostname_from_DNS ($) {
+    my ($hostname) = @_;
+    my $resolved = [];
 
-    while ( $num > 0 ) {
-	push @{$array}, shift @{$array};
-	$num--;
-    }
+    my $res   = Net::DNS::Resolver->new;
+    my $query = $res->search($hostname);
 
-    return @{$array};
-}
-
-sub cmpif {
-    my ( $a, $b ) = @_;
-    my $ai;
-    my $an;
-    my $av;
-    my $aa;
-    my $bi;
-    my $bn;
-    my $bv;
-    my $ba;
-
-    $an = $av = $aa = -1;
-    if ( $a =~ m/([^:.\d]+)(\d+)?(\.(\d+))?(:(\d+))?/ ) {
-	$ai = $1;
-	if ( defined $2 ) { $an = $2 }
-	if ( defined $4 ) { $av = $4 }
-	if ( defined $6 ) { $aa = $6 }
-    }
-    $bn = $bv = $ba = -1;
-    if ( $b =~ m/([^:.\d]+)(\d+)?(\.(\d+))?(:(\d+))?/ ) {
-	$bi = $1;
-	if ( defined $2 ) { $bn = $2 }
-	if ( defined $4 ) { $bv = $4 }
-	if ( defined $6 ) { $ba = $6 }
-    }
-    ( $ai cmp $bi ) || ( $an <=> $bn ) || ( $av <=> $bv ) || ( $aa <=> $ba );
-}
-
-sub netmask2prefix {
-    my ($netmask) = @_;
-
-    my $prefix = 32;
-
-    my @netmask = split( '\.', $netmask );
-    my $raw = $netmask[0] << 24 | $netmask[1] << 16 | $netmask[2] << 8
-	| $netmask[3];
-
-    while ( ( $raw & 1 ) == 0 && $prefix > 0 ) {
-	$raw = $raw >> 1;
-	$prefix--;
-    }
-
-    return $prefix;
-}
-
-sub Get_Host_Props ($$) {
-    my ( $Z, $host ) = @_ ;
-
-    $host =~ /^([^.]+)(\.([^.]+))?(\.$Z->{SOA}->{name})?$/ ;
-    my ( $hostshort, $hostvlan ) = ( $1, $3 ) ;
-    return undef if ( ! defined $hostshort ) ;
-
-    my $hostclass = Host_class( $hostshort, $Z ) ;
-
-    return $Z->{'SERVERS'}->{'BY_NAME'}->{$hostclass}->{'SRVLIST'}->{$hostshort} ;
-}
-
-# $interface Get_If ( $Zone, $host, $vlan )
-sub Get_If {
-    my ( $Z, $host, $vlan ) = @_;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	Abort( $ERR_SYNTAX, "Get_If: " . $host . " not found" );
-    }
-
-    return ( $M->{'ifup'}->{ $host . "." . $vlan } );
-}
-
-# ($dhcpif, $dhcpaddr) Get_Dhcp_Infos ( $Zone, $host )
-sub Get_Dhcp_Infos {
-    my ( $Z, $host ) = @_;
-
-    my $dhcpvlanregex
-	= '^(' . join( '|', @{ $Z->{'SOA'}->{'dhcpvlan'} } ) . ')$';
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	Abort( $ERR_SYNTAX, "Get_Dhcp_Infos: " . $host . " not found" );
-    }
-
-    foreach my $nam (
-	sort { cmpif( $M->{'ifup'}->{$a}, $M->{'ifup'}->{$b} ) }
-	keys %{ $M->{'ifup'} }
-	)
-    {
-	my $net = $nam;
-	$net =~ s/^[^\.]+\.//;
-	if ( $net =~ /$dhcpvlanregex/ ) {
-	    if ( defined $M->{'zone'}->{$nam}->{'ether'} ) {
-		return ( $M->{'ifup'}->{$nam},
-		    $M->{'zone'}->{$nam}->{'ether'} );
-	    }
-	    else {
-		return ( $M->{'ifup'}->{$nam},
-		    $M->{'zone'}->{$nam}->{'vmether'} );
-	    }
-	}
-
-    }
-    return undef;
-}
-
-sub Get_Ordered_Filtered_Hosts {
-    my ( $Z, @hostsfilter ) = @_;
-
-    my @list;
-
-    my $class;
-    foreach $class (
-	sort {
-	    my $i = $Z->{'SERVERS'}->{'BY_NAME'}->{$a}->{'order'};
-	    my $j = $Z->{'SERVERS'}->{'BY_NAME'}->{$b}->{'order'};
-	    if ( !defined $i ) { $i = 9999; }
-	    if ( !defined $j ) { $j = 9999; }
-	    if ( $i == $j ) { return ( $a cmp $b ); }
-	    $i <=> $j;
-	} keys %{ $Z->{'SERVERS'}->{'BY_NAME'} }
-	)
-    {
-	my $hostfilter;
-	foreach $hostfilter (@hostsfilter) {
-	    my $host;
-	    foreach $host (
-		sort
-		keys %{ $Z->{'SERVERS'}->{'BY_NAME'}->{$class}->{'SRVLIST'} }
-		)
-	    {
-		if ( $class =~ /$hostfilter/ || $host =~ /$hostfilter/ ) {
-		    push @list, $host;
-		}
-	    }
-	}
-    }
-
-    return @list;
-}
-
-# HASREF Get_UM_If ( $Zone, $host )
-sub Get_UM_If {
-    my ( $Z, $host ) = @_;
-
-    my $umif = {};
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	Abort( $ERR_SYNTAX, "Get_Dhcp_Infos: " . $host . " not found" );
-    }
-
-    foreach my $nam (
-	sort { cmpif( $M->{'ifup'}->{$a}, $M->{'ifup'}->{$b} ) }
-	keys %{ $M->{'ifup'} }
-	)
-    {
-	my $net = $nam;
-	$net =~ s/^[^\.]+\.//;
-	my $NET = $Z->{'NETWORK'}->{'BY_NAME'}->{$net};
-
-	if ( $M->{'ifup'}->{$nam} =~ m/([^:.\d]+)(\d+)?(\.(\d+))?(:(\d+))?/ )
-	{
-	    my $ai;
-	    my $an;
-	    my $av;
-	    my $aa;
-
-	    $ai = $1;
-	    if ( defined $2 ) { $an = $2 }
-	    if ( defined $4 ) { $av = $4 }
-	    if ( defined $6 ) { $aa = $6 }
-
-	    my $vlan_raw_device = $ai . ( ( defined $an ) ? $an : '' );
-
-	    if (   defined( $umif->{$vlan_raw_device} )
-		&& ( $umif->{$vlan_raw_device} ne 'TRUNK' || !defined $av )
-		&& $umif->{$vlan_raw_device} ne $NET->{'tag'} )
-	    {
-		Abort( $ERR_SYNTAX,
-		          "Get_UM_If[" 
-			. $host . "]: "
-			. $M->{'ifup'}->{$nam}
-			. " hasn't been remapped properly" );
-	    }
-
-	    if ( defined $av ) {
-		$umif->{$vlan_raw_device} = 'TRUNK';
-	    }
-	    else {
-		$umif->{$vlan_raw_device} = $NET->{'tag'};
-	    }
-	}
-	else {
-	    $umif->{ $M->{'ifup'}->{$nam} } = $NET->{'tag'};
-	}
-    }
-    return $umif;
-}
-
-sub UMRemap_If {
-    my ( $Z, $host ) = @_;
-
-    #Debug "UMRemap_If called for $host";
-
-    my %umif;
-    my %umvlan;
-    my %iforphan;
-    my %ifmap;
-    my $lastused = -1;
-    my %umtap;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	Abort( $ERR_SYNTAX, "UMRemap_If: " . $host . " not found" );
-    }
-
-    foreach my $nam (
-	sort { cmpif( $M->{'ifup'}->{$a}, $M->{'ifup'}->{$b} ) }
-	keys %{ $M->{'ifup'} }
-	)
-    {
-	my $net = $nam;
-	$net =~ s/^[^\.]+\.//;
-	my $NET = $Z->{'NETWORK'}->{'BY_NAME'}->{$net};
-
-	if ( !defined( $NET->{'tag'} ) ) {
-	    Abort( $ERR_SYNTAX,
-		      "UMRemap_If[" 
-		    . $host . "]: " 
-		    . $net
-		    . ": cannot wire, tag unknown" );
-	    exit 1;
-	}
-
-#Debug "IF '$M->{ifup}->{$nam}' -> NET '$net' -> TAG '" . (defined $NET->{tag} ? $NET->{tag} : '?') . "'\n";
-	if ( $M->{'ifup'}->{$nam} =~ m/([^:.\d]+)(\d+)?(\.(\d+))?(:(\d+))?/ )
-	{
-	    my $ai;
-	    my $an;
-	    my $av;
-	    my $aa;
-
-	    $ai = $1;
-	    if ( defined $2 ) { $an = $2 }
-	    if ( defined $4 ) { $av = $4 }
-	    if ( defined $6 ) { $aa = $6 }
-
-	    if ( $ai eq 'eth' && $lastused < $an ) {
-		$lastused = $an;
-	    }
-
-	    if (   defined $av
-		&& defined $NET->{'tag'}
-		&& $av != $NET->{'tag'} )
-	    {
-		Abort( $ERR_SYNTAX,
-		          "UMRemap_If[" 
-			. $host . "]: "
-			. "IF TAG "
-			. $av
-			. " != NET TAG "
-			. $NET->{'tag'} );
-		exit 1;
-	    }
-
-	    my $vlan_raw_device = $ai . ( ( defined $an ) ? $an : '' );
-
-	    # Interface deja connectee?
-	    if ( defined( $umif{$vlan_raw_device} ) ) {
-		if (   defined($av)
-		    && $umif{$vlan_raw_device} ne 'TRUNK'
-		    && $UMLTRUNKINGWORKS )
-		{
-
-		    if ( !defined $umvlan{'TRUNK'} || !$UMLTRUNKFACTORIZE ) {
-
-#Debug "$vlan_raw_device promoted to TRUNK, needs new UNTAGGED $umif{$vlan_raw_device}\n";
-			delete $umvlan{ $umif{$vlan_raw_device} };
-			push @{ $iforphan{ $umif{$vlan_raw_device} } },
-			    $vlan_raw_device;
-			$umif{$vlan_raw_device} = 'TRUNK';
-			if ( !defined $umvlan{'TRUNK'} ) {
-			    $umvlan{'TRUNK'} = $vlan_raw_device;
-			}
-		    }
-		    else {
-
-#Debug "$umvlan{'TRUNK'} is already connected to TRUNK, using it for $M->{ifup}->{$nam}\n";
-			$ifmap{ $M->{'ifup'}->{$nam} } = $umvlan{'TRUNK'};
-		    }
-		}
-		elsif ($umif{$vlan_raw_device} ne 'TRUNK'
-		    && $umif{$vlan_raw_device} != $NET->{'tag'} )
-		{
-
-#Debug "$vlan_raw_device already connected to UNTAGGED $umif{$vlan_raw_device}, new one needed for UNTAGGED $NET->{tag}\n";
-		    delete $umvlan{ $NET->{'tag'} };
-		    push @{ $iforphan{ $NET->{'tag'} } },
-			$M->{'ifup'}->{$nam};
-		}
-	    }
-	    else {
-		if ( !defined $av ) {
-		    $umif{$vlan_raw_device} = $NET->{'tag'};
-		    if ( !defined $umvlan{ $NET->{'tag'} } ) {
-			$umvlan{ $NET->{'tag'} } = $vlan_raw_device;
-		    }
-		}
-		else {
-		    $umif{$vlan_raw_device} = 'TRUNK';
-		    if ( !defined $umvlan{'TRUNK'} ) {
-			$umvlan{'TRUNK'} = $vlan_raw_device;
-		    }
-		}
-	    }
-
-	    if (   defined $umif{$vlan_raw_device}
-		&& defined $umvlan{ $umif{$vlan_raw_device} }
-		&& $umvlan{ $umif{$vlan_raw_device} } ne $vlan_raw_device )
-	    {
-
-#Debug "TAG $umif{$vlan_raw_device} already connected to IF $umvlan{ $umif{$vlan_raw_device} }\n";
-		$ifmap{$vlan_raw_device} = $umvlan{ $umif{$vlan_raw_device} };
-		delete $umif{$vlan_raw_device};
-	    }
-	}
-	else {
-	    Warn( $ERR_SYNTAX,
-		      "UMRemap_If[" 
-		    . $host
-		    . "]: Can't parse interface name "
-		    . $M->{'ifup'}->{$nam}
-		    . ", skipped" );
-	}
-    }
-
-    #if ( scalar( keys %ifmap ) != 0 || scalar( keys %iforphan ) != 0 ) {
-    #    Warn( $ERR_SYNTAX, "UMRemap_If[" . $host
-    #        . "]: Automatic remapping, config may not work!" );
-    #}
-
-#
-# Exemple de %iforphan nouvelle formule :
-#    (
-#	'6' => [ 'eth2:5', 'eth2:6' ],
-#	'7' => [ 'eth2:1' ],
-#	'8' => [ 'eth2:2' ],
-#	'4' => [ 'eth2:7' ],
-#	'5' => [ 'eth2:3', 'eth2:4' ]
-#    )
-#
-# FIXME le double foreach et double sort c'est douteux, mais c'était le moins invasif.
-#
-
-#Debug "iforphan : "; warn Dumper(\%iforphan); Debug "ifmap : "; warn Dumper(\%ifmap);
-
-    my %tmpindexes;
-    foreach my $nam (
-	sort { cmpif( $iforphan{$a}[0], $iforphan{$b}[0] ) || $a <=> $b }
-	keys %iforphan
-	)
-    {
-	foreach my $namidx (
-	    sort {
-		cmpif( $iforphan{$nam}[$a], $iforphan{$nam}[$b] )
-		    || $a <=> $b;
-	    } 0 .. @{ $iforphan{$nam} } - 1
-	    )
-	{
-	    if ( !defined $umvlan{$nam} ) {
-		$lastused++;
-
-# Debug "orphan UNTAGGED $nam (was $iforphan{$nam}[$namidx]) allocated to eth$lastused\n";
-		$ifmap{ $iforphan{$nam}[$namidx] } = "eth" . $lastused;
-		$umvlan{$nam}                      = "eth" . $lastused;
-		$umif{ "eth" . $lastused }         = $nam;
-		$tmpindexes{ $umvlan{$nam} }       = 0;
-	    }
-	    else {
-
-#Debug "false orphan UNTAGGED $nam (was $iforphan{$nam}[$namidx]) merged with $umvlan{$nam}\n";
-		$ifmap{ $iforphan{$nam}[$namidx] } = $umvlan{$nam};
-		if ( defined $tmpindexes{ $umvlan{$nam} } ) {
-		    $ifmap{ $iforphan{$nam}[$namidx] }
-			.= ':' . $tmpindexes{ $umvlan{$nam} }++;
-		}
-	    }
-
-# Debug "iforphan : "; warn Dumper(\%iforphan); Debug "ifmap : "; warn Dumper(\%ifmap);
-	}
-    }
-
-    foreach my $nam (
-	sort { cmpif( $M->{'ifup'}->{$a}, $M->{'ifup'}->{$b} ) }
-	keys %{ $M->{'ifup'} }
-	)
-    {
-	if ( !defined $ifmap{ $M->{ifup}->{$nam} } ) {
-	    $M->{'ifupremapped'}->{$nam} = $M->{'ifup'}->{$nam};
-	    if ( defined $M->{'route'}->{ $M->{'ifup'}->{$nam} } ) {
-		$M->{'routeremapped'}->{ $M->{'ifup'}->{$nam} }
-		    = $M->{route}->{ $M->{'ifup'}->{$nam} };
-	    }
-	    if ( defined $M->{'delroute'}->{ $M->{'ifup'}->{$nam} } ) {
-		$M->{'delrouteremapped'}->{ $M->{'ifup'}->{$nam} }
-		    = $M->{'delroute'}->{ $M->{'ifup'}->{$nam} };
-	    }
-	}
-	else {
-	    $M->{'ifupremapped'}->{$nam} = $ifmap{ $M->{'ifup'}->{$nam} };
-	    if ( defined $M->{'route'}->{ $M->{ifup}->{$nam} } ) {
-		$M->{'routeremapped'}->{ $ifmap{ $M->{'ifup'}->{$nam} } }
-		    = $M->{'route'}->{ $M->{'ifup'}->{$nam} };
-	    }
-	    if ( defined $M->{'delroute'}->{ $M->{'ifup'}->{$nam} } ) {
-		$M->{'delrouteremapped'}->{ $ifmap{ $M->{'ifup'}->{$nam} } }
-		    = $M->{'delroute'}->{ $M->{'ifup'}->{$nam} };
-	    }
-	}
-    }
-
-    delete $M->{'ifup'};
-    delete $M->{'route'};
-    delete $M->{'delroute'};
-    $M->{'ifup'}     = $M->{'ifupremapped'};
-    $M->{'route'}    = $M->{'routeremapped'};
-    $M->{'delroute'} = $M->{'delrouteremapped'};
-    delete $M->{'ifupremapped'};
-    delete $M->{'routeremapped'};
-    delete $M->{'delrouteremapped'};
-}
-
-sub Get_UM_Filename {
-    my ( $Z, $host ) = @_;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	return undef;
-    }
-
-    return ( $M->{'umlfilename'} );
-
-}
-
-sub Get_Initrd_Filename ($$) {
-    my ( $Z, $host ) = @_;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	return undef;
-    }
-
-    return ( $M->{'initrd'} );
-}
-
-sub Get_Ramdisk_size_from_Initrd ($) {
-    my ($initrd) = @_;
-    $initrd = "/distrib/tftpboot/$initrd";
-
-    # On ne peut pas utiliser File::stat sans perturber lib-update etc.
-    my @st_initrd = stat $initrd;
-    unless ( @st_initrd and $st_initrd[2] & S_IFREG ) {
-	Abort( $ERR_OPEN, "Impossible de stat($initrd): $!" );
-    }
-
-    return $st_initrd[7] / 1024;
-}
-
-sub Get_Cmdline ($$) {
-    my ( $Z, $host ) = @_;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    if ( !defined($M) ) {
-	return undef;
-    }
-
-    return ( $M->{'cmdline'} );
-}
-
-sub Get_PXE_Filename {
-    my ( $Z, $host ) = @_;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    return undef if ( !defined($M) ) ;
-
-    if ( $M->{'arch'} eq 'amd64' ) {
-	return ( $M->{'arch'}."/".$M->{'pxefilename'} );
+    if ($query) {
+        foreach my $rr ( $query->answer ) {
+            next unless $rr->type eq "A";
+            push( @{$resolved}, $rr->address );
+        }
     }
     else {
-	return ( $M->{'pxefilename'} );
+        Warn( $CODE->{'BIND_QUERY'}, "Query failed: " . $res->errorstring );
+        return undef;
     }
-}
-
-
-sub Get_Active_Filename {
-    my ( $Z, $host ) = @_;
-
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    return ( $M->{'umlfilename'} ) if ($PFTOOLS_VARS->{'UML'} && defined $M->{'umlfilename'});
-    return ( $M->{'vmwfilename'} ) if ($PFTOOLS_VARS->{'VMWARE'} && defined $M->{'vmwfilename'});
-    return Get_PXE_Filename ( $Z, $host ) ;
-}
-
-sub Get_Active_Systemmap {
-    my ( $Z, $host ) = @_;
-
-    my $system_map = Get_PXE_Filename ( $Z, $host ) ;
-    $system_map =~ s/vmlinuz/System.map/ ;
-    return $system_map ;
-}
-
-sub Get_dns_from_hostname {
-    my ( $Z, $host ) = @_;
-
-    $host =~ m/^([^.]+)(\.([^.]+))?(\.$Z->{SOA}->{name})?$/ ;
-    my $hostnum = $1 ;
-    $hostnum =~ s/.*([\d]+)$/$1/ ;
-    my $M = Get_Host_Props ( $Z, $host ) ;
-
-    return Get_dns_from_zone( $Z, $M, $hostnum );
-}
-
-sub Get_dns_from_zone {
-    my ( $Z, $M, $hostnum ) = @_;
-
-    if ( !defined($M) ) {
-	return undef;
-    }
-
-    my $rawdns;
-    if ( defined $M->{'dns'} && $M->{'dns'} ne "" ) {
-	$rawdns = $M->{'dns'};
-    }
-    else {
-	$rawdns = join( ", ", @{ $Z->{'NS'} } );
-    }
-
-    my @dns;
-    foreach my $dns ( split( /[,\s]+/, $rawdns ) ) {
-	my @resolved = Resolv( $dns, $Z );
-	if ( $#resolved >= 0 && defined $resolved[0] ) {
-	    @resolved = sort @resolved;
-	    push @dns, rotate( \@resolved, $hostnum );
-	}
-	else {
-	    push @dns, $dns;
-	}
-    }
-    return @dns;
-}
-
-#
-#	HASHREF Init_lib_net (STRING $fic_conf)
-#
-#	Initialisation de la structure de donnees a partir du fichier $fic_conf
-#	Une reference sur la structure est retournee.
-#
-#=============================================================================================
-sub Init_lib_net {
-    my ($fic_conf) = @_;
-
-    my $C;
-    my $Z;
-    my $s;
-
-    # Initialisation de la structure de donnees
-    $Z = {};
-    $Z->{'NETWORK'} = { { 'BY_ADDR', {} }, { 'BY_NAME', {} } };
-    $Z->{'SERVERS'} = { { 'BY_ADDR', {} }, { 'BY_NAME', {} } };
-    $Z->{'SOA'}   = {};
-    $Z->{'NS'}    = [];
-    $Z->{'MX'}    = [];
-    $Z->{'ALIAS'} = {};
-
-    # Chargement du fichier de configuration reseau
-    $C = Load_conf( $fic_conf, 0 );
-
-    # Calcul de la conf reseau et de la zone
-    foreach $s ( keys %$C ) {
-	if ( $C->{$s}->{'type'} =~ /network$/ ) {
-	    Add_network( $Z, $C->{$s}, $s );
-	}
-
-	# Prise en compte de la zone
-	if ( $C->{$s}->{'type'} =~ /zone$/ ) {
-	    Add_zone( $Z, $C->{$s}, $s );
-	}
-    }
-
-    # Calcul de la conf serveur
-    # (Il doit obligatoirement etre fait en seconde passe
-    # il utilise les donnees reseau et zone)
-    foreach $s ( keys %$C ) {
-	if ( $C->{$s}->{'type'} =~ /server$/ ) {
-	    Add_server( $Z, $C->{$s}, $s );
-	}
-    }
-
-    # Retour de la structure de donnees
-    return ($Z);
-}
-
-#
-#	VOID Add_server (HASHREF $Z, HASHREF $S, STRING $srv)
-#
-#	Ajoute une description de serveur a la structure de donnee $Z
-#	En entree $S contient les informations sur les serveurs de type $srv
-#
-#===================================================================================
-sub Add_server {
-    my ( $Z, $S, $srv ) = @_;
-    my $start;
-    my $s;
-
-    # Calcul de la plage d'adresse alouee et du nombre de serveurs a definir
-
-    if ( !defined( $S->{'nodes'} ) ) {
-	$S->{'nodes'} = 1;
-    }
-    my $nodeslast = $S->{'nodes'} - 1;
-    if ( $nodeslast < 0 ) {
-	$nodeslast = 0;
-    }
-
-    if ( !defined( $S->{'number'} ) ) {
-	$S->{'number'} = 1;
-    }
-    my $last = $S->{'number'} - 1;
-    if ( $last < 0 ) {
-	$last = 0;
-    }
-
-    $srv =~ s/(_*)$//;
-    my $nodes = length($1);
-    $srv =~ s/(%*)$//;
-    my $digit = length($1);
-
-    # Pas de nodes et plusieurs nodes
-    if ( $nodeslast > 0 && ( !defined($nodes) || $nodes <= 0 ) ) {
-	Abort( $ERR_SYNTAX,
-	    "Plusieurs nodes " . $srv . " et pas de place pour l'index!" );
-    }
-
-    # Pas assez de nodes pour le nombre de nodes
-    if ( $nodeslast > 1 && ceil( log($nodeslast) / log(26) ) > $nodes ) {
-	Warn( $ERR_SYNTAX,
-	          "Dernier node " 
-		. $srv . " = "
-		. $nodeslast
-		. " et pas assez de place ("
-		. $nodes
-		. ") pour l'index!" );
-    }
-
-    # Pas de digits et plusieurs machines
-    if ( $last > 0 && ( !defined($digit) || $digit <= 0 ) ) {
-	Abort( $ERR_SYNTAX,
-	    "Plusieurs " . $srv . " et pas de place pour le numero!" );
-    }
-
-    # Pas assez de digits pour le nombre de machines
-    if ( $last > 1 && length( sprintf( "%s", $last ) ) > $digit ) {
-	Warn( $ERR_SYNTAX,
-	          "Dernier " 
-		. $srv . " = " 
-		. $last
-		. " et pas assez de place ("
-		. $digit
-		. ") pour le numero!" );
-    }
-
-    # Initialisation de la structure pour ces serveurs
-    my $N = {};
-    $N->{'comment'} = $S->{'comment'} || "Server $srv <no comment specified>";
-    $N->{'type'} = $S->{'type'};
-
-    #$N->{range}   = $S->{range};
-    $N->{'number'} = $S->{'number'};
-    $N->{'nodes'}  = $S->{'nodes'};
-
-    $N->{'order'} = $S->{'order'};
-
-    $N->{SRVLIST} = {};
-
-    my $ipincrement = 1;
-    if ( defined $S->{'ipincrement'} ) {
-	$ipincrement = $S->{'ipincrement'};
-    }
-
-    # Mlt : Gestion des entrees dhcp pour certains sereurs d'un vlan uniquement
-    # On ajoute un vlan a la liste dhcpclanpartial seulement si il n'est pas
-    # deja present dans cette liste ou dans la liste globale dhcpvlan.
-    # Lors de la generation du dhcpd.conf les entrees presentes dans dhcpvlanpartial
-    # entraineront la creation du subnet correspondant mais seul les hosts correspondants
-    # a des machines qui auront declare des dhcpvlan seront generes.
-    # !!! Il ne peut Y avoir qu'une SEULE entree dhcp de deploiement par machine !!!
-    # !!! entre autre parcequ'il n'y a qu'un seul ether.n par machine :-)        !!!
-    # !!! donc la presence de cette directive au niveau d'une machine annule le  !!!
-    # !!! traitement des autres declaration dans des vlans plus globaux.         !!!
-    if ( defined $S->{dhcpvlan} ) {
-        my $vlan = $S->{dhcpvlan} ;
-        if ( ! grep (/^$vlan$/, @{ $Z->{SOA}->{dhcpvlan} }) ) {
-            if ( ! grep (/^$vlan$/, @{ $Z->{SOA}->{dhcpvlanpartial} }) ) {
-                push (@{ $Z->{SOA}->{dhcpvlanpartial} }, $vlan) ;
-            }
-        }
-    }
-
-    # Traitement de chaque occurence
-    my $ipindex = -$ipincrement;
-    foreach $s ( 0 .. $last ) {
-	for my $n ( 0 .. $nodeslast ) {
-	    my $M = {};
-	    my $i;
-	    my $j;
-	    my $mnam;
-
-	    $ipindex += $ipincrement;
-
-	    # Definition du nom
-	    my $cnamindex    = "";
-	    my $cnamindexnum = "";
-	    if ( defined($digit) && $digit > 0 ) {
-		$cnamindex .= sprintf( "%0" . $digit . "s", $s );
-		$cnamindexnum .= sprintf( "%s", $s );
-	    }
-	    my $mnamindex    = $cnamindex;
-	    my $mnamindexnum = $cnamindexnum;
-	    if ( defined($nodes) && $nodes > 0 ) {
-		$mnamindex
-		    = $cnamindex
-		    . sprintf( "%0" . $nodes . "s",
-		    node2index( $n, $nodes ) );
-		$mnamindexnum
-		    = $cnamindexnum
-		    . sprintf( "%0" . $nodes . "s",
-		    node2index( $n, $nodes ) );
-	    }
-
-	    $mnam = $srv . $mnamindex;
-	    if ( $cnamindexnum eq "" ) {
-		$cnamindexnum = "0";
-	    }
-	    if ( $mnamindexnum eq "" ) {
-		$mnamindexnum = "0";
-	    }
-
-	    $M->{'name'}     = $mnam;
-	    $M->{'zone'}     = {};
-	    $M->{'ifup'}     = {};
-	    $M->{'route'}    = {};
-	    $M->{'delroute'} = {};
-
-	    my @common_keys = (
-		'filename',
-		'pxefilename',
-		'umlfilename',
-		'vmwfilename',
-		'pxelinuxconf',
-		'pxetemplate',
-		'deploymode',
-		'dns',
-		'arch',
-		'distrib',
-		'initrd',
-		'cmdline',
-		'console'
-	    ) ;
-	    foreach my $key ( @common_keys ) {
-		if ( defined ( $S->{$key}->{$mnamindexnum} ) ) {
-		    if ( $key eq 'arch' && $S->{$key}->{$mnamindexnum} !~ /^$ALLOWED_ARCH$/ ) {
-			Abort( $ERR_SYNTAX, "Invalid architecture for host ".$srv.$mnamindexnum." : ".$S->{$key}->{$mnamindexnum} ) ;
-		    } elsif ( $key eq 'deploymode' ) {
-			Abort ( $ERR_SYNTAX, "Invalid deploymode key for host ".$srv.$mnamindexnum." : ".$S->{$key}->{$mnamindexnum} )
-				if ( $S->{$key}->{$mnamindexnum} !~ /^$ALLOWED_DEPLOYMODE$/ ) ;
-		    }
-		    $M->{$key} = $S->{$key}->{$mnamindexnum} ;
-		}
-		elsif ( defined ( $S->{$key}->{'default'} ) ) {
-		    if ( $key eq 'arch' && $S->{$key}->{'default'} !~ /^$ALLOWED_ARCH$/ ) {
-			Abort( $ERR_SYNTAX, "Invalid default architecture for host ".$srv." : ".$S->{$key}->{'default'} ) ;
-		    } elsif ( $key eq 'deploymode' ) {
-			Abort ( $ERR_SYNTAX, "Invalid default deploymode key ".$S->{$key}->{'default'} )
-				if ( $S->{$key}->{'default'} !~ /^$ALLOWED_DEPLOYMODE$/ ) ;
-		    }
-		    $M->{$key} = $S->{$key}->{'default'} ;
-		}
-		elsif ( $key eq 'deploymode' ) {
-		    $M->{'deploymode'} = 'pf-tools' ;
-		}
-		elsif ( $key eq 'initrd' && $M->{'deploymode'} eq 'pf-tools' ) {
-		    $M->{'initrd'} = 'initrd' ;
-		}
-		elsif ( $key eq 'arch' ) {
-		    $M->{'arch'} = 'i386' ;
-		}
-		elsif ( $key eq 'console' && defined $Z->{'SOA'}->{'console'} ) {
-			$M->{'console'} = $Z->{'SOA'}->{'console'};
-		}
-	    }
-
-	    delete $M->{'console'} if $M->{'console'} and $M->{'console'} eq 'default';
-
-            # Mlt : Ajout de zone dhcp partielle
-            if ( defined $S->{dhcpvlan} ) {
-                $M->{dhcpvlan} = $S->{dhcpvlan} ;
-            }
-
-	    if ( defined $S->{'bonding'} ) {
-		foreach my $bond ( keys %{$S->{'bonding'}} ) {
-		    if ( defined $S->{'bonding'}->{$bond}->{$mnamindexnum} ) {
-		    	@{$M->{'bonding'}->{$bond}} = split ( /,/, $S->{'bonding'}->{$bond}->{$mnamindexnum} ) ;
-		    }
-		    elsif ( defined $S->{'bonding'}->{$bond}->{'default'} ) {
-		    	@{$M->{'bonding'}->{$bond}} = split ( /,/, $S->{'bonding'}->{$bond}->{'default'} ) ;
-		    }
-		    else {
-			Abort( $ERR_SYNTAX, "No default bonding config defined for interface ".$bond ) ;
-		    }
-		    foreach my $iface ( @{$M->{'bonding'}->{$bond}} ) {
-		    	if ( defined $S->{'interface'}->{$iface} ) {
-			    if ( ref ( $S->{'interface'}->{$iface} ) eq 'HASH' ) {
-				if ( defined $S->{'interface'}->{$iface}->{$mnamindexnum} ) {
-				    Abort( $ERR_SYNTAX, "Cannot define interface $iface: already used in bonding definition $bond" );
-				}
-			    }
-			    else {
-			    	Abort( $ERR_SYNTAX, "Cannot define interface $iface: already used in bonding definition $bond" );
-			    }
-			}
-		    }
-		}
-	    }
-
-	    # vrrp?
-	    my $vrrp;
-	    foreach $j ( keys %{ $S->{'vrrp'} } ) {
-		if ( $S->{'vrrp'}->{$j} eq $s
-		    || ( $S->{'vrrp'}->{$j} eq "last" && $s == $last ) )
-		{
-		    $vrrp = $j;
-		    $mnam = $j;
-		}
-	    }
-
-	    my $goteth1 = 0;
-
-	    # Traitement de chaque interface (ou reseau)
-	    foreach $i ( sort { cmpif( $a, $b ) }
-		keys %{ $S->{'interface'} } )
-	    {
-		my $nam;
-
-		if ( $i eq 'eth1' ) {
-		    $goteth1 = 1;
-		}
-
-		$j = $i;
-		if ( $j =~ m/^eth3/ && $NOETH3 ) {
-		    if ($goteth1) {
-			$j = 'eth1' . $' . ':9999';
-		    }
-		    else {
-			$j = 'eth1' . $';
-		    }
-		}
-
-		# Definition de l'entree DNS pour cette interface
-		my $lan ;
-		if ( ref ( $S->{'interface'}->{$i} ) eq 'HASH' ) {
-		    if ( defined $S->{'interface'}->{$i}->{$mnamindexnum} ) {
-			$lan = $S->{'interface'}->{$i}->{$mnamindexnum} ;
-		    }
-		    elsif ( ! defined $S->{'interface'}->{$i}->{'default'} ) {
-			Warn( $ERR_SYNTAX, "No default vlan defined for interface ".$i." skipping this interface for host $mnam" ) ;
-			next ;
-		    }
-		    else {
-			$lan = $S->{'interface'}->{$i}->{'default'} ;
-		    }
-		}
-		else {
-		    $lan = $S->{'interface'}->{$i} ;
-		}
-		
-		if ( $i =~ /^(?:eth|bond)[\d]+\.((TAG)?[\d]+)$/ ) {
-		    my $tag = $1 ;
-		    if ( defined $Z->{'NETWORK'}->{'BY_NAME'}->{$lan}->{'tag'} ) {
-			Warn ( $ERR_SYNTAX, "Tag ".$tag." differs from defined tag "
-				.$Z->{'NETWORK'}->{'BY_NAME'}->{$lan}->{'tag'}." for vlan ".$lan." on ".$i." for host ".$mnam )
-			    if ( $tag =~ /^[\d]+/ && $tag != $Z->{'NETWORK'}->{'BY_NAME'}->{$lan}->{'tag'} );
-		    }
-		    else {
-			Abort ( $ERR_SYNTAX, "Tag is not defined for vlan ".$lan ); # if ( $1 =~ /^TAG/ );
-		    }
-		}
-		
-		$nam = $mnam . "." . $lan;
-		
-		if ( $M->{'ifup'}->{$nam} ) {
-		    Abort ( $ERR_SYNTAX, "Cannot define $i on vlan ".$lan." ".$M->{'ifup'}->{$nam}." is already on this vlan for host ".$mnam ) ;
-		}
-
-		my $addr = $Z->{'NETWORK'}->{'BY_NAME'}->{$lan}->{'network'};
-
-		if ( defined $S->{'ip'}->{$lan}->{$mnamindexnum} ) {
-		    $start = $S->{'ip'}->{$lan}->{$mnamindexnum}
-		}
-		elsif ( defined $S->{'ipstart'}->{$lan} ) {
-		    $start = $S->{'ipstart'}->{$lan};
-		}
-		elsif ( defined $S->{'ipstart'}->{'default'} ) {
-		    $start = $S->{'ipstart'}->{'default'};
-		}
-		elsif ( defined $S->{'shortname'} ) {
-		    $start = $S->{'ipstart'}->{ $S->{'shortname'} };
-		}
-
-		if ( !defined $start ) {
-		    Abort( $ERR_SYNTAX, "No ipstart for " . $nam );
-		}
-
-		$M->{'zone'}->{$nam} = {};
-		if ( defined $S->{'ip'}->{$lan}->{$mnamindexnum} ) {
-		    $M->{'zone'}->{$nam}->{'FIELD'}
-		        = Address ( $addr, $start, 0 ) ;
-		}
-		else {
-		    $M->{'zone'}->{$nam}->{'FIELD'}
-		        = Address( $addr, $start, $ipindex );
-		}
-		
-		$M->{'zone'}->{$nam}->{'TYPE'} = 'A';
-
-		# Adresse ethernet (pas forcement avec dhcp, eg tftp)
-		if ( defined( $S->{'ether'}->{$mnamindexnum} ) ) {
-		    $M->{'zone'}->{$nam}->{'ether'}
-			= $S->{'ether'}->{$mnamindexnum};
-		}
-
-		if ( defined( $S->{'vmether'}->{$mnamindexnum} ) ) {
-		    $M->{'zone'}->{$nam}->{'vmether'}
-			= $S->{'vmether'}->{$mnamindexnum};
-		}
-		elsif ( defined( $S->{'ether'}->{$mnamindexnum} ) ) {
-		    $M->{'zone'}->{$nam}->{'vmether'} = '00:50:56:' . sprintf(
-			"%02x:%02x:%02x",
-			unpack( "L", $mnam ) % 255,    # L : long unsigned,
-			unpack( "L", reverse $mnam ) % 255,
-			$start + $ipindex
-		    );
-		}
-
-		# Definition de l'alias DNS principal
-		if ( defined $S->{'shortname'} && $S->{'shortname'} eq $lan ) {
-		    $M->{'zone'}->{$mnam}            = {};
-		    $M->{'zone'}->{$mnam}->{'FIELD'} = $nam;
-		    $M->{'zone'}->{$mnam}->{'TYPE'}  = 'CNAME';
-		}
-
-		# Alias de vlan pour la classe
-		if ( !defined( $Z->{'ALIAS'}->{ $srv . '.' . $lan } ) ) {
-		    $Z->{'ALIAS'}->{ $srv . '.' . $lan } = [];
-		}
-		if (scalar(
-			grep( /^$nam$/, $Z->{'ALIAS'}->{ $srv . '.' . $lan } )
-		    ) == 0
-		    )
-		{
-		    push(
-			@{ $Z->{'ALIAS'}->{ $srv . '.' . $lan } },
-			$M->{'zone'}->{$nam}->{'FIELD'}
-		    );
-		}
-
-		# Alias de vlan pour le cluster
-		if ( $nodeslast > 0 ) {
-		    if (!defined(
-			    $Z->{'ALIAS'}->{ $srv . $cnamindex . '.' . $lan }
-			)
-			)
-		    {
-			$Z->{'ALIAS'}->{ $srv . $cnamindex . '.' . $lan }
-			    = [];
-		    }
-		    if (scalar(
-			    grep( /^$nam$/,
-				$Z->{'ALIAS'}
-				    ->{ $srv . $cnamindex . '.' . $lan } )
-			) == 0
-			)
-		    {
-			push(
-			    @{  $Z->{'ALIAS'}
-				    ->{ $srv . $cnamindex . '.' . $lan }
-				},
-			    $M->{'zone'}->{$nam}->{'FIELD'}
-			);
-		    }
-		}
-
-		# Traduction du tag si format <iface>\.TAG[\d]+
-		if ( $j =~ /TAG[\d]+$/ ) {
-			$j =~ s/TAG[\d]+$/$Z->{'NETWORK'}->{'BY_NAME'}->{$lan}->{'tag'}/ ;
-		}
-
-		# Definition de l'entree dans /etc/network/interface
-		if ( defined( $S->{'dhcp'} ) && $i eq $S->{'dhcp'} ) {
-		    $M->{'ifup'}->{'dhcp'} = $j;
-		}
-		else {
-		    $M->{'ifup'}->{$nam} = $j;
-		}
-
-		# Traitement des routes
-		my $r;
-		foreach $r ( keys %{ $S->{$i} } ) {
-		    if ( $r =~ m/^(route|delroute)/ ) {
-			my $act = $1 ;
-			if ( ref ( $S->{$i}->{$r} ) eq 'HASH' ) {
-			    if ( defined $S->{$i}->{$r}->{$mnamindexnum} ) {
-				$M->{$act}->{$j}->{$r} = $S->{$i}->{$r}->{$mnamindexnum} ;
-			    } elsif ( ! defined $S->{$i}->{$r}->{'default'} ) {
-				Warn ( $ERR_SYNTAX, "No default route defined for interface ".$i." skipping this route for host $mnam" ) ;
-			    } else {
-				$M->{$act}->{$j}->{$r} = $S->{$i}->{$r}->{'default'} ;
-			    }
-			} else {
-			    $M->{$act}->{$j}->{$r} = $S->{$i}->{$r};
-			}
-		    }
-		}
-
-		# Traitement des mtu
-		if ( defined( $S->{$i}->{'mtu'} ) ) {
-		    $M->{'mtu'}->{$j} = $S->{$i}->{'mtu'};
-		}
-
-		# Traitement des media
-		if ( defined( $S->{$i}->{'media'} ) ) {
-		    $M->{'media'}->{$j} = $S->{$i}->{'media'};
-		}
-
-		# Traitement des noarp
-		if ( defined( $S->{$i}->{'noarp'} ) ) {
-		    $M->{'noarp'}->{$j} = $S->{$i}->{'noarp'};
-		}
-	    }
-
-	    # Definition des alias DNS
-	    foreach $j ( keys %{ $S->{'alias'} } ) {
-		my $lan;
-		my $nam;
-		my $addr;
-
-		# Alias par machine
-		$lan = $S->{'alias'}->{$j};
-		$nam = $j . $mnamindex;
-
-		# ne pas ecraser si shortname deja existant
-		if ( !defined $M->{'zone'}->{$nam} ) {
-		    $M->{'zone'}->{$nam}            = {};
-		    $M->{'zone'}->{$nam}->{'FIELD'} = $mnam . "." . $lan;
-		    $M->{'zone'}->{$nam}->{'TYPE'}  = 'CNAME';
-		}
-
-	     # Alias "round robin" pour l'ensemble de cette classe de serveurs
-		$nam = $mnam . "." . $lan;
-
-		#if ( !defined( $Z->{ALIAS}->{$j} ) ) {
-		#    $Z->{ALIAS}->{$j} = [];
-		#}
-		#push ( @{ $Z->{ALIAS}->{$j} }, $M->{zone}->{$nam}->{FIELD} );
-		if ( $s == 0 && $n == 0 && !defined $M->{'zone'}->{$j} ) {
-		    $M->{'zone'}->{$j}            = {};
-		    $M->{'zone'}->{$j}->{'FIELD'} = $srv . "." . $lan;
-		    $M->{'zone'}->{$j}->{'TYPE'}  = 'CNAME';
-		}
-		if (   $nodeslast > 0
-		    && $s == 0
-		    && $n == 0
-		    && !defined $M->{'zone'}->{ $j . $cnamindex } )
-		{
-		    $M->{'zone'}->{ $j . $cnamindex } = {};
-		    $M->{'zone'}->{ $j . $cnamindex }->{'FIELD'}
-			= $srv . $cnamindex . "." . $lan;
-		    $M->{'zone'}->{ $j . $cnamindex }->{'TYPE'} = 'CNAME';
-		}
-	    }
-
-	    # Insertion du serveur dans sa classe
-	    $N->{'SRVLIST'}->{$mnam} = $M;
-	}
-
-	# Vips du cluster
-    }
-
-    # Insertion de la classe de serveurs dans la structure principale
-    if ( defined $S->{'shortname'} ) {
-	if ( defined $S->{'ipstart'}->{ $S->{'shortname'} } ) {
-	    $start = $S->{'ipstart'}->{ $S->{'shortname'} };
-	}
-	else {
-	    $start = $S->{'ipstart'}->{'default'};
-	}
-
-	my $srv_addr = Address ( $Z->{'NETWORK'}->{'BY_NAME'}->{ $S->{'shortname'} }->{'network'}, $start, 0 );
-	if ( defined $Z->{'SERVERS'}->{'BY_ADDR'}->{$srv_addr} ) {
-	    Warn ( $ERR_SYNTAX, "Address ".$srv_addr." for server ".$srv." is already in use" );
-	}
-	else {
-		push ( @{$Z->{'SERVERS'}->{'BY_ADDR'}->{$srv_addr}}, $N );
-	}
-    }
-
-    $Z->{'SERVERS'}->{'BY_NAME'}->{$srv} = $N;
-
-    # Remapping UM
-    if ($PFTOOLS_VARS->{'UML'}) {
-	my $mnam;
-	foreach $mnam ( keys %{ $N->{'SRVLIST'} } ) {
-	    UMRemap_If( $Z, $mnam );
-	}
-    }
-}
-
-#
-#	VOID Add_zone (HASHREF $Z, HASHREF $S, STRING $zone)
-#
-#	Ajoute la description de la zone $zone (SOA MX et NS) a la
-#	structure de donnees $Z a partir des informations contenues
-#	dans la section $S
-#
-#================================================================================
-sub Add_zone {
-    my ( $Z, $S, $zone ) = @_;
-
-    my $c;
-    my $t_secs;
-    my $t_text;
-    my $mail;
-    my $soa;
-
-    # Verification de l'unicite de la declaration
-    if ( defined( $Z->{'SOA'}->{'name'} ) ) {
-	Abort( $ERR_SYNTAX,
-	          "Declaration zone dupliquee ("
-		. $Z->{'SOA'}->{'name'}
-		. ") et ("
-		. $zone
-		. ")" );
-    }
-
-    # Ajout des informations SOA
-    # Le numero de serie est genere automatiquement, on prends
-    # l'heure system en seconde.
-    # l'adresse mail est corrigee si besoin (@ => .)
-    # Les adresse SOA et Mail sont complettes (.$)
-
-    $t_secs = time();
-    $t_text = localtime($t_secs);
-
-    $mail = $S->{'mail'};
-    $mail =~ s/@/\./;
-    $mail =~ s/([^\.])$/$1./;
-
-    $soa = $S->{'soa'};
-    $soa =~ s/([^\.])$/$1./;
-
-    if ( defined $S->{'serial'} && $S->{'serial'} =~ m|([\d.]+)| ) {
-	my $rev = $1;
-
-	$rev =~ s/\.//g;
-
-	$Z->{'SOA'}->{'serial'}
-	    = $rev . "\t; Serial (" . $S->{'serial'} . ")";
-    }
-    else {
-	$Z->{'SOA'}->{'serial'} = $t_secs . "\t; Serial (" . $t_text . ")";
-    }
-    $Z->{'SOA'}->{'name'}    = $zone;
-    $Z->{'SOA'}->{'comment'} = $S->{'comment'}
-	|| "Zone $zone <no comment specified>";
-    $Z->{'SOA'}->{'soa'}     = $soa;
-    $Z->{'SOA'}->{'mail'}    = $mail;
-    $Z->{'SOA'}->{'refresh'} = $S->{'refresh'};
-    $Z->{'SOA'}->{'retry'}   = $S->{'retry'};
-    $Z->{'SOA'}->{'expire'}  = $S->{'expire'};
-    $Z->{'SOA'}->{'negttl'}  = $S->{'negttl'};
-    $Z->{'SOA'}->{'ttl'}     = $S->{'ttl'};
-
-    # Mlt : Ajout de zone dhcp partielle
-    # $Z->{SOA}->{dhcpvlan} = Liste des vlans dont TOUTES les machines ont
-    # une entree dans dhcpd.conf
-    # $Z->{SOA}->{dhcpvlanpartial} = Liste des vlans dont SEULEMENT CERTAINES
-    # machines ont une entree dans dhcpd.conf
-    if ( defined $S->{'dhcpvlan'} ) {
-	@{ $Z->{'SOA'}->{'dhcpvlan'} } = split( /[,\s]+/, $S->{'dhcpvlan'} );
-    }
-    else {
-	@{ $Z->{SOA}->{'dhcpvlan'} } = @DEFAULTDHCPVLAN;
-    }
-    $Z->{SOA}->{dhcpvlanpartial} = [] ;
-
-    if ( $S->{'console'} and $S->{'console'} ne 'default' ) {
-	$Z->{SOA}->{'console'} = $S->{'console'};
-    }
-
-    # Ajout des champs NS
-    foreach $c ( sort ( keys %{ $S->{'ns'} } ) ) {
-	push( @{ $Z->{'NS'} }, $S->{'ns'}->{$c} );
-    }
-
-    # Ajout des champs MX
-    foreach $c ( sort ( keys %{ $S->{'mx'} } ) ) {
-	push( @{ $Z->{'MX'} }, $S->{'mx'}->{$c} );
-    }
-}
-
-#
-#	VOID Add_network (HASHREF $Z, HASHREF $S, STRING $net)
-#
-#	Ajoute une description de reseau a la structure de donnee $Z
-#	En entree $S contient les informations sur les reseaux de type $net
-#
-#===================================================================================
-sub Add_network {
-    my ( $Z, $S, $net ) = @_;
-
-    my $N = {};
-
-    # Verification des declarations
-    if ( !defined( $S->{'network'} ) ) {
-	Abort( $ERR_SYNTAX,
-	    "Adresse de reseau manquante pour le reseau " . $net );
-    }
-
-    if ( !defined( $S->{'netmask'} ) ) {
-	Abort( $ERR_SYNTAX,
-	    "Masque de reseau manquant pour le reseau " . $net );
-    }
-
-    if ( defined( $Z->{'NETWORK'}->{'BY_ADDR'}->{ $S->{'network'} } ) ) {
-	Abort( $ERR_SYNTAX,
-	          "Adresse de reseau dupliquee ("
-		. $S->{'network'}
-		. ") pour le reseau "
-		. $net . " avec le reseau "
-		. $Z->{'NETWORK'}->{'BY_ADDR'}->{ $S->{'network'} }->{'name'} );
-    }
-
-    # Calcul des adresses, netmasks et broadcasts
-    $N->{'name'}      = $net;
-    $N->{'network'}   = $S->{'network'};
-    $N->{'netmask'}   = $S->{'netmask'};
-    $N->{'broadcast'} = Broadcast( $N->{'network'}, $N->{'netmask'} );
-    $N->{'prefix'}    = netmask2prefix( $S->{'netmask'} );
-    $N->{'mtu'}       = $S->{'mtu'};
-    $N->{'tag'}       = $S->{'tag'};
-    $N->{'media'}     = $S->{'media'};
-    $N->{'comment'}   = $S->{'comment'}
-	|| "Network $net <no comment specified>";
-    $N->{'scope'}     = $S->{'scope'} if ( defined $S->{'scope'} );
-
-    # Insertion dans la structure principale
-    $Z->{'NETWORK'}->{'BY_ADDR'}->{ $N->{'network'} } = $N;
-    $Z->{'NETWORK'}->{'BY_NAME'}->{ $N->{'name'} }    = $N;
-}
-
-#
-#	STRING Host_class (STRING $host)
-#
-#	Retourne la classe de serveur a laquelle appartient le serveur $h
-#
-#================================================================================
-sub Host_class {
-    my ( $h, $Z ) = @_;
-
-# !!!!!! Attention ne marchera pas si la classe se termine par de chiffres !!!!
-# Gros fix qui tache
-    if ( defined $Z->{'SERVERS'}->{'BY_NAME'}->{$h} ) {
-	return ($h);
-    }
-
-    # Gros fix qui tache encore plus...
-    $h =~ s/(\d)[a-z]+$/$1/;
-    if ( defined $Z->{'SERVERS'}->{'BY_NAME'}->{$h} ) {
-	return ($h);
-    }
-
-    $h =~ s/\d+$//;
-    return ($h);
-}
-
-#
-#	STRING Broadcast (STRING $a, STRING $s)
-#
-#	Retourne l'adresse de broadcast correspondant
-#	au reseau d'adresse $a et au netmask $n
-#
-#==================================================================
-sub Broadcast {
-    my ( $a, $n ) = @_;
-
-    my $i;
-
-    my (@A) = split( /\./, $a );
-    my (@N) = split( /\./, $n );
-
-    foreach $i ( 0 .. 3 ) {
-	$A[$i] += 0;
-	$N[$i] += 0;
-	$A[$i] = $A[$i] + ( ( ~( $N[$i] ) ) & 255 );
-    }
-    return join( '.', @A );
-
-}
-
-#
-#	STRING Address (STRING $b, STRING $o)
-#
-#	Retourne l'adresse correspondant
-#	a la base $b et a l'offset $o
-#	ex: $b=192.168.22.0 $o=102 => 192.168.22.102
-#
-#============================================================
-#sub Address {
-#    my ( $b, $o ) = @_;
-#
-#    ## Cette fonction ne fonctionne que pour les /24, a refaire si autre !!
-#
-#    $b =~ s/[^\.]+$//;
-#    return ( $b . $o );
-#}
-
-sub Address {
-    my ( $b, $o, $n ) = @_;
-
-    my @b = split( '\.', $b );
-    my @o = split( '\.', $o );
-    my @r;
-
-    while ( $#o < $#b ) {
-	unshift @o, 0;
-    }
-
-    while ( $#o > 0 && $o[0] == 0 ) {
-	push @r, shift @b;
-	shift @o;
-    }
-
-    while ( $#o >= 0 ) {
-	push @r, $o[0];
-	shift @b;
-	shift @o;
-    }
-
-    $r[3] += $n;
-
-    my $i = 3;
-    my $c = 0;
-    while ( $i >= 0 ) {
-	$r[$i] += $c;
-	$c = $r[$i] / 256;
-	$r[$i] %= 256;
-	$i--;
-    }
-
-    return ( join( '.', @r ) );
-}
-
-
-sub Mk_zoneheader {
-    my ( $fic_zone, $Z ) = @_;
-    my $m;
-    my $n;
-
-    # Ouverture du fichier de destination
-    open( FIC_ZONE, "> " . $fic_zone )
-	|| Abort( $ERR_OPEN, "Impossible d'ouvrir " . $fic_zone );
-    my $old_STDOUT = select(FIC_ZONE);
-
-    ### Zone
-    print ";;\n";
-    print ";; Fichier de configuration BIND\n";
-    print ";;\n";
-    print ";; ", $Z->{'SOA'}->{'comment'}, "\n";
-    print
-	";;============================================================================\n\n";
-    print "\n";
-    printf "\$TTL %s\n", $Z->{'SOA'}->{'ttl'};
-    printf "%-29s IN SOA\t%s %s (\n", '@', $Z->{'SOA'}->{'soa'},
-	$Z->{'SOA'}->{'mail'};
-    printf "%-30s%s\n",   '', $Z->{'SOA'}->{'serial'};
-    printf "%-30s%s\n",   '', $Z->{'SOA'}->{'refresh'};
-    printf "%-30s%s\n",   '', $Z->{'SOA'}->{'retry'};
-    printf "%-30s%s\n",   '', $Z->{'SOA'}->{'expire'};
-    printf "%-30s%s\n",   '', $Z->{'SOA'}->{'negttl'};
-    printf "%-30s%s\n\n", '', ')';
-
-    foreach $n ( @{ $Z->{'NS'} } ) {
-	printf "%-29s IN NS\t%s\n", '', $n;
-    }
-    print "\n";
-
-    foreach $m ( @{ $Z->{'MX'} } ) {
-	printf "%-29s IN MX\t%s\n", '', $m;
-    }
-    print "\n";
-
-    $| = 1;
-    select($old_STDOUT);
-    close(FIC_ZONE);
-}
-
-#
-#	VOID Mk_zone (STRING $fic_zone, HASHREF $Z)
-#
-#	Construit un le fichier $fic_zone pour la zone DNS decrite par la structure $Z
-#
-#==============================================================================================
-sub Mk_zone {
-    my ( $fic_zone, $Z ) = @_;
-
-    Mk_zoneheader( $fic_zone, $Z );
-
-    # Ouverture du fichier de destination
-    open( FIC_ZONE, ">> " . $fic_zone )
-	|| Abort( $ERR_OPEN, "Impossible d'ouvrir " . $fic_zone );
-    my $old_STDOUT = select(FIC_ZONE);
-
-    my $s;
-    my $n;
-    my $m;
-    my $j;
-
-    ### Reseaux
-    print "\n\n;;\n";
-    print ";; Networks\n";
-    print
-	";;============================================================================\n\n";
-
-    foreach $n ( sort ( keys %{ $Z->{'NETWORK'}->{'BY_ADDR'} } ) ) {
-	my $N = $Z->{'NETWORK'}->{'BY_ADDR'}->{$n};
-	print "; ", $N->{'comment'}, "\n";
-	print
-	    ";----------------------------------------------------------------------------\n";
-	printf(
-	    "%-29s IN A\t%s\n",
-	    "network." . $N->{'name'},
-	    $N->{'network'}
-	);
-	printf(
-	    "%-29s IN A\t%s\n",
-	    "netmask." . $N->{'name'},
-	    $N->{'netmask'}
-	);
-	printf( "%-29s IN A\t%s\n", "prefix." . $N->{'name'},
-	    $N->{'prefix'} );
-	printf(
-	    "%-29s IN A\t%s\n",
-	    "broadcast." . $N->{'name'},
-	    $N->{'broadcast'}
-	);
-	print "\n";
-    }
-
-    ### Servers
-    print "\n\n;;\n";
-    print ";; Servers\n";
-    print
-	";;============================================================================\n\n";
-
-    foreach $s ( sort ( keys %{ $Z->{'SERVERS'}->{'BY_ADDR'} } ) ) {
-    	foreach my $host ( @{$Z->{'SERVERS'}->{'BY_ADDR'}->{$s}} ) {
-	    print "; ",         $host->{'comment'}, "\n";
-	    print "; number: ", $host->{'number'},  "\n";
-	    print "; nodes:  ", $host->{'nodes'},   "\n" if ( defined( $host->{'nodes'} ) && $host->{'nodes'} > 1 );
-	    print ";----------------------------------------------------------------------------\n";
-
-	    foreach $m ( sort ( keys %{ $host->{'SRVLIST'} } ) ) {
-		my $M = $host->{'SRVLIST'}->{$m};
-		my $nam;
-
-		foreach $nam ( sort ( keys %{ $M->{'zone'} } ) ) {
-		    printf ( "%-29s IN %s\t%s\n", $nam, $M->{'zone'}->{$nam}->{'TYPE'}, $M->{'zone'}->{$nam}->{'FIELD'} );
-		}
-		print "\n";
-	    }
-    	}
-	
-    }
-
-    ### Alias
-    print "\n\n;;\n";
-    print ";; Alias (round robin)\n";
-    print
-	";;============================================================================\n\n";
-
-    foreach $j ( sort ( keys %{ $Z->{'ALIAS'} } ) ) {
-	my $i;
-
-	foreach $i ( sort ( @{ $Z->{'ALIAS'}->{$j} } ) ) {
-	    printf( "%-29s IN A\t%s\n", $j, $i );
-	}
-    }
-
-    # Fermeture du fichier de destination
-    $| = 1;
-    select($old_STDOUT);
-    close(FIC_ZONE);
-
-}
-
-#
-#	VOID Mk_interfaces (STRING $host, STRING $fic_iface, HASHREF $Z)
-#
-#	Construit le fichier de declaration d'interfaces $fic_iface pour la
-#	machine $host a partir des informations contenues dans la structure $Z
-#
-#======================================================================================
-sub Mk_interfaces {
-    my ( $host, $fic_iface, $Z ) = @_;
-
-    # Calcul de la classe d'appartenance du serveur
-    my $hostclass = Host_class( $host, $Z );
-    my $resolve = 0;
-
-    # Recherche des informations dans la base de configuration
-    my $N = $Z->{'SERVERS'}->{'BY_NAME'}->{$hostclass};
-    if ( !ref($N) ) {
-	Abort( $ERR_SYNTAX,
-	          "La classe de serveurs "
-		. $hostclass
-		. " n'existe pas dans la configuration" );
-    }
-    my $M = $N->{'SRVLIST'}->{$host};
-
-    if ( !ref($M) ) {
-	Abort( $ERR_SYNTAX,
-	    "La machine " . $host . " n'existe pas dans la configuration" );
-    }
-
-    # Ouverture du fichier de destination
-    open( FIC_IFACE, "> " . $fic_iface )
-	|| Abort( $ERR_OPEN, "Impossible d'ouvrir " . $fic_iface );
-    my $old_STDOUT = select(FIC_IFACE);
-
-    # Ajout de l'interface de bouclage
-    print "auto lo\n";
-    print "iface lo inet loopback\n";
-
-    # Ajout de l'interface automatique si presente
-    if ( defined( $M->{'ifup'}->{'dhcp'} ) ) {
-	print "auto ",  $M->{'ifup'}->{'dhcp'}, "\n";
-	print "iface ", $M->{'ifup'}->{'dhcp'}, " inet dhcp\n";
-	Mk_routes( $M, $Z, $M->{'ifup'}->{'dhcp'} );
-    }
-    else {
-	$resolve = 1;
-    }
-
-    # Ajout des interfaces statiques
-    #foreach $nam ( sort { $M->{ifup}->{$a} cmp $M->{ifup}->{$b} }
-    foreach my $nam (
-	sort { cmpif( $M->{'ifup'}->{$a}, $M->{'ifup'}->{$b} ) }
-	keys %{ $M->{'ifup'} }
-	)
-    {
-	next if ( $nam eq 'dhcp' );
-
-	my $iface = $M->{'ifup'}->{$nam};
-
-	print "\nauto $iface\n";
-	print "iface $iface inet static\n";
-
-	my $net = $nam;
-	$net =~ s/^[^\.]+\.//;
-	my $NET = $Z->{'NETWORK'}->{'BY_NAME'}->{$net};
-
-	if ( $M->{'bonding'}->{$iface} ) {
-	    print
-		"\tslaves          ",
-		join(' ', @{ $M->{'bonding'}->{$iface} }),
-		"\n" ;
-	}
-
-	if ($resolve) {
-	    print "\taddress         ", $M->{'zone'}->{$nam}->{'FIELD'}, "\n";
-	    print "\tnetmask         ", $NET->{'netmask'},   "\n";
-	    print "\tbroadcast       ", $NET->{'broadcast'}, "\n";
-	    print "\tnetwork         ", $NET->{'network'},   "\n";
-	}
-	else {
-	    print "\taddress         " 
-		. $nam . '.'
-		. $Z->{'SOA'}->{'name'} . "\n";
-	    print "\tnetmask         netmask." 
-		. $net . '.'
-		. $Z->{'SOA'}->{'name'} . "\n";
-	    print "\tbroadcast       broadcast." 
-		. $net . '.'
-		. $Z->{'SOA'}->{'name'} . "\n";
-	    print "\tnetwork         network." 
-		. $net . '.'
-		. $Z->{'SOA'}->{'name'} . "\n";
-	}
-
-	my $defaultmtu = ($PFTOOLS_VARS->{'UML'}) ? 1496 : 1500;
-	if ( $iface =~ m/^([^:.]+)\.(\d+)(:\d+)?$/ ) {
-	    my $ifname = $1;
-	    my $iftag  = $2;
-
-	    print "\tvlan_raw_device $ifname\n";
-	    $defaultmtu = 1496;
-
-	    if ( defined $NET->{'tag'} and $NET->{'tag'} != $iftag ) {
-		Warn( $ERR_SYNTAX,
-		      "Les tags de $iface et de $net different ($iftag != $NET->{'tag'})!" );
-	    }
-	}
-
-	if ( defined $NET->{'mtu'} ) {
-	    $defaultmtu = $NET->{'mtu'};
-	}
-
-	print "\tup              ifconfig $iface mtu ",
-	    defined $M->{'mtu'}->{$iface} ?  $M->{'mtu'}->{$iface} : $defaultmtu,
-	    " ",
-	    defined $M->{'noarp'}->{$iface} ? "-arp" : "arp",
-	    "\n";
-
-	my $defaultmedia = "autoneg on";
-	if ( defined $NET->{'media'} ) {
-	    $defaultmedia = $NET->{'media'};
-	}
-	if ( defined $M->{'media'}->{$iface} ) {
-	    $defaultmedia = $M->{'media'}->{$iface};
-	}
-
-	my @defaultmedia = split ' ', $defaultmedia;
-	my $mediaerror = 0;
-	while ( @defaultmedia ) {
-	    my $mediaopt = shift @defaultmedia;
-	    my $mediaval = shift @defaultmedia;
-
-	    unless ( defined $mediaopt and defined $mediaval ) {
-		Warn( $ERR_SYNTAX, "Media syntax error: $defaultmedia" );
-		$mediaerror = 1;
-		next;
-	    }
-
-	    if ( $mediaopt eq 'speed' ) {
-		unless ( $mediaval =~ m/^\d+$/ ) {
-		    Warn( $ERR_SYNTAX, "Media syntax error: $defaultmedia" );
-		    $mediaerror = 1;
-		    next;
-		}
-	    }
-	    elsif ( $mediaopt eq 'duplex' ) {
-		unless ( $mediaval =~ m/^(half|full)$/ ) {
-		    Warn( $ERR_SYNTAX, "Media syntax error: $defaultmedia" );
-		    $mediaerror = 1;
-		    next;
-		}
-	    }
-	    elsif ( $mediaopt eq 'autoneg' ) {
-		unless ( $mediaval =~ m/^(on|off)$/ ) {
-		    Warn( $ERR_SYNTAX, "Media syntax error: $defaultmedia" );
-		    $mediaerror = 1;
-		    next;
-		}
-	    }
-	    else {
-		Warn( $ERR_SYNTAX, "Media syntax error: $defaultmedia" );
-		$mediaerror = 1;
-		next;
-	    }
-	}
-
-	if ( !$mediaerror ) {
-	    my $ifname = $iface;
-	    my $iftag;
-	    if ( $ifname =~ m/^([^:.]+)\.(\d+)(:\d+)?$/ ) {
-		$ifname = $1;
-		$iftag = $2;
-	    }
-	    unless ( $M->{'bonding'}->{$ifname} || $iftag ) {
-		print "\tup              ethtool -s $ifname $defaultmedia || true\n";
-	    }
-	}
-
-	Mk_routes( $M, $Z, $iface );
-
-    }
-    print "\n";
-
-    # Fermeture du fichier de destination
-    close(FIC_IFACE);
-    select($old_STDOUT);
-}
-
-#
-#	STRING/ARRAY Resolv (STRING $host, HASHREF $Z)
-#
-#	Resout un nom
-#
-#======================================================================================
-sub Resolv {
-    my ( $host, $Z ) = @_;
-
-    my $i;
-    my $j;
-
-    my $host2 = $host ;
-    $host2 =~ s/\.$Z->{SOA}->{name}// ;
-    my ( $hostshort, $hostvlan ) = split ( /\./, $host2 ) ;
-    if ( ! defined ) { $hostvlan = "" ; }
-    my $M = Get_Host_Props ( $Z, $host2 ) ;
-
-    if ( defined( $M->{'zone'}->{$host2}->{'FIELD'} ) ) {
-	if ( $M->{'zone'}->{$host2}->{'TYPE'} eq "CNAME" ) {
-	    return (
-		Resolv(
-		    $M->{'zone'}->{$host2}->{'FIELD'} . '.'
-			. $Z->{'SOA'}->{'name'},
-		    $Z
-		)
-	    );
-	}
-	else {
-	    return ( $M->{'zone'}->{$host2}->{'FIELD'} );
-	}
-    }
-
-    foreach $i ( keys %{ $Z->{'SERVERS'}->{'BY_NAME'} } ) {
-	my $N2 = $Z->{'SERVERS'}->{'BY_NAME'}->{$i};
-	foreach $j ( keys %{ $N2->{'SRVLIST'} } ) {
-	    my $M2 = $N2->{'SRVLIST'}->{$j};
-	    if ( defined( $M2->{'zone'}->{$host2}->{'FIELD'} ) ) {
-		if ( $M2->{'zone'}->{$host2}->{'TYPE'} eq "CNAME" ) {
-		    return (
-			Resolv(
-			    $M2->{'zone'}->{$host2}->{'FIELD'} . '.'
-				. $Z->{'SOA'}->{'name'},
-			    $Z
-			)
-		    );
-		}
-		else {
-		    return ( $M2->{'zone'}->{$host2}->{'FIELD'} );
-		}
-	    }
-	}
-    }
-
-    if ( defined( $Z->{'ALIAS'}->{$host2} ) ) {
-	if (wantarray) {
-	    return ( @{ $Z->{'ALIAS'}->{$host2} } );
-	}
-	else {
-	    return ( $Z->{'ALIAS'}->{$host2}
-		    [ int( rand( $#{ $Z->{'ALIAS'}->{$host2} } + 1 ) ) ] );
-	}
-    }
-
-    if (   defined($hostvlan)
-	&& $hostvlan ne ""
-	&& defined( $Z->{'NETWORK'}->{'BY_NAME'}->{$hostvlan} ) )
-    {
-	return ( $Z->{'NETWORK'}->{'BY_NAME'}->{$hostvlan}->{$hostshort} );
-    }
-
-    return undef;
-}
-
-#
-#	VOID Mk_routes (HASHREF $M, HASHREF $Z, STRING $iface)
-#
-#	Calcule les commandes routes du fichier interface
-#
-#======================================================================================
-sub Mk_routes {
-    my ( $M, $Z, $iface ) = @_;
-
-    my $r;
-    foreach $r ( sort ( keys %{ $M->{'route'}->{$iface} } ) ) {
-	my ( $dst, @gw ) = split( /\s+/, $M->{'route'}->{$iface}->{$r} );
-	my $gw;
-	my @gw2;
-	foreach $gw (@gw) {
-	    my @resolved = Resolv( $gw, $Z );
-	    if ( $#resolved >= 0 && defined $resolved[0] ) {
-		my $resolved;
-		foreach $resolved (@resolved) {
-		    push @gw2, $resolved;
-		}
-	    }
-	    else {
-		push @gw2, $gw;
-	    }
-	}
-	if ( $Z->{'NETWORK'}->{'BY_NAME'}->{$dst} ) {
-	    if ( $#gw2 >= 2 ) {
-		print "\tup              ip route add ";
-
-		print $Z->{'NETWORK'}->{'BY_NAME'}->{$dst}->{'network'};
-		print "/";
-		print netmask2prefix(
-		    $Z->{'NETWORK'}->{'BY_NAME'}->{$dst}->{'netmask'} );
-
-		print " scope global";
-
-		print " ", join( ' nexthop via ', @gw2 );
-
-		print " dev " . $iface;
-
-		print "\n";
-	    }
-	    else {
-		print "\tup              route add -net ";
-
-		#print "network.".$dst.".".$Z->{SOA}->{name};
-		print $Z->{'NETWORK'}->{'BY_NAME'}->{$dst}->{'network'};
-		print " netmask ";
-
-		#print "netmask.".$dst.".".$Z->{SOA}->{name};
-		print $Z->{'NETWORK'}->{'BY_NAME'}->{$dst}->{'netmask'};
-
-		print " gateway " . $gw2[0] if ( defined $gw2[0] );
-
-		print " dev " . $iface;
-
-		print "\n";
-	    }
-	}
-	elsif ( $dst eq 'default' ) {
-	    if ( $#gw >= 2 ) {
-		print "\tup              ip route add ";
-
-		print "default";
-
-		print " scope global";
-
-		print " ", join( ' nexthop via ', @gw2 );
-
-		print " dev " . $iface;
-
-		print "\n";
-	    }
-	    else {
-		print "\tgateway " . $gw2[0] if ( defined $gw2[0] );
-
-		#print " dev " . $iface;
-
-		print "\n";
-	    }
-	}
-	else {
-	    if ( $#gw >= 2 ) {
-		print "\tup              ip route add ";
-
-		my $dst2 = Resolv( $dst, $Z );
-		if ( !defined $dst2 ) {
-		    $dst2 = $dst;
-		}
-
-		print $dst2;
-
-		print " scope global";
-
-		print " ", join( ' nexthop via ', @gw2 );
-
-		print " dev " . $iface;
-
-		print "\n";
-	    }
-	    else {
-		print "\tup              route add -host ";
-
-		my $dst2 = Resolv( $dst, $Z );
-		if ( !defined $dst2 ) {
-		    $dst2 = $dst;
-		}
-		print $dst2;
-		print " gateway  " . $gw2[0] if ( defined $gw2[0] );
-
-		print " dev " . $iface;
-
-		print "\n";
-	    }
-	}
-    }
-
-    foreach $r ( sort ( keys %{ $M->{'delroute'}->{$iface} } ) ) {
-	my ($dst) = split( /\s+/, $M->{'route'}->{$iface}->{$r} );
-
-	if ( $Z->{'NETWORK'}->{'BY_NAME'}->{$dst} ) {
-	    print "\tup              ip route del ";
-
-	    print $Z->{'NETWORK'}->{'BY_NAME'}->{$dst}->{network};
-	    print "/";
-	    print netmask2prefix(
-		$Z->{'NETWORK'}->{'BY_NAME'}->{$dst}->{'netmask'} );
-
-	    print " scope global";
-
-	    print " dev " . $iface;
-
-	    print "\n";
-	}
-	elsif ( $dst eq 'default' ) {
-	    print "\tup              ip route del ";
-
-	    print "default";
-
-	    print " scope global";
-
-	    print " dev " . $iface;
-
-	    print "\n";
-	}
-	else {
-	    print "\tup              ip route del ";
-
-	    my $dst2 = Resolv( $dst, $Z );
-	    if ( !defined $dst2 ) {
-		$dst2 = $dst;
-	    }
-
-	    print $dst2;
-
-	    print " scope global";
-
-	    print " dev " . $iface;
-
-	    print "\n";
-	}
-    }
-}
-
-if ( `grep -e '^host[ 	]*:' /proc/cpuinfo 2>/dev/null` ne "" ) {
-    $PFTOOLS_VARS->{'UML'} = 1;
-}
-
-if ( !$PFTOOLS_VARS->{'UML'}
-    && `LANG=C LC_ALL=C /sbin/ifconfig eth0 2>>/dev/null | grep HWaddr | awk '{print \$5}'`
-    =~ "^00:50:56:" )
-{
-    $PFTOOLS_VARS->{'VMWARE'} = 1;
-}
-
-if ( !$PFTOOLS_VARS->{'UML'} && `/sbin/ifconfig eth3 2>>/dev/null` eq "" ) {
-    $NOETH3 = 1;
-}
-
-#
-# Proto		: HASHREF Parse_routing_table ( HASHREF $ref_network )
-# Input		: $ref_network is an hashref obtained by an Init_lib_net on private-network file
-# Output	: return an hashref with the parsed routing table inside which is equivalent to 
-#	$ref_network->{'SERVERS'}->{'BY_NAME'}->{<HOSTTYPE>}->{'SRVLIST'}->{<HOSTNAME>}->{'route'}
-#	UNDEF if an error occured
-sub Parse_routing_table ($) {
-	my ( $ref_network ) = @_ ;
-
-	my $parsed_rt = {} ;
-	
-	unless ( open ( RT, "/sbin/ip route |" ) ) {
-		Warn ( $ERR_OPEN, "Unable to parse local routing table on host" ) ;
-		return undef ;
-	}
-	while ( <RT> ) {
-		chomp ;
-		next if ( /proto kernel/ ) ;
-		m/^([\S]+)\s*(via\s*([\S]+))?\s*(dev\s*([\S]+)).*$/ ;
-		my ( $dest, $gw, $dev ) = ( $1, $3, $5 ) ;
-		$dest =~ s/^([^\/]+)\/[\d]+$/$1/ ;
-		# Convert network into his configuration name
-		$dest = $ref_network->{'NETWORK'}->{'BY_ADDR'}->{$dest}->{'name'} if ( $dest ne 'default' ) ;
-		if ( ! defined $parsed_rt->{$dev} ) {
-			$parsed_rt->{$dev}->{'route1'} = ( defined $gw ) ? $dest." ".$gw : $dest ;
-		}
-		else {
-			my $card = scalar ( keys %{$parsed_rt->{$dev}} ) + 1 ;
-			$parsed_rt->{$dev}->{'route'.$card} = ( defined $gw ) ? $dest." ".$gw : $dest ;
-		}
-	}
-	close ( RT ) ;
-	return $parsed_rt
-}
-
-sub Cmp_routing_table ($$$) {
-	my ( $host, $local_rt, $ref_network ) = @_ ;
-
-	my $result = {} ;
-	my $srv_props	= Get_Host_Props ( $ref_network, $host ) ;
-	if ( ! defined $srv_props ) {
-		Warn ( $ERR_OPEN, "Unable to retrieve ".$host." properties in CVS configuration" ) ;
-		return undef ;
-	}
-	my $cvs_rt	= $srv_props->{'route'} ;
-	# Check for unknown or manual defined routes
-	foreach my $iface ( keys %{$local_rt} ) {
-		foreach my $rt ( keys %{$local_rt->{$iface}} ) {
-			my $exist = 0 ;
-			foreach my $r ( keys %{$cvs_rt->{$iface}} ) {
-				my $route = $cvs_rt->{$iface}->{$r} ;
-				my ( $dst, $via ) = split ( /\s+/, $route ) ;
-				if ( defined $via ) {
-					$via = Resolv ( $via, $ref_network ) ;
-					$route = $dst." ".$via ;
-				}
-				$exist = 1 if ( $route eq $local_rt->{$iface}->{$rt} ) ;
-			}
-			if ( ! $exist ) {
-				$result->{'err'}++ ;
-				push ( @{$result->{'unknown'}}, "Route ".$local_rt->{$iface}->{$rt}." not defined in CVS configuration\n" ) ;
-			}
-		}
-	}
-	# Check for deleted routes
-	foreach my $iface ( keys %{$cvs_rt} ) {
-		foreach my $rc ( keys %{$cvs_rt->{$iface}} ) {
-			my $exist = 0 ;
-			my $route = $cvs_rt->{$iface}->{$rc} ;
-			my ( $dst, $via ) = split ( /\s+/, $route ) ;
-			if ( defined $via ) {
-				$via = Resolv ( $via, $ref_network ) ;
-				$route = $dst." ".$via ;
-			}
-			foreach my $r ( keys %{$local_rt->{$iface}} ) {
-				$exist = 1 if ( $route eq $local_rt->{$iface}->{$r} ) ;
-				last if ( $exist ) ;
-			}
-			if ( ! $exist ) {
-				$result->{'err'}++ ;
-				push ( @{$result->{'undef'}}, "Route ".$cvs_rt->{$iface}->{$rc}." not defined in local routing table\n" ) ;
-			}
-		}
-	}
-	return $result ;
+    return $resolved;
 }
 
 1;
-

Modified: trunk/lib/PFTools/Packages.pm
URL: http://svn.debian.org/wsvn/pf-tools/trunk/lib/PFTools/Packages.pm?rev=902&op=diff
==============================================================================
--- trunk/lib/PFTools/Packages.pm (original)
+++ trunk/lib/PFTools/Packages.pm Wed Sep  8 19:28:28 2010
@@ -22,244 +22,320 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Exporter;
 
+use PFTools::Logger;
+
 our @ISA = ('Exporter');
 
 our @EXPORT = qw(
-	Cmp_pkg_version
-	Get_pkg_depends
-	Get_pkg_policy
-	Get_pkg_status
-	Install_pkg
-	Purge_pkg
-	Update_pkg_repository
+    Cmp_pkg_version
+    Get_pkg_depends
+    Get_pkg_policy
+    Get_pkg_status
+    Install_pkg
+    Purge_pkg
+    Update_pkg_repository
 );
 
 our @EXPORT_OK = qw();
 
-use PFTools::Conf;
-
-my $PKG_CMD = {} ;
-$PKG_CMD->{'deb'}->{'status'}	= 'LANG=C LC_ALL=C /usr/bin/dpkg -s' ;
-$PKG_CMD->{'deb'}->{'update'}	= 'LANG=C LC_ALL=C /usr/bin/apt-get -y --force-yes update' ;
-$PKG_CMD->{'deb'}->{'depends'}	= 'LANG=C LC_ALL=C /usr/bin/apt-cache show' ;
-$PKG_CMD->{'deb'}->{'install'}	= 'LANG=C LC_ALL=C /usr/bin/apt-get -y --force-yes install' ;
-$PKG_CMD->{'deb'}->{'purge'}	= 'LANG=C LC_ALL=C /usr/bin/dpkg --purge' ;
-$PKG_CMD->{'deb'}->{'policy'}	= 'LANG=C LC_ALL=C /usr/bin/apt-cache policy' ;
-$PKG_CMD->{'deb'}->{'compare'}	= 'LANG=C LC_ALL=C /usr/bin/dpkg --compare-versions' ;
-$PKG_CMD->{'rpm'}		= 'TODO' ;
-
-my $VERBOSE = 0 ;
+my $PKG_CMD = {};
+$PKG_CMD->{'deb'}->{'status'} = 'LANG=C LC_ALL=C /usr/bin/dpkg -s';
+$PKG_CMD->{'deb'}->{'update'}
+    = 'LANG=C LC_ALL=C /usr/bin/apt-get -y --force-yes update';
+$PKG_CMD->{'deb'}->{'depends'} = 'LANG=C LC_ALL=C /usr/bin/apt-cache show';
+$PKG_CMD->{'deb'}->{'install'}
+    = 'LANG=C LC_ALL=C /usr/bin/apt-get -y --force-yes install';
+$PKG_CMD->{'deb'}->{'purge'}  = 'LANG=C LC_ALL=C /usr/bin/dpkg --purge';
+$PKG_CMD->{'deb'}->{'policy'} = 'LANG=C LC_ALL=C /usr/bin/apt-cache policy';
+$PKG_CMD->{'deb'}->{'compare'}
+    = 'LANG=C LC_ALL=C /usr/bin/dpkg --compare-versions';
+$PKG_CMD->{'rpm'} = 'TODO';
+
+my $VERBOSE = 0;
 
 sub Get_pkg_status ($$) {
-	my ( $pkg_type, $pkg_name ) = @_ ;
-
-	my $result = {} ;
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'deb' ) {
-		unless ( open ( PKG, $PKG_CMD->{$pkg_type}->{'status'}.' '.$pkg_name.' 2>/dev/null |' ) ) {
-			Warn ( $ERR_OPEN, "Unable to retrieve status for package ".$pkg_name ) if ( $VERBOSE );
-			return undef ;
-		}
-		while ( <PKG>) {
-			if ( /^Status:\s+/ ) {
-				if ( !/^Status:\s+install\s+ok\s+installed\s*$/ ) {
-					$result->{'installed'} = 0 ;
-				}
-				else {
-					$result->{'installed'} = 1 ;
-				}
-			}
-			if ( /^Version:\s+(.+)\s*$/ ) {
-				$result->{'version'} = $1 ;
-				last ;
-			}
-		}
-		close ( PKG ) ;
-	}
-	return $result ;
+    my ( $pkg_type, $pkg_name ) = @_;
+
+    my $result = {};
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'deb' ) {
+        unless (
+            open( PKG,
+                      $PKG_CMD->{$pkg_type}->{'status'} . ' '
+                    . $pkg_name
+                    . ' 2>/dev/null |'
+            )
+            )
+        {
+            Warn( $CODE->{'OPEN'},
+                "Unable to retrieve status for package " . $pkg_name )
+                if ($VERBOSE);
+            return undef;
+        }
+        while (<PKG>) {
+            if (/^Status:\s+/) {
+                if ( !/^Status:\s+install\s+ok\s+installed\s*$/ ) {
+                    $result->{'installed'} = 0;
+                }
+                else {
+                    $result->{'installed'} = 1;
+                }
+            }
+            if (/^Version:\s+(.+)\s*$/) {
+                $result->{'version'} = $1;
+                last;
+            }
+        }
+        close(PKG);
+    }
+    return $result;
 }
 
 sub Update_pkg_repository ($) {
-	my ( $pkg_type ) = @_ ;
-
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return 0 ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return 0 ;
-	}
-	elsif ( $pkg_type eq 'deb' ) {
-		if ( deferredlogsystem( $PKG_CMD->{$pkg_type}->{'update'} ) ) {
-			Warn( $ERR_OPEN, "Updating repository failed !" ) if ( $VERBOSE );
-			return 0 ;
-		}
-	}
-	return 1 ;
+    my ($pkg_type) = @_;
+
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return 0;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return 0;
+    }
+    elsif ( $pkg_type eq 'deb' ) {
+        if ( deferredlogsystem( $PKG_CMD->{$pkg_type}->{'update'} ) ) {
+            Warn( $CODE->{'OPEN'}, "Updating repository failed !" )
+                if ($VERBOSE);
+            return 0;
+        }
+    }
+    return 1;
 }
 
 sub Purge_pkg ($$) {
-	my ( $pkg_type, $pkg_name ) = @_ ;
-
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return 0 ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return 0 ;
-	}
-	elsif ( $pkg_type eq 'deb' ) {
-		if ( deferredlogsystem ( $PKG_CMD->{$pkg_type}->{'purge'}." '".$pkg_name."'" ) ) {
-			Warn( $ERR_OPEN, "Unable to purge ".$pkg_name ) if ( $VERBOSE );
-			return 0 ;
-		}
-	}
-	return 1 ;
+    my ( $pkg_type, $pkg_name ) = @_;
+
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return 0;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return 0;
+    }
+    elsif ( $pkg_type eq 'deb' ) {
+        if (deferredlogsystem(
+                $PKG_CMD->{$pkg_type}->{'purge'} . " '" . $pkg_name . "'"
+            )
+            )
+        {
+            Warn( $CODE->{'OPEN'}, "Unable to purge " . $pkg_name )
+                if ($VERBOSE);
+            return 0;
+        }
+    }
+    return 1;
 }
 
 sub Get_pkg_depends ($$) {
-	my ( $pkg_type, $pkg_name ) = @_ ;
-	my $dep_list ;
-
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'deb' ) {
-		unless ( open( APTDEP, $PKG_CMD->{$pkg_type}->{'depends'}.' '.$pkg_name.' 2>/dev/null |' ) ) {
-			Warn ( $ERR_OPEN, "Unable to get depends for package ".$pkg_name ) if ( $VERBOSE );
-			return undef ;
-		}
-		while (<APTDEP>) {
-			if (m/^Depends: (.*)$/) {
-				foreach my $pkg ( split ( /,/, $1 ) ) {
-					if ( $pkg =~ /|/ ) {
-						$pkg =~ s/\([^\)]+\)//g ;
-						$pkg =~ s/\s+//g ;
-						foreach my $possible_pkg ( split ( /\|/, $pkg ) ) {
-							if ( $possible_pkg ne $pkg_name ) {
-								$dep_list .= " ".$possible_pkg ;
-							}
-						}
-					}
-					elsif ( $pkg ne $pkg_name ) {
-						$dep_list .= " ".$pkg ;
-					}
-				}
-			}
-		}
-		close ( APTDEP ) ;
-	}
-	$dep_list =~ s/^\s*// ;
-	return $dep_list ;
+    my ( $pkg_type, $pkg_name ) = @_;
+    my $dep_list;
+
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'deb' ) {
+        unless (
+            open( APTDEP,
+                      $PKG_CMD->{$pkg_type}->{'depends'} . ' '
+                    . $pkg_name
+                    . ' 2>/dev/null |'
+            )
+            )
+        {
+            Warn( $CODE->{'OPEN'},
+                "Unable to get depends for package " . $pkg_name )
+                if ($VERBOSE);
+            return undef;
+        }
+        while (<APTDEP>) {
+            if (m/^Depends: (.*)$/) {
+                foreach my $pkg ( split( /,/, $1 ) ) {
+                    if ( $pkg =~ /|/ ) {
+                        $pkg =~ s/\([^\)]+\)//g;
+                        $pkg =~ s/\s+//g;
+                        foreach my $possible_pkg ( split( /\|/, $pkg ) ) {
+                            if ( $possible_pkg ne $pkg_name ) {
+                                $dep_list .= " " . $possible_pkg;
+                            }
+                        }
+                    }
+                    elsif ( $pkg ne $pkg_name ) {
+                        $dep_list .= " " . $pkg;
+                    }
+                }
+            }
+        }
+        close(APTDEP);
+    }
+    $dep_list =~ s/^\s*//;
+    return $dep_list;
 }
 
 sub Get_pkg_policy ($$$) {
-	my ( $pkg_type, $pkg_name, $version ) = @_ ;
-	my ( $installed, $available, $specified_version ) ;
-
-	$specified_version = 0 ;
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'deb' ) {
-		unless ( open( APTPOLICY, $PKG_CMD->{$pkg_type}->{'policy'}.' '.$pkg_name.' 2>/dev/null |' ) ) {
-			Warn ( $ERR_OPEN, "Unable to get policy for package ".$pkg_name ) if ( $VERBOSE );
-			return undef ;
-		}
-		while ( <APTPOLICY> ) {
-			if (m/^  Installed: (.*)$/) {
-				$installed = $1;
-				undef $installed if ( $installed eq '' || $installed eq '(none)' ) ;
-			}
-			elsif (m/^  Candidate: (.*)$/) {
-				$available = $1;
-			}
-			elsif ( defined $version && /\Q$version\E/ ) {
-				$specified_version = 1 ;
-			}
-		}
-		close(APTPOLICY);
-		return ( $installed, $available, $specified_version ) ;
-	}
+    my ( $pkg_type, $pkg_name, $version ) = @_;
+    my ( $installed, $available, $specified_version );
+
+    $specified_version = 0;
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'deb' ) {
+        unless (
+            open( APTPOLICY,
+                      $PKG_CMD->{$pkg_type}->{'policy'} . ' '
+                    . $pkg_name
+                    . ' 2>/dev/null |'
+            )
+            )
+        {
+            Warn( $CODE->{'OPEN'},
+                "Unable to get policy for package " . $pkg_name )
+                if ($VERBOSE);
+            return undef;
+        }
+        while (<APTPOLICY>) {
+            if (m/^  Installed: (.*)$/) {
+                $installed = $1;
+                undef $installed
+                    if ( $installed eq '' || $installed eq "(none)" );
+            }
+            elsif (m/^  Candidate: (.*)$/) {
+                $available = $1;
+            }
+            elsif ( defined $version && /\Q$version\E/ ) {
+                $specified_version = 1;
+            }
+        }
+        close(APTPOLICY);
+        return ( $installed, $available, $specified_version );
+    }
 }
 
 sub Cmp_pkg_version ($$$$) {
-	my ( $pkg_type, $pkg_name, $version1, $version2 ) = @_ ;
-
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return undef ;
-	}
-	else {
-		if ( $pkg_type eq 'deb' ) {
-			if ( ! deferredlogsystem ( $PKG_CMD->{$pkg_type}->{'compare'}.' '.$version1.' lt '.$version2 ) ) {
-				return -1 ;
-			}
-			elsif ( ! deferredlogsystem ( $PKG_CMD->{$pkg_type}->{'compare'}.' '.$version1.' eq '.$version2 ) ) {
-				return 0 ;
-			}
-			else {
-				return 1 ;
-			}
-		}
-	}
+    my ( $pkg_type, $pkg_name, $version1, $version2 ) = @_;
+
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return undef;
+    }
+    else {
+        if ( $pkg_type eq 'deb' ) {
+            if (!deferredlogsystem(
+                          $PKG_CMD->{$pkg_type}->{'compare'} . ' '
+                        . $version1 . ' lt '
+                        . $version2
+                )
+                )
+            {
+                return -1;
+            }
+            elsif (
+                !deferredlogsystem(
+                          $PKG_CMD->{$pkg_type}->{'compare'} . ' '
+                        . $version1 . ' eq '
+                        . $version2
+                )
+                )
+            {
+                return 0;
+            }
+            else {
+                return 1;
+            }
+        }
+    }
 }
 
 sub Install_pkg ($$;$) {
-	my ( $pkg_type, $pkg_name, $version ) = @_ ;
-
-	if ( ! defined $PKG_CMD->{$pkg_type} ) {
-		Warn ( $ERR_OPEN, "Unknown package type ".$pkg_type ) if ( $VERBOSE );
-		return undef ;
-	}
-	elsif ( $pkg_type eq 'rpm' ) {
-		#TODO
-		Warn ( $ERR_OPEN, "Need to implement the RPM handler" ) if ( $VERBOSE );
-		return undef ;
-	}
-	else {
-		if ( $pkg_type eq 'deb' ) {
-			my $install_cmd = $PKG_CMD->{$pkg_type}->{'install'}." '".$pkg_name."'" ;
-			if ( defined $version ) {
-				$install_cmd = $PKG_CMD->{$pkg_type}->{'install'}." '".$pkg_name."=".$version."'" ;
-			}
-			if ( deferredlogsystem ( $install_cmd ) ) {
-				return 0 ;
-			}
-			return 1 ;
-		}
-	}
-}
-
-1;
+    my ( $pkg_type, $pkg_name, $version ) = @_;
+
+    if ( !defined $PKG_CMD->{$pkg_type} ) {
+        Warn( $CODE->{'OPEN'}, "Unknown package type " . $pkg_type )
+            if ($VERBOSE);
+        return undef;
+    }
+    elsif ( $pkg_type eq 'rpm' ) {
+
+        #TODO
+        Warn( $CODE->{'OPEN'}, "Need to implement the RPM handler" )
+            if ($VERBOSE);
+        return undef;
+    }
+    else {
+        if ( $pkg_type eq 'deb' ) {
+            my $install_cmd
+                = $PKG_CMD->{$pkg_type}->{'install'} . " '" . $pkg_name . "'";
+            if ( defined $version ) {
+                $install_cmd
+                    = $PKG_CMD->{$pkg_type}->{'install'} . " '"
+                    . $pkg_name . "="
+                    . $version . "'";
+            }
+            if ( deferredlogsystem($install_cmd) ) {
+                return 0;
+            }
+            return 1;
+        }
+    }
+}
+
+1;

Modified: trunk/lib/PFTools/Update.pm
URL: http://svn.debian.org/wsvn/pf-tools/trunk/lib/PFTools/Update.pm?rev=902&op=diff
==============================================================================
--- trunk/lib/PFTools/Update.pm (original)
+++ trunk/lib/PFTools/Update.pm Wed Sep  8 19:28:28 2010
@@ -26,1936 +26,167 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Exporter;
+
+use PFTools::Logger;
+use PFTools::Packages;
+use PFTools::Update::Addfile;
+use PFTools::Update::Addlink;
+use PFTools::Update::Addmount;
+use PFTools::Update::Common;
+use PFTools::Update::Createfile;
+use PFTools::Update::Installpkg;
+use PFTools::Update::Mkdir;
+use PFTools::Update::Purgepkg;
+use PFTools::Update::Removedir;
+use PFTools::Update::Removefile;
 
 our @ISA = ('Exporter');
 
 our @EXPORT = qw(
-    $ERR_OPEN
-    $ERR_SYNTAX
-
-    CVS_update
-    dirname
-    Do_update
-    Get_source
+    Get_depends_for_action
+    Exec_action
+    Sort_config_sections
 );
 
 our @EXPORT_OK = qw();
 
-use PFTools::Conf;
-use PFTools::Net;
-use PFTools::Packages;
+###########################################
+# Global vars
 
-use Fcntl ':mode';
+my $STARTTIME  = time();
+my $APT_UPDATE = 1;
 
-#Librairies Debconf
-use Debconf::Db;
-use Debconf::Template;
-use Debconf::ConfModule;
+sub Get_depends_for_action ($$$$) {
+    my ( $action, $ref_section, $dest, $options ) = @_;
 
-# Error code
-our $ERR_OPEN = 1;
-our $ERR_SYNTAX = 2;
-
-$ENV{'PATH'}            = $ENV{'PATH'} . ":/usr/local/sbin:/usr/local/bin";
-$ENV{'DEBIAN_FRONTEND'} = "noninteractive";
-$ENV{'DEBIAN_PRIORITY'} = "critical";
-
-my $STARTTIME = time();
-$DEFERREDLOG = 0;
-
-# Constantes
-my $PFTOOLSCONF     = "/etc/pf-tools.conf";
-my $CVS_CHECKOUT    = "/var/lib/cvsguest";
-my $HOSTNAME        = $SUBST{'HOSTNAME'};
-my $HOSTTYPE        = $SUBST{'HOSTTYPE'};
-my $CVS_UMASK       = 0077;
-my $COMMON          = "update-common";
-my $DEFAULT_MODE    = '0640';
-my $DEFAULT_DIRMODE = '0750';
-my $DEFAULT_OWNER   = 'root';
-my $DEFAULT_GROUP   = 'root';
-my $DEFAULT_FSTYPE  = 'nfs';
-my $DEFAULT_OPTIONS = 'defaults,noexec,nosuid,nodev,hard,intr';
-my $APT_GET         = 'LANG=C LC_ALL=C /usr/bin/apt-get -y --force-yes';
-my $APT_GET_DEPENDS = 'LANG=C LC_ALL=C /usr/bin/apt-get -y --force-yes -s -u';
-my $APT_POLICY      = 'LANG=C LC_ALL=C /usr/bin/apt-cache policy';
-my $APT_UPDATE      = 1;
-my $DPKG            = 'LANG=C LC_ALL=C /usr/bin/dpkg';
-
-#$PKGLIST         = "/var/lib/apt/lists";
-
-# Conf Par Defaut
-my $PF_STATUS_DIR = "/var/lib/pftools";
-
-my $CVS_USER       = "cvsguest";
-my $CVS_RSH        = "/usr/local/sbin/cvs_rsh";
-my $CVS_SERVER     = "cvs.private";
-my $CVS_ROOT       = "/var/lib/cvs";
-my $CVS_REPOSITORY = $CVS_ROOT . "/repository";
-my $CVS_CONFIG     = "config";
-our $CVS_COMMAND;
-my $CVS_BRANCHE;
-
-# End Conf Par Defaut!
-
-if ( -r $PFTOOLSCONF ) {
-    my $newuid;
-    my $newgid;
-    my $dev;
-    my $ino;
-    my $mode;
-    my $nlink;
-    my $uid;
-    my $gid;
-    my $rdev;
-    my $size;
-    my $atime;
-    my $mtime;
-    my $ctime;
-    my $blksize;
-    my $blocks;
-
-    (   $dev,  $ino,   $mode,  $nlink, $uid,     $gid, $rdev,
-	$size, $atime, $mtime, $ctime, $blksize, $blocks
-    ) = lstat($PFTOOLSCONF);
-
-    if ( $uid == 0 && $gid == 0 && S_IMODE($mode) == 0600 && S_ISREG($mode) )
-    {
-
-	my $result;
-	my $return;
-	unless ( $result = do $PFTOOLSCONF ) {
-	    warn "couldn't parse $PFTOOLSCONF: $@" if $@;
-	    warn "couldn't do $PFTOOLSCONF: $!" unless defined $return;
-	    warn "couldn't run $PFTOOLSCONF"    unless $return;
-	}
+    if ( $action eq "addfile" ) {
+        Addfile_depends( $ref_section, $dest, $options );
     }
-    else {
-	print STDERR "Ignoring weak config (check owner/group/mode)\n";
+    elsif ( $action eq "apt-get" || $action eq "installpkg" ) {
+        Installpkg_depends( $ref_section, $dest, $options );
+    }
+    elsif ( $action eq "mkdir" ) {
+        Mkdir_depends( $ref_section, $dest, $options );
+    }
+    elsif ( $action eq "addmount" ) {
+        Addmount_depends( $ref_section, $dest, $options );
+    }
+    elsif ( $action eq "createfile" ) {
+        Createfile_depends( $ref_section, $dest, $options );
+    }
+    elsif ( $action eq "addlink" ) {
+        Addlink_depends( $ref_section, $dest, $options );
     }
 }
 
-# Constantes deduites de la conf
-my $CVS_WORKING_DIR = $CVS_CHECKOUT . "/" . $HOSTNAME;
-my $CVS_TMP_DIR     = $CVS_CHECKOUT . "/" . $HOSTNAME . "/tmp";
-my $CVS_OLD_DIR     = $CVS_CHECKOUT . "/" . $HOSTNAME . "/old";
-my $GLOBAL_CONF     = $CVS_WORKING_DIR . "/" . $CVS_CONFIG . "/GLOBAL";
-my $TEMPLATES       = $CVS_WORKING_DIR . "/" . $CVS_CONFIG . "/TEMPLATES";
+sub Exec_action ($$$$$$) {
+    my ( $action, $ref_section, $dest, $options, $hash_subst, $global_config )
+        = @_;
 
-# Fonctions utilisees dans les fichiers de conf
-
-sub isipaddr {
-    my ($ip) = @_;
-
-    my @sub = split( '\.', $ip );
-
-    if ( $#sub != 3 ) {
-	return 0;
+    # Adding some commons entries into substitution hash : $hash_subst
+    $hash_subst->{'SECTIONNAME'} = $dest;
+    return 0 if ( $action eq "ignore" );
+    return Addfile_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "addfile" );
+    if ( $action eq "apt-get" || $action eq "installpkg" ) {
+        if ($APT_UPDATE) {
+            if ( !Update_pkg_repository( $options->{'pkg_type'} ) ) {
+                Warn( $CODE->{'OPEN'},
+                    "An error occured during updating packages lists" );
+                return 1;
+            }
+            $APT_UPDATE = 0;
+        }
+        return Installpkg_action( $ref_section, $dest, $options, $hash_subst,
+            $global_config )
+            if ( $action eq "apt-get" || $action eq "installpkg" );
     }
-
-    my $i;
-
-    foreach $i ( 0 .. 3 ) {
-	if ( $sub[$i] < 0 || $sub[$i] > 255 ) {
-	    return 0;
-	}
-    }
-
-    return -1;
+    return Purgepkg_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "dpkg-purge" || $action eq "purgepkg" );
+    return Mkdir_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "mkdir" );
+    return Addmount_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "addmount" );
+    return Createfile_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "createfile" );
+    return Addlink_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "addlink" );
+    return Removefile_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "removefile" );
+    return Removedir_action( $ref_section, $dest, $options, $hash_subst,
+        $global_config )
+        if ( $action eq "removedir" );
 }
 
-sub fullchown {
-    my ( $owner, $group, $dest, $options ) = @_;
-    my $newuid;
-    my $newgid;
-    my $dev;
-    my $ino;
-    my $mode;
-    my $nlink;
-    my $uid;
-    my $gid;
-    my $rdev;
-    my $size;
-    my $atime;
-    my $mtime;
-    my $ctime;
-    my $blksize;
-    my $blocks;
-
-    $newuid = getpwnam($owner);
-    $newgid = getgrnam($group);
-
-    if ( !defined($newuid) || !defined($newgid) ) {
-	return 1;
-    }
-
-    (   $dev,  $ino,   $mode,  $nlink, $uid,     $gid, $rdev,
-	$size, $atime, $mtime, $ctime, $blksize, $blocks
-    ) = stat($dest);
-
-    if (   ( defined($uid) && $uid == $newuid )
-	&& ( defined($gid) && $gid == $newgid ) )
-    {
-	return 0;
-    }
-
-    if ( $options->{'verbose'} || $options->{'simul'} ) {
-	Log("(chown needed)");
-    }
-
-    if ( $options->{'simul'} ) {
-	return 0;
-    }
-
-    return !chown( $newuid, $newgid, $dest );
-}
-
-sub fullchmod {
-    my ( $newmode, $dest, $options ) = @_;
-    my $newuid;
-    my $newgid;
-    my $dev;
-    my $ino;
-    my $mode;
-    my $nlink;
-    my $uid;
-    my $gid;
-    my $rdev;
-    my $size;
-    my $atime;
-    my $mtime;
-    my $ctime;
-    my $blksize;
-    my $blocks;
-
-    (   $dev,  $ino,   $mode,  $nlink, $uid,     $gid, $rdev,
-	$size, $atime, $mtime, $ctime, $blksize, $blocks
-    ) = stat($dest);
-
-    if ( defined($mode) && ( $mode & 07777 ) == $newmode ) {
-	return 0;
-    }
-
-    if ( $options->{'verbose'} || $options->{'simul'} ) {
-	Log("(chmod needed)");
-    }
-
-    if ( $options->{'simul'} ) {
-	return 0;
-    }
-
-    return !chmod( $newmode, $dest );
-}
-
-sub ln_sfn {
-    my ( $source, $dest ) = @_;
-
-    unlink($dest);
-    rmdir($dest);
-    return !symlink( $source, $dest );
-}
-
-sub dirname {
-    my ($file) = @_;
-
-    $file =~ s://:/:g;
-
-    if ( $file =~ m|/| ) {
-	$file =~ s|^(.*)/[^/]+/?$|$1|;
-    }
-    else {
-	$file = '.';
-    }
-
-    return $file;
-}
-
-sub Do_moveold {
-    my ( $dest, $options ) = @_;
-
-    if ( -e $dest ) {
-	my $old = $CVS_OLD_DIR . "/" . $dest . "." . $STARTTIME;
-
-	if ( $options->{'verbose'} ) {
-	    Log( "(moving old to " . $old . ")" );
-	}
-
-	if ( !$options->{'simul'} ) {
-	    Mk_dest_dir($old);
-	    deferredlogsystem( "/bin/mv '" . $dest . "' '" . $old . "'" );
-	}
-    }
-}
-
-sub Do_chownmod {
-    my ( $S, $dest, $options ) = @_;
-
-    my $owner;
-    my $group;
-    my $mode;
-
-    $owner = defined( $S->{'owner'} ) ? $S->{'owner'} : $DEFAULT_OWNER;
-    $group = defined( $S->{'group'} ) ? $S->{'group'} : $DEFAULT_GROUP;
-
-    if ( fullchown( $owner, $group, $dest, $options ) ) {
-	Warn( $ERR_OPEN,
-	          "Impossible d'attribuer " 
-		. $dest . " a " 
-		. $owner . "."
-		. $group );
-	return 1;
-    }
-
-    $mode
-	= defined( $S->{'mode'} )
-	? $S->{'mode'}
-	: ( ( -d $dest ) ? $DEFAULT_DIRMODE : $DEFAULT_MODE );
-    $mode =~ s/^[^0]/0$&/;
-
-    if ( fullchmod( eval($mode), $dest, $options ) ) {
-	Warn( $ERR_OPEN,
-	    "Impossible d'attribuer les droits " . $mode . " a " . $dest );
-	return 1;
-    }
-}
-
-sub Exec_cmd ($) {
-	my ( $cmd ) = @_;
-
-	if ( deferredlogsystem($cmd) ) {
-	    Warn( $ERR_OPEN, "Impossible d'executer [" . $cmd . "]" );
-	    return 1;
-	}
-	return 0;
-}
-
-sub Do_on_config {
-    my ( $S, $options ) = @_;
-
-    if ( !$options->{'simul'} && defined( $S->{'on_config'} ) )
-	{
-	return Exec_cmd ( Subst_vars ( $S->{'on_config'} ) );
-	}
-}
-
-sub Do_before_change {
-    my ( $S, $options ) = @_;
-
-    if (   !$options->{'simul'}
-	&& defined( $S->{'before_change'} )
-	&& !$options->{'noaction'} )
-    {
-	return Exec_cmd ( Subst_vars ( $S->{'before_change'} ) );
-	}
-}
-
-sub Do_after_change {
-    my ( $S, $options ) = @_;
-
-    if (   !$options->{'simul'}
-	&& defined( $S->{'after_change'} )
-	&& !$options->{'noaction'} )
-    {
-	return Exec_cmd ( Subst_vars ( $S->{'after_change'} ) );
-    }
-}
-
-sub Do_on_noaction {
-    my ( $S, $options ) = @_;
-
-    if (   !$options->{'simul'}
-	&& defined( $S->{'on_noaction'} )
-	&& $options->{'noaction'} )
-    {
-	return Exec_cmd ( Subst_vars ( $S->{'on_noaction'} ) );
-    }
-}
-
-my %DEPENDS;
-my %FUNCTIONS;
-
-$DEPENDS{'addfile'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    while ( $dest ne '/' && $dest ne '.' ) {
-	$S->{'depends'} .= " " . dirname($dest);
-	$dest = dirname($dest);
-    }
-};
-
-$FUNCTIONS{'addfile'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $source;
-    my $tmp;
-    my $cmp;
-
-    if ( !defined( $S->{'source'} ) ) {
-	Abort( $ERR_SYNTAX, "Source non definie pour " . $dest );
-    }
-    $SUBST{'SECTIONNAME'} = $dest;
-    if ( $S->{'source'} =~ /\s/ ) {
-	$source = Get_tmp_dest($dest) . ".merged";
-	unlink($source);
-
-	my $splitsource;
-	foreach $splitsource ( split( ' ', $S->{'source'} ) ) {
-	    $splitsource = Get_source( Subst_vars($splitsource) );
-	    if ( !-f $splitsource ) {
-		Warn( $ERR_OPEN, "Impossible d'ouvrir " . $splitsource );
-		return 1;
-	    }
-	    if (deferredlogsystem(
-		    "cat '" . $splitsource . "' >> " . $source
-		)
-		)
-	    {
-		Warn( $ERR_OPEN,
-		          "Impossible de concatener "
-			. $splitsource
-			. " dans "
-			. $tmp );
-		return 1;
-	    }
-	}
-    }
-    else {
-	$source = Get_source( Subst_vars( $S->{'source'} ) );
-    }
-
-    $SUBST{'SOURCE'}      = $source;
-    $tmp                  = Get_tmp_dest($dest);
-    $SUBST{'DESTINATION'} = $tmp;
-
-    if ( defined( $S->{'filter'} ) ) {
-	my $filter = Subst_vars( $S->{'filter'} );
-	if ( deferredlogsystem($filter) ) {
-	    Warn( $ERR_OPEN, "Impossible d'appliquer " . $filter );
-	    return 1;
-	}
-    }
-    else {
-
-	if (deferredlogsystem(
-		"/bin/cp -a '" . $source . "' '" . $tmp . "'"
-	    )
-	    )
-	{
-	    Warn( $ERR_OPEN,
-		"Impossible de copier " . $source . " vers " . $tmp );
-	    return 1;
-	}
-    }
-
-    if ( !-f $tmp ) {
-	Warn( $ERR_OPEN, "Impossible d'ouvrir " . $tmp );
-	return 1;
-    }
-
-    $cmp = 0;
-    if ( deferredlogsystem( "/usr/bin/cmp -s '" . $tmp . "' '" . $dest . "'" )
-	)
-    {
-
-	$cmp = 1;
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	if ( $options->{'diff'} ) {
-	    deferredlogsystem(
-		"/usr/bin/diff -uN '" . $dest . "' '" . $tmp . "'" );
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !$options->{'simul'} ) {
-
-	    # Fuck dpkg conffiles
-	    if (   $options->{'noaction'}
-		&& -e $dest
-		&& !-e $dest . ".dpkg-dist" )
-	    {
-		deferredlogsystem(
-		    "/bin/cp -a '" . $dest . "' '" . $dest . ".dpkg-dist'" );
-	    }
-
-	    Do_moveold( $dest, $options );
-
-	    if (Mk_dest_dir($dest)
-		|| deferredlogsystem(
-		    "/bin/cp -a '" . $tmp . "' '" . $dest . "'"
-		)
-		)
-	    {
-		Warn( $ERR_OPEN,
-		    "Impossible de copier " . $tmp . " vers " . $dest );
-		return 1;
-	    }
-	}
-    }
-
-    Do_chownmod( $S, $dest, $options );
-
-    if ($cmp) {
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$FUNCTIONS{'dpkg-purge'} = sub {
-    my ( $S, $dest, $options, $pkg_type ) = @_;
-
-    $pkg_type = 'deb' if ( ! defined $pkg_type ) ;
-
-    my $name_filter = $S->{'name_filter'};
-    if ($name_filter) {
-	$SUBST{'SECTIONNAME'} = $dest;
-	my $newdest = deferredlogpipe( Subst_vars($name_filter) );
-	unless ( defined $newdest ) {
-	    Warn( $ERR_OPEN,
-		"Impossible d'appliquer name_filter $name_filter" );
-	    return 1;
-	}
-	unless ($newdest) {
-	    Warn( $ERR_OPEN, "Resultat vide pour name_filter $name_filter" );
-	    return 1;
-	}
-	$dest = $newdest;
-    }
-
-#     my $installed_version;
-# 
-#     open( DPKG, $DPKG . ' -s ' . $dest . ' 2>/dev/null |' );
-#     while (<DPKG>) {
-# 	if (/^Status:\s+/) {
-# 	    if ( !/^Status:\s+install\s+ok\s+installed\s*$/ ) {
-# 		$installed_version = 0;
-# 		last;
-# 	    }
-# 	}
-# 
-# 	if (/^Version:\s+(.+)\s*$/) {
-# 	    $installed_version = $1;
-# 	    last;
-# 	}
-#     }
-#     close(DPKG);
-
-    my $status = Get_pkg_status ( $pkg_type, $dest ) ;
-    if ( ! defined $status ) {
-	Warn ( $ERR_OPEN, "Impossible d'obtenir le statut du paquet ".$dest ) ;
-	return 1;
-    }
-
-    if ( $status->{'installed'} ) {
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !$options->{'simul'} ) {
-# 	    if ( deferredlogsystem( $DPKG . " -P '" . $dest . "'" ) ) {
-# 		Warn( $ERR_OPEN,
-# 		    "Purge du package " . $dest . " impossible" );
-# 		return 1;
-# 	    }
-	    if ( ! Purge_pkg ( $pkg_type, $dest ) ) {
-		Warn ( $ERR_OPEN, "Une erreur est survenue lors de la purge du paquet ".$dest ) ;
-		return 1 ;
-	    }
-	}
-
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-sub aptupdate ($){
-    my ( $pkg_type ) = @_ ;
-
-    if ($APT_UPDATE) {
-	if ( ! Update_pkg_repository ( $pkg_type ) ) {
-	    return 1;
-        }
-        $APT_UPDATE = 0;
-    }
-    return 0;
-}
-
-$DEPENDS{'apt-get'} = sub {
-    my ( $S, $dest, $options, $pkg_type ) = @_;
-
-    $pkg_type = 'deb' if ( ! defined $pkg_type ) ;
-    if ( aptupdate( $pkg_type ) ) {
-	return 1;
-    }
-    
-
-#     open( APTDEP, $APT_GET_DEPENDS . ' install ' . $dest . ' 2>/dev/null |' );
-#     while (<APTDEP>) {
-# 	if (m/^  (.*)$/) {
-# 	    my $pkg;
-# 	    foreach $pkg ( split( ' ', $1 ) ) {
-# 		if ( $pkg ne $dest ) {
-# 		    $S->{'depends'} .= " " . $pkg;
-# 		}
-# 	    }
-# 	}
-#     }
-#     close(APTDEP);
-    my $deps = Get_pkg_depends ( $pkg_type, $dest ) ;
-    if ( ! defined $deps ) {
-	Warn ( $ERR_OPEN, "Impossible de recuperer les dependances du paquet ".$dest ) ;
-	return 1;
-    }
-    else {
-	$S->{'depends'} = $dest ;
-    }
-};
-
-$FUNCTIONS{'apt-get'} = sub {
-    my ( $S, $dest, $options, $pkg_type ) = @_;
-
-    $pkg_type = 'deb' if ( ! defined $pkg_type ) ;
-    my $installed_version;
-    my $available_version;
-    my $specified_version = 0;
-    my $install;
-
-    my $name_filter = $S->{'name_filter'};
-    if ($name_filter) {
-	$SUBST{'SECTIONNAME'} = $dest;
-	my $newdest = deferredlogpipe( Subst_vars($name_filter) );
-	unless ( defined $newdest ) {
-	    Warn( $ERR_OPEN,
-		"Impossible d'appliquer name_filter $name_filter" );
-	    return 1;
-	}
-	unless ($newdest) {
-	    Warn( $ERR_OPEN, "Resultat vide pour name_filter $name_filter" );
-	    return 1;
-	}
-	$dest = $newdest;
-    }
-
-    aptupdate( $pkg_type );
-
-#     open( APTPOLICY, $APT_POLICY . ' ' . $dest . ' 2>/dev/null |' );
-#     while (<APTPOLICY>) {
-# 	if (m/^  Installed: (.*)$/) {
-# 	    $installed_version = $1;
-# 	    if ( $installed_version eq '' || $installed_version eq '(none)' )
-# 	    {
-# 		undef $installed_version;
-# 	    }
-# 	}
-# 	elsif (m/^  Candidate: (.*)$/) {
-# 	    $available_version = $1;
-# 	}
-#     }
-#     close(APTPOLICY);
-
-    ( $installed_version, $available_version, $specified_version ) = Get_pkg_policy ( $pkg_type, $dest, $S->{'version'} ) ;
-    
-#     if ( !defined($available_version) ) {
-# 	Warn( $ERR_OPEN, "Package " . $dest . " indisponible" );
-# 	return 1;
-#     }
-
-    if ( !defined ( $available_version ) ) {
-	Warn( $ERR_OPEN, "Package " . $dest . " indisponible" );
-	return 1;
-    }
-    if ( defined ( $S->{'version'} ) && ! $specified_version ) {
-	Warn( $ERR_OPEN, "Package " . $dest . " en version " . $S->{'version'} . " indisponible" );
-	return 1;
-    }
-
-#     if (!defined($installed_version)
-# 	|| !deferredlogsystem(
-# 	          $DPKG
-# 		. ' --compare-versions '
-# 		. $installed_version . ' lt '
-# 		. $available_version
-# 	)
-# 	)
-#     {
-# 	$install++;
-#     }
-
-    if ( defined $installed_version ) {
-	my $compare = Cmp_pkg_version ( $pkg_type, $dest, $installed_version, $available_version ) ;
-	if ( defined $compare && $compare < 0 ) {
-	    $install++ ;
-	}
-    }
-
-    if ($install) {
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	if ( $options->{'diff'} ) {
-	    Log("(inst = "
-		    . (
-		    defined($installed_version) ? $installed_version : '?'
-		    )
-		    . ", avail = "
-		    . (
-		    defined($available_version) ? $available_version : '?'
-		    )
-		    . ")"
-	    );
-	}
-
-	if ( defined( $S->{'delay'} ) && !$options->{'noaction'} ) {
-	    $HOSTNAME =~ /\d+$/;
-	    if ( $& ne "" ) {
-		sleep( 120 * $& );
-	    }
-	}
-
-	if ( !$options->{'simul'} && defined( $S->{'debconf'} ) ) {
-
-	    my $DEB;
-	    my $conf;
-	    my $pkg;
-
-	    Debconf::Db->load;
-	    foreach $conf ( keys %{ $S->{'debconf'} } ) {
-
-		($pkg) = split( m:/:, $conf );
-
-		if ( !$DEB->{$pkg} ) {
-		    $DEB->{$pkg} = 1;
-		    Debconf::Template->load( $TEMPLATES . "/" . $pkg, $pkg );
-		}
-
-		Debconf::ConfModule->command_set( $conf,
-		    $S->{'debconf'}->{$conf} );
-		Debconf::ConfModule->command_fset( $conf, "seen", "true" );
-	    }
-	    Debconf::Db->save;
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( defined( $S->{'reply'} ) ) {
-	    $install = $S->{'reply'};
-	    eval "\$install = sprintf (\"echo '$install' |\")";
-	}
-	else {
-	    $install = '';
-	}
-
-	if ( !$options->{'simul'} ) {
-# 	    if (deferredlogsystem(
-# 		    $install . " " . $APT_GET . " install '" . $dest . "'"
-# 		)
-# 		)
-# 	    {
-# 		Warn( $ERR_OPEN, "Installation de " . $dest . " impossible" );
-# 		return 1;
-# 	    }
-	    if ( ! Install_pkg ( $pkg_type, $dest, $S->{'version'} ) ) {
-	        Warn( $ERR_OPEN, "Installation de ".$dest." impossible" ) ;
-		return 1;
-	    }
-	}
-
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$DEPENDS{'addmount'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    while ( $dest ne '/' && $dest ne '.' ) {
-	$S->{'depends'} .= " " . dirname($dest);
-	$dest = dirname($dest);
-    }
-};
-
-$FUNCTIONS{'addmount'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $addmount;
-    my $source;
-    my $fstype;
-    my $opts;
-    my $sortedopts;
-
-    my $oldsource;
-    my $olddest;
-    my $oldfstype;
-    my $oldopts;
-    my $oldresolvedopts;
-
-    my $oldmsource;
-    my $oldmresolvedsource;
-    my $oldmdest;
-    my $oldmfstype;
-    my $oldmopts;
-
-    my $addmountfstab  = 0;
-    my $addmountmounts = 0;
-
-    my $Z;
-
-    if ( !defined( $S->{'source'} ) ) {
-	Abort( $ERR_SYNTAX, "Source non definie pour " . $dest );
-    }
-    $SUBST{'SECTIONNAME'} = $dest;
-    $source = Subst_vars( $S->{'source'} );
-
-    my $sourceaddr = $source;
-    $sourceaddr =~ s/^([^:]+):(.+)$/$1/;    # NFS
-    if ( defined($sourceaddr) && !isipaddr($sourceaddr) ) {
-	if ( !defined($Z) ) {
-	    $Z = Init_lib_net( Get_source("GLOBAL:private-network") );
-	}
-	my $sourceip = Resolv( $sourceaddr, $Z );
-	if ( defined($sourceip) && $sourceip ne "" ) {
-	    $source =~ s/^([^:]+):(.+)$/$sourceip:$2/;
-	}
-    }
-
-    $SUBST{'SOURCE'} = $source;
-
-    $opts = defined( $S->{'options'} ) ? $S->{'options'} : $DEFAULT_OPTIONS;
-
-    my $optsaddr = $opts;
-    $optsaddr =~ s/^(.*,)?ip=([^,]+)(,.*)?$/$2/;
-    if ( defined($optsaddr) && !isipaddr($optsaddr) ) {
-	if ( !defined($Z) ) {
-	    $Z = Init_lib_net( Get_source("GLOBAL:private-network") );
-	}
-	my $optsip = Resolv( $optsaddr, $Z );
-	if ( defined($optsip) && $optsip ne "" ) {
-	    $opts =~ s/^(.*,)?ip=([^,]+)(,.*)?$/$1ip=$optsip$3/;
-	}
-    }
-
-    $SUBST{'OPTIONS'} = $opts;
-    $sortedopts = join( ',', sort split( ',', $opts ) );
-
-    $fstype = defined( $S->{'fstype'} ) ? $S->{'fstype'} : $DEFAULT_FSTYPE;
-    $SUBST{'FSTYPE'} = $fstype;
-
-    if ( !open( FSTAB, "< /etc/fstab" ) ) {
-	Warn( $ERR_OPEN, "Impossible de lire /etc/fstab" );
-	return 1;
-    }
-    while (<FSTAB>) {
-	if (m/^[ 	]*([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)/
-	    )
-	{
-	    my $resolved1 = $1;
-	    {
-		my $oldsourceaddr = $1;
-		$oldsourceaddr =~ s/^([^:]+):(.+)$/$1/;    # NFS
-		if ( defined($oldsourceaddr) && !isipaddr($oldsourceaddr) ) {
-		    if ( !defined($Z) ) {
-			$Z = Init_lib_net(
-			    Get_source("GLOBAL:private-network") );
-		    }
-		    my $oldsourceip = Resolv( $oldsourceaddr, $Z );
-		    if ( defined($oldsourceip) && $oldsourceip ne "" ) {
-			$resolved1 =~ s/^([^:]+):(.+)$/$oldsourceip:$2/;
-		    }
-		}
-	    }
-
-	    my $resolved4 = $4;
-	    {
-		my $oldoptsaddr = $4;
-		$oldoptsaddr =~ s/^(.*,)?ip=([^,]+)(,.*)?$/$2/;
-		if ( defined($oldoptsaddr) && !isipaddr($oldoptsaddr) ) {
-		    if ( !defined($Z) ) {
-			$Z = Init_lib_net(
-			    Get_source("GLOBAL:private-network") );
-		    }
-		    my $oldoptsip = Resolv( $oldoptsaddr, $Z );
-		    if ( defined($oldoptsip) && $oldoptsip ne "" ) {
-			$resolved4
-			    =~ s/^(.*,)?ip=([^,]+)(,.*)?$/$1ip=$oldoptsip$3/;
-		    }
-		}
-	    }
-
-	    if ( $1 eq $source && $source ne "none" ) {
-		$olddest = $2;
-	    }
-	    if ( $2 eq $dest ) {
-		$oldsource = $1;
-	    }
-
-	    if ( $resolved1 eq $source && $2 eq $dest ) {
-		$oldfstype       = $3;
-		$oldopts         = $4;
-		$oldopts         = join( ',', sort split( ',', $oldopts ) );
-		$oldresolvedopts = $resolved4;
-		$oldresolvedopts
-		    = join( ',', sort split( ',', $oldresolvedopts ) );
-	    }
-	}
-    }
-    close(FSTAB);
-
-    $addmountfstab = 1;
-    if (   defined($oldsource)
-	&& $oldsource eq $source
-	&& defined($olddest)
-	&& $olddest eq $dest
-	&& defined($oldfstype)
-	&& $oldfstype eq $fstype
-	&& defined($oldopts)
-	&& $oldopts eq $sortedopts
-	&& defined($oldresolvedopts)
-	&& $oldresolvedopts eq $sortedopts )
-    {
-	$addmountfstab = 0;
-    }
-
-    if ( !$options->{'noaction'} ) {
-	if ( !open( MOUNTS, "< /proc/mounts" ) ) {
-	    Warn( $ERR_OPEN, "Impossible de lire /proc/mounts" );
-	}
-	else {
-	    while (<MOUNTS>) {
-		if (m/^([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)[ 	]+([^ 	]+)/
-		    )
-		{
-		    my $resolved1 = $1;
-		    {
-			my $oldmsourceaddr = $1;
-			$oldmsourceaddr =~ s/^([^:]+):(.+)$/$1/;    # NFS
-			if ( defined($oldmsourceaddr)
-			    && !isipaddr($oldmsourceaddr) )
-			{
-			    if ( !defined($Z) ) {
-				$Z = Init_lib_net(
-				    Get_source("GLOBAL:private-network") );
-			    }
-			    my $oldmsourceip = Resolv( $oldmsourceaddr, $Z );
-			    if ( defined($oldmsourceip)
-				&& $oldmsourceip ne "" )
-			    {
-				$resolved1
-				    =~ s/^([^:]+):(.+)$/$oldmsourceip:$2/;
-			    }
-			}
-		    }
-
-		    if ( $resolved1 eq $source && $source ne "none" ) {
-			$oldmdest = $2;
-		    }
-		    if ( $2 eq $dest ) {
-			$oldmsource         = $1;
-			$oldmresolvedsource = $resolved1;
-		    }
-
-		    if ( $resolved1 eq $source && $2 eq $dest ) {
-			$oldmfstype = $3;
-			$oldmopts   = $4;
-			$oldmopts = join( ',', sort split( ',', $oldmopts ) );
-		    }
-		}
-	    }
-	    close(MOUNTS);
-
-	    #todo, parsing options, utilisation de celles de fstab
-	    $addmountmounts = 1;
-	    if (   defined($oldmresolvedsource)
-		&& $oldmresolvedsource eq $source
-		&& defined($oldmdest)
-		&& $oldmdest eq $dest
-		&& defined($oldmfstype)
-		&& $oldmfstype eq $fstype
-		&& defined($oldresolvedopts)
-		&& $oldresolvedopts eq $sortedopts )
-	    {
-		$addmountmounts = 0;
-	    }
-	}
-    }
-
-    if ( $addmountfstab || $addmountmounts || !-d $dest ) {
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !-d $dest && $dest ne 'none' ) {
-	    if ( !defined( $FUNCTIONS{'mkdir'} ) ) {
-		Warn( $ERR_OPEN, "Fonction mkdir necessaire pour addmount" );
-		return 1;
-	    }
-	    $FUNCTIONS{'mkdir'}->( $S, $dest, $options );
-	}
-
-	if ($addmountfstab) {
-	    my $tmp = Get_tmp_dest("/etc/fstab");
-
-	    if ( !open( FSTAB, "< /etc/fstab" ) ) {
-		Warn( $ERR_OPEN, "Impossible de lire /etc/fstab" );
-		return 1;
-	    }
-
-	    if ( !open( NEWFSTAB, "> " . $tmp ) ) {
-		Warn( $ERR_OPEN, "Impossible de creer " . $tmp );
-		return 1;
-	    }
-
-	    while (<FSTAB>) {
-		my $line = $_;
-		if (   defined($oldsource)
-		    && $oldsource ne $source
-		    && $line =~ m|^[ 	]*$oldsource[ 	]+| )
-		{
-		    Warn( $ERR_OPEN,
-			      "Suppression de la source "
-			    . $oldsource
-			    . " de fstab" );
-		}
-		elsif (defined($olddest)
-		    && $olddest ne $dest
-		    && $line =~ m|^[ 	]*[^ 	]+[ 	]+$olddest[ 	]+| )
-		{
-		    Warn( $ERR_OPEN,
-			      "Suppression de la destination " 
-			    . $olddest
-			    . " de fstab" );
-		}
-		elsif (defined($oldfstype)
-		    && $oldfstype ne $fstype
-		    && $line =~ m|^[ 	]*$source+[ 	]+$dest[ 	]+| )
-		{
-		    Warn( $ERR_OPEN,
-			      "Suppression du mauvais type "
-			    . $oldfstype
-			    . " pour "
-			    . $source
-			    . " de fstab" );
-		}
-		elsif (defined($oldopts)
-		    && $oldopts ne $opts
-		    && $line =~ m|^[ 	]*$source+[ 	]+$dest[ 	]+| )
-		{
-		    Warn( $ERR_OPEN,
-			      "Suppression des mauvaises options " 
-			    . $oldopts
-			    . " pour "
-			    . $source
-			    . " de fstab" );
-		}
-		else {
-		    print NEWFSTAB $line;
-		}
-	    }
-	    print NEWFSTAB $source . "	" . $dest . "	" . $fstype . "	" . $opts
-		. "	0 0\n";
-	    close(NEWFSTAB);
-	    close(FSTAB);
-
-	    if ( $options->{'diff'} ) {
-		deferredlogsystem( "diff -uN '/etc/fstab' '" . $tmp . "'" );
-	    }
-
-	    if ( !$options->{'simul'} ) {
-		if ( system( "cat '" . $tmp . "' > /etc/fstab" ) ) {
-		    Warn( $ERR_OPEN,
-			      "Impossible de recopier " 
-			    . $tmp
-			    . " dans /etc/fstab" );
-		    return 1;
-		}
-	    }
-	}
-
-	if ($addmountmounts) {
-
-	    if ( $options->{'diff'} ) {
-		if ((   ( defined $oldmresolvedsource )
-			? $oldmresolvedsource
-			: '?'
-		    ) ne $source
-		    )
-		{
-		    Log("src "
-			    . (
-			    ( defined $oldmresolvedsource )
-			    ? $oldmresolvedsource
-			    : '?'
-			    )
-			    . " -> "
-			    . $source
-		    );
-		}
-		if ( ( ( defined $oldmdest ) ? $oldmdest : '?' ) ne $dest ) {
-		    Log(      "dst "
-			    . ( ( defined $oldmdest ) ? $oldmdest : '?' )
-			    . " -> "
-			    . $dest );
-		}
-		if ( ( ( defined $oldmfstype ) ? $oldmfstype : '?' ) ne
-		    $fstype )
-		{
-		    Log(      "fs  "
-			    . ( ( defined $oldmfstype ) ? $oldmfstype : '?' )
-			    . " -> "
-			    . $fstype );
-		}
-		if ( ( ( defined $oldresolvedopts ) ? $oldresolvedopts : '?' )
-		    ne $opts )
-		{
-		    Log("opt "
-			    . (
-			    ( defined $oldresolvedopts )
-			    ? $oldresolvedopts
-			    : '?'
-			    )
-			    . " -> "
-			    . $opts
-		    );
-		}
-	    }
-
-	    if ( !$options->{'simul'} && !$options->{'noaction'} ) {
-
-		if (   defined($oldmsource)
-		    && $oldmsource ne $source
-		    && ( !defined($oldmresolvedsource)
-			|| $oldmresolvedsource ne $source )
-		    )    # Pas la peine de remounter si le resolv est le meme
-		{
-		    if ( deferredlogsystem( "umount '" . $oldmsource . "'" ) )
-		    {
-			Warn( $ERR_OPEN,
-			    "Impossible d'unmounter la source "
-				. $oldmsource );
-			return 1;
-		    }
-		}
-
-		if ( defined($oldmdest) && $oldmdest ne $dest ) {
-		    if ( deferredlogsystem( "umount '" . $oldmdest . "'" ) ) {
-			Warn( $ERR_OPEN,
-			    "Impossible d'unmounter la destination "
-				. $oldmdest );
-			return 1;
-		    }
-		}
-
-		if ( defined($oldmfstype) && $oldmfstype ne $fstype ) {
-		    if ( deferredlogsystem( "umount '" . $dest . "'" ) ) {
-			Warn( $ERR_OPEN,
-			    "Impossible d'unmounter la destination "
-				. $dest );
-			return 1;
-		    }
-		}
-
-		if (   defined($oldopts)
-		    && $oldopts ne $opts
-		    && defined($oldmfstype)
-		    && $oldmfstype eq $fstype )
-		{
-		    if (deferredlogsystem(
-			    "mount -o 'remount," . $opts . "' '" . $dest . "'"
-			)
-			)
-		    {
-			Warn( $ERR_OPEN,
-			          "Impossible de remounter la destination " 
-				. $dest
-				. " avec les options "
-				. $opts );
-			return 1;
-		    }
-		}
-		else {
-
-		    if (deferredlogsystem(
-			          "mount -t '" 
-				. $fstype 
-				. "' -o '" 
-				. $opts . "' '"
-				. $source . "' '"
-				. $dest . "'"
-			)
-			)
-		    {
-			Warn( $ERR_OPEN,
-			          "Impossible de mounter la source " 
-				. $source . " sur "
-				. $dest
-				. " de type "
-				. $fstype
-				. " avec les options "
-				. $opts );
-			return 1;
-		    }
-		}
-	    }
-	}
-
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$FUNCTIONS{'ignore'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    return 0;
-};
-
-$DEPENDS{'addlink'} = sub {
-    my ( $S, $dest, $options ) = @_;
-    my $source = Subst_vars( $S->{'source'} );
-
-    while ( $source ne '/' && $source ne '.' ) {
-	$S->{'depends'} .= " " . dirname($source);
-	$source = dirname($source);
-    }
-    while ( $dest ne '/' && $dest ne '.' ) {
-	$S->{'depends'} .= " " . dirname($dest);
-	$dest = dirname($dest);
-    }
-};
-
-$FUNCTIONS{'addlink'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $cmp = 0;
-
-    $SUBST{'SECTIONNAME'} = $dest;
-    if ( !defined( $S->{'source'} ) ) {
-	Abort( $ERR_SYNTAX, "Source non definie pour " . $dest );
-    }
-    my $source = Subst_vars( $S->{'source'} );
-
-    if ( !-l $dest || ( -l $dest && readlink($dest) ne $source ) ) {
-	$cmp = 1;
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	if ( $options->{'diff'} ) {
-	    if ( -l $dest ) {
-		Log( "( readlink = " . readlink($dest) . ")" );
-	    }
-	    else {
-		Log( "( !-l " . $dest . ")" );
-	    }
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !$options->{'simul'} ) {
-	    Do_moveold( $dest, $options );
-
-	    if ( Mk_dest_dir($dest) || ln_sfn( $source, $dest ) ) {
-		Warn( $ERR_OPEN,
-		    "Impossible de lier " . $dest . " a " . $source );
-		return 1;
-	    }
-	}
-
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$DEPENDS{'createfile'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    while ( $dest ne '/' && $dest ne '.' ) {
-	$S->{'depends'} .= " " . dirname($dest);
-	$dest = dirname($dest);
-    }
-};
-
-$FUNCTIONS{'createfile'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $cmp = 0;
-
-    $SUBST{'SECTIONNAME'} = $dest;
-    if ( !defined $S->{'source'} ) {
-	if ( !-f $dest ) {
-	    $cmp = 1;
-
-	    if ( $options->{'verbose'} || $options->{'simul'} ) {
-		Log("(action needed)");
-	    }
-
-	    Do_on_config( $S, $options ) && return 1;
-
-	    Do_before_change( $S, $options ) && return 1;
-
-	    if ( !$options->{'simul'} ) {
-
-		#Do_moveold( $dest, $options );
-
-		if (deferredlogsystem(
-			"/usr/bin/touch -t 197901010000 '" . $dest . "'"
-		    )
-		    )
-		{
-		    Warn( $ERR_OPEN,
-			"Impossible de creer le fichier " . $dest );
-		    return 1;
-		}
-	    }
-	}
-    }
-    else {
-	my $source;
-	my $tmp;
-
-	$source = Get_source( Subst_vars( $S->{'source'} ) );
-	$SUBST{'SOURCE'} = $source;
-
-	$tmp = Get_tmp_dest($dest);
-	$SUBST{'DESTINATION'} = $tmp;
-
-	if ( !-f $source ) {
-	    Warn( $ERR_OPEN, "Impossible d'ouvrir " . $source );
-	    return 1;
-	}
-
-	if ( defined( $S->{'filter'} ) ) {
-	    my $filter = Subst_vars( $S->{'filter'} );
-	    if ( deferredlogsystem($filter) ) {
-		Warn( $ERR_OPEN, "Impossible d'appliquer " . $filter );
-		return 1;
-	    }
-	}
-	else {
-
-	    if (deferredlogsystem(
-		    "/bin/cp -a '" . $source . "' '" . $tmp . "'"
-		)
-		)
-	    {
-		Warn( $ERR_OPEN,
-		    "Impossible de copier " . $source . " vers " . $tmp );
-		return 1;
-	    }
-	}
-
-	if ( !-f $tmp ) {
-	    Warn( $ERR_OPEN, "Impossible d'ouvrir " . $tmp );
-	    return 1;
-	}
-
-	if ( !-f $dest ) {
-	    $cmp = 1;
-
-	    if ( $options->{'verbose'} || $options->{'simul'} ) {
-		Log("(action needed)");
-	    }
-
-	    Do_on_config( $S, $options ) && return 1;
-
-	    Do_before_change( $S, $options ) && return 1;
-
-	    if ( !$options->{'simul'} ) {
-
-		#Do_moveold( $dest, $options );
-
-		if (deferredlogsystem(
-			"/bin/cp -a '" . $source . "' '" . $dest . "'"
-		    )
-		    )
-		{
-		    Warn( $ERR_OPEN,
-			"Impossible de creer le fichier " . $dest );
-		    return 1;
-		}
-	    }
-	}
-    }
-
-    Do_chownmod( $S, $dest, $options );
-
-    if ($cmp) {
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$DEPENDS{'mkdir'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    while ( $dest ne '/' && $dest ne '.' ) {
-	$S->{'depends'} .= " " . dirname($dest);
-	$dest = dirname($dest);
-    }
-};
-
-$FUNCTIONS{'mkdir'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $cmp = 0;
-
-    $SUBST{'SECTIONNAME'} = $dest;
-    if ( !-d $dest ) {
-	$cmp = 1;
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !$options->{'simul'} ) {
-	    Do_moveold( $dest, $options );
-
-	    if ( deferredlogsystem( "/bin/mkdir -p '" . $dest . "'" ) ) {
-		Warn( $ERR_OPEN,
-		    "Impossible de creer le repertoire " . $dest );
-		return 1;
-	    }
-	}
-    }
-
-    Do_chownmod( $S, $dest, $options );
-
-    if ($cmp) {
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$FUNCTIONS{'removefile'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $cmp = 0;
-    if ( -d $dest ) {
-	Warn( $ERR_OPEN,
-	    "La destination " . $dest . "doit etre un fichier!" );
-	return 1;
-    }
-    if ( -f $dest ) {
-	$cmp = 1;
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !$options->{'simul'} ) {
-
-	    Do_moveold( $dest, $options );
-
-	    # Pas besoin, move -> del
-	    #if (!unlink($dest) )
-	    #{
-	    #    Warn( $ERR_OPEN,
-	    #        "Impossible d'effacer " . $dest );
-	    #    return;
-	    #}
-	}
-    }
-
-    # Mais bien sur
-    #Do_chownmod( $S, $dest, $options );
-
-    if ($cmp) {
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-$FUNCTIONS{'removedir'} = sub {
-    my ( $S, $dest, $options ) = @_;
-
-    my $cmp = 0;
-    if ( -e $dest && !-d $dest ) {
-	Warn( $ERR_OPEN,
-	    "La destination " . $dest . "doit etre un repertoire!" );
-	return 1;
-    }
-    if ( -d $dest ) {
-	$cmp = 1;
-
-	if ( $options->{'verbose'} || $options->{'simul'} ) {
-	    Log("(action needed)");
-	}
-
-	Do_on_config( $S, $options ) && return 1;
-
-	Do_before_change( $S, $options ) && return 1;
-
-	if ( !$options->{'simul'} ) {
-
-	    Do_moveold( $dest, $options );
-
-	    # Pas besoin, move -> del
-	    #if (!rmdir($dest) )
-	    #{
-	    #    Warn( $ERR_OPEN,
-	    #        "Impossible d'effacer " . $dest );
-	    #    return;
-	    #}
-	}
-    }
-
-    # Mais bien sur
-    #Do_chownmod( $S, $dest, $options );
-
-    if ($cmp) {
-	Do_after_change( $S, $options ) && return 1;
-
-	Do_on_noaction( $S, $options ) && return 1;
-    }
-
-    return 0;
-};
-
-sub Mk_dest_dir {
-    my ($dir) = @_;
-
-    $dir =~ s://:/:g;    # supprimer // sinon ca marche moins bien
-
-    $dir =~ s:/[^/]+/*$::;
-
-    # verif que pas un fichier a la place d'un rep au milieu du mkdir -p
-    my $dir2 = $dir;
-    while ( $dir2 ne "" && !-e $dir2 ) {
-	$dir2 =~ s:/[^/]+/*$::;
-    }
-    if ( $dir2 ne "" && -e $dir2 && !-d $dir2 ) {
-	unlink($dir2);
-    }
-
-    $dir && return system( "/bin/mkdir -p '" . $dir . "' >/dev/null 2>&1" );
-}
-
-sub Get_tmp_dest {
-    my ($dest) = @_;
-
-    my $tmp = $CVS_TMP_DIR . "/" . $dest;
-
-    Mk_dest_dir($tmp);
-
-    if ( -d $tmp ) {
-	rmdir($tmp);
-    }
-    elsif ( -e $tmp ) {
-	unlink($tmp);
-    }
-
-    return $tmp;
-}
-
-sub Get_source {
-    my ($source) = @_;
-
-    $source =~ s!^HOST:!$CVS_WORKING_DIR/$CVS_CONFIG/$HOSTTYPE!;
-    $source =~ s!^CONFIG:!$CVS_WORKING_DIR/$CVS_CONFIG/!;
-    $source =~ s!^CVS:!$CVS_WORKING_DIR/!;
-    $source =~ s!^GLOBAL:!$GLOBAL_CONF/!;
-    return $source;
-}
-
-sub Trie_prio {
-    my ( $C, $a ) = @_;
+sub __Sort_depends_prio ($$) {
+    my ( $action, $section ) = @_;
 
     my $prio = 0;
 
-    if ( $a eq "/etc/passwd" ) {
-	return $prio;
-    }
+    # First : authentication parts
+    return $prio if ( $section eq "/etc/passwd" );
     $prio++;
-    if ( $a eq "/etc/group" ) {
-	return $prio;
-    }
+    return $prio if ( $section eq "/etc/group" );
+    $prio++;
+    return $prio if ( $section eq "/etc/shadow" );
+    $prio++;
+    return $prio if ( $section eq "/etc/gshadow" );
     $prio++;
 
-    if ( $a eq "/etc/shadow" ) {
-	return $prio;
-    }
+    # Second : directory and mount points
+    return $prio if ( $action eq 'mkdir' );
     $prio++;
-    if ( $a eq "/etc/gshadow" ) {
-	return $prio;
-    }
+    return $prio if ( $action eq 'addmount' );
     $prio++;
 
-    if ( $C->{$a}->{'action'} eq 'mkdir' ) {
-	return $prio;
-    }
+    # Third : Packaging infra and packages
+    return $prio if ( $section =~ /^\/etc\/apt\// );
     $prio++;
-    if ( $C->{$a}->{'action'} eq 'addmount' ) {
-	return $prio;
-    }
+    return $prio if ( $section eq "pf-tools" );
+    $prio++;
+    return $prio if ( $action eq "dpkg-purge" || $action eq "purgepkg" );
+    $prio++;
+    return $prio if ( $action eq "apt-get" || $action eq "installpkg" );
     $prio++;
 
-    if ( $a =~ m|^/etc/apt/| ) {
-	return $prio;
-    }
+    # Fourth : creations and adds for files and links
+    return $prio if ( $action eq 'createfile' );
     $prio++;
-    if ( $a eq "pf-tools" ) {
-	return $prio;
-    }
+    return $prio if ( $action eq 'addfile' );
+    $prio++;
+    return $prio if ( $action eq 'addlink' );
     $prio++;
 
-    if ( $C->{$a}->{'action'} eq 'dpkg-purge' ) {
-	return $prio;
-    }
-    $prio++;
-    if ( $C->{$a}->{'action'} eq 'apt-get' ) {
-	return $prio;
-    }
+    # Fifth : removing files and dirs
+    return $prio if ( $action =~ /^remove/ );
     $prio++;
 
-    if ( $C->{$a}->{'action'} eq 'createfile' ) {
-	return $prio;
-    }
-    $prio++;
-    if ( $C->{$a}->{'action'} eq 'addfile' ) {
-	return $prio;
-    }
-    $prio++;
-
-    if ( $C->{$a}->{'action'} eq 'addlink' ) {
-	return $prio;
-    }
-
-    if ( $C->{$a}->{'action'} eq 'removefile' ) {
-	return $prio;
-    }
-    if ( $C->{$a}->{'action'} eq 'removedir' ) {
-	return $prio;
-    }
-    $prio++;
+    # Last : other elements
     return $prio;
 }
 
-sub Trie_dependances {
-    my ( $C, $a, $b ) = @_;
+sub Sort_config_sections ($$$) {
+    my ( $host_config, $a, $b ) = @_;
 
-    my $prioa = Trie_prio( $C, $a );
-    my $priob = Trie_prio( $C, $b );
+    my $prioa = __Sort_depends_prio( $host_config->{$a}->{'action'}, $a );
+    my $priob = __Sort_depends_prio( $host_config->{$b}->{'action'}, $b );
 
     if ( $prioa != $priob ) {
-	return $prioa <=> $priob;
-    }
-    else {
-	return $a cmp $b;
-    }
-}
-
-sub Do_updateloop {
-    my ( $C, $options, @sortedkeys ) = @_;
-    my $s;
-    my $errorcount = 0;
-
-    foreach $s (@sortedkeys) {
-	if (   defined( $C->{$s} )
-	    && !defined( $C->{$s}->{'doing'} )
-	    && !defined( $C->{$s}->{'done'} ) )
-	{
-
-	    $C->{$s}->{'doing'} = 1;
-
-	    if (   defined( $C->{$s}->{'action'} )
-		&& defined( $DEPENDS{ $C->{$s}->{'action'} } ) )
-	    {
-		$DEPENDS{ $C->{$s}->{'action'} }->( $C->{$s}, $s, $options );
-	    }
-
-	    if ( defined( $C->{$s}->{'depends'} ) ) {
-		my @dependsraw;
-		my @depends;
-		my $d;
-
-		@dependsraw = split( /[ ,]+/, $C->{$s}->{'depends'} );
-
-		foreach $d (@dependsraw) {
-		    if ( defined($d) && $d ne "" && defined( $C->{$d} ) ) {
-			if ( $d eq $s ) {
-			    Warn ( $ERR_SYNTAX,
-				"["
-				. $s
-				. "] circular dependancy detected, skipping this depend"
-			    );
-			    FlushLog();
-			    next;
-			}
-			push @depends, $d;
-			if ( $C->{$d}->{'action'} eq 'addmount' ) {
-			    Warn( $ERR_OPEN,
-				"[" 
-				. $s
-				. "] depends on addmount ["
-				. $d
-				. "], it may not work during install!" );
-			    FlushLog();
-			}
-		    }
-		}
-
-		if ( $#depends >= 0 ) {
-		    Log( "<" . $s . "> " . join( ' ', @depends ) );
-		    $errorcount += Do_updateloop( $C, $options, @depends );
-		}
-	    }
-
-	    Log( "[" . $s . "]" );
-
-	    if ( !defined( $C->{$s}->{'action'} ) ) {
-		Abort( $ERR_SYNTAX, "Action non definie" );
-	    }
-	    if ( !defined( $FUNCTIONS{ $C->{$s}->{'action'} } ) ) {
-		Abort( $ERR_SYNTAX,
-		    "Action inconnue '" . $C->{$s}->{'action'} . "'" );
-	    }
-
-	    if ($FUNCTIONS{ $C->{$s}->{'action'} }->( $C->{$s}, $s, $options )
-		)
-	    {
-		FlushLog();
-		$errorcount++;
-	    }
-	    else {
-		DelLog();
-	    }
-
-	    $C->{$s}->{'done'} = 1;
-	}
+        return $prioa <=> $priob;
     }
 
-    return $errorcount;
-}
-
-sub Do_update {
-    my ($ref_options) = @_;
-
-    my $C;
-    my $s;
-
-    #     my $options;
-    my @sortedkeys;
-    my $errorcount = 0;
-
-    #     if ( $ref_options->{'help'} ) {
-    #         Do_help();
-    #         exit;
+    #     else {
+    # 		return $a cmp $b;
     #     }
-
-    my $branchecvs;
-
-    # Si le demande a ma machine une branche precise
-    $branchecvs
-	= ( $ref_options->{"branche-cvs"} )
-	? $ref_options->{"branche-cvs"}
-	: GetBrancheFromCmdLine();
-
-    # Sinon je repart sur celle d'avant
-    $branchecvs = GetRunningBrancheName() unless $branchecvs;
-
-    if ( CVS_update( $branchecvs, $ref_options ) || ( !( $C = Get_conf() ) ) )
-    {
-	Abort( $ERR_OPEN, "Impossible de charger la configuration\n" );
-    }
-
-    SaveRunningBrancheName($branchecvs);
-
-    if ( defined( $ref_options->{'noupdate'} ) ) {
-	Abort( $ERR_OPEN, "Configuration desactivee [noupdate]" );
-    }
-
-    @sortedkeys = sort { Trie_dependances( $C, $a, $b ) } keys %$C;
-
-    $| = 1;
-    $errorcount = Do_updateloop( $C, $ref_options, @sortedkeys );
-
-    Log( $errorcount . " error(s) detected." );
-    FlushLog();
-}
-
-sub Get_conf {
-
-    my $C = {};
-    my $template;
-    my $conf;
-
-    $HOSTNAME =~ /^(.*?)(\d*)([a-z]*)$/;
-
-#$template = "update-" . $1 . "(" . $2 . "(" . $3 . ")?)?"; FAIT PLANTER PERL5.6 XXX
-    $template = "update-" . $1 . "(" . $2 . "|" . $2 . $3 . ")?";
-
-    opendir( CONFIG, Get_source("GLOBAL:") );
-    foreach $conf ( $COMMON, sort grep ( /^$template$/, readdir(CONFIG) ) ) {
-	my $c = Load_conf( Get_source( "GLOBAL:" . $conf ), 1 );
-	foreach ( keys %$c ) {
-	    if ( $c->{$_}->{'action'} eq 'ignore' && !defined( $C->{$_} ) ) {
-		Warn( $ERR_OPEN,
-		    "ignoring previous inexistant [" . $_ . "] in " . $conf );
-	    }
-	    $C->{$_} = $c->{$_};
-	}
-    }
-    closedir(CONFIG);
-
-    return $C;
-}
-
-# Enregsitre le nom de la branche utilise actuellement dans le dossier
-# PF_STATUS_DIR, le but de ce fichier est de permettre a update-config
-# retrouver la branche du CVS qu'il doit MAJ.
-sub SaveRunningBrancheName($) {
-
-    `mkdir -p $PF_STATUS_DIR` unless ( -d $PF_STATUS_DIR );
-    my $branche = shift;
-    open STATUSBRANCHE, ">$PF_STATUS_DIR" . "/branche";
-    print STATUSBRANCHE $branche if $branche;
-    close STATUSBRANCHE;
-
-}
-
-sub GetRunningBrancheName {
-
-    return unless ( -r $PF_STATUS_DIR . "/branche" );
-
-    open STATUSBRANCHE, "<$PF_STATUS_DIR" . "/branche";
-
-    my @STATUSBRANCHE = <STATUSBRANCHE>;
-
-    close STATUSBRANCHE;
-    return shift @STATUSBRANCHE;
-
-}
-
-# Si une branche a été passée en para, elle est retournée sinon undef.
-sub GetBrancheFromCmdLine {
-
-    my $branche;
-    open CMDLINE, "</proc/cmdline";
-    $branche = $1 if ( <CMDLINE> =~ /pfbcvs=(\S+)/ );
-
-    close CMDLINE;
-
-    return $branche;
-
-}
-
-# MAJ le CVS, peut mettre une branche précise à jour, en passant le nom
-# de cette branche en paramètre
-sub CVS_update (;$$) {
-    my ( $branche, $options ) = @_;
-
-    if ($branche) {
-	if ( defined $CVS_COMMAND ) {
-	    print
-		"Attention : j'ignore la variable \$CVS_COMMAND définie dans "
-		. "`$PFTOOLSCONF' car j'utilise une branche précise ($branche)\n"
-		if defined $options and $options->{verbose};
-	    undef $CVS_COMMAND;
-	}
-	$CVS_BRANCHE = $branche;
-    }
-
-    my $ret;
-    my $umask = umask($CVS_UMASK);
-    my $olddeferredlog;
-
-    $ENV{'CVS_RSH'} = $CVS_RSH;
-
-    # CVS_COMMAND peut deja etre def dans /etc/pf-tools.conf
-    unless ( defined($CVS_COMMAND) and ($CVS_COMMAND) ) {
-	if ( $HOSTNAME =~ /^deploy\d+/ or -d "/vol" ) {
-	    $CVS_COMMAND = "/usr/bin/cvs -R -d '";
-	}
-	else {
-	    $CVS_COMMAND
-		= "/usr/bin/cvs -d ':ext:"
-		. $CVS_USER . "\@"
-		. $CVS_SERVER . ":";
-	}
-
-	$CVS_COMMAND .= $CVS_REPOSITORY . "'";
-
-	$CVS_COMMAND .= " checkout ";
-	$CVS_COMMAND .= " -r $CVS_BRANCHE" if ($CVS_BRANCHE);
-
-	$CVS_COMMAND .= " $CVS_CONFIG";
-
-    }
-
-    print $CVS_COMMAND. "\n" if $options->{'debug'} or $options->{'verbose'};
-
-    system( "/bin/mkdir -p '" . $CVS_WORKING_DIR . "' 2>/dev/null" );
-
-    $olddeferredlog = $DEFERREDLOG;
-    $DEFERREDLOG    = 1;
-    $ret            = deferredlogsystem(
-	"cd '" . $CVS_WORKING_DIR . "';" . $CVS_COMMAND );
-    $DEFERREDLOG = $olddeferredlog;
-
-    if ($ret) {
-	FlushLog();
-    }
-    else {
-	DelLog();
-    }
-
-    umask($umask);
-    return $ret;
 }
 
 1;
-

Modified: trunk/sbin/fix_hosts
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/fix_hosts?rev=902&op=diff
==============================================================================
--- trunk/sbin/fix_hosts (original)
+++ trunk/sbin/fix_hosts Wed Sep  8 19:28:28 2010
@@ -24,124 +24,124 @@
 use strict;
 use warnings;
 
-use Sys::Hostname ;
-use Digest::MD5;
-use PFTools::Conf ;
-use PFTools::Net;
-use PFTools::Update;
-use File::Compare ;
-use File::Copy ;
+use Data::Dumper;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Getopt::Long qw( :config ignore_case_always bundling );
+use IO::File;
+use Sys::Hostname;
+
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+#################################
+# VARS
+my $HELP              = 0;
+my $HOSTNAME          = hostname;
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $IP_TYPE           = 'ipv4';
+my $INPUT_FILE        = '/etc/hosts';
+my $OUTPUT_FILE       = '/etc/hosts';
+my $GLOBAL_STRUCT     = {};
 
 my $program = $0;
-$program =~ s%.*/%%; # cheap basename
+$program =~ s%.*/%%;    # cheap basename
 
 my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
 
-my $HOSTS_CFG	= "/etc/hosts" ;
-my $HOSTNAME	= hostname ;
-my $DEST	= "-" ;
-my $NET		= "GLOBAL:private-network" ;
-my $HELP	= 0 ;
-my $DEBUG	= 0 ;
-my $VERBOSE	= 0 ;
+###################################
+# Funtions
 
-sub Display_usage () {
-print STDERR << "# ENDHELP";
+sub Do_help {
+    print STDERR << "# ENDHELP";
     $program - version $version
 
-Usage:	$0 [options]
-	-h --help:	print help and exit
-	-v --verbose:	be more verbose
-	-s --src	source for hosts configuration (default: /etc/hosts)
-	-d --dest	destination for fixed information (default: /etc/hosts)
-	--host		hostname on which hosts configuration applied
-	-n --net	Possiblitiy for defining an alternate PATH for private-network file (default GLOBAL:private-network)
+Usage:	$program [options]
+	--help		: print help and exit
+	-h --host	: hostname for which we want to build interfaces file
+	-s --site	: site on which hostname is defined (optional)
+	-c --config	: file where pf-tools configuration is stored e.g. /etc/pf-tools.conf (optional)
+	--store		: file where global structure datas are in storable format (optional)
+	-t --type	: IP type to fix, allowed values are ipv4 and ipv6. Default value is ipv4
+	-i --input	: input file to fix default value is /etc/hosts
+	-o --output	: output file default value is /etc/hosts
+    
 # ENDHELP
 }
 
+##################################
+### MAIN
 
-sub Fix_hosts ($$$) {
-	my ( $hostname, $ip_systeme, $dst ) = @_ ;
+GetOptions(
+    'help'       => \$HELP,
+    'host|h=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'type|t=s'   => \$IP_TYPE,
+    'input|i=s'  => \$INPUT_FILE,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
 
-	unless ( open ( HOSTS, $HOSTS_CFG ) ) {
-		warn "Unable top open ".$HOSTS_CFG."\n" ;
-		return 0 ;
-	}
-	my @tmp_hosts = <HOSTS> ;
-	foreach ( @tmp_hosts ) {
-		chomp ;
-		next if ( ! /$hostname/ ) ;
-		s/^127.0.([\d]{1,3}\.[\d]{1,3})/$ip_systeme/ ;
-	}
-	
-	if ( $dst eq '-' ) {
-		foreach ( @tmp_hosts ) {
-			print $_."\n" ;
-		}
-		return 1 ;
-	}
-	else {
-		unless ( open ( TMPDST, ">/tmp/etc_hosts" ) ) {
-			warn "Unable to open temporary destination file /tmp/etc_hosts\n" ;
-			return 0 ;
-		}
-		foreach ( @tmp_hosts ) {
-			print TMPDST $_."\n" ;
-		}
-		close ( TMPDST ) ;
-		if ( compare ( '/tmp/etc_hosts', $dst ) ) {
-			return move ( '/tmp/etc_hosts', $dst) ;
-		} else {
-			if ( $DEBUG ) {
-				warn "No need to move /tmp/etc_hosts to ".$dst." they are equals\n" ;
-				warn "Unlinking source file /tmp/etc_hosts\n" ;
-			}
-			if ( ! unlink ( '/tmp/etc_hosts' ) ) {
-				warn "Unable to unlink source file /tmp/etc_hosts\n" ;
-				warn "Please clean it manually\n" ;
-			}
-		}
-		return 1 ;
-	}
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-##### MAIN
-GetOptions(
-    'src|s=s'	=> \$HOSTS_CFG,
-    'dst|d=s'	=> \$DEST,
-    'host=s'	=> \$HOSTNAME,
-    'net|n=s'	=> \$NET,
-    'debug'	=> \$DEBUG,
-    'help|h'	=> \$HELP,
-    'verbose|v'	=> \$VERBOSE
-) or die "GetOptions error, try --help: $!\n";
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
-if ( $HELP ) {
-	Display_usage () ;
-	exit 0 ;
-}
-elsif ( ! -e $HOSTS_CFG ) {
-	die "Unexistant hosts configuration ".$HOSTS_CFG."\n" ;
-}
-elsif ( -z $HOSTS_CFG ) {
-	die "Empty configuration file for hosts ".$HOSTS_CFG."\n" ;
+if ( !$PF_CONFIG->{'features'}->{$IP_TYPE} ) {
+    print Dumper $PF_CONFIG;
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Aborting because " . $IP_TYPE . " is not activated inot PF-Tools" );
 }
 
-$DEST = "-" if ( $DEBUG ) ;
-$VERBOSE = 1 if ( $DEBUG ) ;
-
-my $NETWORK		= Init_lib_net ( Get_source ( $NET ) ) ;
-my ( $IF_SYS, $MAC )	= Get_Dhcp_Infos ( $NETWORK, $HOSTNAME ) ;
-my $subst = {} ;
-Init_SUBST ( $subst, $HOSTNAME, 'private' ) ;
-my $IF_LIST		= $NETWORK->{'SERVERS'}->{'BY_NAME'}->{$subst->{'HOSTTYPE'}}->{'SRVLIST'}->{$HOSTNAME}->{'ifup'} ;
-my $VLAN		= '' ;
-foreach my $if ( keys %{$IF_LIST} ) {
-	$VLAN = $if if ( $IF_LIST->{$if} eq $IF_SYS ) ;
-}
-my $IP_SYS	= $NETWORK->{'SERVERS'}->{'BY_NAME'}->{$subst->{'HOSTTYPE'}}->{'SRVLIST'}->{$HOSTNAME}->{'zone'}->{$VLAN}->{'FIELD'} ;
-if ( ! Fix_hosts ( $HOSTNAME, $IP_SYS, $DEST ) ) {
-	die "Unable to fix file ".$HOSTS_CFG."\n" ;
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
 }
 
+my $fixed_input
+    = Fix_hosts( $HOSTNAME, $INPUT_FILE, $SITE, $IP_TYPE, $GLOBAL_STRUCT,
+    $PF_CONFIG );
+if ( !defined $fixed_input ) {
+    Abort( $CODE->{'EXEC'},
+        "An error occured during fixing file " . $OUTPUT_FILE );
+}
+
+my $output_fh = IO::File->new("> $OUTPUT_FILE")
+    or Abort( $CODE->{'OPEN'},
+        "Unable to open destination file $OUTPUT_FILE: $OS_ERROR" );
+$output_fh->print ( join '', @{$fixed_input} )
+    or Abort ( $CODE->{'OPEN'},
+        "Unable to write to destination file $OUTPUT_FILE: $OS_ERROR" );
+$output_fh->close()
+    or Abort( $CODE->{'OPEN'},
+        "Unable to close destination file $OUTPUT_FILE: $OS_ERROR" );
+
+exit 0;

Modified: trunk/sbin/mk_dhcp
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/mk_dhcp?rev=902&op=diff
==============================================================================
--- trunk/sbin/mk_dhcp (original)
+++ trunk/sbin/mk_dhcp Wed Sep  8 19:28:28 2010
@@ -24,167 +24,92 @@
 use strict;
 use warnings;
 
-use PFTools::Net;
-use PFTools::Conf ;
-use PFTools::Update;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use IO::File;
 
-sub Mk_dhcp {
-    my ( $head, $fic, $Z ) = @_;
-    my $oldout;
-    my $vlan;
-    my $s;
+use PFTools::Logger;
+use PFTools::Utils;
 
-    my $dhcpvlanregex
-	= '^([^.]+)\.('
-	. join( '|', @{ $Z->{'SOA'}->{'dhcpvlan'} } )
-	. ')(\.*)?$';
+#####################################
+# Vars
+my $HELP              = 0;
+my $HEADER            = '';
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $OUTPUT_FILE       = '';
+my $GLOBAL_STRUCT     = {};
 
-    open( FIC, ">" . $fic ) || die "Cannot open " . $fic . " : " . $!;
-    $oldout = select(FIC);
+my $program = $0;
+$program =~ s%.*/%%;    # cheap basename
 
-    open( HEAD, "<" . $head ) || die "Cannot open " . $head . " : " . $!;
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
 
-    while (<HEAD>) {
-	print;
-    }
+#####################################
+# Functions
 
-    close(HEAD);
+sub Do_help {
+    print STDERR << "# ENDHELP";
+    $program - version $version
 
-    print "\n";
-
-    # Mlt : dhcpvlanpartial = subnets ou seulement certaine machines auront une section host
-    foreach $vlan ( @{ $Z->{'SOA'}->{'dhcpvlan'} }, @{ $Z->{SOA}->{dhcpvlanpartial} } ) {
-	printf( "# %s\n",
-	    $Z->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'comment'} );
-	printf(
-	    "subnet %s netmask %s {\n}\n\n",
-	    $Z->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'network'},
-	    $Z->{'NETWORK'}->{'BY_NAME'}->{$vlan}->{'netmask'}
-	);
-    }
-
-    print "\n";
-
-    foreach $s ( sort ( keys %{ $Z->{'SERVERS'}->{'BY_ADDR'} } ) ) {
-	foreach my $host ( @{$Z->{'SERVERS'}->{'BY_ADDR'}->{$s}} ) {
-
-	    print "# ",         $host->{'comment'}, "\n";
-	    print "# number: ", $host->{'number'},  "\n";
-	    print "# nodes:  ", $host->{'nodes'},   "\n" if ( defined( $host->{'nodes'} ) && $host->{'nodes'} > 1 );
-	    print "\n";
-
-	    foreach my $m ( sort ( keys %{ $host->{'SRVLIST'} } ) ) {
-		my $nam;
-		my $M = $host->{'SRVLIST'}->{$m};
-
-		foreach $nam ( sort ( keys %{ $M->{'zone'} } ) ) {
-
-                # Mlt : traitement dhcpvlanpartial : ajout des hosts concernes.
-                # !!! Il ne peut Y avoir qu'une SEULE entree dhcp de deploiement par machine !!!
-                # !!! entre autre parcequ'il n'y a qu'un seul ether.n par machine :-)        !!!
-                # !!! donc la presence de cette directive au niveau d'une machine annule le  !!!
-                # !!! traitement des autres declaration dans des vlans plus globaux.         !!!
-                my $nam2 = '' ;
-                if ( $nam =~ /$dhcpvlanregex/ ) {
-                    if ( ! defined $M->{dhcpvlan} ) {
-                        $nam2 = $1;
-                    }
-                }
-                if ( defined $M->{dhcpvlan} ) {
-                    my $dhcpvlanpartialregex = '^([^.]+)\.' . $M->{dhcpvlan} . '(\.*)?$';
-                    if ( $nam =~ /$dhcpvlanpartialregex/ ) {
-                        $nam2 = $1;
-                    }
-                }
-
-                if ( $nam2 ) {
-			my $hostnum = $nam2;
-			$hostnum =~ s/^.*?(\d*)[a-z]*$/$1/;
-			$hostnum =~ s/^0*//;
-			if ( $hostnum eq "" ) { $hostnum = 0; }
-
-			if ( defined( $M->{'zone'}->{$nam}->{'ether'} ) ) {
-			    printf( "host %s {\n", $nam2 );
-			    printf( "  hardware ethernet %s;\n", $M->{'zone'}->{$nam}->{'ether'} );
-			    printf( "  fixed-address %s.%s;\n", $nam, $Z->{'SOA'}->{'name'} );
-
-                            # Mlt : Option router ...
-                            # Si on trouve une route par defaut sur ce reseau on ajoute l'option routers
-                            foreach my $route ( keys %{ $M->{route}->{$M->{ifup}->{$nam}} } ) {
-                                    if ( $M->{route}->{$M->{ifup}->{$nam}}->{$route} =~  /^default\s([^;]+)/ ) {
-                                            printf( "  option routers %s;\n", $1) ;
-                                    }
-                            }
-
-			    if ( defined( $M->{'filename'} ) && $M->{'filename'} ne "" ) {
-				printf( "  filename \"%s\";\n", $M->{'filename'} );
-			    }
-
-			    if ( $M->{'initrd'} ) { printf qq{# initrd "%s";\n}, $M->{'initrd'}; }
-
-			    if ( $M->{'cmdline'} ) { printf qq{# cmdline "%s";\n}, $M->{'cmdline'}; }
-
-			    if ( $M->{'console'} ) { printf qq{# console "%s";\n}, $M->{'console'}; }
-
-			    if ( defined( $M->{'pxefilename'} ) && $M->{'pxefilename'} ne "" ) {
-				if ( $M->{'arch'} eq 'amd64' ) {
-				    printf( "# pxefilename \"%s\";\n", $M->{'arch'}."/".$M->{'pxefilename'} );
-				}
-				else {
-				    printf( "# pxefilename \"%s\";\n", $M->{'pxefilename'} );
-				}
-			    }
-
-			    if ( defined( $M->{'pxelinuxconf'} ) && $M->{'pxelinuxconf'} ne "" ) {
-				printf( "  option option-209 \"%s\";\n", $M->{'pxelinuxconf'} );
-			    }
-
-			    my @dns = Get_dns_from_zone( $Z, $M, $hostnum );
-
-			    if ( $#dns >= 0 && defined $dns[0] ) {
-				printf( "  option domain-name-servers %s;\n", join( ", ", @dns ) );
-			    }
-
-			    print "}\n\n";
-			}
-			if ( defined( $M->{'zone'}->{$nam}->{'vmether'} ) && ( $PFTOOLS_VARS->{'VMWARE'} || $PFTOOLS_VARS->{'UML'} ) ) {
-			    printf( "host %s {\n", $nam2 );
-			    printf( "  hardware ethernet %s;\n", $M->{'zone'}->{$nam}->{'vmether'} );
-			    printf( "  fixed-address %s.%s;\n", $nam, $Z->{'SOA'}->{'name'} );
-
-			    if ( defined( $M->{'vmwfilename'} ) && $M->{'vmwfilename'} ne "" ) {
-				printf( "  filename \"%s\";\n", $M->{'vmwfilename'} );
-			    }
-
-			    if ( defined( $M->{'pxelinuxconf'} ) && $M->{'pxelinuxconf'} ne "" ) {
-				printf( "  option option-209 \"%s\";\n", $M->{'pxelinuxconf'} );
-			    }
-
-			    my @dns = Get_dns_from_zone( $Z, $M, $hostnum );
-
-			    if ( $#dns >= 0 && defined $dns[0] ) {
-				printf( "  option domain-name-servers %s;\n", join( ", ", @dns ) );
-			    }
-
-			    print "}\n\n";
-			}
-		    }
-		}
-	    }
-	}
-	
-	print "\n";
-    }
-
-    $| = 1;
-    select($oldout);
-    close(FIC);
+Usage:	$program [options]
+	--help		: print help and exit
+	-H --header : header file for dhcp configuration
+	-s --site	: site on which hostname is defined
+	--store		: file where global structure datas are in storable format (optional)
+	-c --config	: pf-tools config file (optional)
+	-o --output	: output file
+    
+# ENDHELP
 }
 
-my ($HEAD, $SRC, $DST) = @ARGV;
-unless ( $HEAD and $SRC and $DST ) {
-    die "Usage: $0 head src dest\n";
+############################################
+### MAIN
+
+GetOptions(
+    'help'       => \$HELP,
+    'H|header=s' => \$HEADER,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
+
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-Mk_dhcp( Get_source($HEAD), $DST, Init_lib_net( Get_source($SRC) ) );
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( "", $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        Abort( $CODE->{'UNDEF_KEY'},
+            "A site MUST BE defined for building DNS zone forward" );
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
+}
+
+if ( !defined $GLOBAL_STRUCT->{'DHCP'}->{'BY_SITE'}->{$SITE} ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Site " . $SITE . " is not defined into global configuration" );
+}
+
+my $DHCP = Mk_dhcp( $HEADER, $GLOBAL_STRUCT->{'DHCP'}->{'BY_SITE'}->{$SITE} );
+
+my $output_fh = IO::File->new ( '>' . $OUTPUT_FILE )
+    or Abort( $CODE->{'OPEN'},
+        "Unable to open destination file $OUTPUT_FILE: $OS_ERROR" );
+$output_fh->print ( join "\n", @{$DHCP} )
+    or Abort( $CODE->{'OPEN'},
+        "Unable to write to destination file $OUTPUT_FILE: $OS_ERROR" );
+$output_fh->close()
+    or Abort( $CODE->{'OPEN'},
+        "Unable to close destination file $OUTPUT_FILE: $OS_ERROR" );
+
+exit 0;

Modified: trunk/sbin/mk_grubopt
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/mk_grubopt?rev=902&op=diff
==============================================================================
--- trunk/sbin/mk_grubopt (original)
+++ trunk/sbin/mk_grubopt Wed Sep  8 19:28:28 2010
@@ -24,114 +24,124 @@
 use strict;
 use warnings;
 
-use Sys::Hostname ;
-use Digest::MD5;
-use PFTools::Net;
-use PFTools::Update;
-use File::Compare ;
-use File::Copy ;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
+
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+####################################################
+# Vars
+
+my $GRUB_VERSION      = 2;
+my $MENU_GRUB         = "";
+my $HOSTNAME          = "";
+my $SITE              = "";
+my $OUTPUT            = "";
+my $HELP              = 0;
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $GLOBAL_STRUCT     = {};
 
 my $program = $0;
-$program =~ s%.*/%%; # cheap basename
+$program =~ s%.*/%%;    # cheap basename
 
 my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
 
-my $MENU_GRUB	= "/boot/grub/menu.lst" ;
-my $HOSTNAME	= hostname ;
-my $DEST	= "-" ;
-my $NET		= "GLOBAL:private-network" ;
-my $HELP	= 0 ;
-my $DEBUG	= 0 ;
-my $VERBOSE	= 0 ;
+######################################################
+# Functions
 
-sub Display_usage () {
-print STDERR << "# ENDHELP";
+sub Do_help () {
+    print STDERR << "# ENDHELP";
     $program - version $version
 
-Usage:	$0 [options]
-	-h --help:	print help and exit
-	-v --verbose:	be more verbose
-	-s --src	source for GRUB configuration (default: /boot/grub/menu.lst)
-	-d --dst	destination for modified GRUB configuration (default: /boot/grub/menu.lst)
-	--host		hostname on which GRUB configuration applied
-	-n --net	Possiblitiy for defining an alternate PATH for private-network file (default GLOBAL:private-network)
+Usage:	$program [options]
+	-h --help	: print help and exit
+	-h --host	: the hostname for which you want to build grub configuration
+	-s --site	: the site where the hostname is defined
+	--src		: the source for grub configuration
+	--grub		: version of grub default value is 2
+	-o --output	: destination for modified GRUB configuration
+	--store		: path for accessing storable file containing the global configuration
+	-c --config	: path for accessing pf-tools.conf file
 # ENDHELP
 }
 
+#######################################################""
+### MAIN
 
-sub Change_kopt ($$$) {
-	my ( $cmd_line, $menulst, $dst ) = @_ ;
+GetOptions(
+    'help'       => \$HELP,
+    'h|host=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'src=s'      => \$MENU_GRUB,
+    'grub=s'     => \$GRUB_VERSION,
+    'o|output=s' => \$OUTPUT,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+) or die "Didn't grok options (see --help).\n";
 
-	unless ( open ( MENU, $menulst ) ) {
-		warn "Unable top open ".$menulst."\n" ;
-		return 0 ;
-	}
-	my @tmp_grub = <MENU> ;
-	foreach ( @tmp_grub ) {
-		chomp ;
-		next if ( ! /^\# kopt=.*$/ ) ;
-		s/$/ $cmd_line/ if ( defined $cmd_line && ! /$cmd_line$/ ) ;
-	}
-	
-	if ( $dst eq '-' ) {
-		foreach ( @tmp_grub ) {
-			print $_."\n" ;
-		}
-		return 1 ;
-	}
-	else {
-		unless ( open ( TMPDST, ">/tmp/menulst" ) ) {
-			warn "Unable to open temporary destination file /tmp/menulst\n" ;
-			return 0 ;
-		}
-		foreach ( @tmp_grub ) {
-			print TMPDST $_."\n" ;
-		}
-		close ( TMPDST ) ;
-		if ( compare ( '/tmp/menulst', $dst ) ) {
-			return move ( '/tmp/menulst', $dst) ;
-		} else {
-			if ( $DEBUG ) {
-				warn "No need to move /tmp/menulst to ".$dst." they are equals\n" ;
-				warn "Unlinking source file /tmp/menulst\n" ;
-			}
-			if ( ! unlink ( '/tmp/menulst' ) ) {
-				warn "Unable to unlink source file /tmp/menulst\n" ;
-				warn "Please clean it manually\n" ;
-			}
-		}
-		return 1 ;
-	}
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-##### MAIN
-GetOptions(
-    'src|s=s'	=> \$MENU_GRUB,
-    'dst|d=s'	=> \$DEST,
-    'host=s'	=> \$HOSTNAME,
-    'net|n=s'	=> \$NET,
-    'debug'	=> \$DEBUG,
-    'help|h'	=> \$HELP,
-    'verbose|v'	=> \$VERBOSE
-) or die "GetOptions error, try --help: $!\n";
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
-if ( $HELP ) {
-	Display_usage () ;
-	exit 0 ;
-}
-elsif ( ! -e $MENU_GRUB ) {
-	die "Unexistant GRUB configuration ".$MENU_GRUB."\n" ;
-}
-elsif ( -z $MENU_GRUB ) {
-	die "Empty configuration file for GRUB ".$MENU_GRUB."\n" ;
+if ( $OUTPUT eq "" ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "You MUST define a valid output for this command use '-' if you want to use STDOUT"
+    );
 }
 
-$DEST = "-" if ( $DEBUG ) ;
-$VERBOSE = 1 if ( $DEBUG ) ;
-
-my $NETWORK = Init_lib_net ( Get_source ( $NET ) ) ;
-if ( ! Change_kopt ( Get_Cmdline ( $NETWORK, $HOSTNAME ), $MENU_GRUB, $DEST ) ) {
-	die "Unable to change kernel options(s) into file ".$MENU_GRUB."\n" ;
+if ( $HOSTNAME eq "" ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Unable to modify grub options for an undefined hostname" );
 }
 
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
+}
+
+if ( !defined $GLOBAL_STRUCT->{'DHCP'}->{'BY_SITE'}->{$SITE} ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Site " . $SITE . " is not defined into global configuration" );
+}
+
+if (!Change_kopt_for_hostname(
+        $HOSTNAME,     $SITE,          $MENU_GRUB, $OUTPUT,
+        $GRUB_VERSION, $GLOBAL_STRUCT, $PF_CONFIG
+    )
+    )
+{
+    Abort( $CODE->{'EXEC'},
+        "Unable to change kernel options(s) into file " . $MENU_GRUB );
+}
+
+exit 0;

Modified: trunk/sbin/mk_interfaces
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/mk_interfaces?rev=902&op=diff
==============================================================================
--- trunk/sbin/mk_interfaces (original)
+++ trunk/sbin/mk_interfaces Wed Sep  8 19:28:28 2010
@@ -23,13 +23,119 @@
 use strict;
 use warnings;
 
-use PFTools::Net;
-use PFTools::Update;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use IO::File;
+use Sys::Hostname;
 
-my ($config, $host, $dst) = @ARGV;
-unless ($config and $host and $dst) {
-    die "Usage: $0 config host dest\n";
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+#################################
+# VARS
+my $HELP              = 0;
+my $HOSTNAME          = hostname;
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $OUTPUT_FILE       = '/etc/network/interfaces';
+my $GLOBAL_STRUCT     = {};
+my @HEADER_DEST = (
+    "#################################################",
+    "# File was auto-generated with mk_interfaces tool",
+    "#\n",
+);
+
+my $program = $0;
+$program =~ s%.*/%%;    # cheap basename
+
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
+
+###################################
+# Funtions
+
+sub Do_help {
+    print STDERR << "# ENDHELP";
+    $program - version $version
+
+Usage:	$program [options]
+	--help		: print help and exit
+	-h --host	: hostname for which we want to build interfaces file
+	-s --site	: site on which hostname is defined (optional)
+	-c --config	: file where pf-tools configuration is stored e.g. /etc/pf-tools.conf (optional)
+	--store		: file where global structure datas are in storable format (optional)
+	-o --output	: output file default value is /etc/network/interfaces
+    
+# ENDHELP
 }
 
-Mk_interfaces( $host, $dst, Init_lib_net( Get_source($config) ) );
+##################################
+### MAIN
 
+GetOptions(
+    'help'       => \$HELP,
+    'host|h=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
+
+if ($HELP) {
+    Do_help();
+    exit 0;
+}
+
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
+
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
+}
+
+my $iface = Mk_interfaces( $HOSTNAME, $GLOBAL_STRUCT, $PF_CONFIG, $SITE );
+if ( !defined $iface ) {
+    Abort( $CODE->{'EXEC'},
+        "An error occured during building interfaces file " . $OUTPUT_FILE );
+}
+
+my $output_fh = IO::File->new( '>' . $OUTPUT_FILE )
+    or Abort( $CODE->{'OPEN'},
+        "Unable to open destination $OUTPUT_FILE : $OS_ERROR" );
+$output_fh->print( join "\n", @HEADER_DEST )
+    or Abort( $CODE->{'OPEN'},
+        "Unable to write on destination file $OUTPUT_FILE : $OS_ERROR" );
+foreach my $if ( @{ $iface->{'__order'} } ) {
+    $output_fh->print( join "\n", @{ $iface->{$if} }, "\n" )
+        or Abort( $CODE->{'OPEN'},
+            "Unable to write on destination file $OUTPUT_FILE : $OS_ERROR" );
+}
+$output_fh->close()
+    or Abort( $CODE->{'OPEN'},
+        "Unable to close destination file $OUTPUT_FILE : $OS_ERROR" );
+
+exit 0;

Modified: trunk/sbin/mk_pxelinuxcfg
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/mk_pxelinuxcfg?rev=902&op=diff
==============================================================================
--- trunk/sbin/mk_pxelinuxcfg (original)
+++ trunk/sbin/mk_pxelinuxcfg Wed Sep  8 19:28:28 2010
@@ -2,7 +2,7 @@
 ##
 ##  $Id$
 ##
-##  Copyright (C) 2007-2008 Christophe Caillet <quadchris at free.fr>
+##  Copyright (C) 2007-2010 Christophe Caillet <quadchris at free.fr>
 ##  Copyright (C) 2003-2005 Damien Clermonte <damien at sitadelle.com>
 ##  Copyright (C) 2001-2003 Olivier Molteni <olivier at molteni.net>
 ##
@@ -24,243 +24,110 @@
 use strict;
 use warnings;
 
-use Digest::MD5;
-use PFTools::Net;
-use PFTools::Update;
-use File::Compare ;
-use File::Copy ;
+use Data::Dumper;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use File::Path qw( make_path );
 
-my $DEPLOY_DOCROOT	= "/var/www";
-my $PRESEED_REPOS	= $DEPLOY_DOCROOT."/preseed" ;
+use PFTools::Logger;
+use PFTools::Utils;
 
-if ( ! -e $PRESEED_REPOS ) {
-	mkdir $PRESEED_REPOS ;
-	my ($login,$pass,$uid,$gid) = getpwnam ( 'www-data' ) ;
-	chown $uid, $gid, $PRESEED_REPOS ;
-	my $mode = '2750' ;
-	chmod ( oct ( $mode ), $PRESEED_REPOS ) ;
+############################################
+# Vars
+
+my $DEPLOY_DOCROOT    = "/var/www";
+my $HELP              = 0;
+my $PF_SCRIPT         = 'pf-tools-config.sh';
+my $PXE_TPL           = '';
+my $PRESEED_TPL       = '';
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $GLOBAL_STRUCT     = {};
+my $DEFAULT_PRESEED   = '';
+
+my $program = $0;
+$program =~ s%.*/%%;    # cheap basename
+
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
+
+############################################
+# Functions
+
+sub Do_help {
+    print STDERR << "# ENDHELP";
+    $program - version $version
+
+Usage:	$program [options]
+	--help		: print help and exit
+	-s --site	: site for which you want to build PXE and preseed files
+	--script	: script which is "wgotten" and executed as post-install preseed default value is pf-tools-config.sh
+	--store		: file where global structure datas are in storable format (optional)
+	-c --config	: pf-tools config file (optional)
+    
+# ENDHELP
 }
 
-my $TPL_PRESEED			= "/usr/share/pf-tools/templates/standard-preseed.tpl" ;
-my $TPL_UBUNTU_PRESEED	= "/usr/share/pf-tools/templates/ubuntu-preseed.tpl" ;
-my $DEFAULT_PRESEED	= $PRESEED_REPOS."/default_preseed.txt" ;
+############################################
+### MAIN
 
-sub Get_kpkg_from_pxefilename ($$) {
-	my ( $pxefilename, $deploymode ) = @_ ;
-	
-	if ( $deploymode =~ /^ubuntu/ ) {
-		$pxefilename =~ /vmlinuz-(.+)$/;
-		return "linux-image-".$1;
-	}
-	else {
-		if ( $pxefilename =~ /pxe/ ) {
-			my ( $vm, $type, $pxe, $version, @append ) = split ( /-/, $pxefilename ) ;
-			return "linux-image-".$version."-".$type."-".join ( "-", @append )."-grsec" ;
-		}
-		else {
-			my ( $vm, $version, $type, $append_version ) = split ( /-/, $pxefilename ) ;
-			return "linux-image-".$version."-".$type."-".$append_version."-grsec" ;
-		}
-	}
+GetOptions(
+    'help'       => \$HELP,
+    'script=s'   => \$PF_SCRIPT,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+) or die "Didn't grok options (see --help).\n";
+
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-sub Build_preseed_filename ($$$) {
-	my ( $srv_name, $preseed_tpl, $ref_srv ) = @_ ;
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( "", $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
-	if ( ! open ( PRESEED_TPL, $preseed_tpl ) ) {
-		warn "Unable to get preseed template from file ".$preseed_tpl."\n" ;
-		return $DEFAULT_PRESEED ;
-	}
-	my $preseed_content = join '', <PRESEED_TPL> ;
-	close ( PRESEED_TPL ) ;
-	my $deb_kernel = Get_kpkg_from_pxefilename ( $ref_srv->{'pxefilename'}, $ref_srv->{'deploymode'} ) ;
-	$preseed_content =~ s/%KERNELPKG%/$deb_kernel/gs ;
-	
-	my $distrib	= $ref_srv->{'distrib'} ;
-	my $dist_src	= $ref_srv->{'deploymode'} ;
-	$dist_src	=~ s/^(debian|ubuntu)-installer/$1/ ;
-	
-	$preseed_content =~ s/%DISTSRC%/$dist_src/gs ;
-	$preseed_content =~ s/%DISTRIB%/$distrib/gs ;
-	
-	if ( ! open ( DST_PRESEED, ">/tmp/tmp_preseed" ) ) {
-		warn "Unable to create preseed file /tmp_preseed\n" ;
-		return $DEFAULT_PRESEED ;
-	}
-	print DST_PRESEED $preseed_content ;
-	close ( DST_PRESEED ) ;
-	my $src = "/tmp/tmp_preseed" ;
-	my $dst = $PRESEED_REPOS."/preseed_".$srv_name ;
-	if ( compare ( $src, $dst ) ) {
-		move ($src, $dst) ;
-	} else {
-		if ( ! unlink ( $src ) ) {
-			warn "Unable to unlink source file ".$src."\n" ;
-		}
-	}
-	return "preseed_".$srv_name ;
+if ( !-e $PF_CONFIG->{'path'}->{'preseed_dir'} ) {
+    make_path( $PF_CONFIG->{'path'}->{'preseed_dir'} );
+    my ( $login, $pass, $uid, $gid ) = getpwnam('www-data');
+    chown $uid, $gid, $PF_CONFIG->{'path'}->{'preseed_dir'};
+    my $mode = '2750';
+    chmod( oct($mode), $PF_CONFIG->{'path'}->{'preseed_dir'} );
+}
+$DEFAULT_PRESEED
+    = $PF_CONFIG->{'path'}->{'preseed_dir'} . "/default_preseed.txt";
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        Abort( $CODE->{'UNDEF_KEY'},
+            "A site MUST BE defined for building DNS zone forward" );
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
 }
 
-sub Get_MD5SUM_from_preseedfilename ($) {
-	my ( $filename ) = @_;
-	my ( $md5, $hdl );
-	
-	$md5 = Digest::MD5->new;
-	open $hdl, $PRESEED_REPOS."/".$filename || return undef;
-	$md5->addfile ( $hdl );
-	return $md5->hexdigest;
+if ( !defined $GLOBAL_STRUCT->{'DHCP'}->{'BY_SITE'}->{$SITE} ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Site " . $SITE . " is not defined into global configuration" );
 }
 
-sub Mk_pxe_bootfile ($;$$) {
-	my ( $Z, $default_template, $tftp_dir ) = @_;
-	my $oldout;
-	my $s;
-	my $templates = {};
-
-	my $pxelinuxconfdir = dirname ( $default_template );
-	my $pxetftpdir = $tftp_dir || dirname ( $default_template );
-	open TPL, $default_template
-	    or die "Unable to open $default_template: $!\n";
-	@{ $templates->{$default_template} } = <TPL>;
-	close TPL;
-
-	my $dhcpvlanregex
-		= '^([^.]+)\.('
-		. join( '|', @{ $Z->{'SOA'}->{'dhcpvlan'} } )
-		. ')(\.*)?$';
-
-	foreach $s ( sort ( keys %{ $Z->{'SERVERS'}->{'BY_ADDR'} } ) ) {
-		foreach my $host ( @{$Z->{'SERVERS'}->{'BY_ADDR'}->{$s}}  ) {
-	
-			foreach my $m ( sort ( keys %{ $host->{'SRVLIST'} } ) ) {
-				my $nam;
-				my $M = $host->{'SRVLIST'}->{$m};
-				my $debian_installer = 0 ;
-				$debian_installer = 1 if ( defined $M->{'deploymode'} && $M->{'deploymode'} =~ /^(debian|ubuntu)-installer/ ) ;
-				foreach $nam ( sort ( keys %{ $M->{'zone'} } ) ) {
-					if ( $nam =~ /$dhcpvlanregex/ ) {
-						my $nam2 = $1;
-	
-						#my $vlan2 = $2;
-						if (   defined( $M->{'zone'}->{$nam}->{'ether'} )
-							&& defined( $M->{'filename'} )
-							&& defined( $M->{'pxefilename'} ) )
-						{
-							if ( $M->{'filename'} ne 'pxelinux.0' ) {
-								Warn( $ERR_SYNTAX,
-									"Mk_pxelinuxconf[" 
-									. $nam2
-									. "]: pxefilename exists but filename is not pxelinux.0!"
-								);
-							}
-							my $addr = Resolv( $nam . '.' . $Z->{'SOA'}->{'name'}, $Z );
-							if ( defined $addr
-								&& $addr ne $nam . '.' . $Z->{'SOA'}->{'name'} )
-							{
-								my $hexaddr = sprintf( '%02X%02X%02X%02X',
-								split( '\.', $addr ) );
-	
-								if ( -e $pxetftpdir . "/" . $hexaddr ) {
-									unlink( $pxetftpdir . "/" . $hexaddr );
-								}
-	
-								open( PXELINUXCFG,
-									">" . $pxetftpdir . "/" . $hexaddr )
-									|| die "impossible d'ecrire "
-										. $pxelinuxconfdir . "/"
-										. $hexaddr . ": "
-										. $!;
-
-								my $template_name ;
-								if ( $debian_installer ) {
-									if ( $M->{'deploymode'} =~ /^ubuntu/ ) {
-										$template_name = 'ubuntu-installer' ;
-									}
-									else {
-										$template_name = 'standard-installer' ;
-									}
-								}
-								else {
-									$template_name = $M->{'pxetemplate'} ? $M->{'pxetemplate'} : $default_template;
-								}
-
-								unless (defined $templates->{$template_name}) {
-									my $tpl = ( ($template_name =~ m/^\//) ? '' : "$pxelinuxconfdir/" )
-										. $template_name;
-									open PXETEMPLATE, $tpl or die "Impossible d'ouvrir $tpl : . $!\n";
-									@{ $templates->{$template_name} } = <PXETEMPLATE>;
-									close PXETEMPLATE;
-								}
-	
-								my $temptemplatecontent = join '', @{ $templates->{$template_name} };
-								my $kernel_filename	= Get_PXE_Filename ( $Z, $m ) ;
-								if ( ! defined $kernel_filename ) {
-									warn "Unable to retrieve kernel filename for host ".$m."\n" ;
-								}
-								$temptemplatecontent =~ s/%KERNEL%/$kernel_filename/gs;
-
-								if ( $debian_installer ) {
-									# Building preseed file
-									$temptemplatecontent =~ s/%DEPLOYMODE%/$M->{'deploymode'}/gs ;
-									$temptemplatecontent =~ s/%DISTRIB%/$M->{'distrib'}/gs ;
-									if ( defined $M->{'initrd'} ) {
-										$temptemplatecontent =~ s/%INITRD%/$M->{'initrd'}/gs ;
-									}
-									else {
-										$temptemplatecontent =~ s/initrd=([^\s]*)%INITRD%//gs ;
-									}
-									my $preseed_file;
-									if ( $M->{'deploymode'} =~ /^ubuntu/ ) {
-										$preseed_file = Build_preseed_filename ( $m, $TPL_UBUNTU_PRESEED, $M ) ;
-									}
-									else {
-										$preseed_file = Build_preseed_filename ( $m, $TPL_PRESEED, $M ) ;
-									}
-									# MD5sum on generated preseed file
-									$temptemplatecontent =~
-										s/%PRESEED_URL%/preseed\/$preseed_file/gs;
-									my $preseed_md5 = Get_MD5SUM_from_preseedfilename ( $preseed_file ) ;
-									if ( ! defined $preseed_md5 ) {
-										die "Unable to get md5dum for preseed filename "
-											.$preseed_file." for host ".$m."\n" ;
-									}
-									$temptemplatecontent =~ s/%PRESEED_MD5%/$preseed_md5/gs;
-								} else {
-									my $ramdisk_size = Get_Ramdisk_size_from_Initrd($M->{'initrd'} );
-									$temptemplatecontent =~ s/%RAMDISK_SIZE%/$ramdisk_size/gs;
-									$temptemplatecontent =~ s/%INITRD%/$M->{'initrd'}/gs;
-								}
-
-								my $arch = $M->{'arch'} || 'i386' ;
-								$temptemplatecontent =~ s/%ARCH%/$arch/gs;
-	
-								my $cmdline = $M->{'cmdline'} || '';
-								$temptemplatecontent =~ s/%CMDLINE%/$cmdline/gs;
-	
-								my $console = $M->{'console'} || '';
-								$console = "console=" . $console if $console;
-								$temptemplatecontent =~ s/%CONSOLE%/$console/gs;
-	
-								my $serial_speed = $M->{'serialspeed'} || '115200' ;
-								$temptemplatecontent =~ s/%SERIAL_SPEED%/$serial_speed/gs;
-	
-								$temptemplatecontent =~ s/ +/ /gs;
-	
-								print PXELINUXCFG $temptemplatecontent;
-								close PXELINUXCFG;
-							}
-						}
-					}
-				}
-			}
-		}
-	}
+my $site_part = $GLOBAL_STRUCT->{'SITE'}->{'BY_NAME'}->{$SITE};
+my $host_part = $site_part->{'HOST'}->{'BY_NAME'};
+foreach my $hostclass ( @{ $site_part->{'HOST'}->{'__hostclass_pxe'} } ) {
+    foreach my $host ( keys %{ $host_part->{$hostclass} } ) {
+        next if ( ref $host_part->{$hostclass}->{$host} ne 'HASH' );
+        my $mode
+            = $host_part->{$hostclass}->{$host}->{'deployment'}->{'mode'};
+        my $pxe_template = $PF_CONFIG->{'path'}->{'templates_dir'} . '/'
+            . $PF_CONFIG->{$mode}->{'pxe'};
+        my $preseed_tpl = $PF_CONFIG->{'path'}->{'templates_dir'} . '/'
+            . $PF_CONFIG->{$mode}->{'preseed'};
+        my $pxe_file
+            = Mk_PXE_bootfile( $host, $host_part->{$hostclass}->{$host},
+            $pxe_template, $preseed_tpl, $DEFAULT_PRESEED, $PF_SCRIPT,
+            $PF_CONFIG );
+    }
 }
 
-my ( $SRC, $TEMPLATE, $TFTP_DIR ) = @ARGV ;
-unless ( $SRC && $TEMPLATE ) {
-    warn "Usage: $0 src template\n";
-    die "\t(confs will be written do template's dirname)\n";
-}
-
-Mk_pxe_bootfile ( Init_lib_net ( Get_source ( $SRC ) ), Get_source ( $TEMPLATE ), $TFTP_DIR ) ;
+exit 0;

Modified: trunk/sbin/mk_resolvconf
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/mk_resolvconf?rev=902&op=diff
==============================================================================
--- trunk/sbin/mk_resolvconf (original)
+++ trunk/sbin/mk_resolvconf Wed Sep  8 19:28:28 2010
@@ -23,23 +23,97 @@
 use strict;
 use warnings;
 
-use PFTools::Net;
-use PFTools::Update;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
 
-my ($config, $host, $dst) = @ARGV;
-unless ($config and $host and $dst) {
-    die "Usage: $0 config host dest\n";
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+#################################
+# VARS
+my $HELP              = 0;
+my $HOSTNAME          = hostname;
+my $SITE              = '';
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $OUTPUT_FILE       = '/etc/resolv.conf';
+my $GLOBAL_STRUCT     = {};
+
+my $program = $0;
+$program =~ s%.*/%%;    # cheap basename
+
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
+
+###################################
+# Funtions
+
+sub Do_help {
+    print STDERR << "# ENDHELP";
+    $program - version $version
+
+Usage:	$program [options]
+	--help		: print help and exit
+	-h --host	: hostname for which we want to build interfaces file
+	-s --site	: site on which hostname is defined (optional)
+	-c --config	: file where pf-tools configuration is stored e.g. /etc/pf-tools.conf (optional)
+	--store		: file where global structure datas are in storable format (optional)
+	-o --output	: output file default value is /etc/network/interfaces
+    
+# ENDHELP
 }
 
-my $Z   = Init_lib_net( Get_source($config) );
-my @dns = Get_dns_from_hostname( $Z, $host );
+##################################
+### MAIN
 
-open OUT, ">$dst" or die "open: $dst: $!\n";;
+GetOptions(
+    'help'       => \$HELP,
+    'host|h=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
 
-print OUT "search " . $Z->{SOA}->{name} . "\n";
-foreach my $dns (@dns) {
-    print OUT "nameserver $dns\n" if $dns;
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-close OUT;
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
 
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
+}
+
+if ( !Mk_resolvconf( $HOSTNAME, $GLOBAL_STRUCT, $SITE, $OUTPUT_FILE ) ) {
+    Abort( $CODE->{'EXEC'},
+        "An error occured during build of file " . $OUTPUT_FILE );
+}
+
+exit 0;

Modified: trunk/sbin/mk_sourceslist
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/mk_sourceslist?rev=902&op=diff
==============================================================================
--- trunk/sbin/mk_sourceslist (original)
+++ trunk/sbin/mk_sourceslist Wed Sep  8 19:28:28 2010
@@ -24,68 +24,77 @@
 use strict;
 use warnings;
 
-use PFTools::Net;
-use PFTools::Conf;
-use PFTools::Update;
-use File::Compare ;
-use File::Copy ;
-use Getopt::Long qw( :config ignore_case_always bundling ) ;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
 
-my $HELP		= 0 ;
-my $SRC 		= "" ;
-my $DST 		= "" ;
-my $TPL_DIR		= "/usr/share/pf-tools/templates/" ;
-my $DEFAULT_TPL	= "sources.list.tpl";
-my $TPL			= "" ;
-my $SECTIONS	= "common" ;
-my $HOST		= '' ;
-my $BACKPORTS	= 0 ;
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
 
-my $DEF_SECTIONS = {} ;
-$DEF_SECTIONS->{'debian'}	= "main contrib non-free" ;
-$DEF_SECTIONS->{'ubuntu'}	= "main universe restricted" ;
+############################################
+# Vars
 
-chomp ( $HOST ) ;
+my $HELP              = 0;
+my $HOSTNAME          = hostname;
+my $OUTPUT_FILE       = "";
+my $TEMPLATE          = "";
+my $SITE              = "";
+my $SECTIONS          = "common";
+my $TO_ADD            = "";
+my $BACKPORTS         = 0;
+my $GLOBAL_STORE_FILE = '';
+my $PF_CONFIG_FILE    = '';
+my $PF_CONFIG         = {};
+my $GLOBAL_STRUCT     = {};
 
 my $program = $0;
-$program =~ s%.*/%%; # cheap basename
+$program =~ s%.*/%%;    # cheap basename
 
-my $version = sprintf("svn-r%s", q$Revision$ =~ /([\d.]+)/);
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
 
+############################################
+# Functions
 
-sub Usage () {
+sub Do_help () {
 
-print <<EOF
+    print <<EOF
 
 $program - version $version
 
-Synopsis : $program [-h|--help] [-s|--src <private-network source] [-d|--dst <sources.list dest>]
-		[ -t|--tpl <sources.list template>] [-b|--backports] [--host <hostname>] [[section] [section]]
+Synopsis : $program [--help] [-h|--host hostname <hostname>] [-s|--site <site_name>]
+			[-o|--output <sources.list dest>] [ -t|--tpl <sources.list template>] [-b|--backports]
+			[-a|--add <sections to add>] [-c|--config <pf_tools_file>] [--store <filename>]
 
 	This tool permits to build the sources.list file according to distribution defined
 	in private-network file from PF-Tools configuration. It can also add some sections
 	to custom repository
 
-	-h | --help		Displays this message and exits
+	--help			Displays this message and exits
 
-	-s | --src		Defines here where to find the private-network file
+	-h | --host		Defines here the hostname you want to build the sources.list
 
-	-d | --dst		Defines here where to build the sources.list file
+	-s | --site		Defines here the site on which the hostname is defined
+
+	-o | --output		Defines here where to build the sources.list file
 
 	-t | --tpl		Defines here where to find the sources.list template. If not defined
-				the program will use /usr/share/pf-tools/templates/sources.list.tpl
+				the program will use template path issued from pf-tools.conf file
 
-	-b | --backports	Adds the backport repository from debian-backports
+	-a | --add		Defines here the list(comma-separated) of sections you want to add into custom repository
 
-	--host		Defines for which hostname you want to build the sources.list. This
-			option is mainly for debugging
+	-b | --backports	Adds the backport repository from offical source according to hostname's
+				deployment mode
 
+	-c | --config		Define here where is the pf-tools.conf file
+
+	--store			Define here where the storable file which contains the global structure is
 
 	You can add on CLI some sections to add to the "common" section for custom repository
 	
 	Sample use :
 	
-	$program -s GLOBAL:private-network -d /tmp/sources.list -h stream-tv00 stream
+	$program -s mysite -o /tmp/sources.list -h stream-tv00 -a stream
 
 	This command generate the sources.list file on /tmp for stream-tv00 host and adds the
 	section stream to the custom packages repository
@@ -93,89 +102,63 @@
 EOF
 }
 
-sub Mk_sourceslist ($$$$) {
-	my ( $ref_srv, $dst, $tpl, $sections ) = @_ ;
-	
-	if ( ! open ( SOURCESTPL, $tpl ) ) {
-		warn "Unable to get sources.list template from file ".$tpl."\n" ;
-		return 1 ;
-	}
-	my $sources_content = join '', <SOURCESTPL> ;
-	close ( SOURCESTPL ) ;
+#############################################################
+### MAIN
 
-	$sources_content =~ s/%DISTRIB%/$ref_srv->{'distrib'}/gs ;
-	my $dist_src	= $ref_srv->{'deploymode'} ;
-	$dist_src	=~ s/^(debian|ubuntu)-installer/$1/ ;
+GetOptions(
+    'help'       => \$HELP,
+    'host|h=s'   => \$HOSTNAME,
+    'site|s=s'   => \$SITE,
+    'tpl|t=s'    => \$TEMPLATE,
+    'a|add=s'    => \$TO_ADD,
+    'config|c=s' => \$PF_CONFIG_FILE,
+    'store=s'    => \$GLOBAL_STORE_FILE,
+    'backport|b' => \$BACKPORTS,
+    'output|o=s' => \$OUTPUT_FILE
+) or die "Didn't grok options (see --help).\n";
 
-	my $security = ( $dist_src eq 'debian' ) ? $ref_srv->{'distrib'}."/updates" : $ref_srv->{'distrib'}."-security" ;
-
-	$sources_content =~ s/%DISTSRC%/$dist_src/gs ;
-	$sources_content =~ s/%SECURITY%/$security/gs ;
-	$sources_content =~ s/%DEFAULT_SECTIONS%/$DEF_SECTIONS->{$dist_src}/gs ;
-	$sources_content =~ s/%CUSTOM_SECTIONS%/$sections/gs ;
-
-	if ( $BACKPORTS ) {
-		my $back_src ;
-		my $back_sections ;
-		if ( $dist_src eq 'debian' ) {
-			$back_src = $dist_src."-backports" ;
-		}
-		elsif ( $dist_src eq 'ubuntu' ) {
-			$back_src = $dist_src ;
-		}
-		$sources_content .= "\ndeb http://mirrors.private/".$back_src." ".$ref_srv->{'distrib'}."-backports ".$DEF_SECTIONS->{$dist_src}."\n" ;
-	}
-
-	if ( ! open ( DST, ">".$dst ) ) {
-		warn "Unable to open destination's sources.list ".$dst."\n" ;
-		return 1 ;
-	}
-	print DST $sources_content ;
-	close ( DST ) ;
-	return 0 ;
+if ($HELP) {
+    Do_help();
+    exit 0;
 }
 
-GetOptions (
-	'h|help'	=> \$HELP,
-	'host=s'	=> \$HOST,
-	's|src=s'	=> \$SRC,
-	'd|dst=s'	=> \$DST,
-	't|tpl=s'	=> \$TPL,
-	'b|backports'	=> \$BACKPORTS
-) || die "Didn't grok options on CLI\n" ;
-
-if ( $HELP ) {
-	Usage () ;
-	exit 0 ;
+if ( $HOSTNAME eq "" ) {
+    Abort( $CODE->{'UNDEF_KEY'},
+        "Unable to build sources.list for an undefined hostname" );
 }
 
-if ( $SRC eq "" || $DST eq "" ) {
-	warn "Source or/and destination are not defined : cannot build sources.list file\n" ;
-	Usage () ;
-	exit 1 ;
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $PF_CONFIG_FILE, $GLOBAL_STORE_FILE );
+
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
 }
 
-if ( @ARGV ) { $SECTIONS .= " ".join ( " ", @ARGV ) ; }
+$TO_ADD =~ s/,/ /g;
+$SECTIONS .= " " . $TO_ADD;
+Mk_sourceslist( $HOSTNAME, $SITE, $OUTPUT_FILE, $SECTIONS, $TEMPLATE,
+    $BACKPORTS, $GLOBAL_STRUCT, $PF_CONFIG );
 
-my $PF_NET	= Init_lib_net ( Get_source ( $SRC ) ) ;
-
-my $hosttype ;
-if ( $HOST ne '' ) {
-	my %tmp_subst ;
-	Init_SUBST ( \%tmp_subst, $HOST, 'private' ) ;
-	$hosttype	= $tmp_subst{'HOSTTYPE'} ;
-}
-else {
-	$HOST		= $SUBST{'HOSTNAME'} ;
-	$hosttype	= $SUBST{'HOSTTYPE'} ;
-}
-my $SRV		= $PF_NET->{'SERVERS'}->{'BY_NAME'}->{$hosttype}->{'SRVLIST'}->{$HOST} ;
-
-if ( $SRV->{'deploymode'} =~ /^ubuntu/ && $TPL eq "" ) {
-	$TPL = $TPL_DIR."ubuntu-sources.list.tpl";
-}
-elsif ( $TPL eq "" ) {
-	$TPL = $TPL_DIR.$DEFAULT_TPL;
-}
-
-Mk_sourceslist ( $SRV, $DST, $TPL, $SECTIONS ) ;
+exit 0;

Modified: trunk/sbin/update-config
URL: http://svn.debian.org/wsvn/pf-tools/trunk/sbin/update-config?rev=902&op=diff
==============================================================================
--- trunk/sbin/update-config (original)
+++ trunk/sbin/update-config Wed Sep  8 19:28:28 2010
@@ -2,7 +2,7 @@
 ##
 ##  $Id$
 ##
-##  Copyright (C) 2007-2009 Christophe Caillet <quadchris at free.fr>
+##  Copyright (C) 2007-2010 Christophe Caillet <quadchris at free.fr>
 ##  Copyright (C) 2003-2005 Damien Clermonte <damien at sitadelle.com>
 ##  Copyright (C) 2001-2003 Olivier Molteni <olivier at molteni.net>
 ##
@@ -24,71 +24,133 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Getopt::Long qw( :config ignore_case_always bundling );
+use Sys::Hostname;
 
-use PFTools::Update;
 use PFTools::Conf;
+use PFTools::Logger;
+use PFTools::Structqueries;
+use PFTools::Utils;
+
+#################################
+# VARS
+my $PF_CONFIG     = {};
+my $GLOBAL_STRUCT = {};
 
 my $program = $0;
-$program =~ s%.*/%%; # cheap basename
+$program =~ s%.*/%%;    # cheap basename
 
 my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
+
+###################################
+# Funtions
 
 sub Do_help {
     print STDERR << "# ENDHELP";
     $program - version $version
 
-Usage:	$0 [options]
-	-d --debug:	print debug info
-        -u --diff:	diff files, versions, mountpoints, links => --simul
-	-h --help:	print help and exit
-	-i --install:	install mode
-	-s --simul:	simulation mode, fake everything
-	-v --verbose:	be more verbose
-  --branche-cvs=: update based on a specific CVS branche.
+Usage:	$program [options]
+	--help			: print help and exit
+	-h --host		: hostname for update-config
+	--site			: site for hostname (optional)
+	-c --config		: path to access to pf-tools.conf file (optional)
+	--store			: path to storable file which contains gloabl configuration
+	-f --force-reload	: forcing the reload of global structure by parsing all configuration files from repository
+	-d --debug		: print debug info
+	-u --diff		: diff files, versions, mountpoints, links => --simul
+	-i --install		: install mode
+	-s --simul		: simulation mode, fake everything
+	-v --verbose		: be more verbose
+	-p --pkg_type		: specify the package type default is deb (optional)
+	--branch		: update based on a specific VCS branche.
     
 # ENDHELP
 }
+
+##################################
+### MAIN
 
 # All options are disabled by default
 my $options = {};
 
 GetOptions(
-    $options,
-    'branche-cvs=s',
-    'debug|d',
-    'diff|u',
-    'help|h',
-    'install|i',
-    'noaction',
-    'noupdate',
-    'quiet|q',
-    'simul|s',
-    'verbose|v',
+    $options,         'branch=s',   'debug|d',   'diff|u',
+    'force-reload|f', 'help',       'install|i', 'noaction',
+    'noupdate',       'quiet|q',    'simul|s',   'pkg_type|p=s',
+    'verbose|v',      'config|c=s', 'store=s',   'host|h=s',
+    'site=s'
 ) or die "GetOptions error, try --help: $!\n";
 
 if ( $options->{'help'} ) {
-	Do_help();
-	exit;
+    Do_help();
+    exit 0;
+}
+$options->{'store'} = "" if ( !defined $options->{'store'} );
+my $HOSTNAME = $options->{'host'} || hostname;
+my $SITE     = $options->{'site'} || "";
+
+( $PF_CONFIG, $GLOBAL_STRUCT )
+    = Init_TOOLS( $HOSTNAME, $options->{'config'}, $options->{'store'},
+    $options->{'force-reload'} );
+
+#### VERIFYING UPDATE FEATURE IN PF-TOOLS CONFIG ABORTING IF DEACTIVATED !!!
+if ( !$PF_CONFIG->{'features'}->{'update'} ) {
+    Abort( $CODE->{'OK'},
+        "update-config command has been deactivated in features section in pf-tools.conf"
+    );
+}
+
+if ( $SITE eq '' ) {
+    if ( !defined $PF_CONFIG->{'location'}->{'site'} ) {
+        my $site_list = Get_site_from_hostname( $HOSTNAME, $GLOBAL_STRUCT );
+        if ( !defined $site_list ) {
+            Abort( $CODE->{'UNDEF_KEY'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname not defined" );
+        }
+        elsif ( scalar @{$site_list} > 1 ) {
+            Abort( $CODE->{'DUPLICATE_VALUE'},
+                      "Unable to retrieve site for hostname "
+                    . $HOSTNAME
+                    . " : hostname appeared in multiple sites : "
+                    . join( ",", @{$site_list} ) . ".\n"
+                    . "Please relaunch this command with the right site" );
+        }
+        else {
+            ($SITE) = @{$site_list};
+        }
+    }
+    else {
+        $SITE = $PF_CONFIG->{'location'}->{'site'};
+    }
+}
+
+if ( $options->{'help'} ) {
+    Do_help();
+    exit;
 }
 
 if ( $options->{'quiet'} ) {
-	Log("update-config started in quiet mode...");
-	$DEFERREDLOG = 1;
+    Log("update-config started in quiet mode...");
+    Set_deferredlog();
 }
 
-if ( $options->{'diff'} ) {
-	$options->{'simul'} = 1;
+$options->{'simul'} = 1 if ( $options->{'diff'} );
+
+if ( defined( $ARGV[0] ) && $ARGV[0] eq ':NO-ACTION:' ) {
+    Warn( $CODE->{'OPEN'}, ":NO-ACTION: depreciated, please use --noaction" );
+    $options->{'noaction'} = 1;
+}
+if ( defined( $ARGV[0] ) && $ARGV[0] eq ':NO-UPDATE:' ) {
+    Warn( $CODE->{'OPEN'}, ":NO-UPDATE: depreciated, please use --noupdate" );
+    $options->{'noupdate'} = 1;
 }
 
-if ( defined( $ARGV[0] ) && $ARGV[0] eq ':NO-ACTION:' ) {
-	Warn( $ERR_OPEN, ":NO-ACTION: depreciated, please use --noaction" );
-	$options->{'noaction'} = 1;
-}
-if ( defined( $ARGV[0] ) && $ARGV[0] eq ':NO-UPDATE:' ) {
-	Warn( $ERR_OPEN, ":NO-UPDATE: depreciated, please use --noupdate" );
-	$options->{'noupdate'} = 1;
-}
+Do_update_from_GLOBAL( $HOSTNAME, $SITE, $options, $GLOBAL_STRUCT,
+    $PF_CONFIG );
 
-Do_update( $options ) ;
+Unset_deferredlog() if ( $options->{'quiet'} );
 
+exit 0;

Modified: trunk/templates/standard-installer
URL: http://svn.debian.org/wsvn/pf-tools/trunk/templates/standard-installer?rev=902&op=diff
==============================================================================
--- trunk/templates/standard-installer (original)
+++ trunk/templates/standard-installer Wed Sep  8 19:28:28 2010
@@ -1,15 +1,15 @@
-SERIAL 0 %SERIAL_SPEED% 2
-DISPLAY %DEPLOYMODE%/%ARCH%/boot-screens/myboot.txt
+SERIAL 0 [% serial_speed %] 2
+DISPLAY [% mode %]/[% distrib %]/[% arch %]/boot-screens/myboot.txt
 
 DEFAULT linux
 
 LABEL install
-	kernel %DEPLOYMODE%/%ARCH%/linux
-	append DEBCONF_PRIORITY=critical vga=normal auto=true initrd=%DEPLOYMODE%/%ARCH%/initrd.gz interface=eth0 netcfg/no_default_route=true url=http://vip-deploy.vlan-systeme.private/%PRESEED_URL% url/checksum=%PRESEED_MD5% -- %CONSOLE% %CMDLINE%
+	kernel [% mode %]/[% distrib %]/[% arch %]/linux
+	append DEBCONF_PRIORITY=critical vga=normal auto=true initrd=[% mode %]/[% distrib %]/[% arch %]/initrd.gz interface=[% iface %] netcfg/no_default_route=true url=http://vip-deploy.vlan-systeme.private/[% preseed_url %] url/checksum=[% preseed_md5 %] -- [% console %] [% cmdline %]
 
 LABEL linux
-	kernel %KERNEL%
-	append vga=normal root=/dev/sda2 -- %CONSOLE% %CMDLINE%
+	kernel [% kernel %]
+	append vga=normal root=/dev/sda2 initrd=[% arch %]/[% initrd %] -- [% console %] [% cmdline %]
 
 PROMPT 1
 TIMEOUT 100

Modified: trunk/templates/ubuntu-installer
URL: http://svn.debian.org/wsvn/pf-tools/trunk/templates/ubuntu-installer?rev=902&op=diff
==============================================================================
--- trunk/templates/ubuntu-installer (original)
+++ trunk/templates/ubuntu-installer Wed Sep  8 19:28:28 2010
@@ -1,15 +1,15 @@
-SERIAL 0 %SERIAL_SPEED% 2
-DISPLAY %DEPLOYMODE%/%ARCH%/boot-screens/myboot.txt
+SERIAL 0 [% serial_speed %] 2
+DISPLAY [% mode %]/[% distrib %]/[% arch %]/boot-screens/myboot.txt
 
 DEFAULT linux
 
 LABEL install
-	kernel %DEPLOYMODE%/%ARCH%/linux
-	append DEBCONF_PRIORITY=critical vga=normal auto=true initrd=%DEPLOYMODE%/%ARCH%/initrd.gz console-setup/ask_detect=false console-setup/layoutcode=fr console-setup/codeset=. interface=eth0 netcfg/no_default_route=true netcfg/get_hostname=unassigned-hostname url=http://vip-deploy.private/%PRESEED_URL% url/checksum=%PRESEED_MD5% -- %CONSOLE% %CMDLINE%
+	kernel [% mode %]/[% distrib %]/[% arch %]/linux
+	append DEBCONF_PRIORITY=critical vga=normal auto=true initrd=[% mode %]/[% distrib %]/[% arch %]/initrd.gz console-setup/ask_detect=false console-setup/layoutcode=fr console-setup/codeset=. interface=[% iface %] netcfg/no_default_route=true netcfg/get_hostname=unassigned-hostname url=http://vip-deploy.private/[% preseed_url %] url/checksum=[% preseed_md5 %] -- [% console %] [% install_cmdline %]
 
 LABEL linux
-	kernel %KERNEL%
-	append vga=normal root=/dev/sda2 initrd=%INITRD% -- %CONSOLE% %CMDLINE%
+	kernel [% kernel %]
+	append vga=normal root=/dev/sda2 initrd=[% initrd %] -- [% console %] [% cmdline %]
 
 PROMPT 1
 TIMEOUT 100

Modified: trunk/tools/dumpiplist.pl
URL: http://svn.debian.org/wsvn/pf-tools/trunk/tools/dumpiplist.pl?rev=902&op=diff
==============================================================================
--- trunk/tools/dumpiplist.pl (original)
+++ trunk/tools/dumpiplist.pl Wed Sep  8 19:28:28 2010
@@ -27,19 +27,19 @@
 use strict;
 use warnings;
 
-use Data::Dumper;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use Getopt::Long qw ( :config ignore_case_always bundling );
 
 use PFTools::Net;
 use PFTools::Update;
-use Getopt::Long qw ( :config ignore_case_always bundling ) ;
-
-my $help	= 0 ;
-my $type	= '' ;
-my $src		= '' ;
-my $read	= 0 ;
-my $program	= $0;
-$program	=~ s%.*/%%; # cheap basename
-my $version	= sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
+
+my $help    = 0;
+my $type    = '';
+my $src     = '';
+my $read    = 0;
+my $program = $0;
+$program =~ s%.*/%%;                 # cheap basename
+my $version = sprintf( "svn-r%s", q$Revision$ =~ /([\d.]+)/ );
 
 sub _ipcomp {
     my ( $a, $b ) = @_;
@@ -75,143 +75,167 @@
 }
 
 sub order_servers ($) {
-	my ( $ref_net ) = @_ ;
-	my $result = [] ;
-	my $order = {} ;
-	
-	foreach my $srv ( keys %{$ref_net} ) {
-		my $srv_order ;
-		if ( ! defined $ref_net->{$srv}->{'order'} ) {
-			$srv_order = 999 ;
-		}
-		else {
-			$srv_order = $ref_net->{$srv}->{'order'} ;
-		}
-		push ( @{$order->{$srv_order}}, $srv ) ;
-	}
-# 	foreach my $prio ( sort keys %{$order} ) {
-# 		foreach my $srv ( @{$order->{$prio}} ) {
-# 			push ( @{$result}, $srv ) ;
-# 		}
-# 	}
-	return $order ;
+    my ($ref_net) = @_;
+    my $result    = [];
+    my $order     = {};
+
+    foreach my $srv ( keys %{$ref_net} ) {
+        my $srv_order;
+        if ( !defined $ref_net->{$srv}->{'order'} ) {
+            $srv_order = 999;
+        }
+        else {
+            $srv_order = $ref_net->{$srv}->{'order'};
+        }
+        push( @{ $order->{$srv_order} }, $srv );
+    }
+
+    # 	foreach my $prio ( sort keys %{$order} ) {
+    # 		foreach my $srv ( @{$order->{$prio}} ) {
+    # 			push ( @{$result}, $srv ) ;
+    # 		}
+    # 	}
+    return $order;
 }
 
 sub get_srv_iface ($$) {
-	my ( $srv_name, $ref_srv ) = @_ ;
-	my $ordered_vlan = {} ;
-	my $result = {} ;
-	foreach my $vlan ( keys %{$ref_srv->{'ifup'}} ) {
-		my $vlan_name = $vlan ;
-		$vlan_name =~ s/^$srv_name\.//;
-		$ordered_vlan->{$ref_srv->{'ifup'}->{$vlan}} = $vlan_name ;
-	}
-	foreach my $iface ( sort keys %{$ordered_vlan} ) {
-		$result->{$iface}->{'addr'} = $ref_srv->{'zone'}->{$srv_name.".".$ordered_vlan->{$iface}}->{'FIELD'} ;
-		$result->{$iface}->{'vlan'} = $ordered_vlan->{$iface} ;
-	}
-	return $result ;
+    my ( $srv_name, $ref_srv ) = @_;
+    my $ordered_vlan = {};
+    my $result       = {};
+    foreach my $vlan ( keys %{ $ref_srv->{'ifup'} } ) {
+        my $vlan_name = $vlan;
+        $vlan_name =~ s/^$srv_name\.//;
+        $ordered_vlan->{ $ref_srv->{'ifup'}->{$vlan} } = $vlan_name;
+    }
+    foreach my $iface ( sort keys %{$ordered_vlan} ) {
+        $result->{$iface}->{'addr'} = $ref_srv->{'zone'}
+            ->{ $srv_name . "." . $ordered_vlan->{$iface} }->{'FIELD'};
+        $result->{$iface}->{'vlan'} = $ordered_vlan->{$iface};
+    }
+    return $result;
 }
 
 sub get_srv_ip ($$) {
-	my ( $srv_type, $ref_net ) = @_ ;
-	my $result = {} ;
-	
-	foreach my $srv ( keys %{$ref_net->{$srv_type}->{'SRVLIST'}} ) {
-		my $ref_srv = $ref_net->{$srv_type}->{'SRVLIST'}->{$srv} ;
-		foreach my $iface ( keys %{$ref_srv->{'zone'}} ) {
-			next if ( $iface !~ /^$srv\./ ) ;
-			$result->{$ref_srv->{'zone'}->{$iface}->{'FIELD'}}->{'hostname'} = $srv ;
-			$result->{$ref_srv->{'zone'}->{$iface}->{'FIELD'}}->{'iface'} = $ref_srv->{'ifup'}->{$iface} ;
-		}
-	}
-	return $result ;
+    my ( $srv_type, $ref_net ) = @_;
+    my $result = {};
+
+    foreach my $srv ( keys %{ $ref_net->{$srv_type}->{'SRVLIST'} } ) {
+        my $ref_srv = $ref_net->{$srv_type}->{'SRVLIST'}->{$srv};
+        foreach my $iface ( keys %{ $ref_srv->{'zone'} } ) {
+            next if ( $iface !~ /^$srv\./ );
+            $result->{ $ref_srv->{'zone'}->{$iface}->{'FIELD'} }->{'hostname'}
+                = $srv;
+            $result->{ $ref_srv->{'zone'}->{$iface}->{'FIELD'} }->{'iface'}
+                = $ref_srv->{'ifup'}->{$iface};
+        }
+    }
+    return $result;
 }
 
 sub get_all_ip ($) {
-	my ( $ref_net ) = @_ ;
-	my $result = {} ;
-	
-	foreach my $srv_type ( keys %{$ref_net} ) {
-		foreach my $srv ( keys %{$ref_net->{$srv_type}->{'SRVLIST'}} ) {
-			my $ref_srv = $ref_net->{$srv_type}->{'SRVLIST'}->{$srv} ;
-			foreach my $iface ( keys %{$ref_srv->{'zone'}} ) {
-				next if ( $iface !~ /^$srv\./ ) ;
-				my $entry = {
-					'hostname'	=> $srv,
-					'iface'		=> $ref_srv->{'ifup'}->{$iface}
-				} ;
-				push ( @{$result->{$ref_srv->{'zone'}->{$iface}->{'FIELD'}}}, $entry ) ;
-			}
-		}
-	}
-	return $result ;
-}
-
-GetOptions (
-	'help|h'	=> \$help,
-	'type|t=s'	=> \$type,
-	'read|r'	=> \$read,
-	'src|s=s'	=> \$src
-) || die "Didn't grok options on CLI\n" ;
-
-if ( $help ) {
-	Do_help () ;
-	exit 0 ;
-}
-
-if ( ! $src ) {
-	die "Source file for network description is not defined\n" ;
-} elsif ( ! -e $src ) {
-	die $src." source file doesn't exist\n" ;
-}
-
-my $PF_NET	= Init_lib_net ( Get_source ( $src ) );
-my $SRV_LIST	= $PF_NET->{'SERVERS'}->{'BY_NAME'} ;
-
-if ( $type && ! defined $SRV_LIST->{$type} ) {
-	die "Non existant server type ".$type."\n" ;
-}
-
-# print Dumper $PF_NET;
-if ( $type ) {
-	if ( $read ) {
-		foreach my $srv ( sort keys %{$SRV_LIST->{$type}->{'SRVLIST'}} ) {
-			print "\t".$srv."\n" ;
-			my $srv_net = get_srv_iface ( $srv, $SRV_LIST->{$type}->{'SRVLIST'}->{$srv} ) ;
-			foreach my $iface ( sort keys %{$srv_net} ) {
-				print "\t\t".$iface."(".$srv_net->{$iface}->{'vlan'}.")\t: ".$srv_net->{$iface}->{'addr'}."\n" ;
-			}
-		}
-	}
-	else {
-		my $srv_ip = get_srv_ip ( $type, $SRV_LIST ) ;
-		foreach my $ip ( sort { _ipcomp ( $a, $b ) } keys %{$srv_ip} ) {
-			print $ip."\t".$srv_ip->{$ip}->{'hostname'}."(".$srv_ip->{$ip}->{'iface'}.")\n" ;
-		}
-	}
-} else {
-	if ( $read ) {
-		my $srv_type_list = order_servers ( $SRV_LIST ) ;
-		foreach my $prio ( sort keys %{$srv_type_list} ) {
-			print "Server with deployment priority : ".$prio."\n" ;
-			foreach my $srv_type ( sort @{$srv_type_list->{$prio}} ) {
-				foreach my $srv ( sort keys %{$SRV_LIST->{$srv_type}->{'SRVLIST'}} ) {
-					print "\t".$srv."\n" ;
-					my $srv_net = get_srv_iface ( $srv, $SRV_LIST->{$srv_type}->{'SRVLIST'}->{$srv} ) ;
-					foreach my $iface ( sort keys %{$srv_net} ) {
-						print "\t\t".$iface."(".$srv_net->{$iface}->{'vlan'}.")\t: ".$srv_net->{$iface}->{'addr'}."\n" ;
-					}
-				}
-				print "\n" ;
-			}
-			print "\n" ;
-		}
-	}
-	else {
-		my $ip_list = get_all_ip ( $SRV_LIST ) ;
-		foreach my $ip ( sort { _ipcomp ( $a, $b ) } keys %{$ip_list} ) {
-			print "$ip\t" . join(' ', map { "$_->{'hostname'}($_->{'iface'})" } @{ $ip_list->{$ip} }) . "\n" ;
-		}
-	}
-}
+    my ($ref_net) = @_;
+    my $result = {};
+
+    foreach my $srv_type ( keys %{$ref_net} ) {
+        foreach my $srv ( keys %{ $ref_net->{$srv_type}->{'SRVLIST'} } ) {
+            my $ref_srv = $ref_net->{$srv_type}->{'SRVLIST'}->{$srv};
+            foreach my $iface ( keys %{ $ref_srv->{'zone'} } ) {
+                next if ( $iface !~ /^$srv\./ );
+                my $entry = {
+                    'hostname' => $srv,
+                    'iface'    => $ref_srv->{'ifup'}->{$iface}
+                };
+                push(
+                    @{  $result->{ $ref_srv->{'zone'}->{$iface}->{'FIELD'} }
+                        },
+                    $entry
+                );
+            }
+        }
+    }
+    return $result;
+}
+
+GetOptions(
+    'help|h'   => \$help,
+    'type|t=s' => \$type,
+    'read|r'   => \$read,
+    'src|s=s'  => \$src
+) || die "Didn't grok options on CLI\n";
+
+if ($help) {
+    Do_help();
+    exit 0;
+}
+
+if ( !$src ) {
+    die "Source file for network description is not defined\n";
+}
+elsif ( !-e $src ) {
+    die $src . " source file doesn't exist\n";
+}
+
+my $PF_NET   = Init_lib_net( Get_source($src) );
+my $SRV_LIST = $PF_NET->{'SERVERS'}->{'BY_NAME'};
+
+if ( $type && !defined $SRV_LIST->{$type} ) {
+    die "Non existant server type " . $type . "\n";
+}
+
+if ($type) {
+    if ($read) {
+        foreach my $srv ( sort keys %{ $SRV_LIST->{$type}->{'SRVLIST'} } ) {
+            print "\t" . $srv . "\n";
+            my $srv_net = get_srv_iface( $srv,
+                $SRV_LIST->{$type}->{'SRVLIST'}->{$srv} );
+            foreach my $iface ( sort keys %{$srv_net} ) {
+                print "\t\t" 
+                    . $iface . "("
+                    . $srv_net->{$iface}->{'vlan'} . ")\t: "
+                    . $srv_net->{$iface}->{'addr'} . "\n";
+            }
+        }
+    }
+    else {
+        my $srv_ip = get_srv_ip( $type, $SRV_LIST );
+        foreach my $ip ( sort { _ipcomp( $a, $b ) } keys %{$srv_ip} ) {
+            print $ip. "\t"
+                . $srv_ip->{$ip}->{'hostname'} . "("
+                . $srv_ip->{$ip}->{'iface'} . ")\n";
+        }
+    }
+}
+else {
+    if ($read) {
+        my $srv_type_list = order_servers($SRV_LIST);
+        foreach my $prio ( sort keys %{$srv_type_list} ) {
+            print "Server with deployment priority : " . $prio . "\n";
+            foreach my $srv_type ( sort @{ $srv_type_list->{$prio} } ) {
+                foreach my $srv (
+                    sort keys %{ $SRV_LIST->{$srv_type}->{'SRVLIST'} } )
+                {
+                    print "\t" . $srv . "\n";
+                    my $srv_net = get_srv_iface( $srv,
+                        $SRV_LIST->{$srv_type}->{'SRVLIST'}->{$srv} );
+                    foreach my $iface ( sort keys %{$srv_net} ) {
+                        print "\t\t" 
+                            . $iface . "("
+                            . $srv_net->{$iface}->{'vlan'} . ")\t: "
+                            . $srv_net->{$iface}->{'addr'} . "\n";
+                    }
+                }
+                print "\n";
+            }
+            print "\n";
+        }
+    }
+    else {
+        my $ip_list = get_all_ip($SRV_LIST);
+        foreach my $ip ( sort { _ipcomp( $a, $b ) } keys %{$ip_list} ) {
+            print "$ip\t"
+                . join( ' ',
+                map {"$_->{'hostname'}($_->{'iface'})"} @{ $ip_list->{$ip} } )
+                . "\n";
+        }
+    }
+}

Modified: trunk/tools/kvmlaunch
URL: http://svn.debian.org/wsvn/pf-tools/trunk/tools/kvmlaunch?rev=902&op=diff
==============================================================================
--- trunk/tools/kvmlaunch (original)
+++ trunk/tools/kvmlaunch Wed Sep  8 19:28:28 2010
@@ -33,7 +33,7 @@
 
 use Carp;
 use Digest::CRC qw( crc32_hex );
-use English qw( -no_match_vars ); # Avoids regex performance penalty
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use File::Path;
 use Getopt::Long;
 
@@ -53,136 +53,124 @@
 #}
 
 my $option = {
-    'cvs-update'	=> 1,
-    debug		=> 0,
-    detached		=> 0,
-    'disk-size'		=> 1024,
-    errors		=> 1,
-    mode		=> 'boot',
-    'ram-size'		=> 256,
-    verbose		=> 0,
+    'cvs-update' => 1,
+    debug        => 0,
+    detached     => 0,
+    'disk-size'  => 1024,
+    errors       => 1,
+    mode         => 'boot',
+    'ram-size'   => 256,
+    verbose      => 0,
 };
 
 Getopt::Long::Configure("bundling");
 
-GetOptions( $option,
-    'cvs-update!',
-    'debug|d+',
-    'detached!',
-    'disk-size=s',
-    'errors!',
-    'help|h',
-    'mode|m=s',
-    'oneeach|1',
-    'ram-size=s',
-    'regex|e',
-    'verbose|v+',
+GetOptions(
+    $option,       'cvs-update!', 'debug|d+', 'detached!',
+    'disk-size=s', 'errors!',     'help|h',   'mode|m=s',
+    'oneeach|1',   'ram-size=s',  'regex|e',  'verbose|v+',
 ) or die "FATAL: GetOptions error, try --help";
 
-if ($option->{'help'} or not @ARGV) {
+if ( $option->{'help'} or not @ARGV ) {
     usage();
     exit 1;
 }
 
-if ($option->{'oneeach'}) {
+if ( $option->{'oneeach'} ) {
     $option->{'detached'} = 1;
     $option->{'errors'}   = 0;
 }
 
-if ($option->{'debug'}) {
-    $option->{'verbose'}  = 1;
-}
-
-
-if ($option->{'cvs-update'}) {
+if ( $option->{'debug'} ) {
+    $option->{'verbose'} = 1;
+}
+
+if ( $option->{'cvs-update'} ) {
     CVS_update( undef, $option )
-	&& die "FATAL: Unable to load configuration.\n";
+        && die "FATAL: Unable to load configuration.\n";
 }
 
 my $Z = Init_lib_net( Get_source("GLOBAL:private-network") );
 
-my @hosts = __get_hosts($Z, $option, @ARGV);
+my @hosts = __get_hosts( $Z, $option, @ARGV );
 
 while ( defined( my $vm_hostname = shift @hosts ) ) {
-    eval { __handle_vm($vm_hostname, $Z, $option); };
+    eval { __handle_vm( $vm_hostname, $Z, $option ); };
 
     if ($EVAL_ERROR) {
-	die "FATAL: $vm_hostname: $EVAL_ERROR\n"
-	    if $option->{'errors'};
-
-	warn "IGNORED: $vm_hostname: $EVAL_ERROR\n";
+        die "FATAL: $vm_hostname: $EVAL_ERROR\n"
+            if $option->{'errors'};
+
+        warn "IGNORED: $vm_hostname: $EVAL_ERROR\n";
     }
 }
 
 exit 0;
 
 # End of program: only functions below.
-
 
 # Return the list of host names to launch
 sub __get_hosts {
-    my ($Z, $option, @argv) = @_;
-
-    my @hosts_pattern =
-	  $option->{'oneeach'} ? ('00$')
-	: $option->{'regex'}   ? @argv
-	:                        map { '^' . $_ . '$' } @argv;
+    my ( $Z, $option, @argv ) = @_;
+
+    my @hosts_pattern
+        = $option->{'oneeach'} ? ('00$')
+        : $option->{'regex'}   ? @argv
+        :                        map { '^' . $_ . '$' } @argv;
 
     my @hosts = Get_Ordered_Filtered_Hosts( $Z, @hosts_pattern );
     die "FATAL: No matching host found.\n"
-	unless @hosts;
-    
+        unless @hosts;
+
     warn "DEBUG: hosts: @hosts\n"
-	if $option->{'debug'};
+        if $option->{'debug'};
 
     return @hosts;
 }
-
 
 # Do the magic for one VM
 sub __handle_vm {
-    my ($vm_hostname, $Z, $option) = @_;
+    my ( $vm_hostname, $Z, $option ) = @_;
 
     warn "INFO: handling host $vm_hostname\n"
-	if $option->{'verbose'};
+        if $option->{'verbose'};
 
     my $vm_dir = "/home/kvm/vm/$vm_hostname";
-    unless (-d $vm_dir) {
-	warn "INFO: creating $vm_dir\n"
-	    if $option->{'verbose'};
-
-	mkpath($vm_dir); # will properly croak() if needed
+    unless ( -d $vm_dir ) {
+        warn "INFO: creating $vm_dir\n"
+            if $option->{'verbose'};
+
+        mkpath($vm_dir);    # will properly croak() if needed
     }
 
     my $vm_disk_file = "$vm_dir/$vm_hostname.qcow";
-    unless (-f $vm_disk_file) {
-	warn "INFO: no disk file, forcing install mode\n"
-	    if $option->{'verbose'};
-
-	$option->{'mode'} = 'install';
-    }
-
-    my @interfaces = __get_list_of_interfaces($Z, $vm_hostname);
-    my @net_args =
-	map { ('-net', $_) }
-	map { (
-	    "nic,vlan=$_->{'vlan'},macaddr=$_->{'mac'},model=e1000",
-	    "tap,vlan=$_->{'vlan'},ifname=$_->{'ifname'},script=no",
-	) }
-	@interfaces;
-
-    my   @screen_args = ('-S', $vm_hostname);
+    unless ( -f $vm_disk_file ) {
+        warn "INFO: no disk file, forcing install mode\n"
+            if $option->{'verbose'};
+
+        $option->{'mode'} = 'install';
+    }
+
+    my @interfaces = __get_list_of_interfaces( $Z, $vm_hostname );
+    my @net_args = map { ( '-net', $_ ) }
+        map {
+        (   "nic,vlan=$_->{'vlan'},macaddr=$_->{'mac'},model=e1000",
+            "tap,vlan=$_->{'vlan'},ifname=$_->{'ifname'},script=no",
+            )
+        } @interfaces;
+
+    my @screen_args = ( '-S', $vm_hostname );
     push @screen_args, qw( -d -m )
-	if $option->{'detached'};
-
-    if ($option->{'mode'} eq 'stop-net') {
-	__remove_tap_interfaces($option, @interfaces);
-	exit 0;
-    }
-
-    __install_tap_interfaces($option, @interfaces);
-    if ($option->{'mode'} eq 'start-net') {
-	exit 0;
+        if $option->{'detached'};
+
+    if ( $option->{'mode'} eq 'stop-net' ) {
+        __remove_tap_interfaces( $option, @interfaces );
+        exit 0;
+    }
+
+    __install_tap_interfaces( $option, @interfaces );
+    if ( $option->{'mode'} eq 'start-net' ) {
+        exit 0;
     }
 
     # TODO: prepend console=ttyS0.... to the cmdline in order to use kvm's
@@ -195,53 +183,54 @@
     # (yet?) how to do that.
 
     my @kvm_cmd = (
-	'screen',	@screen_args,
-	'kvm',
-	'-drive',	"file=$vm_disk_file,if=scsi,boot=on",
-	'-m',		$option->{'ram-size'},
-	@net_args,
-	'-curses',	'-k', 'fr',
-#	'-nographic',	'-monitor', qx{tty},
+        'screen', @screen_args,
+        'kvm',
+        '-drive', "file=$vm_disk_file,if=scsi,boot=on",
+        '-m',     $option->{'ram-size'},
+        @net_args,
+        '-curses', '-k', 'fr',
+
+        #	'-nographic',	'-monitor', qx{tty},
     );
 
-    if ($option->{'mode'} eq 'install') {
-	__system_or_croak("kvm-img create $vm_disk_file $option->{'disk-size'}M");
-
-	# TODO: To fix the two following "FIXME" markers: extract the necessary
-	# parts from mk_pxelinuxcfg and put them in a package in order to be
-	# able to use here $SUBST (for ARCH PRESEED_URL CMDLINE etc.)
-	#
-	# kernel debian-installer/%ARCH%/linux initrd
-	# debian-installer/%ARCH%/initrd.gz append DEBCONF_PRIORITY=critical
-	# vga=normal auto=true initrd=debian-installer/%ARCH%/initrd.gz
-	# interface=eth0 netcfg/no_default_route=true url=%PRESEED_URL%
-	# url/checksum=%PRESEED_MD5% -- %CONSOLE% %CMDLINE%
-
-	# FIXME: 'amd64' hardcoded
-	my $kernel = '/distrib/tftpboot/debian-installer/amd64/linux';
-	my $initrd = '/distrib/tftpboot/debian-installer/amd64/initrd.gz';
-
-	# FIXME: this is a dirty hack to get the cmdline from the PXE config file.
-	my $vm_ip_in_hex = __get_host_ip_in_hex($Z, $vm_hostname);
-	my $pxe_cfg_file = "/distrib/tftpboot/pxelinux.cfg/$vm_ip_in_hex";
-	my $cmdline      = qx{grep DEBCONF_PRIORITY $pxe_cfg_file};
-	chomp $cmdline;
-	$cmdline =~ s{\A \s* append \s* (.*) \s* \z}{$1}xms;
-
-	# Disable framebuffer for the installation, I prefer the good old text mode,
-	# especially when connected via the "curses" or "monitor" KVM modes!
-	$cmdline =~ s{vga=normal}{fb=false}xms;
-
-	push @kvm_cmd,
-	    '-no-reboot',
-	    '-kernel',	$kernel,
-	    '-initrd',	$initrd,
-	    '-append',	$cmdline;
+    if ( $option->{'mode'} eq 'install' ) {
+        __system_or_croak(
+            "kvm-img create $vm_disk_file $option->{'disk-size'}M");
+
+       # TODO: To fix the two following "FIXME" markers: extract the necessary
+       # parts from mk_pxelinuxcfg and put them in a package in order to be
+       # able to use here $SUBST (for ARCH PRESEED_URL CMDLINE etc.)
+       #
+       # kernel debian-installer/%ARCH%/linux initrd
+       # debian-installer/%ARCH%/initrd.gz append DEBCONF_PRIORITY=critical
+       # vga=normal auto=true initrd=debian-installer/%ARCH%/initrd.gz
+       # interface=eth0 netcfg/no_default_route=true url=%PRESEED_URL%
+       # url/checksum=%PRESEED_MD5% -- %CONSOLE% %CMDLINE%
+
+        # FIXME: 'amd64' hardcoded
+        my $kernel = '/distrib/tftpboot/debian-installer/amd64/linux';
+        my $initrd = '/distrib/tftpboot/debian-installer/amd64/initrd.gz';
+
+    # FIXME: this is a dirty hack to get the cmdline from the PXE config file.
+        my $vm_ip_in_hex = __get_host_ip_in_hex( $Z, $vm_hostname );
+        my $pxe_cfg_file = "/distrib/tftpboot/pxelinux.cfg/$vm_ip_in_hex";
+        my $cmdline      = qx{grep DEBCONF_PRIORITY $pxe_cfg_file};
+        chomp $cmdline;
+        $cmdline =~ s{\A \s* append \s* (.*) \s* \z}{$1}xms;
+
+  # Disable framebuffer for the installation, I prefer the good old text mode,
+  # especially when connected via the "curses" or "monitor" KVM modes!
+        $cmdline =~ s{vga=normal}{fb=false}xms;
+
+        push @kvm_cmd,
+            '-no-reboot',
+            '-kernel', $kernel,
+            '-initrd', $initrd,
+            '-append', $cmdline;
     }
 
     __system_or_croak(@kvm_cmd);
 }
-
 
 sub usage {
     warn <<"EOH";
@@ -291,98 +280,98 @@
 EOH
 }
 
-
 # Get the IP address for iface $iface of host $host
 sub __get_iface_ip {
-    my ($Z, $host, $iface) = @_;
-
-    my $hostclass = Host_class( $host, $Z );
-    my $N = $Z->{'SERVERS'}->{'BY_NAME'}->{$hostclass};
-    my $M = $N->{'SRVLIST'}->{$host};
+    my ( $Z, $host, $iface ) = @_;
+
+    my $hostclass     = Host_class( $host, $Z );
+    my $N             = $Z->{'SERVERS'}->{'BY_NAME'}->{$hostclass};
+    my $M             = $N->{'SRVLIST'}->{$host};
     my $host_dot_vlan = '';
 
-    foreach my $hdv (keys %{ $M->{'ifup'} }) {
-	$host_dot_vlan = $hdv
-	    if $M->{'ifup'}->{$hdv} eq $iface;
+    foreach my $hdv ( keys %{ $M->{'ifup'} } ) {
+        $host_dot_vlan = $hdv
+            if $M->{'ifup'}->{$hdv} eq $iface;
     }
 
     croak "FATAL: Unable to find iface $iface"
-	unless $host_dot_vlan;
+        unless $host_dot_vlan;
 
     my $ip = $M->{'zone'}->{$host_dot_vlan}->{'FIELD'};
 
     return $ip;
 }
-
 
 # Same as __get_iface_ip(), but give the IP address in hexadecimal format
 sub __get_host_ip_in_hex {
-    my ($Z, $host) = @_;
-
-    my $ip = __get_iface_ip($Z, $host, 'eth0');
+    my ( $Z, $host ) = @_;
+
+    my $ip = __get_iface_ip( $Z, $host, 'eth0' );
     return sprintf '%02X%02X%02X%02X', split '\.', $ip;
 }
-
 
 # Return a list of anonymous hashrefs describing the $host interfaces
 sub __get_list_of_interfaces {
-    my ($Z, $host) = @_;
-
-    my ($dhcpif, $dhcp_address) = Get_Dhcp_Infos( $Z, $host );
+    my ( $Z, $host ) = @_;
+
+    my ( $dhcpif, $dhcp_address ) = Get_Dhcp_Infos( $Z, $host );
 
     my @interfaces = ();
-#    #UMRemap_If( $Z, $host );
+
+    #    #UMRemap_If( $Z, $host );
     my $umif = Get_UM_If( $Z, $host );
     foreach my $ifname ( sort { cmpif( $a, $b ) } keys %{$umif} ) {
-	my $tag = $umif->{$ifname};
-	next unless defined $tag;
-
-	my $virtual_ifname = __get_virtual_ifname($host, $ifname);
-	my $ip_address     = __get_iface_ip($Z, $host, $ifname);
-
-	warn "DEBUG:   iface $ifname <-> tag $tag <-> vif $virtual_ifname <-> IP $ip_address\n"
-	    if $option->{'debug'};
-
-	my ($bridge_name, $mac_address);
-	if ($tag == 13) {
-#	    $bridge_name = 'brsystem2'; # FIXME gruik temporaire
-	    $mac_address = uc $dhcp_address;
-	}
-	else {
-	    if ($tag eq 'TRUNK') {
-		$tag = 0;
-	    }
-
-	    $bridge_name = "br$tag";
-
-	    my @mac_address = qw( AC DE 48 ); # private
-	    # Ajouter les 3 derniers octets de l'adresse IP de cette interface
-	    my @ip_address = split '\.', $ip_address;
-	    shift @ip_address;
-	    push @mac_address, map { sprintf "%02X", $_ } @ip_address;
-
-	    $mac_address = join ':', @mac_address;
-	}
-
-	push @interfaces, {
-	    bridge => $bridge_name,
-	    ifname => $virtual_ifname,
-	    ip     => $ip_address,
-	    mac    => $mac_address,
-	    vlan   => $tag,
-	};
+        my $tag = $umif->{$ifname};
+        next unless defined $tag;
+
+        my $virtual_ifname = __get_virtual_ifname( $host, $ifname );
+        my $ip_address = __get_iface_ip( $Z, $host, $ifname );
+
+        warn
+            "DEBUG:   iface $ifname <-> tag $tag <-> vif $virtual_ifname <-> IP $ip_address\n"
+            if $option->{'debug'};
+
+        my ( $bridge_name, $mac_address );
+        if ( $tag == 13 ) {
+
+            #	    $bridge_name = 'brsystem2'; # FIXME gruik temporaire
+            $mac_address = uc $dhcp_address;
+        }
+        else {
+            if ( $tag eq 'TRUNK' ) {
+                $tag = 0;
+            }
+
+            $bridge_name = "br$tag";
+
+            my @mac_address = qw( AC DE 48 );    # private
+              # Ajouter les 3 derniers octets de l'adresse IP de cette interface
+            my @ip_address = split '\.', $ip_address;
+            shift @ip_address;
+            push @mac_address, map { sprintf "%02X", $_ } @ip_address;
+
+            $mac_address = join ':', @mac_address;
+        }
+
+        push @interfaces,
+            {
+            bridge => $bridge_name,
+            ifname => $virtual_ifname,
+            ip     => $ip_address,
+            mac    => $mac_address,
+            vlan   => $tag,
+            };
     }
 
     return @interfaces;
 }
-
 
 #
 # In our model, the virtual interfaces (the tun devices) are named as
 # "$hostname.$number", where $hostname is the VM name and $number is the VM
 # network interface number. For instance, the tun device for host admstream00
 # interface eth2 would be "admstream00.2".
-# 
+#
 # However, a network interface name has a maximum size of $IFNAMESIZ - 1
 # characters. So, the tun device for host abv1-ncdn-varnish00 interfaces eth0
 # and eth1, "abv1-ncdn-varnish00.0" and "abv1-ncdn-varnish00.1", would both be
@@ -394,13 +383,17 @@
 # gives us short enough names, such as "m-8f6aac88.0" and "m-8f6aac88.1"
 # instead of "abv1-ncdn-varnish00.0" and "abv1-ncdn-varnish00.1".
 #
-sub __get_virtual_ifname { my ($host, $ifname) = @_;
-
-    my $IFNAMESIZ         = 16;             # <linux/if.h>
-    my $MAX_HOSTNAME_SIZE = $IFNAMESIZ - 3; # '.' + one digit + NULL
+sub __get_virtual_ifname {
+    my ( $host, $ifname ) = @_;
+
+    my $IFNAMESIZ         = 16;                # <linux/if.h>
+    my $MAX_HOSTNAME_SIZE = $IFNAMESIZ - 3;    # '.' + one digit + NULL
 
     my ($iface_number) = $ifname =~ m{\A \D+ (\d+) \z}xms;
-    my $mangled_hostname = length($host) > $MAX_HOSTNAME_SIZE ? "m-" . crc32_hex($host) : $host;
+    my $mangled_hostname
+        = length($host) > $MAX_HOSTNAME_SIZE
+        ? "m-" . crc32_hex($host)
+        : $host;
 
     my $virtual_ifname = join '.', $mangled_hostname, $iface_number;
 
@@ -408,65 +401,66 @@
 }
 
 sub __install_tap_interfaces {
-    my ($option, @interfaces) = @_;
+    my ( $option, @interfaces ) = @_;
 
     foreach my $iface (@interfaces) {
-	# create the TUN/TAP device
-	__create_tun_device($option, $iface->{'ifname'});
-
-	# add it to the bridge hosting the corresponding VLAN
-	__brctl_addif($option, $iface->{'vlan'}, $iface->{'ifname'});
+
+        # create the TUN/TAP device
+        __create_tun_device( $option, $iface->{'ifname'} );
+
+        # add it to the bridge hosting the corresponding VLAN
+        __brctl_addif( $option, $iface->{'vlan'}, $iface->{'ifname'} );
     }
 }
 
 sub __remove_tap_interfaces {
-    my ($option, @interfaces) = @_;
+    my ( $option, @interfaces ) = @_;
 
     foreach my $iface (@interfaces) {
-	__brctl_delif($option, $iface->{'vlan'}, $iface->{'ifname'});
-	__delete_tun_device($option, $iface->{'ifname'});
+        __brctl_delif( $option, $iface->{'vlan'}, $iface->{'ifname'} );
+        __delete_tun_device( $option, $iface->{'ifname'} );
     }
 }
 
 sub __create_tun_device {
-    my ($option, $ifname) = @_;
+    my ( $option, $ifname ) = @_;
 
     warn "INFO: creating tun device $ifname\n"
-	if $option->{'verbose'};
+        if $option->{'verbose'};
 
     __system_or_carp("tunctl -b -t $ifname");
     __system_or_carp("ifconfig $ifname up");
 }
 
 sub __delete_tun_device {
-    my ($option, $ifname) = @_;
+    my ( $option, $ifname ) = @_;
 
     warn "INFO: deleting tun device $ifname\n"
-	if $option->{'verbose'};
+        if $option->{'verbose'};
 
     __system_or_carp("ifconfig $ifname down");
     __system_or_carp("tunctl -d $ifname");
 }
 
 sub __brctl_addif {
-    my ($option, $vlan_tag, $ifname) = @_;
+    my ( $option, $vlan_tag, $ifname ) = @_;
 
     my $brname = "br$vlan_tag";
 
     warn "INFO: adding tun device $ifname to bridge $brname\n"
-	if $option->{'verbose'};
+        if $option->{'verbose'};
 
     my $cmd = "brctl addif $brname $ifname";
     __system_or_carp($cmd);
 }
 
 sub __brctl_delif {
-    my ($option, $vlan_tag, $ifname) = @_;
+    my ( $option, $vlan_tag, $ifname ) = @_;
 
     my $brname = "br$vlan_tag";
 
     warn "INFO: removing tun device $ifname from bridge $brname\n"
-	if $option->{'verbose'};
+        if $option->{'verbose'};
 
     my $cmd = "brctl delif $brname $ifname";
     __system_or_carp($cmd);
@@ -476,13 +470,13 @@
     my @cmd = @_;
 
     system(@cmd) == 0
-	or croak "FATAL: system(@cmd): $OS_ERROR";
+        or croak "FATAL: system(@cmd): $OS_ERROR";
 }
 
 sub __system_or_carp {
     my @cmd = @_;
 
     system(@cmd) == 0
-	or carp "IGNORED: system(@cmd): $OS_ERROR\nGo check manually!";
-}
-
+        or carp "IGNORED: system(@cmd): $OS_ERROR\nGo check manually!";
+}
+

Propchange: trunk/tools/kvmlaunch
            ('svn:mergeinfo' removed)

Modified: trunk/tools/pflaunch
URL: http://svn.debian.org/wsvn/pf-tools/trunk/tools/pflaunch?rev=902&op=diff
==============================================================================
--- trunk/tools/pflaunch (original)
+++ trunk/tools/pflaunch Wed Sep  8 19:28:28 2010
@@ -31,7 +31,9 @@
 # il va chercher la conf dans config/GLOBAL/PF/«hostname».cfg
 #
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
 use Expect;
+use File::Path qw( make_path );
 use File::Temp;
 use Getopt::Long;
 use Net::IP;
@@ -39,10 +41,9 @@
 use Sys::Hostname;
 use Thread;
 
-use Sitalibs::Config;
-
 use PFTools::Net;
 use PFTools::Update;
+use Sitalibs::Config;
 
 my $HOSTNAME = hostname;
 
@@ -93,9 +94,9 @@
     return unless $a and ref $a eq 'HASH';
 
     foreach my $section ( keys %$a ) {
-	foreach my $key ( keys %{ $a->{$section} } ) {
-	    $a->{$section}->{$key} =~ s/\s+#\s+.*$//;
-	}
+        foreach my $key ( keys %{ $a->{$section} } ) {
+            $a->{$section}->{$key} =~ s/\s+#\s+.*$//;
+        }
     }
 
     return $a;
@@ -109,9 +110,9 @@
     my ($if) = @_;
 
     if ( length($if) > $IFNAMSIZ - 1 ) {
-	my $oldif = $if;
-	$if = substr( $if, length($if) - $IFNAMSIZ + 1 );
-	__Debug("ifname trop long : $oldif -> $if");
+        my $oldif = $if;
+        $if = substr( $if, length($if) - $IFNAMSIZ + 1 );
+        __Debug("ifname trop long : $oldif -> $if");
     }
 
     return $if;
@@ -124,27 +125,27 @@
 sub __runCmds ($;$) {
     my $cmds;
     if ( ref $_[0] eq 'ARRAY' ) {
-	$cmds = shift;
+        $cmds = shift;
     }
     else {
-	push @$cmds, shift;
+        push @$cmds, shift;
     }
     return unless defined $cmds;
     my $quiet = shift;
 
     my $ok = 1;    # OK
     foreach my $cmd (@$cmds) {
-	my @ret = `$cmd 2>&1`;
-
-	if ($?) {
-	    $ok = 0;
-	}
-	elsif ($quiet) {
-	    __Debug(@ret);
-	}
-	else {
-	    __Debug(@ret);
-	}
+        my @ret = `$cmd 2>&1`;
+
+        if ($CHILD_ERROR) {
+            $ok = 0;
+        }
+        elsif ($quiet) {
+            __Debug(@ret);
+        }
+        else {
+            __Debug(@ret);
+        }
     }
     return $ok;
 }
@@ -156,18 +157,18 @@
     my $vm = shift;
 
     unless ( defined $vm and $vm ) {
-	__Err("__FamillyNumFromVM appelé sans parametre");
-	return;
+        __Err("__FamillyNumFromVM appelé sans parametre");
+        return;
     }
 
     if ( defined $cache->{'FamillyNumFromVM '}->{$vm}
-	and $cache->{'FamillyNumFromVM '}->{$vm} )
+        and $cache->{'FamillyNumFromVM '}->{$vm} )
     {
-	return (
-	    $cache->{'FamillyNumFromVM '}->{$vm}->{f},
-	    $cache->{'FamillyNumFromVM '}->{$vm}->{n},
-	    $cache->{'FamillyNumFromVM '}->{$vm}->{s}
-	);
+        return (
+            $cache->{'FamillyNumFromVM '}->{$vm}->{f},
+            $cache->{'FamillyNumFromVM '}->{$vm}->{n},
+            $cache->{'FamillyNumFromVM '}->{$vm}->{s}
+        );
     }
 
     my $famille;
@@ -175,41 +176,41 @@
     my $section;
 
     if ( $vm =~ /^(\S+)(\d\d)$/ ) {
-	$famille = $1;
-	$num     = $2;
-	$section = $famille . "%%";
-	unless ( exists $private_network->{$section} ) {
-	    if ( exists $private_network->{$vm} ) {
-		__Info(
-		    "La section $section n'existe pas, c'est $vm qui sera prise à la place"
-		);
-		$section = $vm;
-	    }
-	    else {
-		__Err(
-		    "La section $section n'existe pas, et pas de section $vm à la place. Problème a venir ..."
-		);
-	    }
-	}
+        $famille = $1;
+        $num     = $2;
+        $section = $famille . "%%";
+        unless ( exists $private_network->{$section} ) {
+            if ( exists $private_network->{$vm} ) {
+                __Info(
+                    "La section $section n'existe pas, c'est $vm qui sera prise à la place"
+                );
+                $section = $vm;
+            }
+            else {
+                __Err(
+                    "La section $section n'existe pas, et pas de section $vm à la place. Problème a venir ..."
+                );
+            }
+        }
     }
     elsif ( $vm =~ /^(\S+)$/ ) {
-	__Info(
-	    "Attention, nom de machine sans extension numerique, c'est bien ce que vous voulez ?"
-	);
-	$famille = $1;
-	$num     = 0;
-	$section = $famille;
-	unless ( $private_network->{$section}->{'umlfilename.default'} ) {
-	    __Info(
-		"Attention, la machine `$vm' n'a pas de clef umlfilename.default, elle ne sera donc pas lancée"
-	    );
-	}
+        __Info(
+            "Attention, nom de machine sans extension numerique, c'est bien ce que vous voulez ?"
+        );
+        $famille = $1;
+        $num     = 0;
+        $section = $famille;
+        unless ( $private_network->{$section}->{'umlfilename.default'} ) {
+            __Info(
+                "Attention, la machine `$vm' n'a pas de clef umlfilename.default, elle ne sera donc pas lancée"
+            );
+        }
     }
     else {
-	__Fault(
-	    "L'entrée `$vm' de votre fichier de configuration de correspond pas a un\n
+        __Fault(
+            "L'entrée `$vm' de votre fichier de configuration de correspond pas a un\n
           nom de machine valide."
-	);
+        );
     }
     $cache->{'FamillyNumFromVM '}->{$vm}->{f} = $famille;
     $cache->{'FamillyNumFromVM '}->{$vm}->{n} = $num;
@@ -225,15 +226,15 @@
     my $s = $private_network->{$section};
 
     __Fault("Familly '$famille' NOT found !")
-	unless ( defined($s) and ($section) );
+        unless ( defined($s) and ($section) );
     __Fault("VM $famille$num out of range.") if ( $s->{number} <= $num );
 
     my $listalias;
     foreach my $key ( keys %$s ) {
-	if ( $key =~ /^alias\.(\S+)/ ) {
-	    push @$listalias, $1 if ( $num == 0 );
-	    push @$listalias, $1 . $num;
-	}
+        if ( $key =~ /^alias\.(\S+)/ ) {
+            push @$listalias, $1 if ( $num == 0 );
+            push @$listalias, $1 . $num;
+        }
     }
 
     return $listalias;
@@ -253,12 +254,12 @@
 
     # Recherche des ipstart
     $ipstart->{default}
-	= ( defined( $s->{"ipstart.default"} ) )
-	? $s->{"ipstart.default"}
-	: -1;
+        = ( defined( $s->{"ipstart.default"} ) )
+        ? $s->{"ipstart.default"}
+        : -1;
 
     foreach my $key ( keys %$s ) {
-	if ( $key =~ /^ipstart\.(\S+)/ ) {
+        if ( $key =~ /^ipstart\.(\S+)/ ) {
 
      # ATTENTION ce calcul est faux si on ne travaille pas que sur des /24. Et
      # c'est justement le cas avec le nouvel adressage !
@@ -266,26 +267,26 @@
      #die "$famille, $num : ipstart.$1 out of range (".$s->{$key}.")\n"
      #	  if (($s->{$key} > 254) or ($s->{$key} < 1));
 
-	    $ipstart->{$1} = $s->{$key};
-	}
+            $ipstart->{$1} = $s->{$key};
+        }
     }
 
     # Creation des adresses
     foreach my $key ( keys %$s ) {
-	if ( $key =~ /^interface\.\S+/ ) {
-	    my $vlan    = $s->{$key};
-	    my $network = $private_network->{$vlan}->{'network'};
-	    __Err("Can't get IP of vlan $vlan") unless defined $network;
-	    my $ip = Address(
-		$network,
-		( defined $ipstart->{$vlan} )
-		? $ipstart->{$vlan}
-		: $ipstart->{default},
-		$num
-	    );
-
-	    push @$listip, { lan => $vlan, ip => $ip };
-	}
+        if ( $key =~ /^interface\.\S+/ ) {
+            my $vlan    = $s->{$key};
+            my $network = $private_network->{$vlan}->{'network'};
+            __Err("Can't get IP of vlan $vlan") unless defined $network;
+            my $ip = Address(
+                $network,
+                ( defined $ipstart->{$vlan} )
+                ? $ipstart->{$vlan}
+                : $ipstart->{default},
+                $num
+            );
+
+            push @$listip, { lan => $vlan, ip => $ip };
+        }
     }
 
     return $listip;
@@ -301,33 +302,33 @@
     my $l = Config_Key( $configfile, "init", '@vlan' );
 
     if ($l) {
-	foreach ( @{$l} ) {
-	    $h->{"vlan-$_"} = 1 if defined $_;
-	}
+        foreach ( @{$l} ) {
+            $h->{"vlan-$_"} = 1 if defined $_;
+        }
     }
 
     my $section_start = Config_Key( $configfile, "init", '@start' );
 
     if ( !$section_start ) {
-	__Fault(
-	    "Je ne trouve pas l'entrée \@start dans $configfile, (section [init])"
-	);
+        __Fault(
+            "Je ne trouve pas l'entrée \@start dans $configfile, (section [init])"
+        );
     }
 
     foreach my $vm (@$section_start) {
-	my ( $famille, $num, $section ) = __FamillyNumFromVM($vm);
-
-	my $s = $private_network->{$section};
-
-	unless ($s) {
-	    __Fault(
-		"(Je ne peux pas lire la section `$section` from $privatenetworkfile pour la vm `$vm'"
-	    );
-	}
-
-	foreach my $lan ( %{$s} ) {
-	    $h->{ $s->{$lan} } = 1 if ( $lan =~ /^interface\./ );
-	}
+        my ( $famille, $num, $section ) = __FamillyNumFromVM($vm);
+
+        my $s = $private_network->{$section};
+
+        unless ($s) {
+            __Fault(
+                "(Je ne peux pas lire la section `$section` from $privatenetworkfile pour la vm `$vm'"
+            );
+        }
+
+        foreach my $lan ( %{$s} ) {
+            $h->{ $s->{$lan} } = 1 if ( $lan =~ /^interface\./ );
+        }
     }
 
     # le sort, c'est juste pour ce que soit toujours traité dans le même ordre
@@ -345,19 +346,19 @@
     my @brshow = `brctl show`;
     shift @brshow;    # ligne d'entete
     foreach my $line (@brshow) {
-	$h->{$1} = 1 if ( $line =~ /^(\S+)\s+/ );
+        $h->{$1} = 1 if ( $line =~ /^(\S+)\s+/ );
     }
 
     # Dans le cas ou la configuration a changé entre temps
     if ( opendir( DIR, $PF_STATUS_DIR . "/bridge/" ) ) {
-	foreach ( readdir DIR ) {
-	    next if /^\./;
-	    $h->{$_} = 1;
-	}
-	closedir DIR;
+        foreach ( readdir DIR ) {
+            next if /^\./;
+            $h->{$_} = 1;
+        }
+        closedir DIR;
     }
     else {
-	__Err( "Can't open dir " . $PF_STATUS_DIR . "/bridge/" );
+        __Err( "Can't open dir " . $PF_STATUS_DIR . "/bridge/" );
     }
 
     @$listbr = sort keys %$h;
@@ -374,7 +375,7 @@
     my $section = $private_network->{$vlan};
 
     __Err("Can't read section [$vlan] from `$privatenetworkfile'")
-	unless ( defined($section) and ($section) );
+        unless ( defined($section) and ($section) );
     return $section;
 }
 
@@ -386,16 +387,16 @@
     my $listVM = Config_Key( $configfile, "init", "\@start" );
 
     foreach my $vm (@$listVM) {
-	my $uml_cfg = Config_Section( $configfile, "uml-$vm" );
-
-	my $priorite = 10;    # Val par defaut
-	$priorite = $uml_cfg->{priorite}
-	    if ( defined( $uml_cfg->{priorite} ) );
-
-	__Fault("Mauvaise priorite pour la section [uml-$vm]")
-	    if ( $priorite < 0 or $priorite > 255 );
-
-	$umlToLaunch->[$priorite] .= " $vm";
+        my $uml_cfg = Config_Section( $configfile, "uml-$vm" );
+
+        my $priorite = 10;    # Val par defaut
+        $priorite = $uml_cfg->{priorite}
+            if ( defined( $uml_cfg->{priorite} ) );
+
+        __Fault("Mauvaise priorite pour la section [uml-$vm]")
+            if ( $priorite < 0 or $priorite > 255 );
+
+        $umlToLaunch->[$priorite] .= " $vm";
     }
 
     return $umlToLaunch;
@@ -417,15 +418,15 @@
 
     my @ipstart;
     if ( $s->{ "ipstart." . $vlan } ) {
-	@ipstart = split( /\./, $s->{ "ipstart." . $vlan } );
+        @ipstart = split( /\./, $s->{ "ipstart." . $vlan } );
     }
     else {
-	@ipstart = split( /\./, $s->{"ipstart.default"} ) unless @ipstart;
+        @ipstart = split( /\./, $s->{"ipstart.default"} ) unless @ipstart;
     }
 
     unless (@ipstart) {
-	__Err("can't find ipstart for `$section'");
-	return;
+        __Err("can't find ipstart for `$section'");
+        return;
     }
     @ipstart = reverse @ipstart;
     push @ipstart, "0" while ( @ipstart < 4 );
@@ -433,8 +434,8 @@
 
     my $n = $private_network->{$vlan}->{'network'};
     __Fault(  "Je ne peux pas lire la s network du "
-	    . "vlan `$vlan' dans '$privatenetworkfile'" )
-	unless $n;
+            . "vlan `$vlan' dans '$privatenetworkfile'" )
+        unless $n;
 
     my @n_ip;
     @n_ip = split( /\./, $n );
@@ -443,8 +444,8 @@
     $ip[$_] = ( $n_ip[$_] + $ipstart[$_] ) foreach ( 0 .. 3 );
 
     unless ( @n_ip == 4 ) {
-	__Err("Ip invalide pour `$vm', `$vlan'");
-	return;
+        __Err("Ip invalide pour `$vm', `$vlan'");
+        return;
     }
     $n_ip[3] += $num;
     my $ip = join ".", @ip;
@@ -470,13 +471,13 @@
     $mtu = Config_Key( $configfile, "vlan-default", "mtu" ) unless $mtu;
 
     unless ($mtu) {
-	__Err(
-	    "Can't read mtu from vlan-* section, using default (`$vlan_default_mtu')"
-	);
-	$mtu = $vlan_default_mtu;
+        __Err(
+            "Can't read mtu from vlan-* section, using default (`$vlan_default_mtu')"
+        );
+        $mtu = $vlan_default_mtu;
     }
     if ( $mtu > 1496 ) {
-	__Err("$vlan : mtu de `$mtu' > à 1496");
+        __Err("$vlan : mtu de `$mtu' > à 1496");
     }
 
     my $t = Config_Key( $configfile, $vlan, "\@ip" );
@@ -485,54 +486,54 @@
     my $arp = "";
     my $settingarp = Config_Key( $configfile, $vlan, "arp" );
     $settingarp = Config_Key( $configfile, "vlan-default", "arp" )
-	unless $settingarp;
+        unless $settingarp;
     if ($settingarp) {
-	if ( $settingarp eq "true" ) {
-	    $arp = "arp";
-	}
-	elsif ( $settingarp eq "false" ) {
-	    $arp = "-arp";
-	}
-	else {
-	    __Err("Mauvaise valeur pour la clef arp (true/false)");
-	}
+        if ( $settingarp eq "true" ) {
+            $arp = "arp";
+        }
+        elsif ( $settingarp eq "false" ) {
+            $arp = "-arp";
+        }
+        else {
+            __Err("Mauvaise valeur pour la clef arp (true/false)");
+        }
     }
 
     __Info(
-	"Attention vous n'avez pas d'\@ip ni dans la section [vlan-default] ni"
-	    . "dans [vlan-$vlan] pour le vlan `$vlan'" )
-	unless $t;
+        "Attention vous n'avez pas d'\@ip ni dans la section [vlan-default] ni"
+            . "dans [vlan-$vlan] pour le vlan `$vlan'" )
+        unless $t;
 
     foreach my $v (@$t) {
-	next unless defined $v;
-	if ( $v =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}(?:\/[\d.]+)?$/ ) {
+        next unless defined $v;
+        if ( $v =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}(?:\/[\d.]+)?$/ ) {
 
 # une IP et éventuellement un préfixe ou un netmask : 1.2.3.4/24 ou 1.2.3.4/255.255.255.0
 # si pas de préfixe ou netmask : le netmask du vlan
-	    my ( $ip, $cidr ) = ipv4_parse($v);    # 1.2.3.4, 24
-	    my $mask
-		= $cidr
-		? ipv4_cidr2msk($cidr)
-		: $vlan_setup->{netmask};          # 255.255.255.0
-	    __Debug("DEBUG: v=$v ip=$ip mask=$mask");
-	    push @ip, [ $ip, $mask ];
-	}
-	elsif ( $v ne 'none' ) {
+            my ( $ip, $cidr ) = ipv4_parse($v);    # 1.2.3.4, 24
+            my $mask
+                = $cidr
+                ? ipv4_cidr2msk($cidr)
+                : $vlan_setup->{netmask};          # 255.255.255.0
+            __Debug("DEBUG: v=$v ip=$ip mask=$mask");
+            push @ip, [ $ip, $mask ];
+        }
+        elsif ( $v ne 'none' ) {
 
    # un nom de machine (juste un hostname et on le prend dans le vlan courant)
-	    my $vn = __GetVMnet($v);
-
-	    unless ($vn) {
-		__Err(
-		    "Mauvaise valeur : `$_' dans le fichier de conf dans une section \@ip"
-		);
-	    }
-
-	    foreach (@$vn) {
-		push @ip, [ $_->{ip}, $vlan_setup->{netmask} ]
-		    if $_->{lan} eq $vlan and $_->{ip};
-	    }
-	}
+            my $vn = __GetVMnet($v);
+
+            unless ($vn) {
+                __Err(
+                    "Mauvaise valeur : `$_' dans le fichier de conf dans une section \@ip"
+                );
+            }
+
+            foreach (@$vn) {
+                push @ip, [ $_->{ip}, $vlan_setup->{netmask} ]
+                    if $_->{lan} eq $vlan and $_->{ip};
+            }
+        }
     }
 
     my $i;
@@ -540,30 +541,30 @@
 
     # retrouver les interfaces que j'ai déja lancée
     if ( open STATUS_IFBR, "<" . $PF_STATUS_DIR . "/ifbr" ) {
-	foreach (<STATUS_IFBR>) {
-	    $i++ if (/^($brname|$brname:\d+)$/);
-	}
-	close STATUS_IFBR;
+        foreach (<STATUS_IFBR>) {
+            $i++ if (/^($brname|$brname:\d+)$/);
+        }
+        close STATUS_IFBR;
     }
     open STATUS_IFBR, ">>" . $PF_STATUS_DIR . "/ifbr";
     foreach my $cidr (@ip) {
-	my ( $ip, $mask ) = @$cidr;
-
-	my $ifbr = $brname;
-	$ifbr .= ":" if ($i);
-	$ifbr .= $i - 1 if ($i);
-	print STATUS_IFBR $ifbr . "\n";
-
-	my $cmd = "ifconfig $ifbr";
-	$cmd .= " $ip";
-	$cmd .= " netmask $mask";
-	$cmd .= " $arp";
-	$cmd .= " mtu $mtu";
-	$cmd .= " promisc" unless $i;
-	$cmd .= " up";
-
-	push @$cmds, $cmd;
-	$i++;
+        my ( $ip, $mask ) = @$cidr;
+
+        my $ifbr = $brname;
+        $ifbr .= ":" if ($i);
+        $ifbr .= $i - 1 if ($i);
+        print STATUS_IFBR $ifbr . "\n";
+
+        my $cmd = "ifconfig $ifbr";
+        $cmd .= " $ip";
+        $cmd .= " netmask $mask";
+        $cmd .= " $arp";
+        $cmd .= " mtu $mtu";
+        $cmd .= " promisc" unless $i;
+        $cmd .= " up";
+
+        push @$cmds, $cmd;
+        $i++;
     }
     close STATUS_IFBR;
 
@@ -587,13 +588,13 @@
     my $brname = "br" . $tag;
 
     __Info(   "  Mise en place de '" 
-	    . $vlan . "` ("
-	    . $vlan_setup->{comment}
-	    . ")" );
+            . $vlan . "` ("
+            . $vlan_setup->{comment}
+            . ")" );
     __Debug( "  bridge `" . $brname . " @ " . $vlan_setup->{network} . "'" );
 
     #  `ifconfig $brname 2>/dev/null`;
-    __runCmds( ["brctl addbr $brname"], 1 );    # unless ($?);
+    __runCmds( ["brctl addbr $brname"], 1 );    # unless ($CHILD_ERROR);
 
     # J'applique les réglages pour le bridge,
     # s'il y a un réglage particulier pour un bridge je l'utilise
@@ -602,24 +603,24 @@
     my $svlan = Config_Section( $configfile, $vlan );
 
     foreach ( keys %$sdef ) {
-	$br_setting->{$1} = $sdef->{ "br-" . $1 }
-	    if (/^br-(.+)$/);
+        $br_setting->{$1} = $sdef->{ "br-" . $1 }
+            if (/^br-(.+)$/);
     }
     foreach ( keys %$svlan ) {
-	$br_setting->{$1} = $svlan->{ "br-" . $1 }
-	    if (/^br-(.+)$/);
+        $br_setting->{$1} = $svlan->{ "br-" . $1 }
+            if (/^br-(.+)$/);
     }
 
     unless ($br_setting) {
-	__Debug(
-	    "  Je ne trouve pas de réglage pour le br, j'utilise ce par defaut."
-	);
-	$br_setting = { stp => 'off', setfd => 1, sethello => 1 };
+        __Debug(
+            "  Je ne trouve pas de réglage pour le br, j'utilise ce par defaut."
+        );
+        $br_setting = { stp => 'off', setfd => 1, sethello => 1 };
     }
 
     foreach $para ( keys %{$br_setting} ) {
-	__Debug("  $brname : $para = $br_setting->{$para}");
-	__runCmds( [ "brctl $para $brname " . $br_setting->{$para} ], "1" );
+        __Debug("  $brname : $para = $br_setting->{$para}");
+        __runCmds( [ "brctl $para $brname " . $br_setting->{$para} ], "1" );
 
     }
 
@@ -627,26 +628,26 @@
     my $trunk = Config_Key( $configfile, "global", "trunk" );
     $trunk = "eth1" unless ($trunk);
     `ifconfig $trunk up 2>/dev/null`;
-    unless ($?) {
-	__Info("    Upping `$trunk.$tag'");
-	__runCmds(
-	    [   "vconfig set_name_type DEV_PLUS_VID_NO_PAD",
-		"vconfig add $trunk $tag",
-		"ifconfig $trunk.$tag 0.0.0.0 mtu 1496 promisc up",
-	    ]
-	);
-	__BridgeAttacheIf( $brname, $trunk . "." . $tag );
+    unless ($CHILD_ERROR) {
+        __Info("    Upping `$trunk.$tag'");
+        __runCmds(
+            [   "vconfig set_name_type DEV_PLUS_VID_NO_PAD",
+                "vconfig add $trunk $tag",
+                "ifconfig $trunk.$tag 0.0.0.0 mtu 1496 promisc up",
+            ]
+        );
+        __BridgeAttacheIf( $brname, $trunk . "." . $tag );
     }
 
     # J'attache les pates des vm (dans le cas d'un restart)
     my $tmp = __GetIfByVlan($vlan);
     foreach (@$tmp) {
-	__BridgeAttacheIf( $brname,
-	    __sanitize_ifname( $_ . "." . $vlan_setup->{tag} ) );
+        __BridgeAttacheIf( $brname,
+            __sanitize_ifname( $_ . "." . $vlan_setup->{tag} ) );
     }
 
     unless ( -f $PF_STATUS_DIR . "/bridge/" . $brname ) {
-	`touch $PF_STATUS_DIR"/bridge/"$brname`;
+        `touch $PF_STATUS_DIR"/bridge/"$brname`;
     }
 }
 
@@ -660,34 +661,34 @@
     my $brname = shift;
 
     unless ($brname) {
-	__Debug("__BridgeDel: pas de valeur en parametre");
-	return;
+        __Debug("__BridgeDel: pas de valeur en parametre");
+        return;
     }
 
     my $ifattached = __BridgeGetIfAttached($brname);
     if (@$ifattached) {
-	__Debug(  "Vous avez "
-		. @$ifattached
-		. " interface(s) attachée(s) à $brname" );
-	__Debug("Je les détache...");
-
-	__BridgeDetacheIf( $brname, $_ ) foreach (@$ifattached);
+        __Debug(  "Vous avez "
+                . @$ifattached
+                . " interface(s) attachée(s) à $brname" );
+        __Debug("Je les détache...");
+
+        __BridgeDetacheIf( $brname, $_ ) foreach (@$ifattached);
     }
 
     __Info("  J'arrete le bridge `$brname'");
 
     # Je vire les alias du br
     if ( open STATUS_IFBR, "<" . $PF_STATUS_DIR . "/ifbr" ) {
-	foreach (<STATUS_IFBR>) {
-	    next unless (/^$brname:/);
-	    chomp;
-	    `ifconfig $_ 2>/dev/null`;
-	    __runCmds( "ifconfig $_ down", 1 ) unless $?;
-	}
-	close STATUS_IFBR;
+        foreach (<STATUS_IFBR>) {
+            next unless (/^$brname:/);
+            chomp;
+            `ifconfig $_ 2>/dev/null`;
+            __runCmds( "ifconfig $_ down", 1 ) unless $CHILD_ERROR;
+        }
+        close STATUS_IFBR;
     }
     else {
-	__Err( "Can't open " . $PF_STATUS_DIR . "/ifbr" );
+        __Err( "Can't open " . $PF_STATUS_DIR . "/ifbr" );
     }
 
     __runCmds( [ "ifconfig $brname down", "brctl delbr $brname" ], 1 );
@@ -699,10 +700,10 @@
 
     #  descend les $trunk.$tag
     __runCmds( [ "ifconfig $trunk.$1 down", "vconfig rem $trunk.$1" ], "1" )
-	if ( !$? and $brname =~ /(\d+)$/ );
+        if ( !$CHILD_ERROR and $brname =~ /(\d+)$/ );
 
     if ( -f $PF_STATUS_DIR . "/bridge/" . $brname ) {
-	unlink $PF_STATUS_DIR . "/bridge/" . $brname;
+        unlink $PF_STATUS_DIR . "/bridge/" . $brname;
     }
 }
 
@@ -714,19 +715,19 @@
     my $list   = [];
 
     return $list
-	unless defined $brname;    # éviter du travail inutile et des warnings
+        unless defined $brname;    # éviter du travail inutile et des warnings
 
     my @brshow = `brctl show`;
     shift @brshow;                 # ligne d'entete
 
     my $b;
     foreach my $line (@brshow) {
-	$b = $1 if ( $line =~ /^(\S+)\s+/ );
-
-	if ( $b eq $brname ) {
-	    push @$list, $1
-		if ( $line =~ /^\S+\s+\S+\s+\S+\s+(\S+)$/ );
-	}
+        $b = $1 if ( $line =~ /^(\S+)\s+/ );
+
+        if ( $b eq $brname ) {
+            push @$list, $1
+                if ( $line =~ /^\S+\s+\S+\s+\S+\s+(\S+)$/ );
+        }
     }
 
     return $list;
@@ -739,14 +740,14 @@
     my $list = [];
 
     return $list
-	unless defined $vlan;    # éviter du travail inutile et des warnings
+        unless defined $vlan;    # éviter du travail inutile et des warnings
 
     my $ListVM = Config_Key( $configfile, "init", "\@start" );
 
     foreach my $vm ( @{$ListVM} ) {
-	foreach ( @{ __GetVMnet($vm) } ) {
-	    push( @$list, $vm ) if ( $_->{lan} eq $vlan );
-	}
+        foreach ( @{ __GetVMnet($vm) } ) {
+            push( @$list, $vm ) if ( $_->{lan} eq $vlan );
+        }
     }
 
     return $list;
@@ -757,22 +758,22 @@
     my ( $bridge, $if ) = @_;
 
     unless ( $bridge and $if ) {
-	__Err(
-	    "__BridgeAttacheIf called with undef or empty bridge and/or if");
-	return undef;
+        __Err(
+            "__BridgeAttacheIf called with undef or empty bridge and/or if");
+        return undef;
     }
 
     `ifconfig $if 2>&1`;
-    if ($?) {
-
-	# Pourquoi
-	__Debug(
-	    "L'interface `$if' ne semble pas dispo, l'UML n'est sans doute pas lancée"
-	);
-	return;
+    if ($CHILD_ERROR) {
+
+        # Pourquoi
+        __Debug(
+            "L'interface `$if' ne semble pas dispo, l'UML n'est sans doute pas lancée"
+        );
+        return;
     }
     else {
-	__runCmds( ["brctl addif $bridge $if"], "1" );
+        __runCmds( ["brctl addif $bridge $if"], "1" );
     }
     __runCmds( ["ifconfig $if up"], "1" );
 
@@ -787,16 +788,16 @@
     my ( $bridge, $if ) = @_;
 
     unless ( $bridge and $if ) {
-	__Err(
-	    "__BridgeDetacheIf called with undef or empty bridge and/or if");
-	return;
+        __Err(
+            "__BridgeDetacheIf called with undef or empty bridge and/or if");
+        return;
     }
 
     unless ( __runCmds( ["brctl delif $bridge $if"], 1 ) ) {
-	__Err(
-	    "Attention : Je n'arrive pas à détacher `$if' du bridge `$bridge'"
-	);
-	return;
+        __Err(
+            "Attention : Je n'arrive pas à détacher `$if' du bridge `$bridge'"
+        );
+        return;
     }
 
     return 1;
@@ -815,65 +816,65 @@
 
     __Info("  Lancement des vm");
     foreach my $i ( 0 .. 255 ) {
-	next unless $umls->[$i];
-
-	foreach my $host ( split / /, $umls->[$i] ) {
-	    next unless $host;
-
-	    my ( undef, undef, $section ) = __FamillyNumFromVM($host);
-	    unless (
-		exists $private_network->{$section}->{'umlfilename.default'} )
-	    {
-		__Info(
-		    "Attention, la machine `$host' n'a pas de clef umlfilename.default,"
-			. "elle ne sera donc pas lancée" );
-		next;
-	    }
-
-	    if ( __Umlrunning($host) ) {
-		__Info("`$host' est déjà lancé...");
-		next;
-	    }
-	    my $branche = __GetBrancheCVS($host);
-
-	    my $mem = Config_Key( $configfile, "uml-" . $host, "mem" );
-	    my $disksize
-		= Config_Key( $configfile, "uml-" . $host, "disksize" );
-	    $disksize = Config_Key( $configfile, "uml-default", "disksize" )
-		unless $disksize;
-	    $disksize = 768 unless $disksize;
-
-	    unless ( ( -f $ENV{HOME} . "/.uml/$host.disk0" )
-		or ( $options->{dontcheckdf} ) )
-	    {
-		while (
-		    __GetDiskSpaceLeft( $ENV{HOME} . "/.uml/" ) < $disksize )
-		{
-		    __Err(
-			"Probleme d'espace disque... Il me faut `$disksize' Mo pour lancer `$host'"
-		    );
-		    sleep 5;
-		}
-	    }
-
-	    if ( $mem and $mem < 16 ) {
-		__Debug(
-		    "$host : memoire $mem trop faible (< 16Mo), je la passe à 16Mo"
-		);
-		$mem = 16;
-	    }
-	    __Info( "     " . __PrintTime() );
-	    __Debug("     priorité : `$i'");
-	    __Info("     vm : `$host'");
-	    __Info("     branche : `$branche'") if ($branche);
-
-	    my $cmd = "$umlaunch --wait --detached ";
-	    $cmd .= "--branche-cvs=" . $branche . " " if $branche;
-	    $cmd .= "--mem=" . $mem . " "             if $mem;
-	    $cmd .= "--disksize=" . $disksize . " "   if $disksize;
-	    $cmd .= $host;
-	    __Fault("$cmd failed") unless ( __runCmds( [$cmd] ) );
-	}
+        next unless $umls->[$i];
+
+        foreach my $host ( split / /, $umls->[$i] ) {
+            next unless $host;
+
+            my ( undef, undef, $section ) = __FamillyNumFromVM($host);
+            unless (
+                exists $private_network->{$section}->{'umlfilename.default'} )
+            {
+                __Info(
+                    "Attention, la machine `$host' n'a pas de clef umlfilename.default,"
+                        . "elle ne sera donc pas lancée" );
+                next;
+            }
+
+            if ( __Umlrunning($host) ) {
+                __Info("`$host' est déjà lancé...");
+                next;
+            }
+            my $branche = __GetBrancheCVS($host);
+
+            my $mem = Config_Key( $configfile, "uml-" . $host, "mem" );
+            my $disksize
+                = Config_Key( $configfile, "uml-" . $host, "disksize" );
+            $disksize = Config_Key( $configfile, "uml-default", "disksize" )
+                unless $disksize;
+            $disksize = 768 unless $disksize;
+
+            unless ( ( -f $ENV{HOME} . "/.uml/$host.disk0" )
+                or ( $options->{dontcheckdf} ) )
+            {
+                while (
+                    __GetDiskSpaceLeft( $ENV{HOME} . "/.uml/" ) < $disksize )
+                {
+                    __Err(
+                        "Probleme d'espace disque... Il me faut `$disksize' Mo pour lancer `$host'"
+                    );
+                    sleep 5;
+                }
+            }
+
+            if ( $mem and $mem < 16 ) {
+                __Debug(
+                    "$host : memoire $mem trop faible (< 16Mo), je la passe à 16Mo"
+                );
+                $mem = 16;
+            }
+            __Info( "     " . __PrintTime() );
+            __Debug("     priorité : `$i'");
+            __Info("     vm : `$host'");
+            __Info("     branche : `$branche'") if ($branche);
+
+            my $cmd = "$umlaunch --wait --detached ";
+            $cmd .= "--branche-cvs=" . $branche . " " if $branche;
+            $cmd .= "--mem=" . $mem . " "             if $mem;
+            $cmd .= "--disksize=" . $disksize . " "   if $disksize;
+            $cmd .= $host;
+            __Fault("$cmd failed") unless ( __runCmds( [$cmd] ) );
+        }
     }
 }
 
@@ -882,10 +883,10 @@
     my $pid = shift;
 
     foreach (`ps ax`) {
-	if (/^\s*(\d+)/) {
-	    return 1 if ( $1 == $pid );
-
-	}
+        if (/^\s*(\d+)/) {
+            return 1 if ( $1 == $pid );
+
+        }
     }
     return 0;
 }
@@ -917,8 +918,8 @@
     $screen->slave->clone_winsize_from( \*STDIN );
     $screen->spawn("screen -r $hostname");
     unless ($screen) {
-	__Err("Pas réussi à récupérer le screen: `$!'");
-	return;
+        __Err("Pas réussi à récupérer le screen: `$OS_ERROR'");
+        return;
     }
 
     #$screen->raw_pty(1);
@@ -928,23 +929,23 @@
 
 #### A améliorer
     if ( $screen->expect( 2, "# " ) ) {
-	$screen->send("exit\n");
+        $screen->send("exit\n");
     }
 
     if ( $screen->expect( 2, /login/ ) ) {
-	$screen->send("\n");
+        $screen->send("\n");
     }
     else {
-	__Debug("Never got login prompt on $hostname");
-	return;
+        __Debug("Never got login prompt on $hostname");
+        return;
     }
 
     $screen->send("root\n");
     sleep 1;
 
     unless ( $screen->expect( 15, "Password:" ) ) {
-	__Debug("Never got password prompt on $hostname");
-	return;
+        __Debug("Never got password prompt on $hostname");
+        return;
     }
 
     $screen->send("l&f|cn|!\n");
@@ -952,7 +953,7 @@
 
     $shutdowndelay = "now" unless $shutdowndelay;
     $screen->send(
-	"\nshutdown -h $shutdowndelay \"shutdown via pflaunch...\"");
+        "\nshutdown -h $shutdowndelay \"shutdown via pflaunch...\"");
     $screen->send("\nexit\n");
 
     $screen->soft_close();
@@ -975,84 +976,84 @@
     # Recupération de la liste des umls
     my $v = [];
     foreach my $i ( reverse( 0 .. 255 ) ) {
-	next unless $umls->[$i];
-	foreach ( split / /, $umls->[$i] ) {
-	    next unless $_;
-
-	    my $vm;
-	    $vm->{vm} = $_;
-	    $vm->{status} = __Umlrunning($_) ? $RUNNING : $HALTED;
-
-	    $vm->{shutdowndelay}
-		= Config_Key( $configfile, "uml-$_", "shutdowndelay" );
-	    $vm->{shutdowndelay}
-		= Config_Key( $configfile, "uml-default", "shutdowndelay" )
-		unless $vm->{shutdowndelay};
-
-	    push @$v, $vm;
-	}
+        next unless $umls->[$i];
+        foreach ( split / /, $umls->[$i] ) {
+            next unless $_;
+
+            my $vm;
+            $vm->{vm} = $_;
+            $vm->{status} = __Umlrunning($_) ? $RUNNING : $HALTED;
+
+            $vm->{shutdowndelay}
+                = Config_Key( $configfile, "uml-$_", "shutdowndelay" );
+            $vm->{shutdowndelay}
+                = Config_Key( $configfile, "uml-default", "shutdowndelay" )
+                unless $vm->{shutdowndelay};
+
+            push @$v, $vm;
+        }
     }
 
     foreach (@$v) {
-	next if ( $_->{status} == $HALTED );
-	$_->{t} = Thread->new( \&__SendHalt, $_->{vm}, $_->{shutdowndelay} );
+        next if ( $_->{status} == $HALTED );
+        $_->{t} = Thread->new( \&__SendHalt, $_->{vm}, $_->{shutdowndelay} );
     }
 
     my $sdd            = 0;
     my $vm_running_cpt = 0;
     foreach (@$v) {
-	next if ( $_->{status} == $HALTED );
-	$_->{status} = $HALTING if ( $_->{t}->join );
-
-	$sdd = $_->{shutdowndelay}
-	    if ( $_->{shutdowndelay} and ( $sdd < $_->{shutdowndelay} ) );
-	$vm_running_cpt++;
+        next if ( $_->{status} == $HALTED );
+        $_->{status} = $HALTING if ( $_->{t}->join );
+
+        $sdd = $_->{shutdowndelay}
+            if ( $_->{shutdowndelay} and ( $sdd < $_->{shutdowndelay} ) );
+        $vm_running_cpt++;
     }
 
    # Inutile de lancer cette procédure couteuse en tps si aucune uml ne tourne
     if ($vm_running_cpt) {
-	eval {
-	    local $SIG{ALRM} = sub { die "alarm\n" };  # N.B. : \n obligatoire
-
-	    alarm( 60 + $sdd * 60 );
-
-	    while (1) {
-		foreach (@$v) {
-		    next if ( $_->{status} == $HALTED );
-		    $_->{status} = $HALTED
-			unless ( __Umlrunning( $_->{vm} ) );
-
-		    sleep 1;
-		}
-	    }
-
-	    alarm 0;
-	};
+        eval {
+            local $SIG{ALRM} = sub { die "alarm\n" };  # N.B. : \n obligatoire
+
+            alarm( 60 + $sdd * 60 );
+
+            while (1) {
+                foreach (@$v) {
+                    next if ( $_->{status} == $HALTED );
+                    $_->{status} = $HALTED
+                        unless ( __Umlrunning( $_->{vm} ) );
+
+                    sleep 1;
+                }
+            }
+
+            alarm 0;
+        };
     }
 
     foreach (@$v) {
-	next if ( $_->{status} == $HALTED );
-
-	my $failed = 0;
-
-	if ( -r "$ENV{HOME}/.uml/" . $_->{vm} . "/pid" ) {
-	    __Info( "   -Arrete force de `" . $_->{vm} . "'" );
-
-	    eval {
-		local $SIG{ALRM}
-		    = sub { die "alarm\n" };    # N.B. : \n obligatoire
-		alarm 15;
-		`uml_mconsole $_->{vm} halt 2>&1`;
-		$_->{status} = $HALTED unless $?;
-		alarm 0;
-	    };
-	    $failed = 1 if ($@);
-	}
-	elsif ( __Umlrunning( $_->{vm} ) ) {
-	    $failed = 1;
-	}
-
-	__Err( "Je n'arrive pas a arreter : `" . $_->{vm} . "'" );
+        next if ( $_->{status} == $HALTED );
+
+        my $failed = 0;
+
+        if ( -r "$ENV{HOME}/.uml/" . $_->{vm} . "/pid" ) {
+            __Info( "   -Arrete force de `" . $_->{vm} . "'" );
+
+            eval {
+                local $SIG{ALRM}
+                    = sub { die "alarm\n" };    # N.B. : \n obligatoire
+                alarm 15;
+                `uml_mconsole $_->{vm} halt 2>&1`;
+                $_->{status} = $HALTED unless $CHILD_ERROR;
+                alarm 0;
+            };
+            $failed = 1 if ($EVAL_ERROR);
+        }
+        elsif ( __Umlrunning( $_->{vm} ) ) {
+            $failed = 1;
+        }
+
+        __Err( "Je n'arrive pas a arreter : `" . $_->{vm} . "'" );
     }
 }
 
@@ -1066,13 +1067,13 @@
     my $fichier;
     return unless ( -d "/var/run/screen/S-root" );
     opendir( SCREENDIR, "/var/run/screen/S-root" )
-	or __Fault("can't open $!");
+        or __Fault("can't open $OS_ERROR");
     while ( defined( $fichier = readdir(SCREENDIR) ) ) {
-	next if ( $fichier =~ /^\./ );
-
-	if ( $fichier =~ /^\d+\.([^\.]+)/ ) {
-	    $r = 1 if ( $vm eq $1 );
-	}
+        next if ( $fichier =~ /^\./ );
+
+        if ( $fichier =~ /^\d+\.([^\.]+)/ ) {
+            $r = 1 if ( $vm eq $1 );
+        }
 
     }
 
@@ -1084,12 +1085,12 @@
 
     my $ret;
     return $cache->{ipt}->{target}
-	if $cache->{ipt}->{target};
+        if $cache->{ipt}->{target};
 
     open IPTABLESTARGETS, "</proc/net/ip_tables_targets";
     foreach (<IPTABLESTARGETS>) {
-	chomp;
-	$ret->{$_} = 1;
+        chomp;
+        $ret->{$_} = 1;
     }
     close IPTABLESTARGETS;
 
@@ -1101,32 +1102,32 @@
     my $vlan = shift;
 
     unless ($vlan) {
-	__Debug("__SetNetmapByVlan : pas de vlan en parametre !");
-	return;
+        __Debug("__SetNetmapByVlan : pas de vlan en parametre !");
+        return;
     }
 
     my $ipt = __GetIptablesTagets();
     unless ( defined $ipt->{NETMAP} ) {
-	__Info(
-	    "Votre Kernel semble ne pas supporter la target iptables NETMAP, j'ignore la partie vlan de '$vlan'"
-	);
-	return;
+        __Info(
+            "Votre Kernel semble ne pas supporter la target iptables NETMAP, j'ignore la partie vlan de '$vlan'"
+        );
+        return;
     }
 
     my $vlan_if = Config_Key( $configfile, $vlan, "if" );
     $vlan_if = Config_Key( $configfile, "vlan-default", "if" )
-	unless $vlan_if;
+        unless $vlan_if;
 
     __Fault(
-	"Erreur pour '$vlan' : la présence d'une clef 'if' est obligatoire au moins dans la section [vlan-default]"
+        "Erreur pour '$vlan' : la présence d'une clef 'if' est obligatoire au moins dans la section [vlan-default]"
     ) unless $vlan_if;
 
     my $vlandata = $private_network->{$vlan};
     unless ($vlandata) {
-	__Debug(
-	    "Erreur je n'arrive pas a lire dans private-network les infos du vlan `$vlan'"
-	);
-	next;
+        __Debug(
+            "Erreur je n'arrive pas a lire dans private-network les infos du vlan `$vlan'"
+        );
+        next;
     }
 
     my $addrNetExt = Config_Key( $configfile, $vlan, 'netmap' );
@@ -1134,32 +1135,32 @@
 
 # Je vaias chercher dans private-network la conf du vlan pour savoir comment il est adressé
 
-	unless ( $vlandata->{network} ) {
-	    __Err(
-		"Je n'ai pas la key network de la section [$vlan] de private-networ"
-	    );
-	    next;
-	}
-
-	unless ( $vlandata->{netmask} ) {
-	    __Err(
-		"Je n'ai pas la clef 'netmask' de la section [$vlan] de private-network"
-	    );
-	    next;
-	}
-
-	my $addrNetInt = $vlandata->{network} . '/' . $vlandata->{netmask};
-
-	my $postrouting
-	    = "POSTROUTING -o $vlan_if -s $addrNetInt -j NETMAP --to $addrNetExt";
-	my $prerouting
-	    = "PREROUTING -i $vlan_if -d $addrNetExt -j NETMAP --to $addrNetInt";
-	__IptAddChange( "nat", $postrouting );
-	__IptAddChange( "nat", $prerouting );
+        unless ( $vlandata->{network} ) {
+            __Err(
+                "Je n'ai pas la key network de la section [$vlan] de private-networ"
+            );
+            next;
+        }
+
+        unless ( $vlandata->{netmask} ) {
+            __Err(
+                "Je n'ai pas la clef 'netmask' de la section [$vlan] de private-network"
+            );
+            next;
+        }
+
+        my $addrNetInt = $vlandata->{network} . '/' . $vlandata->{netmask};
+
+        my $postrouting
+            = "POSTROUTING -o $vlan_if -s $addrNetInt -j NETMAP --to $addrNetExt";
+        my $prerouting
+            = "PREROUTING -i $vlan_if -d $addrNetExt -j NETMAP --to $addrNetInt";
+        __IptAddChange( "nat", $postrouting );
+        __IptAddChange( "nat", $prerouting );
 
     }
     else {
-	__Debug("Pas de NETMAP pour $vlan");
+        __Debug("Pas de NETMAP pour $vlan");
     }
 
 }
@@ -1168,71 +1169,71 @@
     my $vlan = shift;
 
     unless ($vlan) {
-	__Debug("__SetAliasByVlan : pas de vlan en parametre !");
-	return;
+        __Debug("__SetAliasByVlan : pas de vlan en parametre !");
+        return;
     }
 
     my $vlan_if = Config_Key( $configfile, $vlan, "if" );
     $vlan_if = Config_Key( $configfile, "vlan-default", "if" )
-	unless $vlan_if;
+        unless $vlan_if;
 
     if (   Config_Key( $configfile, $vlan, "alias_begin" )
-	or Config_Key( $configfile, $vlan, "alias_end" ) )
+        or Config_Key( $configfile, $vlan, "alias_end" ) )
     {
-	__Info(
-	    "`$vlan' : Les clef alias_begin et alias_end ne sont plus utilisées,"
-		. "vous avez juste a mettre alias=true" );
+        __Info(
+            "`$vlan' : Les clef alias_begin et alias_end ne sont plus utilisées,"
+                . "vous avez juste a mettre alias=true" );
     }
 
     return
-	unless ( defined( Config_Key( $configfile, $vlan, "alias" ) )
-	and Config_Key( $configfile, $vlan, "alias" ) eq 'true' );
+        unless ( defined( Config_Key( $configfile, $vlan, "alias" ) )
+        and Config_Key( $configfile, $vlan, "alias" ) eq 'true' );
 
 # On va essayer de calculer les alias_begin/alias_end en fonction du netmask
 # du netmap de ce VLAN. Si pas de netmap défini, on cherche dans private-network.
     my $nm = Config_Key( $configfile, $vlan, 'netmap' );
 
     unless ($nm) {
-	__Info(
-	    "Pas de variable netmap pour `$vlan', je cherche dans private-network"
-	);
-	my $vlan_setup = __GetVLanSetup($vlan);
-	unless ( $vlan_setup->{network} and $vlan_setup->{netmask} ) {
-	    __Err(
-		"Pas assez d'information (network et netmask) dans private-network pour le vlan '$vlan'"
-	    );
-	    return;
-	}
-	my ( $ip, $cidr )
-	    = ipv4_parse( $vlan_setup->{network}, $vlan_setup->{netmask} );
-	$nm = "$ip/$cidr";    # Et voilà !
-    }
-
-    my $netmap = new Net::IP($nm) || die "$?";
+        __Info(
+            "Pas de variable netmap pour `$vlan', je cherche dans private-network"
+        );
+        my $vlan_setup = __GetVLanSetup($vlan);
+        unless ( $vlan_setup->{network} and $vlan_setup->{netmask} ) {
+            __Err(
+                "Pas assez d'information (network et netmask) dans private-network pour le vlan '$vlan'"
+            );
+            return;
+        }
+        my ( $ip, $cidr )
+            = ipv4_parse( $vlan_setup->{network}, $vlan_setup->{netmask} );
+        $nm = "$ip/$cidr";    # Et voilà !
+    }
+
+    my $netmap = new Net::IP($nm) || die "$CHILD_ERROR";    # FIXME: WTF?
     unless ($netmap) {
-	__Err("`$nm' n'est pas une adresse réseau valide");
-	return;
+        __Err("`$nm' n'est pas une adresse réseau valide");
+        return;
     }
 
     my $ipz = new Net::IP( $netmap->ip . " - " . $netmap->last_ip );
     unless ($ipz) {
-	__Err(    "Je n'arrive pas a trouver les ip entre "
-		. $netmap->ip . " et "
-		. $netmap->last_ip );
-	return;
+        __Err(    "Je n'arrive pas a trouver les ip entre "
+                . $netmap->ip . " et "
+                . $netmap->last_ip );
+        return;
     }
 
     my $cmd = [];
     unless ( defined $ifAliasCpt{$vlan_if} ) {
-	$ifAliasCpt{$vlan_if} = 0;
+        $ifAliasCpt{$vlan_if} = 0;
     }
     open STATUS_ALIAS, ">>" . $PF_STATUS_DIR . "/aliases";
     do {
-	print STATUS_ALIAS "$vlan_if:$ifAliasCpt{$vlan_if}\n";
-	push @$cmd,
-	    "ifconfig $vlan_if:" . $ifAliasCpt{$vlan_if} . " " . $ipz->ip();
-	$ifAliasCpt{$vlan_if}++;
-	$ipz = $ipz->ip_add_num(1);
+        print STATUS_ALIAS "$vlan_if:$ifAliasCpt{$vlan_if}\n";
+        push @$cmd,
+            "ifconfig $vlan_if:" . $ifAliasCpt{$vlan_if} . " " . $ipz->ip();
+        $ifAliasCpt{$vlan_if}++;
+        $ipz = $ipz->ip_add_num(1);
     } while ($ipz);
 
     __runCmds( $cmd, "1" ) if @$cmd;
@@ -1244,46 +1245,46 @@
     my $dnats = shift;
 
     unless ($dnats) {
-	__Debug("__SetDNATs () appelé sans parametre");
-	return;
+        __Debug("__SetDNATs () appelé sans parametre");
+        return;
     }
 
     my $ipt = __GetIptablesTagets();
     unless ( defined $ipt->{DNAT} ) {
-	__Info(
-	    "Votre Kernel semble ne pas supporter la tarjet iptables DNAT");
-	__Info("J'ignore la clef \@dnat de la section [init]");
-	return;
+        __Info(
+            "Votre Kernel semble ne pas supporter la tarjet iptables DNAT");
+        __Info("J'ignore la clef \@dnat de la section [init]");
+        return;
     }
 
     foreach my $dnat ( @{$dnats} ) {
-	my $dnat_config = Config_Section( $configfile, "dnat-$dnat" );
-	unless ($dnat_config) {
-	    __Err(
-		"`$dnat' est dans la section [init] mais n'a pas de [dnat-$dnat],"
-		    . "le dnat $dnat n'est pas initialisé..." );
-	    return;
-	}
-	unless ( $dnat_config->{'original-dest'}
-	    && $dnat_config->{'rewrite-dest-to'} )
-	{
-	    __Err(
-		"La section [dnat-`$dnat'] n'est pas valide, la section doit contenir les clefs original-dest et rewrite-dest-to"
-	    );
-	    return;
-	}
-
-	__Info(   "  dnat `$dnat' (`"
-		. $dnat_config->{'original-dest'}
-		. "' -> `"
-		. $dnat_config->{'rewrite-dest-to'}
-		. "')" );
-
-	__IptAddChange( "nat",
-	          "PREROUTING -d "
-		. $dnat_config->{'original-dest'}
-		. " -j DNAT --to-destination "
-		. $dnat_config->{'rewrite-dest-to'} );
+        my $dnat_config = Config_Section( $configfile, "dnat-$dnat" );
+        unless ($dnat_config) {
+            __Err(
+                "`$dnat' est dans la section [init] mais n'a pas de [dnat-$dnat],"
+                    . "le dnat $dnat n'est pas initialisé..." );
+            return;
+        }
+        unless ( $dnat_config->{'original-dest'}
+            && $dnat_config->{'rewrite-dest-to'} )
+        {
+            __Err(
+                "La section [dnat-`$dnat'] n'est pas valide, la section doit contenir les clefs original-dest et rewrite-dest-to"
+            );
+            return;
+        }
+
+        __Info(   "  dnat `$dnat' (`"
+                . $dnat_config->{'original-dest'}
+                . "' -> `"
+                . $dnat_config->{'rewrite-dest-to'}
+                . "')" );
+
+        __IptAddChange( "nat",
+                  "PREROUTING -d "
+                . $dnat_config->{'original-dest'}
+                . " -j DNAT --to-destination "
+                . $dnat_config->{'rewrite-dest-to'} );
     }
 }
 
@@ -1291,45 +1292,45 @@
     my $masquerades = shift;
 
     unless ($masquerades) {
-	__Debug("__SetMasqueradeByVlan () appelé sans parametre");
-	return;
+        __Debug("__SetMasqueradeByVlan () appelé sans parametre");
+        return;
     }
 
     my $ipt = __GetIptablesTagets();
     unless ( defined $ipt->{MASQUERADE} ) {
-	__Info(
-	    "Votre Kernel semble ne pas supporter la tarjet iptables MASQUERADE"
-	);
-	__Info("J'ignore la clef \@masquerade de la section [init]");
-	return;
+        __Info(
+            "Votre Kernel semble ne pas supporter la tarjet iptables MASQUERADE"
+        );
+        __Info("J'ignore la clef \@masquerade de la section [init]");
+        return;
     }
 
     foreach my $masquerade ( @{$masquerades} ) {
-	my $masquerade_config
-	    = Config_Section( $configfile, "masquerade-$masquerade" );
-	unless ($masquerade_config) {
-	    __Err(
-		"`$masquerade' est dans la section [init] mais n'a pas de [masquerade-$masquerade],"
-		    . "le masquerade $masquerade n'est pas initialisé..." );
-	    return;
-	}
-	unless ( $masquerade_config->{from} ) {
-	    __Err(
-		"La section [masquerade-`$masquerade'] n'est pas valide, la section doit contenir une clef from et if_out"
-	    );
-	    return;
-	}
-
-	__Info(   "  masquerade `$masquerade' (`"
-		. $masquerade_config->{if_out} . "' / `"
-		. $masquerade_config->{from}
-		. "')" );
-
-	__IptAddChange( "nat",
-	          "POSTROUTING -o "
-		. $masquerade_config->{if_out} . " -s "
-		. $masquerade_config->{from}
-		. " -j MASQUERADE" );
+        my $masquerade_config
+            = Config_Section( $configfile, "masquerade-$masquerade" );
+        unless ($masquerade_config) {
+            __Err(
+                "`$masquerade' est dans la section [init] mais n'a pas de [masquerade-$masquerade],"
+                    . "le masquerade $masquerade n'est pas initialisé..." );
+            return;
+        }
+        unless ( $masquerade_config->{from} ) {
+            __Err(
+                "La section [masquerade-`$masquerade'] n'est pas valide, la section doit contenir une clef from et if_out"
+            );
+            return;
+        }
+
+        __Info(   "  masquerade `$masquerade' (`"
+                . $masquerade_config->{if_out} . "' / `"
+                . $masquerade_config->{from}
+                . "')" );
+
+        __IptAddChange( "nat",
+                  "POSTROUTING -o "
+                . $masquerade_config->{if_out} . " -s "
+                . $masquerade_config->{from}
+                . " -j MASQUERADE" );
     }
 }
 
@@ -1347,17 +1348,17 @@
     my $hex = sprintf( "%x", $ip->intip() );
 
     if ( open RT, "<" . $procf ) {
-	my @r = <RT>;
-	close RT or __Err("Can't close `$procf'");
-	shift @r;
-	foreach (@r) {
-	    if (/^\S+\s+0+(\S+)/) {
-		return 1 if ( lc($1) eq lc($hex) );
-	    }
-	}
+        my @r = <RT>;
+        close RT or __Err("Can't close `$procf'");
+        shift @r;
+        foreach (@r) {
+            if (/^\S+\s+0+(\S+)/) {
+                return 1 if ( lc($1) eq lc($hex) );
+            }
+        }
     }
     else {
-	__Err("Can't open `$procf'");
+        __Err("Can't open `$procf'");
     }
     return;
 }
@@ -1369,51 +1370,51 @@
     my $routes;
 
     foreach my $vlan ( @{ __GetVLanList() } ) {
-	my $gws = Config_Key( $configfile, "$vlan", "gateway" );
-	$gws = Config_Key( $configfile, "vlan-default", "gateway" )
-	    unless $gws;
-
-	my $vs = __GetVLanSetup($vlan);
-	unless ( $vs->{network} and $vs->{netmask} ) {
-	    __Fault(
-		"Je ne trouve pas assez d'information pour le vlan `$vlan'"
-		    . "network = `"
-		    . $vs->{network} . "'"
-		    . "netmask = `"
-		    . $vs->{netmask}
-		    . "'" );
-	    next;
-	}
-	next if ( __RouteExiste( $vs->{network} ) );
-	my $dest = "";
-	if ( defined $gws and $gws ) {
-	    if ( $gws =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ) {
-		$dest = "gateway " . $gws;    # une IP a ete rentré
-	    }
-	    else {
-		$dest = "gateway " . __GetVMip( $gws, $vlan );
-	    }
-	}
-	elsif ( defined( $vs->{tag} ) and ( $vs->{tag} ) ) {
-	    $dest = "dev br" . $vs->{tag};
-	}
-	else {
-	    __Debug("Je n'ai pas de sortie pour `$vlan'");
-	    next;
-	}
-
-	$routes->{"-net $vs->{network} netmask $vs->{netmask} $dest"} = 1;
+        my $gws = Config_Key( $configfile, "$vlan", "gateway" );
+        $gws = Config_Key( $configfile, "vlan-default", "gateway" )
+            unless $gws;
+
+        my $vs = __GetVLanSetup($vlan);
+        unless ( $vs->{network} and $vs->{netmask} ) {
+            __Fault(
+                "Je ne trouve pas assez d'information pour le vlan `$vlan'"
+                    . "network = `"
+                    . $vs->{network} . "'"
+                    . "netmask = `"
+                    . $vs->{netmask}
+                    . "'" );
+            next;
+        }
+        next if ( __RouteExiste( $vs->{network} ) );
+        my $dest = "";
+        if ( defined $gws and $gws ) {
+            if ( $gws =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ) {
+                $dest = "gateway " . $gws;    # une IP a ete rentré
+            }
+            else {
+                $dest = "gateway " . __GetVMip( $gws, $vlan );
+            }
+        }
+        elsif ( defined( $vs->{tag} ) and ( $vs->{tag} ) ) {
+            $dest = "dev br" . $vs->{tag};
+        }
+        else {
+            __Debug("Je n'ai pas de sortie pour `$vlan'");
+            next;
+        }
+
+        $routes->{"-net $vs->{network} netmask $vs->{netmask} $dest"} = 1;
     }
     __Debug($_) foreach (`route`);
     if ( open( STATUS_ROUTE, ">>" . $PF_STATUS_DIR . "/route" ) ) {
-	foreach my $r ( keys %$routes ) {
-	    if ( __runCmds( "route add " . $r ) ) {
-		print STATUS_ROUTE $r . "\n";
-	    }
-	}
+        foreach my $r ( keys %$routes ) {
+            if ( __runCmds( "route add " . $r ) ) {
+                print STATUS_ROUTE $r . "\n";
+            }
+        }
     }
     else {
-	__Fault( "Can't open " . $PF_STATUS_DIR . "/route" );
+        __Fault( "Can't open " . $PF_STATUS_DIR . "/route" );
     }
     close STATUS_ROUTE or __Err("Je n'arrive pas a fermer STATUS_ROUTE");
 }
@@ -1426,8 +1427,8 @@
 
     my $cmds;
     foreach (<STATUS_ROUTE>) {
-	chomp;
-	push @$cmds, "route del $_";
+        chomp;
+        push @$cmds, "route del $_";
     }
 
     __runCmds( $cmds, "stfu" );
@@ -1444,8 +1445,8 @@
 
     my $cmds;
     foreach my $if (<STATUS_ALIAS>) {
-	chomp $if;
-	push @$cmds, "ifconfig $if down" if $if;
+        chomp $if;
+        push @$cmds, "ifconfig $if down" if $if;
     }
 
     __runCmds( $cmds, "stfu" );
@@ -1460,25 +1461,25 @@
 
     # 1/ Le fichier de config
     if ($vm) {
-	my $branche = Config_Key( $configfile, "uml-$vm", "branche" );
-	return $branche if $branche;
+        my $branche = Config_Key( $configfile, "uml-$vm", "branche" );
+        return $branche if $branche;
     }
 
     # 2/ le paramètre de la ligne de commande
     return $options->{branchecvs}
-	if $options->{branchecvs};
+        if $options->{branchecvs};
 
     # 3/ Le contenu de $PF_STATUS_DIR/branche
     if ( -r $PF_STATUS_DIR . "/branche" ) {
-	if ( open STATUSBRANCHE, "<$PF_STATUS_DIR" . "/branche" ) {
-	    my @STATUSBRANCHE = <STATUSBRANCHE>;
-	    close STATUSBRANCHE;
-	    return shift @STATUSBRANCHE;
-	}
-	else {
-	    __Err(
-		"je n'arrive pas a ouvrir " . $PF_STATUS_DIR . "/branche" );
-	}
+        if ( open STATUSBRANCHE, "<$PF_STATUS_DIR" . "/branche" ) {
+            my @STATUSBRANCHE = <STATUSBRANCHE>;
+            close STATUSBRANCHE;
+            return shift @STATUSBRANCHE;
+        }
+        else {
+            __Err(
+                "je n'arrive pas a ouvrir " . $PF_STATUS_DIR . "/branche" );
+        }
 
     }
 
@@ -1488,34 +1489,34 @@
 
 sub __UpdateConfig {
     if ( $cvsupdated or $options->{nocvsupdate} ) {
-	__Debug("Pas d'update du CVS");
+        __Debug("Pas d'update du CVS");
 
     }
     else {
-	my $branchecvs = __GetBrancheCVS();
-
-	__Info("Getting config from CVS");
-	__Info( "  branche CVS `" . $branchecvs . "'" ) if ($branchecvs);
-
-	CVS_update( $branchecvs, $options );
-	$cvsupdated = 1;
-
-	# J'enregistre la branche utilisée pour la prochaine utilisation
-	SaveRunningBrancheName($branchecvs) if $branchecvs;
-
-	unless ( -r $configfile ) {
-	    __Fault(
-		"Je n'arrive pas a lire $configfile, vérifiez votre installation"
-	    );
-	}
-	unless ( -r $privatenetworkfile ) {
-	    __Fault(
-		"Je n'arrive pas a lire $privatenetworkfile, vérifiez votre installation"
-	    );
-	}
-
-	$private_network = Load_Config($privatenetworkfile);
-	__suppress_comments_in_keys($private_network);
+        my $branchecvs = __GetBrancheCVS();
+
+        __Info("Getting config from CVS");
+        __Info( "  branche CVS `" . $branchecvs . "'" ) if ($branchecvs);
+
+        CVS_update( $branchecvs, $options );
+        $cvsupdated = 1;
+
+        # J'enregistre la branche utilisée pour la prochaine utilisation
+        SaveRunningBrancheName($branchecvs) if $branchecvs;
+
+        unless ( -r $configfile ) {
+            __Fault(
+                "Je n'arrive pas a lire $configfile, vérifiez votre installation"
+            );
+        }
+        unless ( -r $privatenetworkfile ) {
+            __Fault(
+                "Je n'arrive pas a lire $privatenetworkfile, vérifiez votre installation"
+            );
+        }
+
+        $private_network = Load_Config($privatenetworkfile);
+        __suppress_comments_in_keys($private_network);
     }
 
 }
@@ -1526,22 +1527,22 @@
 
     return unless ( -f $PF_STATUS_DIR . "/lock" );
     open( LOCK, "<" . $PF_STATUS_DIR . "/lock" )
-	or __Fault("Can't open lock file $!");
+        or __Fault("Can't open lock file $OS_ERROR");
     my $pid = <LOCK>;
     close LOCK;
 
     return unless $pid;
 
     if ( __PidRunning($pid) ) {
-	__Fault(  "Vous avez provablement un plfaunch "
-		. " déjà lancé, si ne n'est pas la cas effacé "
-		. "le fichier de lock "
-		. $PF_STATUS_DIR
-		. "/lock" );
+        __Fault(  "Vous avez provablement un plfaunch "
+                . " déjà lancé, si ne n'est pas la cas effacé "
+                . "le fichier de lock "
+                . $PF_STATUS_DIR
+                . "/lock" );
     }
     else {
 
-	unlink $PF_STATUS_DIR . "/lock";
+        unlink $PF_STATUS_DIR . "/lock";
 
     }
 }
@@ -1549,7 +1550,7 @@
 sub __SetLock {
 
     open( LOCK, ">" . $PF_STATUS_DIR . "/lock" )
-	or __Fault("Can't open lock file $!");
+        or __Fault("Can't open lock file $OS_ERROR");
     print LOCK $$;
     close LOCK;
 
@@ -1558,7 +1559,7 @@
 sub __RemoveLock {
 
     unlink( $PF_STATUS_DIR . "/lock" )
-	or __Err( "Can't remove lock file : " . $PF_STATUS_DIR . "/lock" );
+        or __Err( "Can't remove lock file : " . $PF_STATUS_DIR . "/lock" );
 
 }
 
@@ -1569,16 +1570,16 @@
     $path = "/" unless $path;
     my @dfr = `/bin/df -P $path`;
 
-    if ($?) {
-	__Err("df failed");
-	return;
+    if ($CHILD_ERROR) {
+        __Err("df failed");
+        return;
     }
 
     my @dfs = split /\ +/, $dfr[1];
     unless ( $dfs[3] ) {
-	__Err(
-	    "__GetDiskSpaceLeft:je n'arrive pas trouver l'espace disque...");
-	return 0;
+        __Err(
+            "__GetDiskSpaceLeft:je n'arrive pas trouver l'espace disque...");
+        return 0;
     }
     return int $dfs[3] / 1024;
 
@@ -1595,7 +1596,7 @@
 
 sub __Fault {
     foreach (@_) {
-	__Print( "FAULT>" . $_, 1 );
+        __Print( "FAULT>" . $_, 1 );
     }
     exit 1;
 }
@@ -1603,7 +1604,7 @@
 sub __Err {
     return unless @_;
     foreach (@_) {
-	__Print( "ERROR>" . $_, 1 );
+        __Print( "ERROR>" . $_, 1 );
     }
 }
 
@@ -1611,14 +1612,14 @@
     return unless ( $options->{debug} );
     return unless @_;
     foreach (@_) {
-	__Print( "DEBUG>" . $_, $options->{debug} );
+        __Print( "DEBUG>" . $_, $options->{debug} );
     }
 }
 
 sub __Info {
     return unless @_;
     foreach (@_) {
-	__Print( " INFO>" . $_, $options->{verbose} );
+        __Print( " INFO>" . $_, $options->{verbose} );
     }
 }
 
@@ -1633,13 +1634,13 @@
     print $str if ($p);
 
     if ($logfile) {
-	if ( open( LOG, ">>$logfile" ) ) {
-	    print LOG $str;
-	    close LOG;
-	}
-	else {
-	    print STDERR "Can't open log file : `$logfile'\n";
-	}
+        if ( open( LOG, ">>$logfile" ) ) {
+            print LOG $str;
+            close LOG;
+        }
+        else {
+            print STDERR "Can't open log file : `$logfile'\n";
+        }
     }
 }
 
@@ -1653,46 +1654,46 @@
 
     unless ( $table =~ /^nat$/ )    # filter, mangle
     {
-	__Err("Table invalide");
-	return;
+        __Err("Table invalide");
+        return;
     }
 
     return unless __runCmds( "iptables -t $table -A " . $change );
 
     if ( !( open STATUS_IPT, ">>" . $PF_STATUS_DIR . "/ipt_" . $table ) ) {
-	__Err("Can't record iptables rules changes");
-	return;
+        __Err("Can't record iptables rules changes");
+        return;
     }
     else {
-	__Debug("Enregistrement d'une regle iptables (nat)");
-	print STATUS_IPT $change . "\n";
-	if ( !close STATUS_IPT ) {
-	    __Err("Can't close STATUS_IPT");
-	    return;
-	}
+        __Debug("Enregistrement d'une regle iptables (nat)");
+        print STATUS_IPT $change . "\n";
+        if ( !close STATUS_IPT ) {
+            __Err("Can't close STATUS_IPT");
+            return;
+        }
     }
     return 1;
 }
 
 sub __IptCleanChange () {
     foreach my $table ( "nat", "mangle" ) {
-	my $file = $PF_STATUS_DIR . "/ipt_" . $table;
-	next unless ( -f $file );
-	if ( !( open STATUS_IPT, "<" . $file ) ) {
-	    __Err( "Can't open " . $file );
-	    next;
-	}
-	else {
-	    __Debug(
-		"Suppression des regles iptables ajoutes par pflaunch : ($table)"
-	    );
-	    __runCmds( "iptables -t $table -D " . $_ ) foreach (<STATUS_IPT>);
-	    close STATUS_IPT;
-	    if ( !unlink($file) ) {
-		__Err("Je ne peux pas effacer $file");
-		return;
-	    }
-	}
+        my $file = $PF_STATUS_DIR . "/ipt_" . $table;
+        next unless ( -f $file );
+        if ( !( open STATUS_IPT, "<" . $file ) ) {
+            __Err( "Can't open " . $file );
+            next;
+        }
+        else {
+            __Debug(
+                "Suppression des regles iptables ajoutes par pflaunch : ($table)"
+            );
+            __runCmds( "iptables -t $table -D " . $_ ) foreach (<STATUS_IPT>);
+            close STATUS_IPT;
+            if ( !unlink($file) ) {
+                __Err("Je ne peux pas effacer $file");
+                return;
+            }
+        }
     }
     return 1;
 }
@@ -1715,28 +1716,28 @@
     `modprobe ipt_MASQUERADE 2>&1`;
     ### Reglage de /proc/sys/net/ipv4/ip_forward
     my $forward
-	= ( defined( Config_Key( $configfile, "global", "router" ) )
-	    and Config_Key( $configfile, "global", "router" ) =~ "true" )
-	? 1
-	: 0;
+        = ( defined( Config_Key( $configfile, "global", "router" ) )
+            and Config_Key( $configfile, "global", "router" ) =~ "true" )
+        ? 1
+        : 0;
     __Debug("  /proc/sys/net/ipv4/ip_forward = $forward");
     open IP_FORWARD, ">/proc/sys/net/ipv4/ip_forward"
-	or __Err("Can't open /proc/sys/net/ipv4/ip_forward (w mode)");
+        or __Err("Can't open /proc/sys/net/ipv4/ip_forward (w mode)");
     print IP_FORWARD $forward;
     close IP_FORWARD;
 
     # peut-être aussi bridge-nf-call-arptables et bridge-nf-call-ip6tables ?
     foreach my $procfile ( map {"/proc/sys/net/bridge/$_"}
-	qw'bridge-nf-call-iptables bridge-nf-filter-vlan-tagged' )
+        qw'bridge-nf-call-iptables bridge-nf-filter-vlan-tagged' )
     {
-	if ( -f $procfile ) {
-	    __Debug("  $procfile = 0");
-	    open( EBTABLE, "> $procfile" )
-		or __Err("Can't open $procfile for writing: $!");
-	    print EBTABLE 0;
-	    close(EBTABLE)
-		or __Fault("Can't close $procfile after writing: $!");
-	}
+        if ( -f $procfile ) {
+            __Debug("  $procfile = 0");
+            open( EBTABLE, "> $procfile" )
+                or __Err("Can't open $procfile for writing: $OS_ERROR");
+            print EBTABLE 0;
+            close(EBTABLE)
+                or __Fault("Can't close $procfile after writing: $OS_ERROR");
+        }
 
 #    else {
 # Ces machins n'existent pas en 2.4
@@ -1746,15 +1747,15 @@
 
     #  my $listbrup = __GetListBridgeUp();
     foreach my $lan ( @{ __GetVLanList() } ) {
-	__BridgeAdd($lan);
-	__BridgeSetAddr($lan);
+        __BridgeAdd($lan);
+        __BridgeSetAddr($lan);
     }
 
     __Info("  setting netmap rules and alias...");
     foreach my $vlan ( @{ __GetVLanList() } ) {
-	__Info("    $vlan");
-	__SetNetmapByVlan($vlan);
-	__SetAliasByVlan($vlan);
+        __Info("    $vlan");
+        __SetNetmapByVlan($vlan);
+        __SetAliasByVlan($vlan);
     }
 
 # On fait les routes après les alias pour faciliter les bidouilles double-adressage
@@ -1804,7 +1805,7 @@
     __Info("  Halting Bridges...");
 
     foreach my $brname (@$listbrup) {
-	__BridgeDel($brname);
+        __BridgeDel($brname);
     }
 
     __Info("  Flushing iptables rules...");
@@ -1815,9 +1816,9 @@
     __Info("  Arrêt des interfaces");
 
     foreach ( @{ __GetVLanList() } ) {
-	my $vs = __GetVLanSetup($_);
-	__runCmds( [ "ifconfig $_." . $vs->{tag} . " down" ], 1 )
-	    foreach ( @{ __GetIfByVlan($_) } );
+        my $vs = __GetVLanSetup($_);
+        __runCmds( [ "ifconfig $_." . $vs->{tag} . " down" ], 1 )
+            foreach ( @{ __GetIfByVlan($_) } );
     }
 
     unlink $PF_STATUS_DIR . "/ifbr";
@@ -1859,14 +1860,14 @@
 
   #  print "  * -l --log : log dans /var/log/pflaunch (verbose par défaut)\n";
     print
-	"  * --nocvsupdate : pas d'update CVS lors du lancement d'une commande\n";
+        "  * --nocvsupdate : pas d'update CVS lors du lancement d'une commande\n";
     print
-	"  * --branche-cvs=BRANCHE : Possiblité de forcer une branche CVS\n";
+        "  * --branche-cvs=BRANCHE : Possiblité de forcer une branche CVS\n";
     print
-	"  * --dontcheckdf : Ne controle pas l'espace dispo avant de créer un disque\n";
+        "  * --dontcheckdf : Ne controle pas l'espace dispo avant de créer un disque\n";
     print "\n";
     print
-	" En cas de probleme ou de souhait, n'hésitez pas a utiliser Bugzilla\n";
+        " En cas de probleme ou de souhait, n'hésitez pas a utiliser Bugzilla\n";
     exit;
 }
 
@@ -1901,12 +1902,11 @@
 
 if ( $options->{nocvsupdate} and $options->{branchecvs} ) {
     __Fault(
-	"Hum Hum, vous demandez une branche CVS précise avec en même temps le "
-	    . "flag '--nocvsupdate' !" );
-}
-
-mkdir($PF_STATUS_DIR) unless ( -d $PF_STATUS_DIR );
-mkdir( $PF_STATUS_DIR . "/bridge" ) unless ( -d $PF_STATUS_DIR . "/bridge" );
+        "Hum Hum, vous demandez une branche CVS précise avec en même temps le "
+            . "flag '--nocvsupdate' !" );
+}
+
+make_path("$PF_STATUS_DIR/bridge");
 __Fault("uml_switch est il lancé ? (Paquage uml-utilities)")
     unless ( -S $uml_switch_pipe );
 

Modified: trunk/tools/umlaunch
URL: http://svn.debian.org/wsvn/pf-tools/trunk/tools/umlaunch?rev=902&op=diff
==============================================================================
--- trunk/tools/umlaunch (original)
+++ trunk/tools/umlaunch Wed Sep  8 19:28:28 2010
@@ -26,16 +26,20 @@
 use strict;
 use warnings;
 
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use File::Basename;
+use File::Path qw( make_path );
 use Getopt::Long;
 use Socket;
+
 use PFTools::Conf;
 use PFTools::Net;
 use PFTools::Update;
 
 $PFTools::Conf::PFTOOLS_VARS->{'UML'} = 1;
 
-my $mem      = "128"; # Default RAM size (MB)
-my $disksize = "768"; # Default disz size (MB)
+my $mem      = "128";                # Default RAM size (MB)
+my $disksize = "768";                # Default disz size (MB)
 
 my $ETHTRUNK = 'eth1';
 
@@ -47,12 +51,12 @@
     || `which screen 2>/dev/null` eq "" )
 {
     print STDERR
-	"Sorry, I need vlan, bridge-utils, uml-utilities and screen\n";
+        "Sorry, I need vlan, bridge-utils, uml-utilities and screen\n";
     exit 1;
 }
 
 `ifconfig $ETHTRUNK 2>/dev/null`;
-undef $ETHTRUNK if $?;
+undef $ETHTRUNK if $CHILD_ERROR;
 
 my $options;
 $options->{errors}     = 1;
@@ -80,13 +84,13 @@
     print STDERR "\t   --wait      attendre la fin du deploiement\n";
     print STDERR "\t   --regex     specification des uml par regex\n";
     print STDERR
-	"\t   --no-errors passer a la machine suivante meme en cas d'erreur\n";
-    print STDERR
-	"\t   --branche-cvs permet l'utilisation d'une branche specifique\n";
-    print STDERR
-	"\t-m --mem=XXX   volume de RAM pour l'UML en Mo, defaut ($mem Mo)\n";
-    print STDERR
-	"\t   --disksize=XXX taille de l'image disque en Mo, defaut ($disksize Mo)\n";
+        "\t   --no-errors passer a la machine suivante meme en cas d'erreur\n";
+    print STDERR
+        "\t   --branche-cvs permet l'utilisation d'une branche specifique\n";
+    print STDERR
+        "\t-m --mem=XXX   volume de RAM pour l'UML en Mo, defaut ($mem Mo)\n";
+    print STDERR
+        "\t   --disksize=XXX taille de l'image disque en Mo, defaut ($disksize Mo)\n";
     exit 1;
 }
 
@@ -128,14 +132,14 @@
     my $umlfilename = Get_UM_Filename( $Z, $host );
 
     if ( !defined($umlfilename) ) {
-	print STDERR $host . ": no umlfilename\n";
-
-	if ( !$options->{'errors'} ) {
-	    next;
-	}
-	exit 1;
-
-	#$umlfilename = 'linux-uml-elf-2.4.21-gr1.9.11';
+        print STDERR $host . ": no umlfilename\n";
+
+        if ( !$options->{'errors'} ) {
+            next;
+        }
+        exit 1;
+
+        #$umlfilename = 'linux-uml-elf-2.4.21-gr1.9.11';
     }
 
     #UMRemap_If( $Z, $host );
@@ -148,177 +152,177 @@
     my $disk0 = $ENV{HOME} . "/.uml/" . $host . ".disk0";
     my ( $dhcpif, $dhcpaddr ) = Get_Dhcp_Infos( $Z, $host );
     if ($dhcpif) {
-	$dhcpif =~ s/:.*$//
-	    ; # FIX pour vlan-truc sur ethN:M au lieu de ethN (� cause du double adressage)
+        $dhcpif =~ s/:.*$//
+            ; # FIX pour vlan-truc sur ethN:M au lieu de ethN (� cause du double adressage)
     }
 
     if ( !-f $disk0 ) {
-	print STDERR "Cannot find disk $disk0, creating empty one\n";
-	system("mkdir -p -m 750 `dirname $disk0`");
-	system("dd if=/dev/zero of=$disk0 seek=$disksize count=0 bs=1M");
+        print STDERR "Cannot find disk $disk0, creating empty one\n";
+        make_path( dirname($disk0), { mask => 0750 } );
+        system("dd if=/dev/zero of=$disk0 seek=$disksize count=0 bs=1M");
     }
 
     my $cmdline;
 
     if ( $options->{'detached'} ) {
-	$cmdline = "screen -S $host -d -m ";
+        $cmdline = "screen -S $host -d -m ";
     }
     else {
-	$cmdline = "screen -S $host ";
+        $cmdline = "screen -S $host ";
     }
 
     $cmdline
-	.= "/distrib/tftpboot/$umlfilename umid=$host mconsole=notify:$ENV{HOME}/.uml/$host.notify con0=fd:0,fd:1 con=null ssl=null mem="
-	. $mem
-	. "M fakehd fake_ide ubd=3 root=/dev/ram0 initrd=$initrd ramdisk_size=$ramdisk_size init=/linuxrc ubd0=$disk0";
+        .= "/distrib/tftpboot/$umlfilename umid=$host mconsole=notify:$ENV{HOME}/.uml/$host.notify con0=fd:0,fd:1 con=null ssl=null mem="
+        . $mem
+        . "M fakehd fake_ide ubd=3 root=/dev/ram0 initrd=$initrd ramdisk_size=$ramdisk_size init=/linuxrc ubd0=$disk0";
     $cmdline .= " pfbcvs=" . $options->{branchecvs}
-	if ( $options->{branchecvs} );
+        if ( $options->{branchecvs} );
 
     my $optcmdline = Get_Cmdline( $Z, $host );
     if ($optcmdline) {
-	$cmdline .= ' ' . $optcmdline;
+        $cmdline .= ' ' . $optcmdline;
     }
 
     foreach my $nam ( sort { cmpif( $a, $b ) } keys %{$umif} ) {
-	my $tapaddr;
-	my @tapaddr;
-
-	if ( !defined $umif->{$nam} ) {
-	    next;
-	}
-
-	print STDERR $nam . " <-> " . $umif->{$nam} . "\n";
-
-	my $tag = $umif->{$nam};
-	if ( $tag eq 'TRUNK' ) {
-	    $tag = 0;
-	}
-
-	if ( `ifconfig br$tag 2>/dev/null` eq "" ) {
-	    print STDERR "Upping br" . $tag . "...\n";
-
-	    system( "brctl addbr br" . $tag );
-	    system(   "ifconfig br" 
-		    . $tag
-		    . " 169.254."
-		    . ( $tag >> 8 ) . "."
-		    . ( $tag & 255 )
-		    . " netmask 255.255.255.255 mtu "
-		    . ( ($tag) ? 1496 : 1500 )
-		    . " promisc up" );
-
-	    system( "brctl stp br" . $tag . " off" );
-	    system( "brctl setfd br" . $tag . " 1" );
-	    system( "brctl sethello br" . $tag . " 1" );
-	}
-
-	if ( defined $ETHTRUNK and $ETHTRUNK ) {
-	    system("ifconfig $ETHTRUNK 0.0.0.0 mtu 1500 promisc up");
-	    if ( $tag != 0 ) {
-		if ( `ifconfig $ETHTRUNK.$tag 2>/dev/null` eq "" ) {
-		    print STDERR "Upping $ETHTRUNK." . $tag . "...\n";
-		    system("vconfig set_name_type DEV_PLUS_VID_NO_PAD");
-		    system("vconfig add $ETHTRUNK $tag");
-		    system(
-			"ifconfig $ETHTRUNK.$tag 0.0.0.0 mtu 1496 promisc up"
-		    );
-		}
-	    }
-
-	    if ( $tag == 0 ) {
-		system("brctl addif br$tag $ETHTRUNK 2>/dev/null");
-	    }
-	    else {
-		system("brctl addif br$tag $ETHTRUNK.$tag 2>/dev/null");
-	    }
-	}
-
-	my $tap = "$host.$tag";
-	if ( length($tap) > $IFNAMSIZ - 1 ) {
-	    $tap = substr( $tap, length($tap) - $IFNAMSIZ + 1 );
-	}
-
-	if ( system("tunctl -b -d $tap 1>/dev/null 2>/dev/null") ) {
-	    print STDERR
-		"tunctl refused to free tap device (already running?), aborting\n";
-	    if ( !$options->{'errors'} ) {
-		next;
-	    }
-	    exit 1;
-	}
-	chomp( $tap = `tunctl -b -u 0 -t $tap` );
-	if ( $tap eq '' ) {
-	    print STDERR
-		"tunctl returned no tap devices (already running?), aborting\n";
-	    if ( !$options->{'errors'} ) {
-		next;
-	    }
-	    exit 1;
-	}
-
-	system( "ifconfig " . $tap . " 0.0.0.0 promisc up" );
-
-	# addresse generee aleatoirement, on s'embete pas, on la prend
-	chomp( $tapaddr = `LANG=C LC_ALL=C ifconfig $tap | grep HWaddr` );
-	$tapaddr =~ s/^.* HWaddr ([0-9A-F:]+).*/$1/;
-	@tapaddr = split( ':', $tapaddr );
-	$tapaddr[1] = 'FE';
-	$tapaddr = join( ':', @tapaddr );
-
-	system( "brctl addif br" . $tag . " " . $tap );
-
-	print STDERR $nam . " <-> " . $tap . "\n";
-
-	if ( defined $dhcpif && $nam eq $dhcpif ) {
-	    $cmdline .= " " . $nam . "=tuntap," . $tap . "," . $dhcpaddr;
-	}
-	else {
-	    $cmdline .= " " . $nam . "=tuntap," . $tap . "," . $tapaddr;
-	}
+        my $tapaddr;
+        my @tapaddr;
+
+        if ( !defined $umif->{$nam} ) {
+            next;
+        }
+
+        print STDERR $nam . " <-> " . $umif->{$nam} . "\n";
+
+        my $tag = $umif->{$nam};
+        if ( $tag eq 'TRUNK' ) {
+            $tag = 0;
+        }
+
+        if ( `ifconfig br$tag 2>/dev/null` eq "" ) {
+            print STDERR "Upping br" . $tag . "...\n";
+
+            system( "brctl addbr br" . $tag );
+            system(   "ifconfig br" 
+                    . $tag
+                    . " 169.254."
+                    . ( $tag >> 8 ) . "."
+                    . ( $tag & 255 )
+                    . " netmask 255.255.255.255 mtu "
+                    . ( ($tag) ? 1496 : 1500 )
+                    . " promisc up" );
+
+            system( "brctl stp br" . $tag . " off" );
+            system( "brctl setfd br" . $tag . " 1" );
+            system( "brctl sethello br" . $tag . " 1" );
+        }
+
+        if ( defined $ETHTRUNK and $ETHTRUNK ) {
+            system("ifconfig $ETHTRUNK 0.0.0.0 mtu 1500 promisc up");
+            if ( $tag != 0 ) {
+                if ( `ifconfig $ETHTRUNK.$tag 2>/dev/null` eq "" ) {
+                    print STDERR "Upping $ETHTRUNK." . $tag . "...\n";
+                    system("vconfig set_name_type DEV_PLUS_VID_NO_PAD");
+                    system("vconfig add $ETHTRUNK $tag");
+                    system(
+                        "ifconfig $ETHTRUNK.$tag 0.0.0.0 mtu 1496 promisc up"
+                    );
+                }
+            }
+
+            if ( $tag == 0 ) {
+                system("brctl addif br$tag $ETHTRUNK 2>/dev/null");
+            }
+            else {
+                system("brctl addif br$tag $ETHTRUNK.$tag 2>/dev/null");
+            }
+        }
+
+        my $tap = "$host.$tag";
+        if ( length($tap) > $IFNAMSIZ - 1 ) {
+            $tap = substr( $tap, length($tap) - $IFNAMSIZ + 1 );
+        }
+
+        if ( system("tunctl -b -d $tap 1>/dev/null 2>/dev/null") ) {
+            print STDERR
+                "tunctl refused to free tap device (already running?), aborting\n";
+            if ( !$options->{'errors'} ) {
+                next;
+            }
+            exit 1;
+        }
+        chomp( $tap = `tunctl -b -u 0 -t $tap` );
+        if ( $tap eq '' ) {
+            print STDERR
+                "tunctl returned no tap devices (already running?), aborting\n";
+            if ( !$options->{'errors'} ) {
+                next;
+            }
+            exit 1;
+        }
+
+        system( "ifconfig " . $tap . " 0.0.0.0 promisc up" );
+
+        # addresse generee aleatoirement, on s'embete pas, on la prend
+        chomp( $tapaddr = `LANG=C LC_ALL=C ifconfig $tap | grep HWaddr` );
+        $tapaddr =~ s/^.* HWaddr ([0-9A-F:]+).*/$1/;
+        @tapaddr = split( ':', $tapaddr );
+        $tapaddr[1] = 'FE';
+        $tapaddr = join( ':', @tapaddr );
+
+        system( "brctl addif br" . $tag . " " . $tap );
+
+        print STDERR $nam . " <-> " . $tap . "\n";
+
+        if ( defined $dhcpif && $nam eq $dhcpif ) {
+            $cmdline .= " " . $nam . "=tuntap," . $tap . "," . $dhcpaddr;
+        }
+        else {
+            $cmdline .= " " . $nam . "=tuntap," . $tap . "," . $tapaddr;
+        }
     }
 
     if ( -e "$ENV{HOME}/.uml/$host/mconsole"
-	&& `uml_mconsole $ENV{HOME}/.uml/$host/mconsole version 2>/dev/null`
-	ne '' )
+        && `uml_mconsole $ENV{HOME}/.uml/$host/mconsole version 2>/dev/null`
+        ne '' )
     {
-	printf STDERR "uml already running!\n";
-	if ( !$options->{'errors'} ) {
-	    next;
-	}
-	exit 1;
+        printf STDERR "uml already running!\n";
+        if ( !$options->{'errors'} ) {
+            next;
+        }
+        exit 1;
     }
 
     my $notify;
-    socket( $notify, AF_UNIX, SOCK_DGRAM, 0 ) || die "socket: $!\n";
+    socket( $notify, AF_UNIX, SOCK_DGRAM, 0 ) || die "socket: $OS_ERROR\n";
     unlink("$ENV{HOME}/.uml/$host.notify");
     bind( $notify, sockaddr_un("$ENV{HOME}/.uml/$host.notify") )
-	|| die "bind: $!\n";
+        || die "bind: $OS_ERROR\n";
 
     print $cmdline . "\n";
     system($cmdline);
 
     if ( $options->{'wait'} ) {
-	print STDERR "Waiting for host ready notification... ";
-	while (1) {
-	    my $data;
-
-	    if ( !defined recv( $notify, $data, 4096, 0 ) ) {
-		last;
-	    }
-
-	    my ( $magic, $version, $type, $len, $message )
-		= unpack( "LiiiA*", $data );
-
-	    if ( $magic != 0xcafebabe || $version != 2 ) {
-		die "Sorry, I don't understand this notification version\n";
-	    }
-	    if ( $type == 3 ) {    # user notify
-		if ( $message eq "$host ready" ) {
-		    print STDERR "ready!\n";
-		    last;
-		}
-	    }
-	}
+        print STDERR "Waiting for host ready notification... ";
+        while (1) {
+            my $data;
+
+            if ( !defined recv( $notify, $data, 4096, 0 ) ) {
+                last;
+            }
+
+            my ( $magic, $version, $type, $len, $message )
+                = unpack( "LiiiA*", $data );
+
+            if ( $magic != 0xcafebabe || $version != 2 ) {
+                die "Sorry, I don't understand this notification version\n";
+            }
+            if ( $type == 3 ) {    # user notify
+                if ( $message eq "$host ready" ) {
+                    print STDERR "ready!\n";
+                    last;
+                }
+            }
+        }
     }
     close($notify);
 

Modified: trunk/tools/xenlaunch
URL: http://svn.debian.org/wsvn/pf-tools/trunk/tools/xenlaunch?rev=902&op=diff
==============================================================================
--- trunk/tools/xenlaunch (original)
+++ trunk/tools/xenlaunch Wed Sep  8 19:28:28 2010
@@ -21,9 +21,12 @@
 use strict;
 use warnings;
 
+use Data::Dumper;
+use English qw( -no_match_vars );    # Avoids regex performance penalty
+use File::Path qw( make_path );
+use Getopt::Long;
+
 use Sitalibs::Config;
-use Data::Dumper;
-use Getopt::Long;
 
 my $XENCFGDIR      = "/etc/xen";
 my $KERNELDIR      = "/distrib/tftpboot";
@@ -44,7 +47,7 @@
 
     my ( $famille, $num ) = ( "unknowedonedfamilly", 0 );
     if ( defined $vm and $vm =~ m/^([a-zA-Z0-9-]+)(\d\d)$/ ) {
-	( $famille, $num ) = ( $1, $2 );
+        ( $famille, $num ) = ( $1, $2 );
     }
 
     return ( $famille, $num );
@@ -56,7 +59,7 @@
     my $section = Config_Section( $privatenetwork, $vlan );
 
     print STDERR "ERROR : Can't read section [$vlan%%] from $privatenetwork\n"
-	unless ( defined($section) and ($section) );
+        unless ( defined($section) and ($section) );
 
     return $section;
 }
@@ -68,36 +71,36 @@
     my @ret;
     my $mac = Config_Key( $privatenetwork, $famille . "%%", "ether." . $num );
     unless ($mac) {
-	$mac = Config_Key( $privatenetwork, $famille . "%%",
-	    "vmether." . $num );
+        $mac = Config_Key( $privatenetwork, $famille . "%%",
+            "vmether." . $num );
     }
     unless ($mac) {
-	warn "Can't find first if mac addr ($famille, $num)";
+        warn "Can't find first if mac addr ($famille, $num)";
     }
 
     my $shortname
-	= Config_Key( $privatenetwork, $famille . "%%", "shortname" );
+        = Config_Key( $privatenetwork, $famille . "%%", "shortname" );
     unless ($shortname) {
-	$shortname = "vlan-7";
-	warn
-	    "Attention $famille%% n'a pas de shortname ! J'utilise vlan-7 par defaut\n";
+        $shortname = "vlan-7";
+        warn
+            "Attention $famille%% n'a pas de shortname ! J'utilise vlan-7 par defaut\n";
     }
 
     my $section = Config_Section( $privatenetwork, $famille . "%%" );
 
     foreach my $key ( keys %$section ) {
 
-	if ( $key =~ /^interface\.eth(\d+)/ ) {
-	    my $ifnum = $1;
-	    $ret[$ifnum]->{vlan} = $section->{$key};
-
-	    my $vlan_setup = __GetVLanSetup( $section->{$key} );
-	    $ret[$ifnum]->{tag} = $vlan_setup->{tag};
-
-	    $ret[$ifnum]->{mac} = $mac
-		if ( $ret[$ifnum]->{vlan} eq $shortname );
-
-	}
+        if ( $key =~ /^interface\.eth(\d+)/ ) {
+            my $ifnum = $1;
+            $ret[$ifnum]->{vlan} = $section->{$key};
+
+            my $vlan_setup = __GetVLanSetup( $section->{$key} );
+            $ret[$ifnum]->{tag} = $vlan_setup->{tag};
+
+            $ret[$ifnum]->{mac} = $mac
+                if ( $ret[$ifnum]->{vlan} eq $shortname );
+
+        }
     }
     return @ret;
 }
@@ -117,10 +120,10 @@
     $ret .= "vif = [ '";
 
     foreach (@ifsetup) {
-	$ret .= "','"                    if $count;
-	$ret .= "mac=" . $_->{mac} . "," if $_->{mac};
-	$ret .= "bridge=br" . $_->{tag};
-	$count++;
+        $ret .= "','"                    if $count;
+        $ret .= "mac=" . $_->{mac} . "," if $_->{mac};
+        $ret .= "bridge=br" . $_->{tag};
+        $count++;
     }
 
     $ret .= "' ]";
@@ -142,15 +145,15 @@
     my @viflist = `xm vif-list $vm`;
 
     foreach (@viflist) {
-	if (/\(vif\ (\d+)\)/) {
-
-	    my $vifnum = $1;
-	    print "vif$domid.$vifnum -> $vm.$ifsetup[$vifnum]->{tag}\n";
-
-	    `ifconfig vif$domid.$vifnum down`;
-	    `ifrename -i vif$domid.$vifnum -n $vm.$ifsetup[$vifnum]->{tag}`;
-	    `ifconfig $vm.$ifsetup[$vifnum]->{tag} up`;
-	}
+        if (/\(vif\ (\d+)\)/) {
+
+            my $vifnum = $1;
+            print "vif$domid.$vifnum -> $vm.$ifsetup[$vifnum]->{tag}\n";
+
+            `ifconfig vif$domid.$vifnum down`;
+            `ifrename -i vif$domid.$vifnum -n $vm.$ifsetup[$vifnum]->{tag}`;
+            `ifconfig $vm.$ifsetup[$vifnum]->{tag} up`;
+        }
     }
 }
 
@@ -185,11 +188,11 @@
 #  print STDERR "\t   --regex     specification des uml par regex\n";
 #  print STDERR "\t   --no-errors passer a la machine suivante meme en cas d'erreur\n";
     print STDERR
-	"\t   --branche-cvs permet l'utilisation d'une branche specifique\n";
+        "\t   --branche-cvs permet l'utilisation d'une branche specifique\n";
     print STDERR
-	"\t-m --mem=XXX   volume de RAM pour l'UML en Mo, défaut ($mem Mo)\n";
+        "\t-m --mem=XXX   volume de RAM pour l'UML en Mo, défaut ($mem Mo)\n";
     print STDERR
-	"\t   --disksize=XXX taille de l'image disque en Mo, défaut ($disksize Mo)\n";
+        "\t   --disksize=XXX taille de l'image disque en Mo, défaut ($disksize Mo)\n";
     exit 1;
 }
 
@@ -244,15 +247,11 @@
 print "brname : `$brname'\n";
 
 # disks
-unless ( -d $DISKDIR . "/" . $vm ) {
-    `mkdir -p $DISKDIR/$vm`;
-    die "Probleme lors de la cration du dossier " . $DISKDIR . "/" . $vm
-	if ($!);
-}
+make_path("$DISKDIR/$vm");
 unless ( -f $DISKDIR . "/" . $vm . "/swap.img" ) {
     print "Creation du l'image swap\n";
     system(
-	"dd if=/dev/zero of=$DISKDIR/$vm/swap.img seek=200 count=0 bs=1M 2>/dev/null"
+        "dd if=/dev/zero of=$DISKDIR/$vm/swap.img seek=200 count=0 bs=1M 2>/dev/null"
     );
     system("mksawp -f -v1 /dev/zero of=$DISKDIR/$vm/swap.img 2>/dev/null");
 
@@ -260,14 +259,14 @@
 unless ( -f $DISKDIR . "/" . $vm . "/hda1.img" ) {
     print "Creation du l'image disk boot\n";
     system(
-	"dd if=/dev/zero of=$DISKDIR/$vm/hda1.img seek=15 count=0 bs=1M 2>/dev/null"
+        "dd if=/dev/zero of=$DISKDIR/$vm/hda1.img seek=15 count=0 bs=1M 2>/dev/null"
     );
     system("mkfs.ext2 -F $DISKDIR/$vm/hda1.img 2>/dev/null");
 }
 unless ( -f $DISKDIR . "/" . $vm . "/hda2.img" ) {
     print "Creation du l'image disk systeme\n";
     system(
-	"dd if=/dev/zero of=$DISKDIR/$vm/hda2.img seek=$disksize count=0 bs=1M 2>/dev/null"
+        "dd if=/dev/zero of=$DISKDIR/$vm/hda2.img seek=$disksize count=0 bs=1M 2>/dev/null"
     );
     system("mkfs.ext2 -F $DISKDIR/$vm/hda2.img 2>/dev/null");
 }
@@ -275,7 +274,7 @@
 # Generation du fichier de configuration
 
 open XMCFG, ">" . $XENCFGDIR . "/" . $vm
-    or die "Can't open $XENCFGDIR/$vm $!";
+    or die "Can't open $XENCFGDIR/$vm: $OS_ERROR";
 
 print XMCFG "kernel = \"" . $KERNELDIR . "/" . $kernel . "\"\n";
 print XMCFG "memory = $mem\n";
@@ -293,7 +292,7 @@
 print "Lancement de $vm\n";
 
 my @xmlog = `xm create $vm`;
-if ($?) { print foreach @xmlog }
+if ($CHILD_ERROR) { print foreach @xmlog }
 
 &__renamevif( $vm, $famille, $num );
 




More information about the pf-tools-commits mailing list