#!%TCLSH%


#
# Script pour enregistrer les modifications demandes par un correspondant.
#
# Appel par : script ajout (page lib/ajout.htgt)
#
# Paramtres (formulaire ou URL) :
#   - ajout d'une machine
#	- action : "ajout-machine"
#	- confirm : "non" ou "oui" (si confirmation ok)
#	- nom : nom de la machine  ajouter
#	- domaine : domaine dans lequel elle doit tre ajoute
#	- adr : adresse IP
#	- mac : adresse MAC
#	- iddhcpprofil : l'id du profil DHCP, ou 0
#	- hinfo : type de machine (texte)
#	- droitsmtp : inexistant ou non vide
#	- ttl : valeur (ou vide si pas autoris)
#	- commentaire : informations complmentaires
#	- respnom : nom et prnom du responsable
#	- respmel : adresse lectronique du responsable
#	- nextprog, nextargs : suite du parcours (en cas d'ajout la carte
#		ou depuis la recherche de plage conscutive)
#   - recherche d'une plage conscutive
#	- action : "ajout-multi"
#	- redirect : bouton "Rechercher" ou "Consulter la carte" (cf ajout.htgt)
#	- tri : tri par nbadr ou adr
#	- plage : idreseau de la plage slectionne
#	- nbadr : nb d'adresses souhaites
#   - ajout d'un alias
#	- action : "ajout-alias"
#	- nom : nom de l'alias  ajouter
#	- domaine : domaine dans lequel il doit tre ajout
#	- alias : nom de l'objet existant
#	- domaine2 : domaine dans lequel l'objet existe
#
# Historique
#   2002/04/11 : pda/jean : cration
#   2002/04/19 : pda/jean : ajout de la confirmation
#   2002/05/03 : pda/jean : sparation des trois types de modifications
#   2002/05/23 : pda/jean : ajout du responsable
#   2002/07/09 : pda      : ajout de nologin
#   2002/07/09 : pda      : conversion des noms en minuscules
#   2002/10/31 : pda/jean : correction bug ajout adr ip sur alias existant
#   2002/11/06 : pda/jean : correction de la correction du bug
#   2003/04/24 : pda/jean : interdiction d'ajout d'ip  un mx
#   2003/05/13 : pda/jean : utilisation de la base d'authentification
#   2004/01/14 : pda/jean : ajout IPv6
#   2004/08/04 : pda/jean : ajout mac
#   2005/04/08 : pda/jean : ajout dhcpprofil
#   2007/10/25 : jean     : log des actions de modification
#   2008/02/13 : pda/jean : le responsable est le correspondant si pas prcis
#   2008/07/23 : pda/jean : ajout du droit d'mission SMTP
#   2008/07/29 : pda      : utilisation presenter-rr
#   2010/01/01 : pda      : codage ajout-multi
#   2010/10/08 : pda      : codage parcours (via next)
#   2010/10/09 : pda      : fin codage ajout-multi
#   2010/10/26 : pda      : vrification dhcpprofil sans adresse mac
#

set conf(homeurl)	%HOMEURL%

#
# Chemins utiliss par les scripts
#

set conf(pkg)		%PKGTCL%
set conf(lib)		%DESTDIR%/lib
set conf(libdns)	$conf(lib)/libdns.tcl

#
# Dfinition des noms des pages " trous"
#

set conf(page-ajout-machine)	$conf(lib)/traiteajout-machine.html
set conf(page-ajout-existe)	$conf(lib)/traiteajout-existe.html
set conf(page-ajout-smtp)	$conf(lib)/traiteajout-smtp.html
set conf(page-ajout-multi)	$conf(lib)/traiteajout-multi.html
set conf(page-ajout-alias)	$conf(lib)/traiteajout-alias.html
set conf(err)			$conf(lib)/erreur.html

#
# Quelques paramtres du script
#

set conf(auth)		%AUTH%
set conf(base)		%BASE%
set conf(nologin)	%NOLOGIN%
set conf(log)		%LOG%

