On Tue, 13 May 2025 22:57:05 -0400
Ed Sabol <edwardjsa...@gmail.com> wrote:
Hi Ed,
>
> Well, the standard way of doing that is you fork a child process to run the
> system command while the parent process loops and prints a period (or
> whatever you prefer) every 1 second (make sure you call flush() after
> printing!) while waiting for the child process to finish.
Indeed. As it happens, the Paris Perl Mongueurs (http://paris.mongueurs.net/)
held their monthly meeting last Wednesday night, and I requested advice from
the fine members of the club. They rapidly concluded that's what I should do.
I have a working prototype, it's modeled after
https://stackoverflow.com/questions/471681/how-do-i-fork-properly-with-mod-perl2/.
The page prints the asterisks while the fork builds the tar file, and adds the
summary with file_size, interval, etc... when it detects the file.
It probably needs some polishing, critics welcome. Excuse my French.
https://pastebin.com/wn2Cw5KF
(not sure what line 114 'warn "started\n" ;' is for, since all STDs are
redirected to /dev/null?)
>Lots of good examples of this can be found here:
>
> https://stackoverflow.com/questions/3193091/showing-progress-whilst-running-a-system-command-in-perl/
>
Thank you for this. Interesting answer with waitpid, but have not tested yet
> I also recommend that you still put an upper time limit on your subprocess
> and not just loop infinitely. 30 minutes to an hour seems like a reasonable
> choice. Depends on how big your tar files can be, of course.
Gee, just when I thought I was done with this ;-) But you're right
--
Bien à vous, Vincent Veyron
https://legalcase.libremen.com
Open source legal case, contract and insurance claims management software
package Marica::Base::Rapports::export_raw_data ;
use utf8 ;
use strict ;
use POSIX 'setsid';
use Time::HiRes qw(gettimeofday tv_interval);
use Apache2::Const -compile => qw(OK REDIRECT) ;
sub handler {
binmode(STDOUT, ":utf8") ;
my $r = shift ;
my $req = Apache2::Request->new($r) ;
#récupérer les arguments
my ( %args, @args ) ;
@args = $req->param ;
for (@args) {
$args{$_} = Encode::decode_utf8( $req->param($_) ) ;
#nix those sql injection/htmlcode attacks!
$args{$_} =~ tr/<>;/-/ ;
#les double-quotes viennent interférer avec le html
$args{$_} =~ tr/"/'/ ;
}
my $id_client = $r->pnotes('session')->{id_client} ;
my $content = '<h1 style="text-align: center;">' . _( 'Exportation des données', $r ) . '</h1>' ;
#nom du répertoire de collecte des fichiers/données/documents dans /base/listing
my $token_id = map +(0..9,"a".."z","A".."Z")[rand(10+26*2)], 1..32 ;
my $recipient_dir = $r->document_root() . '/base/listing/' . $r->pnotes('session')->{_session_id} ;
my $result_file_name = $r->pnotes('session')->{_session_id} ;
my $final_file_name = '' ;
#effacer les listings précédents de la session pour démarrer propre
#il faut le faire avant de lancer le fork, sinon le test -e détecte le fichier précédent encore présent
$ENV{'PATH'} = '/bin:/usr/bin' ;
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
my @args = ( 'rm', '-r', $r->document_root() . '/base/listing/' . $r->pnotes('session')->{_session_id} ) ;
system(@args) == 0 or warn "system @args failed: $?" ;
my @args = ( 'rm', $r->document_root() . '/base/listing/' . $r->pnotes('session')->{_session_id} . '.tar.gz' ) ;
system(@args) == 0 or warn "system @args failed: $?" ;
if ( defined $args{go_for_it} ) {
$ENV{'PATH'} = '/bin:/usr/bin' ;
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
$r->content_type('text/html; charset=utf-8') ;
$r->print('<!DOCTYPE html><html lang = "fr"><head><meta http-equiv="Content-Type" content="text/html; charset=utf-8"><title>' . $r->hostname . '</title></head><body><h3>Building tar file</h3><p>*') ;
$r->rflush ; #clear the request buffer
my $t0 = [gettimeofday];
#on sélectionne la base qui va bien
my @databases = $r->dir_config->get('db_name') ;
my $demo_user_name = $r->dir_config('demo_username') ;
my $database = ( $r->pnotes('session')->{username} =~ /$demo_user_name/ ) ? $databases[1] : $databases[0] ;
#on fait un fork pour lancer le long process
#le fork crée le .tar.gz à télécharger
$SIG{CHLD} = 'IGNORE';
defined (my $kid = fork) or die "Cannot fork: $!\n" ;
if ($kid) {
#print "Parent $$ has finished, kid's PID: $kid\n" ;
} else {
# chdir to '/' stops the process from preventing an unmount
chdir '/' or die "Can't chdir to /: $!" ;
open STDIN, '/dev/null' or die "Can't read /dev/null: $!" ;
open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!" ;
open STDERR, '>/tmp/log' or die "Can't write to /tmp/log: $!" ;
setsid or die "Can't start a new session: $!" ;
my $oldfh = select STDERR ;
local $| = 1 ;
select $oldfh ;
# warn "started\n" ;
#créer les répertoires de stockage
mkdir $recipient_dir ;
mkdir '/tmp/marica_data' ;
#dump du schéma de la base
my @args = ('pg_dump', '-s', '-f', $recipient_dir . '/marica.out', $database) ;
system(@args) == 0 or warn "system @args failed: $?" ;
#la commande d'exportation des données du client ressemble à ça:
#psql -f /home/lib/Marica/Base/Procedures/Reversibility/export_raw_data.sql -v id_client=13 -v database=marica postgres
#on crée provisoirement les fichiers data dans /tmp/marica_data
@args = ('psql', '-f', '/home/lib/Marica/Base/Procedures/Reversibility/export_raw_data.sql', '-v', 'id_client=' . $r->pnotes('session')->{id_client}, '-v', 'database=' . $database, 'postgres') ;
system(@args) == 0 or warn "system @args failed: $!" ;
#if faut les déplacer dans $recipient_dir
@args = ('mv', '/tmp/marica_data', $recipient_dir . '/data') ;
system(@args) == 0 or warn "system @args failed: $!" ;
#copier le fichier create_db.sh et remplacer =id_client par la bonne valeur
my $id_client = $r->pnotes('session')->{id_client} ;
my $script ;
open (my $fh_in, "<:encoding(UTF-8)", '/home/lib/Marica/Base/Procedures/Reversibility/create_db.sh') or die "Can't open create_db.sh : $!" ;
while ( <$fh_in> ) {
$script .= $_;
}
$script =~ s/=id_client/=$id_client/ ;
close $fh_in ;
#création du fichier pour le client
my $out_file = $recipient_dir . '/create_db.sh' ;
open (my $fh_out, ">:encoding(UTF-8)", $out_file) or warn "Can't open $out_file : $!" ;
#ajouter le BOM pour que les tableurs s'ouvrent avec le bon encodage (utf8)
#on peut aussi utiliser chr(65279);
#MS-Office a besoin de ça pour identifier l'encodage
print $fh_out chr(0xFEFF) ;
print $fh_out $script ;
close $fh_out ;
#copier le fichier import_raw_data.sql
@args = ('cp', '/home/lib/Marica/Base/Procedures/Reversibility/import_raw_data.sql', $recipient_dir) ;
system(@args) == 0 or warn "system @args failed: $!" ;
#création du fichier tar compressé
my $temp_name = $result_file_name . '.tmp' ;
@args = ( 'tar', '-czf', $r->document_root() . '/base/listing/' . $temp_name, $recipient_dir) ;
system(@args) == 0 or warn "system @args failed: $!" ;
#renommer proprement le fichier tar pour détection par la boucle do { }
$final_file_name = $result_file_name . '.tar.gz' ;
rename $r->document_root() . '/base/listing/' . $temp_name , $r->document_root() . '/base/listing/' . $final_file_name ;
CORE::exit(0); # terminate the process
} # if ($kid)
#pendant que le fork travaille, on vérifie si le fichier .tar.gz final existe
#tant qu'il n'est pas présent, on envoie un nouvel élément toutes les secondes
my $i = 1 ;
do {
my $final_result = $r->document_root() . '/base/listing/' . $result_file_name . '.tar.gz' ;
$i = 0 if -e $final_result ;
$r->print('*') ;
$r->rflush; #clear the request buffer
sleep( 1 ) ;
} while ( $i ) ;
$r->print( '</p>' ) ;
$r->rflush; #clear the request buffer
my $t1 = [gettimeofday] ;
my $t0_t1 = tv_interval $t0, $t1 ;
my $file_size = -s $r->document_root() . '/base/listing/' . $result_file_name . '.tar.gz' ;
$content = '<pre>
using db : ' . $database . '
recipient_dir : ' . $recipient_dir . '
file size : ' . $file_size . '
interval : ' . $t0_t1 . '
</pre>' ;
my $download_link = '<a href="/base/listing/' . $result_file_name . '.tar.gz">Télécharger ' . $result_file_name . '.tar.gz</a>' ;
my $download_zone = '
<h3>Lien</h3>
<p>' . $download_link . '
</p></body>' ;
$content .= $download_zone ;
$r->print( $content ) ;
return Apache2::Const::OK ;
} else {
$content .= presentation($r) ;
} # if ( defined $args{go_for_it} )
$r->content_type('text/html; charset=utf-8') ;
$r->no_cache(1) ;
print $content ;
return Apache2::Const::OK ;
}
1 ;
sub presentation {
my $r = shift ;
my $content = '<h2>Instructions</h2>' ;
$content .= '<p>Cette procédure crée un fichier contenant toutes les données stockées dans la base pour votre compte</p>' ;
$content .= '<p>Ce fichier est une archive tar contenant :</p>' ;
$content .= '
<ul>
<li>le fichier create_db.sh qui crée la base de données Postgresql pour accueillir les données (nommée "import_raw_data")</li>
<li>le fichier marica.out contenant le schema de la base de données</li>
<li>le fichier import.sql qui importe les données</li>
<li>le répertoire data qui contient les données (séparateur de données "TAB")</li>
</ul>' ;
$content .= '<h3>Utilisation</h3>
<ul>
<li>Créer le répertoire /tmp/marica</li>
<li>Extraire de l\'archive tar les 4 éléments ci-dessus, et les placer dans /tmp/marica </li>
<li>Rendre create_db.sh executable</li>
<li>Executer create_db.sh en tant que super-utilisateur</li>
</ul>' ;
my $form = '
<form action=export_raw_data method=POST>
<p><input type=submit value="Exporter les données"><input type=hidden name=go_for_it value=0></p>
</form>
' ;
$content .= $form ;
return $content ;
} #sub presentation
