code-aster-gui 1.8.4-5 / usr / share / astk / remote_tools.tcl

#########################################################################
# COPYRIGHT (C) 2003         EDF R&D              WWW.CODE-ASTER.ORG    #
#                                                                       #
# THIS PROGRAM IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR         #
# MODIFY IT UNDER THE TERMS OF THE GNU GENERAL PUBLIC LICENSE AS        #
# PUBLISHED BY THE FREE SOFTWARE FOUNDATION; EITHER VERSION 2 OF THE    #
# LICENSE, OR (AT YOUR OPTION) ANY LATER VERSION.                       #
# THIS PROGRAM IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL,       #
# BUT WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF        #
# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. SEE THE GNU      #
# GENERAL PUBLIC LICENSE FOR MORE DETAILS.                              #
#                                                                       #
# YOU SHOULD HAVE RECEIVED A COPY OF THE GNU GENERAL PUBLIC LICENSE     #
# ALONG WITH THIS PROGRAM; IF NOT, WRITE TO : EDF R&D CODE_ASTER,       #
#    1 AVENUE DU GENERAL DE GAULLE, 92141 CLAMART CEDEX, FRANCE.        #
#########################################################################

# $Id: remote_tools.tcl 3579 2008-10-24 13:33:54Z courtois $

# ajout des arguments globaux : remote_copy_protocol, remote_shell_protocol, rcdir
#################################################################
proc ashare::get_glob_args { } {
   set lcmd ""
   append lcmd " --remote_shell_protocol=$astk::config(-1,remote_shell_protocol)"
   append lcmd " --remote_copy_protocol=$astk::config(-1,remote_copy_protocol)"
   if { $astk::rcdir_mod } {
      append lcmd " --rcdir=$astk::rcdir"
   }
   return $lcmd
}

# enrobage pour l'appel au browser multi-machines
# numéro du serveur, le chemin+nom, le type (F ou R)
# retourne 0 si ok, 1 sinon
#################################################################
proc ashare::selecteur {srv_OUT dir_OUT typ_OUT srv_IN dir_IN typ_IN {args_sup ""}} {
   upvar $srv_OUT srv
   upvar $dir_OUT dir
   upvar $typ_OUT typ
# voir les serveurs que l'on garde
   set isrv_IN ""
   set k -1
   for { set j -1 } { $j < $astk::config(nb_serv) } { incr j } {
      if { $astk::config($j,etat) == "on" } {
         set cfg($k,num)         $j
         set cfg($k,nom)         $astk::config($j,nom)
         set cfg($k,nom_complet) $astk::config($j,nom_complet)
         set cfg($k,login)       $astk::config($j,login)
         set cfg($k,home)        $astk::config($j,home)
         set cfg($k,xterm)       $astk::config($j,xterm)
         if { $srv_IN == $j } {
            set isrv_IN $k
         }
         if { $ashare::dbg >= 4 } {
            ashare::log "<DEBUG> (selecteur) machine $k : $cfg($k,nom_complet)"
         }
         incr k
      }
   }
   set cfg(nb_serv) $k
   set cfg(-1,remote_shell_protocol) $astk::config(-1,remote_shell_protocol)
   set cfg(-1,remote_copy_protocol)  $astk::config(-1,remote_copy_protocol)
# prépare les arguments
   set args ""
   if { $isrv_IN != "" } {
      append args " -initialsrv $isrv_IN"
   }
   if { $dir_IN != "" } {
      append args " -initialdir $dir_IN"
   }
   if { $typ_IN == "" } {
      append args " -typeOut \"FR\""
   } elseif { $typ_IN == "F" } {
      append args " -typeOut \"F\""
   } elseif { $typ_IN == "R" } {
      append args " -typeOut \"R\""
   }
   if { $ashare::dbg >= 4 } {
      append args " -debug"
      ashare::log "<DEBUG> (selecteur) cfg  : [array get cfg]"
      ashare::log "<DEBUG> (selecteur) args : $args"
   }
   append args " $args_sup"
   set lstemp [eval tkgetdir::tk_getDirectory cfg -font {$astk::ihm(font,brwlst)} $args]
   set iret 1
   set srv ""
   set dir ""
   set typ ""
   if { [string length [lindex $lstemp 1]] > 0 } {
      set srv $cfg([lindex $lstemp 0],num)
      set dir [lindex $lstemp 1]
      set typ [lindex $lstemp 2]
      set iret 0
      if { $ashare::dbg >= 4 } {
         ashare::log "<DEBUG> (selecteur) iret=$iret ; srv # dir # typ : $srv # $dir # $typ"
      }
   }
   return $iret
}

