# automates registration of multiple patients under fastcgi process # assumes fastcgi server running # if using lims_test db: # at least 1 test script has previously run (to populate db tables), # patients table contains 'green' # if using prod db: # no requirements ########################################################################################################### # need to temp. set $ENV{ROSEDB_DEVINIT} to required db in fcgi script # also need temp. override in M::User::verify_credentials() to return $user->username without passwd matching # coz browser login into lims_test db doesn't work anymore ########################################################################################################### use strict; use warnings; BEGIN { use FindBin qw($Bin); # warn 'BIN:'.$Bin; # set lib paths for app: use lib ( '/home/raj/perl5/lib/perl5', "$Bin/../lib", "$Bin/..", ); # this won't work - clobbered by 'while' loop in fastcgi script: # $ENV{ROSEDB_DEVINIT} = "$Bin/../config/rosedb_devinit_test.pl"; } use WWW::Mechanize; use DBIx::Simple; use Data::Dumper; use DateTime; my $mech = WWW::Mechanize->new(); # url that points to fastcgi process: my $home_url = 'http://localhost/hmds'; open my $fh, '>' . './mech.txt' or die $!; use vars qw($random_number); require LIMS::DB; my $db = LIMS::DB->new_or_cached; my $dbh = $db->retain_dbh or die LIMS::DB->error; # use Data::Dumper; warn Dumper $db->dsn; my $dbix = DBIx::Simple->new($dbh); # max request number this yr: my $max_req_no = $dbix->query( "select max(request_number) from requests where year = ?", DateTime->now->year)->list; # specimens list: my $specimens = $dbix->query( 'select sample_code from specimens')->flat; # get 100 random surnames, 5 letters beginning with 'c' & no spaces, from hilis4.patients table: my $surnames = $dbix->query( "select distinct(last_name) from hilis4.patients where last_name like 'c____' limit 100")->flat; #my $last_name = 'green'; # if using lims_test # warn $max_req_no; exit; # warn Dumper $surnames; exit; # warn Dumper $specimens; exit; do_login(); # print $mech->content; exit; do_registration($_) for (1..100); sub do_registration { warn shift; my $surname = $surnames->[$random_number]; # warn $surname; return; $random_number = int rand(@$surnames); # warn $random_number; return; $mech->get($home_url . '/register'); # print $fh $mech->content; $mech->submit_form( fields => { name => $surname } ); # print $fh $mech->content; exit; #sleep(1); # select 1st one: $mech->follow_link( url_regex => qr/(?i:select_patient)/ ); # print $fh $mech->content; exit; #sleep(1); # select 1st one: $mech->follow_link( url_regex => qr/(?i:add_new)/ ); # print $fh $mech->content; exit; #sleep(1); $random_number = int rand(@$specimens); my %fields = ( request_number => ++$max_req_no, referrer_code => 'C9999998', # unknown specimen => $specimens->[$random_number], ); $mech->submit_form( fields => \%fields ); # print $fh $mech->content; exit; sleep(1); } sub do_login { my $userid = 'unknown.user'; my $passwd = 'not-required'; # doesn't work on lims_test anymore $mech->get($home_url); # warn $mech->content; exit; # login: $mech->submit_form( form_name => 'login_form', fields => { authen_username => $userid, authen_password => $passwd, }, ); # warn $mech->content; }