# scripts cgi
set conf(script-map)	bin/liste
set conf(script-seq)	bin/traiteajout
set conf(script-ajout)	bin/ajout

# nb max d'adresses IP pour une recherche d'adresses IP conscutives
set conf(maxip)		1024

# le champ discriminant pour la suite
set conf(form)		{
	{action		1 1}
}

# les champs utiliss pour chacune des actions
set conf(form-ajout-machine)	{
	{confirm	1 1}
	{nom		1 1}
	{domaine	1 1}
	{adr		1 1}
	{mac		1 1}
	{iddhcpprofil	1 1}
	{droitsmtp	0 1}
	{ttl		1 1}
	{hinfo		1 1}
	{commentaire	1 1}
	{respnom	1 1}
	{respmel	1 1}
	{nextprog	0 1}
	{nextargs	0 1}
}

set conf(form-ajout-alias)	{
	{nom		1 1}
	{domaine	1 1}
	{nomref		1 1}
	{domaineref	1 1}
}

set conf(form-ajout-multi)	{
	{redirect	0 1}
	{tri		0 1}
	{plage		1 1}
	{nbadr		1 1}
}

set conf(tableau-multi) {
    global {
	chars {12 normal}
	align {left}
	botbar {yes}
	columns {40 20 40}
    }
    pattern Entete {
	vbar {yes}
	column {
	    format {raw}
	}
	vbar {yes}
	column {
	    format {raw}
	    align {center}
	}
	vbar {yes}
	column { }
	vbar {yes}
    }
    pattern Normal {
	vbar {yes}
	column { }
	vbar {yes}
	column {
	    align {center}
	}
	vbar {yes}
	column {
	    format {raw}
	}
	vbar {yes}
    }
}

#
# Les outils du parfait concepteur de pages Web dynamiques...
#

lappend auto_path $conf(pkg)
package require webapp
package require pgsql
package require arrgen

#
# On y va !
#

# ::webapp::cgidebug ; exit

source $conf(libdns)

##############################################################################
# Ajout d'un nom
##############################################################################

# Historique
#   2002/04/11 : pda/jean : conception
#   2002/04/19 : pda/jean : ajout de la confirmation
#   2002/05/02 : pda/jean : modification du format de hinfo
#   2002/05/03 : pda/jean : mmoriser la mise  jour par le correspondant
#   2003/04/24 : pda/jean : interdiction d'ajout d'ip  un mx
#   2004/08/04 : pda/jean : ajout mac
#   2005/04/08 : pda/jean : ajout iddhcpprofil
#   2010/10/31 : pda      : ajout ttl
#