# substitue des variables avant l'appel à une commande
#   @D = $DISPLAY
#   @F = nom du fichier sélectionné (avec le répertoire)
#   @f = nom du fichier sans le répertoire
#   @R = répertoire contenant le fichier sélectionné
#################################################################
proc ashare::subst_var { cmd } {
   regsub -all "@D" $cmd $ashare::DISPLAY cmd
   set name $astk::sel(filename)
#   if { $name != "" } {
   set dir  [file dirname $name]
   set base [file tail $name]
   # on ne remplace qui si suivi d'un espace ou fin de ligne
   regsub -all "@F " $cmd "$name " cmd
   regsub -all "@f " $cmd "$base " cmd
   regsub -all "@R " $cmd "$dir " cmd
   regsub -all "@F\$" $cmd "$name " cmd
   regsub -all "@f\$" $cmd "$base " cmd
   regsub -all "@R\$" $cmd "$dir " cmd
#   }
   return $cmd
}

# exécute une commande sur un serveur
# substitue les valeurs des variables utilisateur éventuelles
# -1 représente la machine interface
# le tableau de config contient :
# cfg(n°serv,nom_complet) et cfg(n°serv,login)
# c'est à l'appelant d'émettre ou non un message en fonction du code retour
#################################################################
proc ashare::rexec_cmd { serv cfg prog args bg output {parent ""}} {
   upvar $output msg
   upvar $cfg config
   # on récupère stdout et stderr dans un fichier unique
   set num [clock clicks -milliseconds]
   set fout [file join $astk::tmpdir .file_rexec_out]
   append fout "_$num"
   set ferr [file join $astk::tmpdir .file_rexec_err]
   append ferr "_$num"
   # vérifier qu'il n'y a pas de redirection dans la commande
   # numero du process : process

# attente
   ashare::pointeur off
# local ?
   if { $astk::config($serv,islocal) == "oui" ||
        ([ashare::meme_machine $config($serv,nom_complet) $config(-1,nom_complet)]
         && $config($serv,login) == $config(-1,login)) } {
      set serv -1
   }
# substitution des variables et arguments
   append prog " $args"
   set cmd [ ashare::subst_var $prog ]
#
   ashare::mess info 44 $config($serv,nom_complet) $cmd $serv
   if { $serv >= 0 } {
      if { $config(-1,remote_shell_protocol) == "" || $config(-1,remote_shell_protocol) == "RSH" } {
         if { $config($serv,login) != "" } {
            catch { exec rsh -n -l $config($serv,login) $config($serv,nom_complet) $cmd > $fout 2> $ferr & } process
         } else {
            catch { exec rsh -n $config($serv,nom_complet) $cmd > $fout 2> $ferr & } process
         }
      } elseif { $config(-1,remote_shell_protocol) == "SSH" } {
         if { $config($serv,login) != "" } {
            catch { exec ssh -n -l $config($serv,login) $config($serv,nom_complet) $cmd > $fout 2> $ferr & } process
         } else {
            catch { exec ssh -n $config($serv,nom_complet) $cmd > $fout 2> $ferr & } process
         }
      } else {
         set iret 127
         ashare::mess erreur 49 $config(-1,remote_shell_protocol)
         return $iret
      }
   } else {
      set cmd "exec $cmd > $fout 2> $ferr &"
      catch { eval $cmd } process
   }
# attendre la fin si background non demandé
   if { $bg == 0 } {
      ashare::mess info 45 $process

      if { [regexp {^[ ]*([0-9]+)[ ]*} $process] == 0 } {
         set msg $process
         return -999
      }
         set ashare::fini($process) 0
         set ashare::cycle($process) 0
         ashare::attend $process $fout $parent
         tkwait variable ashare::fini($process)
   }
# mettre l'output dans msg
   set idf [open $ferr r]
   set msgerr [read -nonewline $idf]
   close $idf
   set idf [open $fout r]
   set msg [read -nonewline $idf]
   close $idf
   if { $ashare::dbg < 5 } {
      file delete -force $fout
   }

# code retour renvoyé par as_run dans l'output (car rsh renvoie 0)
   set iret_gene 0
   set iret [list]
   set next $msg
   while { [regexp {EXIT_CODE=([-0-9]+)(.*)} $next mat1 iv next] } {
      lappend iret $iv
      if { $iv != 0 } {
         set iret_gene 1
      }
   }
# pb de quota ?
   if { [regexp -nocase {quota.*exceed} $msg] } {
      ashare::mess info 46 $msg
      ashare::mess info 49 $msgerr
      tk_messageBox -title "$ashare::msg($ashare::lang,erreur,txt)" -message [ashare::mess erreur 32 $config($serv,nom_complet)] -type ok
   }
   ashare::pointeur on
   if { [lsearch $iret -999] > -1 } {
      set ich [tk_messageBox -title [ashare::mess ihm 138] -message [ashare::mess erreur 24] -type ok]
   }
# tcl 8.4 : [lsearch -not $iret 0]
   if { [lsearch -regexp $iret {[^0]}] > -1 || $ashare::dbg >= 1 } {
      ashare::mess info 46 $msg
   }
   if { [lsearch -regexp $iret {[^0]}] > -1 || $ashare::dbg >= 3 } {
      ashare::mess info 49 $msgerr
   }
# traitement du code retour (on retourne la valeur s'il n'y en a qu'une, 0 si on n'a rien d'autre !)
   if { [llength $iret] == 0 } {
      set iret 0
   } elseif { [llength $iret] == 1 } {
      set iret [lindex $iret 0]
   }
   if { $ashare::dbg >= 2 && $iret_gene != 0 } {
      ashare::mess info 47 $iret
   }
   return $iret
}

