/usr/share/astk/remote

#########################################################################
# 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 ""
   #XXX should be unusefull
   #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_arg"
   }
   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([^a-zA-Z0-9\-\+]*)} $cmd "$ashare::DISPLAY\\1" 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([^a-zA-Z0-9\-\+]*)} $cmd "$name\\1" cmd
   regsub -all {@f([^a-zA-Z0-9\-\+]*)} $cmd "$base\\1" cmd
   regsub -all {@R([^a-zA-Z0-9\-\+]*)} $cmd "$dir\\1" 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 "None"} { logprogress "None" }} {
   upvar $output msg
   upvar $cfg config

   # on récupère stdout et stderr
   set fout [get_tmpname .file_rexec_out]
   set ferr [get_tmpname .file_rexec_err]
   # vérifier qu'il n'y a pas de redirection dans la commande
   # numero du process : process

  # add --log_progress option and reinit logprogress
  if { $logprogress != "None" } {
    append args " --log_progress=$ashare::fic_progress"
    # on pourrait choisir la fenetre de suivi selon $logprogress
    show_fen $astk::ihm(asjob)
    set logprogress $asjob::actu(f_progress)
  }

# 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" } {
         # using a variable for SSH_OPTS fails on some tcl versions...
         if { $config($serv,login) != "" } {
            catch { exec ssh -X -n -o StrictHostKeyChecking=no -o BatchMode=yes -l $config($serv,login) $config($serv,nom_complet) $cmd > $fout 2> $ferr & } process
         } else {
            catch { exec ssh -X -n -o StrictHostKeyChecking=no -o BatchMode=yes $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 $logprogress "$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
      file delete -force $ferr
   }

# 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 logprogress {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
      # logprogress
      ashare::update_progress $logprogress
      # 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 $logprogress $parent"
      } else {
         set ashare::fini($process) 1
         catch {destroy $astk::ihm(interrompre)}
      }
   } else {
      after 50 "ashare::attend $process $fout $logprogress $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
}

# update progress widget
#################################################################
proc ashare::update_progress { w } {
    if { $w == "None" } {
        return
    }
    textLoadFile $w $ashare::fic_progress
    $w yview end
}

# 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
}

# imprime les infos d'un serveur dans le fichier spécifié
#################################################################
proc write_server_infos { idf serv } {
    puts $idf "P serveur $astk::config($serv,nom_complet)"
    puts $idf "P username $astk::config($serv,login)"
    puts $idf "P aster_root $astk::config($serv,rep_serv)"
    puts $idf "P platform $astk::config($serv,plate-forme)"
    # 1. try to read from server configuration
    set proto_exec ""
    set proto_copyto ""
    set proto_copyfrom ""
    set proxy_dir ""
    catch { set proto_exec $astk::config($serv,protocol_exec) }
    catch { set proto_copyto $astk::config($serv,protocol_copyto) }
    catch { set proto_copyfrom $astk::config($serv,protocol_copyfrom) }
    catch { set proxy_dir $astk::config($serv,proxy_dir) }
    # 2. use the preferences (or a default value)
    if { $proto_exec == "" } {
        set proto_exec "asrun.plugins.server.SSHServer"
        if { $astk::config(-1,remote_shell_protocol) == "RSH" } {
            set proto_exec "asrun.plugins.server.RSHServer"
        }
    }
    if { $proto_copyto == "" } {
        set proto_copyto "asrun.plugins.server.SCPServer"
        if { $astk::config(-1,remote_copy_protocol) == "RCP" } {
            set proto_copyto "asrun.plugins.server.RCPServer"
        }
    }
    if { $proto_copyfrom == "" } {
        set proto_copyfrom "asrun.plugins.server.SCPServer"
        if { $astk::config(-1,remote_copy_protocol) == "RCP" } {
            set proto_copyfrom "asrun.plugins.server.RCPServer"
        }
    }
    if { $proxy_dir == "" } {
        set proxy_dir "/tmp"
    }
    puts $idf "P protocol_exec $proto_exec"
    puts $idf "P protocol_copyto $proto_copyto"
    puts $idf "P protocol_copyfrom $proto_copyfrom"
    puts $idf "P proxy_dir $proxy_dir"
}

# Return True (==1) if 'host' is the same machine as localhost.
#################################################################
proc is_localhost { host { user "" } { ignore_domain 1 } } {
    set refe $astk::config(-1,nom_complet)
    if { $ignore_domain == 1 } {
        set host [lindex [split $host "."] 0]
        set refe [lindex [split $refe "."] 0]
    }
    set iret 0
    if { ($host == "" || $host == "localhost" || $host == $refe) \
       && [is_localuser $user] == 1 } {
        set iret 1
    }
    return $iret
}

# Shorcut function using server id
#################################################################
proc is_localhost_serv { nsrv { ignore_domain 1 } } {
    return [is_localhost $astk::config($nsrv,nom_complet) $astk::config($nsrv,login) $ignore_domain]
}

# Return True (==1) if 'user' is local_user.
#################################################################
proc is_localuser { user } {
    set iret 0
    if { $user == "" || $user == $astk::config(-1,login) } {
        set iret 1
    }
    return $iret
}


# retourne le schema à utiliser pour une action donnée sur un
# serveur donné
#################################################################
proc get_schema { serv action } {
    set schema ""
    catch { set schema $astk::config($serv,schema_$action) }
    if { $schema == "" } {
        set schema [get_default_schema $action]
    }
    return $schema
}


# définition des schémas par défaut
#################################################################
proc get_default_schema { action } {
    switch -exact $action {
        "actu" -
        "edit" -
        "get_results" -
        "info" -
        "purge_flash" -
        "sendmail" -
        "serv" -
        "stop_del" -
        "tail" -
        "get_export" -
        "create_issue" -
        "insert_in_db" {
            return "asrun.plugins.default.$action"
        }
        default {
            ashare::mess erreur 55 $action
        }
    }
}

# retourne un nom de fichier temporaire
#################################################################
proc get_tmpname { { basename ".tmpfile"} } {
   set num [clock clicks -milliseconds]
   set fout [file join $astk::tmpdir $basename]
   append fout "_$num"
   return $fout
}

# expand environment variables
# (only a restricted list of variables are supported)
#################################################################
proc expandvars { txt } {
    global env
    set mapping {}
    foreach var { ASTER_ROOT ASTER_ETC HOME } {
        set val ""
        catch { set val $env($var) }
        if { $val != "" } {
            lappend mapping "\$$var" "$val"
        }
    }
    set txt [string map $mapping $txt]
    return $txt
}

# unexpand environment variables
# (only a restricted list of variables are supported)
#################################################################
proc unexpandvars { txt } {
    global env
    set mapping {}
    foreach var { ASTER_ROOT ASTER_ETC HOME } {
        set val ""
        catch { set val $env($var) }
        if { $val != "" } {
            lappend mapping "$val" "\$$var"
        }
    }
    set txt [string map $mapping $txt]
    return $txt
}
code-aster-gui 1.13.1-2 / usr / share / astk / remote_tools.tcl
