Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Re: Threads and TCL DeleteInterpProc

by zentara (Archbishop)
on Jun 13, 2014 at 09:26 UTC ( #1089801=note: print w/ replies, xml ) Need Help??


in reply to Threads and TCL DeleteInterpProc

is there a way to avoid the error ?

This is just a basic piece of advice when running threads from a gui. Most GUI's are not thread safe, meaning you should not invoke any GUI code BEFORE launching your threads. This is because perl threads copy the entire parent process when they are initiated, and if GUI code is already in the main code, you get multiple ( often error causing) copies of the gui code in the different threads.

Now some GUI toolkits do offer some thread safety, like Gtk2, Gtk3, and others based on the Glib system. I don't know about your gui toolkit, but I would guess it's non-thread-safety the source of the problem.

The most reliable way to avoid the issue, is to create all your threads before any GUI code is invoked in your parent, AND do not put any GUI code into your threads.

I only have an example with Tk , but it should show you the idea. See Re: Perl Tk and Threads or you can google for "perl tk thread safety" and get alot of examples.


I'm not really a human, but I play one on earth.
Old Perl Programmer Haiku ................... flash japh


Comment on Re: Threads and TCL DeleteInterpProc
Re^2: Threads and TCL DeleteInterpProc
by Anonymous Monk on Jun 13, 2014 at 09:45 UTC
    That is probably too late for Tkx because the interpreter is a global
    BEGIN { $Tcl::STACK_TRACE = 0; $interp = Tcl->new; $interp->Init; }
Re^2: Threads and TCL DeleteInterpProc
by x-lours (Acolyte) on Jun 17, 2014 at 14:11 UTC
    thanks for the path to explore.

    i will search in this way, in french of course ;-)

    i don't know much about GUI but in my script i HAVE to alternate between asking user and launching thread if needed.

    i could try the questions and close the widgets BEFORE launching the threads but not the opposite

    i will follow the investigation ;-)

      i could try the questions and close the widgets BEFORE launching the threads but not the opposite

      The idea is to launch as many worker threads as you think you need, right at the beginning, and put them into a sleep loop until you want to wake them. Then make your gui code, and wake up and feed the pre-made threads your command to perform. Finally always program a way so that you can reuse your workers, instead of killing them off and creating new ones.

      Just for your education, you can pass strings to your threads to be eval'd, this makes it easy to reuse threads. For example, look at the simple thread code in this example. You can ask your questions at anytime after the threads are formed, and pass in code to be eval'd by the thread, thru a shared variable.

      Finally, Gtk2 does have some thread safety built-in, allowing you to make widgets as the threads are formed, but it is full of difficulty to get it right. Even in Gtk2, the advice remains the same, make your threads first, before gui code.

      #!/usr/bin/perl use warnings; use strict; use threads; use threads::shared; # works on Windows as far as my limited testing goes my $data = shift || 'date'; #sample code to pass to thread my %shash; #share(%shash); #will work only for first level keys my %hash; my %workers; my $numworkers = 3; foreach my $dthread(1..$numworkers){ share ($shash{$dthread}{'go'}); share ($shash{$dthread}{'progress'}); share ($shash{$dthread}{'timekey'}); #actual instance of the thread share ($shash{$dthread}{'frame_open'}); #open or close the frame share ($shash{$dthread}{'handle'}); share ($shash{$dthread}{'data'}); share ($shash{$dthread}{'pid'}); share ($shash{$dthread}{'die'}); $shash{$dthread}{'go'} = 0; $shash{$dthread}{'progress'} = 0; $shash{$dthread}{'timekey'} = 0; $shash{$dthread}{'frame_open'} = 0; $shash{$dthread}{'handle'} = 0; $shash{$dthread}{'data'} = $data; $shash{$dthread}{'pid'} = -1; $shash{$dthread}{'die'} = 0; $hash{$dthread}{'thread'} = threads->new(\&work,$dthread); } use Tk; use Tk::Dialog; my $mw = MainWindow->new(-background => 'gray50'); my $lframe = $mw->Frame( -background => 'gray50',-borderwidth=>10 ) ->pack(-side =>'left' ,-fill=>'y'); my $rframe = $mw->Frame( -background => 'gray50',-borderwidth=>10 ) ->pack(-side =>'right',-fill =>'both' ); my %actives = (); #hash to hold reusable numbered widgets used for d +ownloads my @ready = (); #array to hold markers indicating activity is need +ed #make 3 reusable downloader widget sets------------------------- foreach(1..$numworkers){ push @ready, $_; #frames to hold indicator $actives{$_}{'frame'} = $rframe->Frame( -background => 'gray50' ); $actives{$_}{'stopbut'} = $actives{$_}{'frame'}->Button( -text => "Stop Worker $_", -background => 'lightyellow', -command => sub { } )->pack( -side => 'left', -padx => 10 +); $actives{$_}{'label1'} = $actives{$_}{'frame'} ->Label( -width => 3, -background => 'black', -foreground => 'lightgreen', -textvariable => \$shash{$_}{'progress'}, )->pack( -side => 'left' ); $actives{$_}{'label2'} = $actives{$_}{'frame'} ->Label( -width => 1, -text => '%', -background => 'black', -foreground => 'lightgreen', )->pack( -side => 'left' ); $actives{$_}{'label3'} = $actives{$_}{'frame'} ->Label( -text => '', -background => 'black', -foreground => 'skyblue', )->pack( -side => 'left',-padx =>10 ); } #-------------------------------------------------- my $button = $lframe->Button( -text => 'Get a worker', -background => 'lightgreen', -command => sub { &get_a_worker(time) } )->pack( -side => 'top', -anchor => 'n', -fill=>'x', -pady +=> 20 ); my $text = $rframe->Scrolled("Text", -scrollbars => 'ose', -background => 'black', -foreground => 'lightskyblue', )->pack(-side =>'top', -anchor =>'n'); my $repeat; my $startbut; my $repeaton = 0; $startbut = $lframe->Button( -text => 'Start Test Count', -background => 'hotpink', -command => sub { my $count = 0; $startbut->configure( -state => 'disabled' ); $repeat = $mw->repeat( 100, sub { $count++; $text->insert( 'end', "$count\n" ); $text->see('end'); } ); $repeaton = 1; })->pack( -side => 'top', -fill=>'x', -pady => 20); my $stoptbut = $lframe->Button( -text => 'Stop Count', -command => sub { $repeat->cancel; $repeaton = 0; $startbut->configure( -state => 'normal' ); })->pack( -side => 'top',-anchor => 'n', -fill=>'x', -pady => 20 ) +; my $exitbut = $lframe->Button( -text => 'Exit', -command => sub { foreach my $dthread(keys %hash){ $shash{$dthread}{'die'} = 1; $hash{$dthread}{'thread'}->join } if ($repeaton) { $repeat->cancel } #foreach ( keys %downloads ) { # #$downloads{$_}{'repeater'}->cancel; #} # $mw->destroy; exit; })->pack( -side => 'top',-anchor => 'n', -fill=>'x', -pady => 20 + ); #dialog to get file url--------------------- my $dialog = $mw->Dialog( -background => 'lightyellow', -title => 'Get File', -buttons => [ "OK", "Cancel" ] ); my $hostl = $dialog->add( 'Label', -text => 'Enter File Url', -background => 'lightyellow' )->pack(); my $hostd = $dialog->add( 'Entry', -width => 100, -textvariable => '', -background => 'white' )->pack(); $dialog->bind( '<Any-Enter>' => sub { $hostd->Tk::focus } ); my $message = $mw->Dialog( -background => 'lightyellow', -title => 'ERROR', -buttons => [ "OK" ] ); my $messagel = $message->add( 'Label', -text => ' ', -background => 'hotpink' )->pack(); $mw->repeat(10, sub{ if(scalar @ready == $numworkers){return} foreach my $set(1..$numworkers){ $actives{$set}{'label1'}-> configure(-text =>\$shash{$set}{'progress'}); if(($shash{$set}{'go'} == 0) and ($shash{$set}{'frame_open'} == 1)) { my $timekey = $shash{$set}{'timekey'}; $workers{ $timekey }{'frame'}->packForget; $shash{$set}{'frame_open'} = 0; push @ready, $workers{$timekey}{'setnum'}; if((scalar @ready) == 3) { } $workers{$timekey} = (); delete $workers{$timekey}; } } }); $mw->MainLoop; ################################################################### sub get_a_worker { my $timekey = shift; $hostd->configure( -textvariable => \$data); if ( $dialog->Show() eq 'Cancel' ) { return } #---------------------------------------------- #get an available frameset my $setnum; if($setnum = shift @ready){print "setnum->$setnum\n"} else{ print "no setnum available\n"; return} $workers{$timekey}{'setnum'} = $setnum; $shash{$setnum}{'timekey'} = $timekey; $workers{$timekey}{'frame'} = $actives{$setnum}{'frame'}; $workers{$timekey}{'frame'}->pack(-side =>'bottom', -fill => 'both' ); $workers{$timekey}{'stopbut'} = $actives{$setnum}{'stopbut'}; $workers{$timekey}{'stopbut'}->configure( -command => sub { $workers{$timekey}{'frame'}->packForget; $shash{ $workers{$timekey}{'setnum'} }{'go'} = 0; $shash{ $workers{$timekey}{'setnum'} }{'frame_open'} = 0; push @ready, $workers{$timekey}{'setnum'}; if((scalar @ready) == $numworkers) { } $workers{$timekey} = (); delete $workers{$timekey}; }); $workers{$timekey}{'label1'} = $actives{$setnum}{'label1'}; $workers{$timekey}{'label1'}->configure( -textvariable => \$shash{$setnum}{'progress'}, ); $workers{$timekey}{'label2'} = $actives{$setnum}{'label2'}; $workers{$timekey}{'label3'} = $actives{$setnum}{'label3'}; $workers{$timekey}{'label3'}->configure(-text => $timekey); $shash{$setnum}{'go'} = 1; $shash{$setnum}{'frame_open'} = 1; #--------end of get_file sub-------------------------- } ################################################################## sub work{ my $dthread = shift; $|++; while(1){ if($shash{$dthread}{'die'} == 1){ goto END }; if ( $shash{$dthread}{'go'} == 1 ){ eval( system( $shash{$dthread}{'data'} ) ); foreach my $num (1..100){ $shash{$dthread}{'progress'} = $num; print "\t" x $dthread,"$dthread->$num\n"; select(undef,undef,undef, .5); if($shash{$dthread}{'go'} == 0){last} if($shash{$dthread}{'die'} == 1){ goto END }; } $shash{$dthread}{'go'} = 0; #turn off self before returning }else { sleep 1 } } END: } #####################################################################

      I'm not really a human, but I play one on earth.
      Old Perl Programmer Haiku ................... flash japh
        thanks. it takes me much time to understand all.

        finally, i try to use sub my_question { use Tk; my($titre, $msg) = @_; Tkx::tk___... } inside my script and it doesn't work either.

        3 sub

        one for directory, one for information and one for asking the user.

        i will try your proposal soon. ;-)
        a enormous thanks to you master.

        it works as i need.

        now i just have to close the point ... for memory i leave here my new code :
        #!/usr/bin/perl ###################################################################### +######### # Auteur : X H, # But : voir le perldoc ... # ATTENTION : ne pas oublier de rajouter perl devant le nom du script +pour que les paramètres soient pris en compte ###################################################################### +######### use warnings; use strict; use Data::Dumper; use Encode; # pour les problèmes d'accent use threads; use Thread::Semaphore; use threads::shared; my @recup = qw/ARMEN1 ARMEN2 INITSE MOA NINIV RESEAU SIRH CSV XML BAD/ +; my %s_hash; my %hash; # les variables génériques, pour horodater le fichier : my ($jour, $mois, $annee) = (localtime(time() - (60 * 60 * 24)))[3, 4, + 5]; my $date_veille = sprintf("%d%02d%02d",(1900+$annee), (++$mois), $jour +); my ($day, $mon, $year, $hour, $min, $sec) = (localtime)[3, 4, 5, 2, 1, + 0]; my $date_fic = sprintf("%d%02d%02d",(1900+$year), (++$mon), $day); my $date_mois = sprintf("%d%02d",(1900+$year), $mon); my $semaphore = Thread::Semaphore->new(5); # Crée un sémaphore avec le + compteur initialisé à cinq # partage des variables, creation des threads, initialisation des vari +ables for (@recup){ share ($s_hash{$_}{'go'}); share (@{$s_hash{$_}{'fic'}}); share ($s_hash{$_}{'source'}); share ($s_hash{$_}{'rep'}); share ($s_hash{$_}{'die'}); $s_hash{$_}{'go'} = 0; $s_hash{$_}{'die'} = 0; $hash{$_}{'thread'} = threads->new(\&recup_fic,$_); } # suite de l'initialisation des variables # le motif des fichiers à récupérer # l'appel de la variable doit être le même que lors du partage (share) + sinon aucune valeur ne sera transmise au threads. @{$s_hash{ARMEN1}{'fic'}} = ('SPO_*_T.tar.gz'); @{$s_hash{ARMEN2}{'fic'}} = ('SPO_*_T.tar.gz'); @{$s_hash{INITSE}{'fic'}} = ('SPOT_MAXIMO_*_T.tar.gz'); @{$s_hash{MOA}{'fic'}} = ('MOA1_*.zip'); @{$s_hash{NINIV}{'fic'}} = ('RMDOGNPM_*.zip'); @{$s_hash{RESEAU}{'fic'}} = ('RMDOGCSEG_*.zip'); @{$s_hash{SIRH}{'fic'}} = ('SPO.GES.N.*.ZIP', 'SPO.REF.N.*.ZIP'); @{$s_hash{CSV}{'fic'}} = ('T_*.csv', 'TP_*.csv' ); @{$s_hash{XML}{'fic'}} = ("\*$date_fic\*\.xml"); @{$s_hash{BAD}{'fic'}} = ('*.bad', 'sqlload_agents.log', 'sqlload_seg_gestion.log', 'sqlload_seg_gestion_saf.log', 'sqlload_t_cat_ressource.log', 'sqlload_t_instal.log', 'sqlload_t_loc_instal.log', 'sqlload_t_loc_sur_instal.log', 'sqlload_t_carac.log', 'sqlload_t_carac_instal.log', 'sqlload_t_ct_ligne.log', 'sqlload_t_ct_saf.log', 'sqlload_t_ct_voie.log', 'sqlload_t_dec_lig.log', 'sqlload_t_dec_voie.log', 'sqlload_t_liste_val.log', 'sqlload_t_loc_saf.log', 'sqlload_t_rat_typ_instal.log', 'sqlload_t_saf.log', 'sqlload_t_spe_typ_instal.log', 'sqlload_t_structure.log', 'sqlload_t_trl.log', 'sqlload_t_trv.log', 'sqlload_t_typ_dec.log', 'sqlload_t_typ_instal.log', 'sqlload_t_typ_loc_autorise.log', 'sqlload_t_typ_saf.log', 'sqlload_t_type_ressource.log', 'sqlload_t_val.log', 'sqlload_t_val_bis.log', 'sqlload_t_val_typ_dec.log', 'sqlload_tp_article_a_exclure.log', 'sqlload_tp_liste_val_admis.log', 'sqlload_tp_structures_deployees.log', 'sqlload_uch.log', 'sqlload_uop.log'); # les répertoires distants où trouver les fichiers $s_hash{ARMEN1}{'source'} = '/transfert/reception'; $s_hash{ARMEN2}{'source'} = "/transfert/reception/DIFARMEN_$date_fic"; $s_hash{INITSE}{'source'} = '/transfert/reception'; # $s_hash{INITSE2}{'source'} = "/transfert/reception/INITSE_$date_fic" +; $s_hash{MOA}{'source'} = '/transfert/reception'; # $s_hash{MOA2}{'source'} = "/transfert/reception/MOA1_$date_fic"; $s_hash{NINIV}{'source'} = '/transfert/reception'; # $s_hash{NINIV2}{'source'} = "/transfert/reception/NINIV_$date_fic"; $s_hash{RESEAU}{'source'} = '/transfert/reception'; # $s_hash{RESEAU2}{'source'} = "/transfert/reception/RESEAU_$date_fic" +; $s_hash{SIRH}{'source'} = '/transfert/reception'; # $s_hash{SIRH2}{'source'} = "/transfert/reception/SIRH_$date_fic"; $s_hash{CSV}{'source'} = '/transfert/reception'; $s_hash{XML}{'source'} = '/transfert/emission'; $s_hash{BAD}{'source'} = '/traces/spotimp/loader'; # pour l'affichage dans la fenêtre $s_hash{ARMEN1}{'data'} = 'non'; $s_hash{ARMEN2}{'data'} = 'non'; $s_hash{INITSE}{'data'} = 'non'; $s_hash{MOA}{'data'} = 'non'; $s_hash{NINIV}{'data'} = 'non'; $s_hash{RESEAU}{'data'} = 'non'; $s_hash{SIRH}{'data'} = 'non'; $s_hash{CSV}{'data'} = 'non'; $s_hash{XML}{'data'} = 'non'; $s_hash{BAD}{'data'} = 'non'; # passage au GUI pour réaliser les traitements. use Tkx; # sélection du répertoire de version pour stockage des fichiers my $rep_fichiers = Tkx::tk___chooseDirectory(-initialdir => '~', -titl +e => decode( "utf-8", "Sélection du répertoire de la version SPOT IF. +"), -mustexist => 1); unless ($rep_fichiers){ for (@recup){ $s_hash{$_}{'die'} = 1; $hash{$_}{'thread'}->join; } exit 9; } $rep_fichiers = encode( "iso-8859-1",$rep_fichiers); my $rep_jour = encode( "iso-8859-1","$rep_fichiers/$date_fic"); if (-d $rep_jour) { $rep_jour = Tkx::tk___chooseDirectory(-initialdir => '~', -title = +> decode( "utf-8", "Sélection du répertoire ou déposer les fichiers P +ROD du jour.")); } else { # print LOG "Creation du repertoire $rep_jour.\n"; mkdir $rep_jour or die "Probleme creation repertoire $rep_jour E/S +: $!\n"; my $rep_tmp = "$rep_jour/CSV"; mkdir $rep_tmp or die "Probleme creation repertoire $rep_tmp E/S: +$!\n"; $rep_tmp = encode( "iso-8859-1","$rep_fichiers/$date_fic/".decode( +"utf8", "XML Générés")); # $rep_tmp = "$rep_jour/XML Générés"; mkdir $rep_tmp or die "Probleme creation repertoire $rep_tmp E/S: +$!\n"; $rep_tmp = encode( "iso-8859-1","$rep_fichiers/$date_fic/".decode( +"utf8", "Logs Préparateur")); # $rep_tmp = "$rep_jour/Logs Préparateur"; mkdir $rep_tmp or die "Probleme creation repertoire $rep_tmp E/S: +$!\n"; } # maintenant que le répertoire du jour est choisi, fin de l'initialisa +tion des varaibles # les répertoires locaux (ou sur le réseau) où déposer les fichiers $s_hash{ARMEN1}{'rep'} = $rep_jour; $s_hash{ARMEN2}{'rep'} = $rep_jour; $s_hash{INITSE}{'rep'} = $rep_jour; $s_hash{MOA}{'rep'} = $rep_jour; $s_hash{NINIV}{'rep'} = $rep_jour; $s_hash{RESEAU}{'rep'} = $rep_jour; $s_hash{SIRH}{'rep'} = $rep_jour; $s_hash{CSV}{'rep'} = "$rep_jour/CSV"; $s_hash{XML}{'rep'} = encode( "iso-8859-1","$rep_fichiers/$date_fic/". +decode("utf8", "XML Générés")); $s_hash{BAD}{'rep'} = encode( "iso-8859-1","$rep_fichiers/$date_fic/". +decode("utf8", "Logs Préparateur")); # la fenêtre où tout se passe my $fenetre = Tkx::widget->new("."); $fenetre->g_wm_title("Recup quotidien"); $fenetre->g_wm_minsize(300, 200); # le label pour le répertoire choisi my $repert = $fenetre->new_ttk__label(-textvariable => \$rep_fichiers, + ); # le bouton pour ARMEN my $armen1 = $fenetre->new_button( -text => decode("utf8","Le fichier +ARMEN SPO_$date_veille*_T.tar.gz est il présent dans le répertoire di +stant ?"), -command => [\&fct_click, 'ARMEN1'], ); my $lib_armen1 = $fenetre->new_ttk__label(-textvariable => \$s_hash{'A +RMEN1'}{'data'}, ); my $armen2 = $fenetre->new_button( -text => decode("utf8","Le fichier +ARMEN SPO_$date_veille*_T.tar.gz est il archivé dans le répertoire di +stant ?"), -command => [\&fct_click, 'ARMEN2'], ); my $lib_armen2 = $fenetre->new_ttk__label(-textvariable => \$s_hash{'A +RMEN2'}{'data'}, ); # le bouton pour INITSE my $initse = $fenetre->new_button( -state => 'disabled', -text => decode("utf8",'Récupératio +n des fichiers INITSE ?'), -command => [\&fct_click, 'INITSE'] +, ); my $lib_initse = $fenetre->new_ttk__label(-textvariable => \$s_hash{'I +NITSE'}{'data'}, ); # le bouton pour MOA my $moa = $fenetre->new_button( -state => 'disabled', -text => decode("utf8",'Récupération d +es fichiers MOA ?'), -command => [\&fct_click, 'MOA'], ); my $lib_moa = $fenetre->new_ttk__label(-textvariable => \$s_hash{'MOA' +}{'data'}, ); # le bouton pour NINIV my $niniv = $fenetre->new_button( -state => 'disabled', -text => decode("utf8",'Récupération + des fichiers NINIV ?'), -command => [\&fct_click, 'NINIV'], ); my $lib_niniv = $fenetre->new_ttk__label(-textvariable => \$s_hash{'NI +NIV'}{'data'}, ); # le bouton pour RESEAU my $reseau = $fenetre->new_button( -state => 'disabled', -text => decode("utf8",'Récupératio +n des fichiers RESEAU ?'), -command => [\&fct_click, 'RESEAU'] +, ); my $lib_reseau = $fenetre->new_ttk__label(-textvariable => \$s_hash{'R +ESEAU'}{'data'}, ); # le bouton pour SIRH my $sirh = $fenetre->new_button( -state => 'disabled', -text => decode("utf8",'Récupération +des fichiers SIRH ?'), -command => [\&fct_click, 'SIRH'], ); my $lib_sirh = $fenetre->new_ttk__label(-textvariable => \$s_hash{'SIR +H'}{'data'}, ); # le bouton pour CSV my $csv = $fenetre->new_button( -state => 'disabled', -text => decode( "utf-8","Les fichie +rs T_*.csv, TP_*.csv\nsont ils présents dans le répertoire distant ?" +), -command => [\&fct_click, 'CSV'], ); # le bouton pour XML my $xml = $fenetre->new_button( -state => 'disabled', -text => decode( "utf-8","Les fichie +rs *.xml sont ils présents dans le répertoire distant ?"), -command => [\&fct_click, 'XML'], ); # le bouton pour Bad, Log my $reste = $fenetre->new_button( -state => 'disabled', -text => decode( "utf-8","Les fichie +rs *.bad, *.log\nsont ils présents dans le répertoire distant ?"), -command => [\&fct_click, 'BAD'], ); # répartition des boutons dans la fenêtre $repert->g_grid(-row => 0, -column => 0, -columnspan => 2, -padx => 5 +, -pady => 5,); $armen1->g_grid(-row => 1, -column => 0, -padx => 5, -pady => 5,); $armen2->g_grid(-row => 2, -column => 0, -padx => 5, -pady => 5,); $initse->g_grid(-row => 3, -column => 0, -padx => 5, -pady => 5,); $moa->g_grid ( -row => 4, -column => 0, -padx => 5, -pady => 5,); $niniv->g_grid( -row => 5, -column => 0, -padx => 5, -pady => 5,); $reseau->g_grid(-row => 6, -column => 0, -padx => 5, -pady => 5,); $sirh->g_grid ( -row => 7, -column => 0, -padx => 5, -pady => 5,); $csv->g_grid( -row => 8, -column => 0, -padx => 5, -pady => 5,); $xml->g_grid( -row => 9, -column => 0, -padx => 5, -pady => 5,); $reste->g_grid( -row => 10, -column => 0, -padx => 5, -pady => 5,); $lib_armen1->g_grid(-row => 1, -column => 1, -padx => 5, -pady => 5,); $lib_armen2->g_grid(-row => 2, -column => 1, -padx => 5, -pady => 5,); $lib_initse->g_grid(-row => 3, -column => 1, -padx => 5, -pady => 5,); $lib_moa->g_grid ( -row => 4, -column => 1, -padx => 5, -pady => 5,); $lib_niniv->g_grid( -row => 5, -column => 1, -padx => 5, -pady => 5,); $lib_reseau->g_grid(-row => 6, -column => 1, -padx => 5, -pady => 5,); $lib_sirh->g_grid ( -row => 7, -column => 1, -padx => 5, -pady => 5,); # Affichage d'un bouton pour fermer la fenêtre my $bouton = $fenetre->new_button( -text => 'Fermer la fenetre', -command => sub { for (@recup){ $s_hash{$_}{'die'} = 1; $hash{$_}{'thread'}->join; } # $fenetre->g_destroy; # plante la fermeture du script ... exit; }, ); $bouton->g_grid(-row => 11, -column => 1, -padx => 5, -pady => 5,); Tkx::MainLoop; # Obligatoire print "Fin du traitement.\n"; =head1 NAME IF_recup_quotidien.pl =head1 SYNOPSIS Interactive mode: perl IF_recup_quotidien.pl =head1 DESCRIPTION Il s'agit d'automatiser la création des répertoire et la récupération +quotidienne des fichiers de PROD pour SPOT IF. =head1 ALGORITHME création des variables partagees pour les threads. création des threads. création de la fenêtre. création des boutons (à l'état inactif) pour les récupérations possibl +es. choix du répertoire de version de SPOT IF. création du répertoire <Date du jour> et des répertoires CSV, XML, Log +s préparateurs dans ce répertoire créé. affichage de répertoire (Label). passage successif, à l'état actif, de chacun des boutons, puis à nouve +au inactif. les boutons permettent, par les threads crees precedemment, si besoin, + récupération des fichiers DIFARMEN, INITSE, MOA1, NINIV, RESEAU, SIRH +d'extension .Tar.GZ ou .Zip dans le répertoire <Date du jour>. récupération des fichiers CSV dans le répertoire du même nom. récupération des fichiers XML dans le répertoire du même nom. récupération des fichiers BAD dans le répertoire des Logs. récupération des fichiers LOG dans le répertoire du même nom. =head1 AUTEUR Xavier HERVIEU, beginner in Perl. =cut sub recup_fic{ # récupération du paramètre my $dthread = shift; while(1){ # print "boucle $dthread "; if($s_hash{$dthread}{'die'} == 1){ goto END }; if ( $s_hash{$dthread}{'go'} == 1 ){ # my $lst_fic = $s_hash{$dthread}{'fic'}; # print Dumper($lst_fic); # print ":$dthread\n"; for my $truc (@{$s_hash{$dthread}{'fic'}}) { $semaphore->down; # eval( system( 'date' ) ); print "fichier '$truc' dans '$s_hash{$dthread}{source} +' vers '$s_hash{$dthread}{rep}'.\n"; # transfert via pscp de PUTTY du ou des fichiers `C:/MCOBOX/pscp -sftp -pw <pwd> <login>\@<ip_adress>:$ +s_hash{$dthread}{source}/$truc "$s_hash{$dthread}{rep}/"` ; $semaphore->up; } $s_hash{$dthread}{'go'} = 0; #turn off self before returni +ng } else { sleep 1; } } END: print "fin du Thread $dthread.\n"; } sub fct_click { my $param = shift; my $etat; my $etat1 = 'disabled'; my $etat2 = 'disabled'; if($param eq 'CSV') { $etat = 'disabled'; $etat1 = 'normal'; } elsif($param eq 'XML') { $etat = 'disabled'; $etat2 = 'normal'; } elsif($param eq 'BAD') { $etat = 'disabled'; } else { $etat = 'normal'; } $s_hash{$param}{'data'} = 'OUI'; $s_hash{$param}{'go'} = 1; $armen1->m_configure(-state => 'disabled'); $armen2->m_configure(-state => 'disabled'); $initse->m_configure(-state => ($s_hash{INITSE}{'data'} eq 'OUI')? +'disabled':$etat); $moa->m_configure(-state => ($s_hash{MOA}{'data'} eq 'OUI')?'disab +led':$etat); $niniv->m_configure(-state => ($s_hash{NINIV}{'data'} eq 'OUI')?'d +isabled':$etat); $reseau->m_configure(-state => ($s_hash{RESEAU}{'data'} eq 'OUI')? +'disabled':$etat); $sirh->m_configure(-state => ($s_hash{SIRH}{'data'} eq 'OUI')?'dis +abled':$etat); $csv->m_configure(-state => ($s_hash{CSV}{'data'} eq 'OUI')?'disab +led':$etat); $xml->m_configure(-state => ($s_hash{XML}{'data'} eq 'OUI')?'disab +led':$etat1); $reste->m_configure(-state => ($s_hash{BAD}{'data'} eq 'OUI')?'dis +abled':$etat2); }
        and now i have to understand repeat and packForget ;-)

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1089801]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (8)
As of 2014-09-16 21:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (50 votes), past polls