# copie de fichiers ou répertoires direct ou par rcp
# si option=commande, on renvoie la ligne de commande pour faire la copie
#################################################################
proc ashare::rcp_cmd { cfg serv1 fich1 serv2 fich2 option {parent ""}} {
   upvar $cfg config
# attente
   ashare::pointeur off
# local ?
   set serv -1
   set remote 0
   set src  $fich1
   set dest $fich2
   if { $astk::config($serv1,islocal) != "oui"
     || [ashare::meme_machine $config($serv1,nom_complet) $config(-1,nom_complet)] != 1
     || $config($serv1,login) != $config(-1,login) } {
      set src $config($serv1,login)@$config($serv1,nom_complet):$fich1
      incr remote
   }
   if { $astk::config($serv2,islocal) != "oui"
     || [ashare::meme_machine $config($serv2,nom_complet) $config(-1,nom_complet)] != 1
     || $config($serv2,login) != $config(-1,login) } {
      set dest $config($serv2,login)@$config($serv2,nom_complet):$fich2
      incr remote
   }
#
   if { $remote == 0 } {
      set cmd "cp -r $fich1 $fich2"
   } else {
      set proto $config(-1,remote_copy_protocol)
      if { $remote == 2 } {
         set serv $serv1
         # pas possible en rsync
         if { $proto == "RSYNC" } {
            set proto RCP
         }
      }
      if { $proto == "" || $proto == "RCP" } {
         set cmd "rcp -r $src $dest"
      } elseif { $proto == "RSYNC" } {
         set cmd "rsync -rz $src $dest"
      } elseif { $proto == "SCP" } {
         set cmd "scp -rBCq $src $dest"
      } else {
         set iret 127
         ashare::mess erreur 49 $proto
         return $iret
      }
   }

   if { $ashare::dbg >= 4 } {
      ashare::log "<DEBUG> (rcp_cmd) commande : $cmd"
   }
   if { $option == "commande" } {
      return $cmd
   } else {
      set cmd "$astk::cmd(shell_cmd) \"$cmd; echo EXIT_CODE=\$?\""
   }

   set iret [ashare::rexec_cmd $serv config $cmd "" 0 out $parent]
   if { $iret != 0 } {
      ashare::mess "erreur" 3 "rcp_cmd de $config($serv1,nom_complet):$fich1 vers $config($serv2,nom_complet):$fich2" $iret $out
   }
   ashare::pointeur on
   return $iret
}