proc traiteajout-machine {dbfd tc ft} {
    global conf
    upvar $ft ftab
    upvar $tc tabcor

    set login $tabcor(login)
    set idcor $tabcor(idcor)

    #
    # Valider les champs du formulaire
    #

    set nom           [string trim [lindex $ftab(nom) 0]]
    set domaine       [string trim [lindex $ftab(domaine) 0]]
    set adr           [string trim [lindex $ftab(adr) 0]]
    set mac           [string trim [lindex $ftab(mac) 0]]
    set iddhcpprofil  [string trim [lindex $ftab(iddhcpprofil) 0]]
    set droitsmtp     [string trim [lindex $ftab(droitsmtp) 0]]
    set ttl           [string trim [lindex $ftab(ttl) 0]]
    set hinfo         [string trim [lindex $ftab(hinfo) 0]]
    set commentaire   [string trim [lindex $ftab(commentaire) 0]]
    set respnom       [string trim [lindex $ftab(respnom) 0]]
    set respmel       [string trim [lindex $ftab(respmel) 0]]
    set confirm       [string trim [lindex $ftab(confirm) 0]]
    set nextprog      [string trim [lindex $ftab(nextprog) 0]]
    set nextargs      [string trim [lindex $ftab(nextargs) 0]]

    #
    # Valider la syntaxe du nom au sens de la RFC ????
    #

    set m [syntaxe-nom $nom]
    if {! [string equal $m ""]} then {
	::webapp::error-exit $conf(err) "Erreur sur le nom '$nom': $m"
    }
    set nom [string tolower $nom]

    #
    # Valider le nom
    #

    set msg [valide-droit-nom $dbfd $idcor $nom $domaine trr "machine"]
    if {! [string equal $msg ""]} then {
	::webapp::error-exit $conf(err) $msg
    }
    set iddom $trr(iddom)

    #
    # Est-ce que ce nom existe, et est dj associ 
    # une adresse IP (ou plus) ?
    #

    set dejaip 0
    set rrexiste 0
    if {! [string equal $trr(idrr) ""]} then {
	set rrexiste 1
	if {! [string equal $trr(ip) ""]} then {
	    set dejaip 1
	}
    } else {
	if {[string equal $respnom ""] && [string equal $respmel ""]} then {
	    set respnom "$tabcor(nom) $tabcor(prenom)"
	    set respmel $tabcor(mel)
	}
    }

    #
    # Vrifier la syntaxe de l'adresse IP
    #

    set m [syntaxe-ip $dbfd $adr "inet"]
    if {[string length $m] > 0} then {
	::webapp::error-exit $conf(err) "Erreur sur l'adresse IP '$adr': $m"
    }

    #
    # Vrifier que l'adresse IP appartient bien  une des plages
    # autorises pour le correspondant
    #

    if {! [droit-correspondant-ip $dbfd $idcor $adr]} then {
	::webapp::error-exit $conf(err) "Vous n'avez pas accs  l'adresse '$adr'"
    }

    #
    # Vrifier enfin que l'adresse n'existe pas dj
    #

    if {[lire-rr-par-ip $dbfd $adr tabrrbidon]} then {
	::webapp::error-exit $conf(err) "L'adresse '$adr' existe dj"
    }

    #
    # Vrifier la syntaxe de l'adresse MAC et que la nouvelle adresse IP
    # n'empite pas sur les intervalles DHCP dynamiques
    #

    if {! [string equal $mac  ""]} then {
	set m [syntaxe-mac $dbfd $mac]
	if {[string length $m] > 0} then {
	    ::webapp::error-exit $conf(err) "Erreur sur l'adresse MAC : $m"
	}
    }

    set mac_a_tester $mac
    if {$dejaip} then {
	set mac_a_tester $trr(mac)
    }
    set m [valide-dhcp-statique $dbfd $mac_a_tester [list $adr]]
    if {[string length $m] > 0} then {
	::webapp::error-exit $conf(err) "$m"
    }

    #
    # Vrifier le profil DHCP
    #

    if {! [check-iddhcpprofil $dbfd $iddhcpprofil dhcpprofil msg]} then {
	::webapp::error-exit $conf(err) "Profil DHCP invalide ($msg)"
    }

    if {[string equal $mac ""] && $iddhcpprofil != 0} then {
	::webapp::error-exit $conf(err) \
		"Impossible de configurer un profil DHCP sans adresse MAC"
    }

    #
    # Rcuprer le type de machine en clair
    #

    set idhinfo [lire-hinfo $dbfd $hinfo]
    if {$idhinfo == -1} then {
	::webapp::error-exit $conf(err) "Le type de machine '$hinfo' n'existe pas."
    }

    #
    # Vrifier le droit d'mission SMTP
    #

    set grdroitsmtp [droit-correspondant-smtp $dbfd $tabcor(idcor)]
    if {$grdroitsmtp} then {
	if {[string equal $droitsmtp ""]} then {
	    set droitsmtp 0
	} else {
	    set droitsmtp 1
	}
    } else {
	set droitsmtp 0
    }

    #
    # Vrifier le droit TTL
    #

    set grdroitttl [droit-correspondant-ttl $dbfd $tabcor(idcor)]
    if {$grdroitttl} then {
	if {[string equal $ttl ""]} then {
	    set ttl -1
	} else {
	    set msg [valide-ttl $ttl]
	    if {! [string equal $msg ""]} then {
		::webapp::error-exit $conf(err) $msg
	    }
	}
    } else {
	set ttl -1
    }

    #
    #  ce niveau l :
    # - si le nom n'existe pas encore, et qu'on a demand l'mission SMTP
    #		=> demander confirmation
    # - s'il y a dj une adresse IP
    #		=> demander confirmation
    # - dans tous les autres cas
    #		=> faire l'action
    #

    #
    # Code en commun pour le cas o il y ait demande de confirmation
    #

    set l {nom domaine adr mac iddhcpprofil droitsmtp ttl hinfo commentaire
			    respnom respmel nextprog nextargs}
    set hidden [::webapp::hide-parameters $l ftab]

    #
    # Demander confirmation s'il y a demande d'mission SMTP
    #

    if {! $dejaip && $droitsmtp && ! [string equal $confirm "oui"]} then {
	#
	# Sortir une page de confirmation
	#

	::webapp::send html [::webapp::file-subst $conf(page-ajout-smtp) \
						[list \
							[list %HIDDEN% $hidden] \
						    ] \
					    ]
	return 0
    }

    #
    # Si le nom existe dj, poser la question, sinon
    # insrer l'objet
    #

    if {$dejaip && ! [string equal $confirm "oui"]} then {
	#
	# Sortir une page avec la liste des attributs de l'objet
	# identifi.
	# Attributs affichs : nom, mac, hinfo, commentaire, respnom, respmel,
	# liste des adresses.
	#

	set machine [presenter-rr $dbfd -1 trr]
	::webapp::send html [::webapp::file-subst $conf(page-ajout-existe) \
					    [list \
						[list %NOM%     $nom] \
						[list %DOMAINE% $domaine] \
						[list %ADR%     $adr] \
						[list %HIDDEN%  $hidden] \
						[list %MACHINE% $machine] \
					    ] \
					]
	return 0
    }

    #
    # L'objet n'a pas dj une adresse IP, ou alors il en a dj
    # une (ou plus), mais l'utilisateur a confirm qu'il souhaite
    # lui attribuer plusieurs adresses.
    #
    # Insrer l'objet (RR + adr IP) ou seulement l'adr IP dans la base
    #
    if {! [::pgsql::lock $dbfd {rr rr_ip} msg]} then {
	::webapp::error-exit $conf(err) "Transaction impossible : $msg"
    }

    if {! $rrexiste} then {
	#
	# Rien n'existait pour ce nom, donc on insre un nouveau
	# RR.
	#
	set msg [ajouter-rr $dbfd $nom $iddom $mac $iddhcpprofil $idhinfo \
		    $droitsmtp $ttl $commentaire $respnom $respmel $idcor trr]
	if {! [string equal $msg ""]} then {
	    ::webapp::error-exit $conf(err) "Impossible d'insrer : $msg"
	}

    } else {
	#
	# Le RR existait dj. Le commentaire ou le hinfo peuvent
	# avoir t modifis par l'utilisateur.
	# N'updater que si ncessaire.
	#

	if {! $dejaip} then {
	    #
	    # Complment d'un RR pr-existant (exemple : dclarer
	    # une machine alors que seul le rle de messagerie existe
	    # dj.
	    #
	    if {! ([string equal $mac $trr(mac)] &&
		    [string equal $iddhcpprofil $trr(iddhcpprofil)] &&
		    [string equal $hinfo $trr(hinfo)] &&
		    [string equal $droitsmtp $trr(droitsmtp)] &&
		    [string equal $ttl $trr(ttl)] &&
		    [string equal $commentaire $trr(commentaire)] &&
		    [string equal $respnom $trr(respnom)] &&
		    [string equal $respmel $trr(respmel)])} then {
		if {[string equal $mac ""]} then {
		    set qmac     NULL
		} else {
		    set qmac     "'[::pgsql::quote $mac]'"
		}
		set qcommentaire [::pgsql::quote $commentaire]
		set qrespnom     [::pgsql::quote $respnom]
		set qrespmel     [::pgsql::quote $respmel]
		if {$iddhcpprofil == 0} then {
		    set iddhcpprofil NULL
		}
		set sql "UPDATE rr SET
					mac = $qmac,
					iddhcpprofil = $iddhcpprofil,
					idhinfo = $idhinfo,
					droitsmtp = $droitsmtp,
					ttl = $ttl,
					commentaire = '$qcommentaire',
					respnom = '$qrespnom',
					respmel = '$qrespmel'
				    WHERE idrr = $trr(idrr)"
		if {! [::pgsql::execsql $dbfd $sql msg]} then {
		    ::webapp::error-exit $conf(err) "Mise  jour impossible HINFO : $msg"
		}
	    }
	}
    }

    set sql "INSERT INTO rr_ip VALUES ($trr(idrr), '$adr')"
    if {! [::pgsql::execsql $dbfd $sql msg]} then {
       ::pgsql::unlock $dbfd "abort" m
	::webapp::error-exit $conf(err) "Impossible d'insrer : $msg"
    }


    #
    # Se rappeler du correspondant qui a effectu la modification
    #

    set msg [touch-rr $dbfd $trr(idrr) $idcor]
    if {[string length $msg] > 0} then {
       ::pgsql::unlock $dbfd "abort" m
	::webapp::error-exit $conf(err) $msg
    }

    if {! [::pgsql::unlock $dbfd "commit" msg]} then {
       ::pgsql::unlock $dbfd "abort" m
       ::webapp::error-exit $conf(err) "L'insertion a chou. Abandon.\n$msg"
    }

    writelog "ajoutmachine" $login "ajout de $nom.$domaine ($adr)"


    #
    # Prparer la suite
    #
     
    switch -- $nextprog {
	map {
	    set suite "$conf(homeurl)/$conf(script-map)?format=carte&$nextargs"
	}
	sequence {
	    foreach kv [split $nextargs "&"] {
		if {[regexp {^([^=]+)=(.*)} $kv bidon k v]} then {
		    lappend nf($k) $v
		}
	    }
	    set nbadr 0
	    if {[info exists nf(nbadr)]} then {
		set nbadr $nf(nbadr)
	    }

	    if {$nbadr > 1} then {
		incr nbadr -1
		set sql "SELECT INET('$adr')+1 AS adr"
		pg_select $dbfd $sql tab {
		    set nadr $tab(adr)
		}

		set suite "$conf(homeurl)/$conf(script-ajout)"
		append suite "?adr=$nadr"
		append suite "&nextprog=sequence"
		append suite "&nextargs="
		append suite [::webapp::post-string "nbadr=$nbadr"]
	    } else {
		set suite "$conf(homeurl)/$conf(script-ajout)"
	    }
	}
	default {
	    set suite "$conf(homeurl)/bin/ajout"
	}
    }

    #
    # Sortie du rsultat
    #

    set machine [presenter-rr $dbfd $trr(idrr) trr]
    ::webapp::send html [::webapp::file-subst $conf(page-ajout-machine) \
					[list \
					    [list %MACHINE% $machine] \
					    [list %SUITE% $suite] \
					] \
				    ]

    return 0
}