# interrompt le process
#################################################################
proc ashare::kill { process fout } {
   set cmd "exec kill -9 $process"
   catch { eval $cmd } out
   # ajoute un exit code dans le fichier output de la commande
   set cmd "exec \\echo EXIT_CODE=-999 >> $fout"
   catch { eval $cmd } out
}

# vérifie que le process tourne encore, sinon ferme la fenetre interrompre
# on cartonne errorCode quand le process est fini (grep)
#################################################################
proc ashare::attend { process fout {parent ""}} {
   incr ashare::cycle($process)
   #ashare::log "<DEBUG> (attend) Process $process, cycle numéro : $ashare::cycle($process)"
   # on attend le 2ème passage avant de faire quoique ce soit
   # sinon on risque de fixer fini=1 avant d'arriver au tkwait
   if { $ashare::cycle($process) > 1 } {
      set cmd "exec $astk::cmd(shell_cmd) \"$astk::cmd(ps) -p $process | grep $process | grep -vc grep\""
      catch { eval $cmd } out
      # au cas où le regexp ne trouve rien, on considère que c'est fini
      set nocc 0
      regexp {([0-9]+)} $out mat1 nocc
      if { $nocc != 0 } {
         # on n'affiche la fenêtre qu'à partir du passage N
         if { [winfo exists $astk::ihm(interrompre)] == 0
           && $ashare::cycle($process) > 2
           && $parent != "" } {
            display_cancel_button $process $fout $parent
         }
      # scrute le process toutes les 100 millisecondes
         after 100 "ashare::attend $process $fout $parent"
      } else {
         set ashare::fini($process) 1
         catch {destroy $astk::ihm(interrompre)}
      }
   } else {
      after 50 "ashare::attend $process $fout $parent"
   }
}

# affiche le bouton interrompre
# intégré ou non à la fenêtre principale
#################################################################
proc display_cancel_button { process fout {parent ""}} {
    set fen $astk::ihm(status).st.cancel
    if { (! [winfo exists $fen]) || [string first ".dirsel_" $parent] == 0 } {
        display_cancel_button_externe $process $fout $parent
    } else {
        set astk::ihm(interrompre) $fen.int
        set fen $astk::ihm(interrompre)
        catch {destroy $fen}
        button $fen -text [ashare::mess ihm 230] \
           -font $astk::ihm(font,labbout) -background $astk::ihm(couleur,suppr) \
           -command "ashare::kill $process $fout ; destroy $fen"
        pack $fen
        catch {grab set $fen}
    }
}

# affiche le bouton interrompre externe
#################################################################
proc display_cancel_button_externe { process fout {parent ""}} {
    set fen $astk::ihm(interrompre)
    toplevel $fen
    wm transient $fen $parent
    wm withdraw $fen
    catch {grab set $fen}
    $fen configure -cursor pirate
    button $fen.int -text [ashare::mess ihm 230] \
       -font $astk::ihm(font,labbout) -background $astk::ihm(couleur,suppr) \
       -command "ashare::kill $process $fout ; destroy $fen"
    pack $fen.int
    wm protocol $fen WM_DELETE_WINDOW "$fen.int invoke"
    ashare::centre_fen $fen $parent
    wm deiconify $fen
}


# machines identiques ?
# sans le nom de domaine
#################################################################
proc ashare::meme_machine { nom1 nom2 } {
   set iret 0
   # ne rien faire si adresse IP
   if { [regexp {[a-zA-Z]+} $nom1] } {
      regsub -all {\..*$} $nom1 "" nom1
   }
   if { [regexp {[a-zA-Z]+} $nom2] } {
      regsub -all {\..*$} $nom2 "" nom2
   }
   if { $nom1 == $nom2 } {
      set iret 1
   }
   return $iret
}