##############################################################################
# Recherche d'un espace conscutif
##############################################################################

# Historique
#   2010/01/01 : pda      : conception
#   2010/10/09 : pda      : fin de la conception
#

proc traiteajout-multi {dbfd _tabcor _ftab} {
    global conf
    upvar $_ftab ftab
    upvar $_tabcor tabcor

    set login $tabcor(login)
    set idcor $tabcor(idcor)
    set idgrp $tabcor(idgrp)

    #
    # Valider les champs du formulaire
    #

    set redirect [string trim [lindex $ftab(redirect) 0]]
    set tri      [string trim [lindex $ftab(tri) 0]]
    set plage    [string trim [lindex $ftab(plage) 0]]
    set nbadr    [string trim [lindex $ftab(nbadr) 0]]

    set lcidr [valide-idreseau $dbfd $plage $idgrp "consult" {4} msg]
    if {[llength $lcidr] != 1} then {
       ::webapp::error-exit $conf(err) $msg
    }
    set cidr [lindex $lcidr 0]

    #
    # Cas spcial pour l'appel  la carte des adresses disponibles
    # On redirige alors vers un autre script CGI.
    #

    if {[string match -nocase {consulter*} $redirect]} then {
	set nftab(cidr) {}
	foreach cidr $lcidr {
	    lappend nftab(cidr) $cidr
	}
	set nftab(format) [list "Carte des adresses"]
	puts stdout [::webapp::call-cgi %DESTDIR%/$conf(script-map) nftab]
	return 0
    }

    #
    # Continuer la validation des champ de formulaire
    #

    if {! [regexp {^[0-9]+$} $nbadr] || $nbadr < 1} then {
       ::webapp::error-exit $conf(err) "Mauvais nombre d'adresses ($nbadr)"
    }

    switch -- $tri {
	nbadr {
	    set order "ORDER BY n ASC, a ASC"
	}
	adr -
	default {
	    set order "ORDER BY a ASC, n ASC"
	}
    }

    #
    # Rechercher les plages libres
    #

    set sql "SELECT *
		FROM ipranges ('$cidr', $conf(maxip), $idgrp)
		WHERE n >= $nbadr
		$order"
    set lranges {}
    pg_select $dbfd $sql tab {
	lappend lranges [list $tab(a) $tab(n)]
    }

    if {[llength $lranges] == 0} then {
       ::webapp::error-exit $conf(err) "Aucune plage conscutive de $nbadr adresse(s) IPv4"
    }

    #
    # Mise en forme
    #

    set donnees {}

    # url de base pour raliser les tris
    set burl "$conf(homeurl)/bin/traiteajout?action=ajout-multi&plage=$plage&nbadr=$nbadr"

    # titre du tableau (avec les urls de tri)
    set c1 [::webapp::helem "a" "Premire adresse IP" "href" "$burl&tri=adr"]
    set c2 [::webapp::helem "a" "Taille de l'intervalle" "href" "$burl&tri=nbadr"]
    lappend donnees [list Entete $c1 $c2 ""]

    # parcours des intervalles trouvs
    foreach l $lranges {
	set a [lindex $l 0]
	set n [lindex $l 1]

	set hidden    [::webapp::form-hidden "adr" $a]
	append hidden [::webapp::form-hidden "nextprog" "sequence"]
	append hidden [::webapp::form-hidden "nextargs" "nbadr=$nbadr"]

	# un peu de cosmtique pour que la signification du
	# bouton de choix soit clairement explicite
	if {$nbadr == $n} then {
	    if {$nbadr == 1} then {
		set msg "Choisir cette adresse"
	    } else {
		set msg "Choisir ces $n adresses"
	    }
	} elseif {$nbadr < $n} then {
	    if {$nbadr == 1} then {
		set msg "Choisir la premire adresse"
	    } else {
		set msg "Choisir les $nbadr premires adresses"
	    }
	}
	set bouton "<input type=\"submit\" value=\"$msg\">"

	set c [::webapp::helem "form" "$hidden$bouton" \
				"method" "post" \
				"action" "$conf(homeurl)/$conf(script-ajout)" \
		    ]

	lappend donnees [list Normal $a $n $c]
    }

    set liste [::arrgen::output "html" $conf(tableau-multi) $donnees]

    #
    # Sortie de la page
    #

    ::webapp::send html [::webapp::file-subst $conf(page-ajout-multi) \
					[list \
					    [list %LISTE% $liste] \
					] \
				    ]
    return 0
}

##############################################################################
# Ajout d'un alias
##############################################################################

# Historique
#   2002/04/19 : pda/jean : conception
#
proc traiteajout-alias {dbfd tc ft} {
    global conf
    upvar $ft ftab
    upvar $tc tabcor

    set login $tabcor(login)
    set idcor $tabcor(idcor)

    #
    # Valider les champs du formulaire
    #

    set nom           [string trim [lindex $ftab(nom) 0]]
    set domaine       [string trim [lindex $ftab(domaine) 0]]
    set nomref        [string trim [lindex $ftab(nomref) 0]]
    set domaineref    [string trim [lindex $ftab(domaineref) 0]]

    #
    # Valider la syntaxe des noms au sens de la RFC ????
    #

    set m [syntaxe-nom $nom]
    if {[string length $m] > 0} then {
	::webapp::error-exit $conf(err) "Erreur sur le nom '$nom': $m"
    }
    set nom [string tolower $nom]

    set m [syntaxe-nom $nomref]
    if {[string length $m] > 0} then {
	::webapp::error-exit $conf(err) "Erreur sur le nom '$nomref': $m"
    }
    set nomref [string tolower $nomref]

    #
    # Valider les noms d'alias et de machine.
    #

    set msg [valide-droit-nom $dbfd $idcor $nom $domaine trr "alias"]
    if {! [string equal $msg ""]} then {
	::webapp::error-exit $conf(err) $msg
    }
    set iddom $trr(iddom)

    set msg [valide-droit-nom $dbfd $idcor $nomref $domaineref trrref "machine-existante"]
    if {! [string equal $msg ""]} then {
	::webapp::error-exit $conf(err) $msg
    }

    #
    # Tous les tests sont ok, il faut insrer l'alias
    #

    if {! [::pgsql::lock $dbfd {rr rr_cname} msg]} then {
	::webapp::error-exit $conf(err) "Transaction impossible : $msg"
    }

    #
    # Rien n'existait pour ce nom, donc on insre un nouveau
    # RR.
    #

    set msg [ajouter-rr $dbfd $nom $iddom "" 0 "" 0 -1 "" "" "" $idcor newrr]
    if {! [string equal $msg ""]} then {
	::webapp::error-exit $conf(err) "Impossible d'insrer : $msg"
    }

    #
    # Ajouter l'alias proprement dit
    #

    set sql "INSERT INTO rr_cname VALUES ($newrr(idrr), $trrref(idrr))"
    if {! [::pgsql::execsql $dbfd $sql msg]} then {
	::webapp::error-exit $conf(err) "Impossible d'insrer l'alias : $msg"
    }

    
    if {! [::pgsql::unlock $dbfd "commit" msg]} then {
       ::pgsql::unlock $dbfd "abort" m
       ::webapp::error-exit $conf(err) "L'insertion a chou. Abandon.\n$msg"
    }

    #
    # Sortie du rsultat
    #

    writelog "ajoutalias" $login \
	"ajout de l'alias $nom.$domaine -> $nomref.$domaineref"

    ::webapp::send html [::webapp::file-subst $conf(page-ajout-alias) \
				    [list \
					    [list %NOM%        $nom] \
					    [list %DOMAINE%    $domaine] \
					    [list %NOMREF%     $nomref] \
					    [list %DOMAINEREF% $domaineref] \
					] \
				]
}

##############################################################################
# Programme principal
##############################################################################

proc main {} {
    global conf

    #
    # Initialisation
    #

    init-dns $conf(nologin) $conf(auth) $conf(base) $conf(err) "" \
			$conf(form) ftab dbfd login tabcor $conf(log)

    #
    # Valider l'action, lire les autres champs du formulaire,
    # et faire le branchement
    #

    set action [lindex $ftab(action) 0]

    if {! [info exists conf(form-$action)]} then {
	::webapp::error-exit $conf(err) "Champ 'action' non conforme : $action"
    }

    if {[llength [::webapp::get-data ftab $conf(form-$action)]] == 0} then {
	::webapp::error-exit $conf(err) "Formulaire non conforme aux spcifications"
    }

    traite$action $dbfd tabcor ftab

    #
    # Dconnexion de la base
    #

    fermer-base $dbfd
}

::webapp::cgi-exec main %DEBUG%
