| 36 |
|
sub init { |
| 37 |
|
my $self=shift; |
| 38 |
|
$self->{switch}=ActiveDoc::SimpleDoc->new(); |
| 39 |
+ |
$self->{switch}->newparse("setupinit"); |
| 40 |
+ |
$self->{switch}->addtag("setupinit","Tool",\&Tool_Start, $self, |
| 41 |
+ |
"", $self, |
| 42 |
+ |
\&Tool_End, $self); |
| 43 |
+ |
$self->{switch}->addtag("setupinit", "Architecture", |
| 44 |
+ |
\&Arch_Start,$self, |
| 45 |
+ |
"", $self, |
| 46 |
+ |
\&Arch_End,$self); |
| 47 |
+ |
$self->{switch}->addtag("setupinit","Environment", |
| 48 |
+ |
\&Environment_init, $self, |
| 49 |
+ |
"", $self, |
| 50 |
+ |
"", $self); |
| 51 |
|
$self->{switch}->newparse("setup"); |
| 52 |
|
$self->{switch}->addtag("setup","Tool",\&Tool_Start, $self, |
| 53 |
|
"", $self, |
| 122 |
|
$self->error("Unable to Parse Document of type $doctype $docversion". |
| 123 |
|
"\n(Only ".$self->{mydoctype}." ". $self->{mydocversion}.")"); |
| 124 |
|
} |
| 125 |
+ |
delete $self->{envcount}; |
| 126 |
+ |
$self->{switch}->parse("setupinit"); |
| 127 |
|
$self->{switch}->parse("setup"); |
| 128 |
|
return $self->{toolfound}; |
| 129 |
|
} |
| 159 |
|
my $self=shift; |
| 160 |
|
my $default=shift; |
| 161 |
|
my $testfiles=shift; |
| 162 |
+ |
|
| 163 |
|
my $OK='false'; |
| 164 |
|
my $file; |
| 165 |
|
|
| 166 |
|
chomp $default; |
| 167 |
|
$default=$self->_expandvars($default); |
| 168 |
+ |
$self->verbose("Testing location"); |
| 169 |
|
print "Trying $default .... "; |
| 170 |
|
if ( -f $default ) { |
| 171 |
|
$OK="true"; |
| 172 |
+ |
$self->verbose("File OK"); |
| 173 |
|
} |
| 174 |
|
else { |
| 175 |
< |
my $fh=FileHandle->new(); |
| 176 |
< |
opendir $fh, $default or do { print "No \n"; return 0; }; |
| 175 |
> |
my $dh=DirHandle->new(); |
| 176 |
> |
opendir $dh, $default or do { print "No $!\n"; return 0; }; |
| 177 |
|
($#{$testfiles}==-1) ? $OK='false' : $OK='true'; |
| 178 |
|
print "\n"; |
| 179 |
< |
my @files=readdir $fh; |
| 180 |
< |
undef $fh; |
| 179 |
> |
my @files=readdir $dh; |
| 180 |
> |
undef $dh; |
| 181 |
|
foreach $file ( @$testfiles ) { |
| 182 |
|
print " Checking for $file .... "; |
| 183 |
|
# now check that the required files are actually there |
| 222 |
|
return $string; |
| 223 |
|
} |
| 224 |
|
|
| 225 |
+ |
sub _askusermenu { |
| 226 |
+ |
my $self=shift; |
| 227 |
+ |
my $querystring=shift; |
| 228 |
+ |
my @items=@_; |
| 229 |
+ |
|
| 230 |
+ |
my $path=-1; |
| 231 |
+ |
my $n; |
| 232 |
+ |
while ( ($path!~/^\d+$/) || ($path > ($#items+1)) || ($path < 1) ) { |
| 233 |
+ |
for (my $i=0; $i<=$#items; $i++ ) { |
| 234 |
+ |
$n=$i+1; |
| 235 |
+ |
print $n.") ".$items[$i]."\n"; |
| 236 |
+ |
} |
| 237 |
+ |
print "\n".$querystring; |
| 238 |
+ |
$path=<STDIN>; |
| 239 |
+ |
chomp $path; |
| 240 |
+ |
} |
| 241 |
+ |
$path--; |
| 242 |
+ |
return $path; |
| 243 |
+ |
} |
| 244 |
|
|
| 245 |
|
sub _askuser { |
| 246 |
|
my $self=shift; |
| 247 |
|
my $querystring=shift; |
| 248 |
|
my $varname=shift; |
| 249 |
|
|
| 250 |
+ |
my $type=$self->{tool}->type($varname); |
| 251 |
+ |
my $path; |
| 252 |
+ |
my $oldpath; |
| 253 |
|
print $self->featuretext($self->{EnvContext}); |
| 254 |
|
for ( ;; ) { |
| 255 |
|
print "\n".$querystring." (RETURN to log as missing)\nset $varname = "; |
| 256 |
|
$path=<STDIN>; |
| 257 |
|
chomp $path; |
| 258 |
+ |
$oldpath=$path; |
| 259 |
|
if ( $path ne "" ) { |
| 260 |
< |
if ( defined $self->{'client'}) { # must be a location |
| 261 |
< |
if ( $self->_testlocation($path , "H", $Envtype{$type} )) { |
| 262 |
< |
return $path; |
| 263 |
< |
} |
| 264 |
< |
print "Error : ".$path." does not exist.\n"; |
| 225 |
< |
next; |
| 226 |
< |
} |
| 227 |
< |
} |
| 228 |
< |
else { |
| 229 |
< |
return $path; |
| 260 |
> |
($path)=$self->_validateparam($type,$path); |
| 261 |
> |
if ( ! defined $path ) { |
| 262 |
> |
print "Error : ".$oldpath." is not valid.\n"; |
| 263 |
> |
next; |
| 264 |
> |
} |
| 265 |
|
} |
| 266 |
+ |
return $path; |
| 267 |
|
} #end for |
| 268 |
|
|
| 269 |
|
} |
| 270 |
|
|
| 271 |
+ |
sub _validateparam { |
| 272 |
+ |
my $self=shift; |
| 273 |
+ |
my $type=shift; |
| 274 |
+ |
my @params=@_; |
| 275 |
+ |
|
| 276 |
+ |
my @newparams=(); |
| 277 |
+ |
foreach $param ( @params ) { |
| 278 |
+ |
if ( defined $self->{'client'}) { # must be a location |
| 279 |
+ |
if ( $self->_testlocation($param , |
| 280 |
+ |
[ $self->{tool}->getfeature($type)] )) { |
| 281 |
+ |
$self->verbose("$param passed validation"); |
| 282 |
+ |
push @newparams,$param; |
| 283 |
+ |
} |
| 284 |
+ |
else { |
| 285 |
+ |
$self->verbose("$param failed validation"); |
| 286 |
+ |
} |
| 287 |
+ |
} |
| 288 |
+ |
else { |
| 289 |
+ |
# --- no other tests to pass so it must be OK |
| 290 |
+ |
push @newparams,$param; |
| 291 |
+ |
} |
| 292 |
+ |
} |
| 293 |
+ |
return @newparams; |
| 294 |
+ |
} |
| 295 |
+ |
|
| 296 |
|
# |
| 297 |
|
# Propgate through the searcher collecting matching tools |
| 298 |
|
# |
| 299 |
|
sub _searchtools { |
| 300 |
|
my $self=shift; |
| 301 |
|
my $tool=shift; |
| 302 |
+ |
my $searcher=shift; |
| 303 |
|
|
| 304 |
|
my @tools=(); |
| 305 |
|
my $area; |
| 306 |
|
my $rtool; |
| 307 |
< |
if ( defined $self->{toolboxsearcher} ) { |
| 308 |
< |
my $it=$self->{toolboxsearcher}->newiterator(); |
| 309 |
< |
while ( ! $it->last() ) { |
| 307 |
> |
my $it=$searcher->newiterator(); |
| 308 |
> |
|
| 309 |
> |
while ( ! $it->last() ) { |
| 310 |
|
$area=$it->next(); |
| 311 |
|
if ( defined $area ) { |
| 312 |
|
$self->verbose("Searching for ".$tool->name()." ". |
| 313 |
|
$tool->version()." in ".$area->location()); |
| 314 |
|
$rtool=$area->toolbox()->gettool($tool->name(),$tool->version()); |
| 315 |
< |
if ( (defined $rtool) && $rtool->equals($tool) ) { |
| 315 |
> |
if ( defined $rtool ) { |
| 316 |
> |
if ( $rtool->equals($tool) ) { |
| 317 |
> |
$self->verbose("Found matching tool"); |
| 318 |
|
push @tools,$rtool; |
| 319 |
+ |
} |
| 320 |
+ |
else { |
| 321 |
+ |
$self->verbose("Rejected tool ".$rtool->name()." " |
| 322 |
+ |
.$rtool->version()); |
| 323 |
+ |
} |
| 324 |
|
} |
| 325 |
+ |
else { |
| 326 |
+ |
$self->verbose("Tool Passed as Undefined"); |
| 327 |
+ |
} |
| 328 |
|
} |
| 329 |
< |
} |
| 329 |
> |
else { |
| 330 |
> |
$self->verbose("Area passed is not defined"); |
| 331 |
> |
} |
| 332 |
|
} |
| 333 |
|
return @tools; |
| 334 |
|
} |
| 343 |
|
my $rv=0; |
| 344 |
|
my @params=(); |
| 345 |
|
$self->verbose("Check Other Projects for tool"); |
| 346 |
< |
my @validtools=$self->_searchtools($tool); |
| 347 |
< |
if ( ! $self->interactive() ) { |
| 348 |
< |
if ( $#validtools >=0 ) { |
| 346 |
> |
my @validtools=(); |
| 347 |
> |
if ( defined $self->{toolboxsearcher} ) { |
| 348 |
> |
@validtools=$self->_searchtools($tool,$self->{toolboxsearcher}); |
| 349 |
> |
} |
| 350 |
> |
if ( $#validtools >=0 ) { |
| 351 |
> |
if ( ! $self->interactive() ) { |
| 352 |
|
@params=$validtools[0]->getfeature($param); |
| 353 |
|
if ( $#params >=0 ) { |
| 354 |
|
$self->verbose("Extracting Feature $param from tool". |
| 355 |
|
" (= @params )\n"); |
| 279 |
– |
#$tool->setfeature($param,@params); |
| 356 |
|
$rv=1; |
| 357 |
|
} |
| 358 |
|
} |
| 360 |
|
return ($rv,@params); |
| 361 |
|
} |
| 362 |
|
|
| 363 |
+ |
sub _getparamsets { |
| 364 |
+ |
my $self=shift; |
| 365 |
+ |
my $tool=shift; |
| 366 |
+ |
my $param=shift; |
| 367 |
+ |
|
| 368 |
+ |
my @paramlist=(); |
| 369 |
+ |
my @params=(); |
| 370 |
+ |
$self->verbose("Searching for parameter settings in other tools"); |
| 371 |
+ |
my @validtools=(); |
| 372 |
+ |
if ( defined $self->{toolboxsearcher} ) { |
| 373 |
+ |
@validtools=$self->_searchtools($tool,$self->{toolboxsearcher}); |
| 374 |
+ |
} |
| 375 |
+ |
else { |
| 376 |
+ |
$self->verbose("No tool searcher available"); |
| 377 |
+ |
} |
| 378 |
+ |
if ( $#validtools >=0 ) { |
| 379 |
+ |
foreach $t ( @validtools ) { |
| 380 |
+ |
@params=$t->getfeature($param); |
| 381 |
+ |
if ( $#params >=0 ) { |
| 382 |
+ |
push @paramlist, [ @params ]; |
| 383 |
+ |
$self->verbose("Found @params"); |
| 384 |
+ |
} |
| 385 |
+ |
} |
| 386 |
+ |
} |
| 387 |
+ |
return @paramlist; |
| 388 |
+ |
} |
| 389 |
+ |
|
| 390 |
|
# -- Tag Routines |
| 391 |
|
|
| 392 |
|
sub Client_start { |
| 440 |
|
$self->{switch}->closegroup("Toolactive"); |
| 441 |
|
} |
| 442 |
|
|
| 443 |
+ |
# -- collect number of variables of the same name - need to know how many |
| 444 |
+ |
# before main setup processing |
| 445 |
+ |
sub Environment_init { |
| 446 |
+ |
my $self=shift; |
| 447 |
+ |
my $name=shift; |
| 448 |
+ |
my $hashref=shift; |
| 449 |
+ |
|
| 450 |
+ |
$self->{switch}->checktag($name, $hashref, 'name'); |
| 451 |
+ |
if ( $self->{Arch} ) { |
| 452 |
+ |
if ( exists $self->{envcount}{$$hashref{'name'}} ) { |
| 453 |
+ |
$self->{envcount}{$$hashref{'name'}}++; |
| 454 |
+ |
} |
| 455 |
+ |
else { |
| 456 |
+ |
$self->{envcount}{$$hashref{'name'}}=0; |
| 457 |
+ |
} |
| 458 |
+ |
} |
| 459 |
+ |
} |
| 460 |
+ |
|
| 461 |
|
sub Environment_Start { |
| 462 |
|
my $self=shift; |
| 463 |
|
my $name=shift; |
| 465 |
|
|
| 466 |
|
$self->{switch}->checktag($name, $hashref, 'name'); |
| 467 |
|
if ( $self->{Arch} ) { |
| 468 |
+ |
my $val=undef; |
| 469 |
|
if ( defined $self->{EnvContext} ) { |
| 470 |
|
$self->parserror(" Attempted to open new <$name> context". |
| 471 |
|
" without closing the previous one"); |
| 472 |
|
} |
| 473 |
+ |
# -- keep a counter of the number of times we see this variable |
| 474 |
+ |
if ( exists $self->{EnvironmentCount}{$$hashref{'name'}} ) { |
| 475 |
+ |
$self->{EnvironmentCount}{$$hashref{'name'}}++; |
| 476 |
+ |
} |
| 477 |
+ |
else { |
| 478 |
+ |
$self->{EnvironmentCount}{$$hashref{'name'}}=0; |
| 479 |
+ |
} |
| 480 |
+ |
|
| 481 |
|
$self->{currentenvtext}=""; |
| 482 |
|
$self->{EnvContext}=$$hashref{'name'}; |
| 483 |
|
undef $self->{Envvalue}; |
| 485 |
|
$$hashref{'type'}=~tr[A-Z][a-z]; |
| 486 |
|
$self->{tool}->type($$hashref{'name'},$$hashref{'type'}); |
| 487 |
|
} |
| 488 |
+ |
# check other installed copies of the tool |
| 489 |
+ |
# -- construct a menu of options |
| 490 |
+ |
my @menulist=(); |
| 491 |
+ |
# -- a value is fixed - unless interactive switch is on |
| 492 |
|
if ( exists $$hashref{'value'}) { |
| 493 |
< |
$self->{Envvalue}=$$hashref{'value'}; |
| 493 |
> |
$val=$$hashref{'value'}; |
| 494 |
> |
if ( $self->interactive() ) { |
| 495 |
> |
unshift @menulist,$$hashref{'value'}; |
| 496 |
> |
} |
| 497 |
|
} |
| 498 |
< |
elsif ( ! $self->interactive() ) { |
| 499 |
< |
# check other installed copies of the tool |
| 500 |
< |
my ($rv,@params)= |
| 501 |
< |
$self->_toolparamcopy($self->{tool},$$hashref{'name'}); |
| 502 |
< |
if ( $rv && ($#params == 0)) { #dont use multivalued params! |
| 503 |
< |
$self->{Envvalue}=$params[0]; # single val parameter |
| 498 |
> |
# -- add any default values to the selection |
| 499 |
> |
if ( ! defined $val ) { |
| 500 |
> |
if ( $self->_checkdefault($hashref) ) { |
| 501 |
> |
my $var=$self->_expandvars($$hashref{'default'}); |
| 502 |
> |
if ( !grep { $_ eq $var } @menulist ) { |
| 503 |
> |
unshift @menulist, $var; |
| 504 |
> |
} |
| 505 |
|
} |
| 506 |
< |
elsif ( defined $ENV{$$hashref{'name'}} ) { |
| 507 |
< |
# check the environment |
| 508 |
< |
$self->{Envvalue}=$ENV{$$hashref{'name'}}; |
| 506 |
> |
# -- check the environment |
| 507 |
> |
if ( defined $ENV{$$hashref{'name'}} ) { |
| 508 |
> |
if ( !grep { $_ eq $ENV{$$hashref{'name'}}} @menulist ) { |
| 509 |
> |
unshift @menulist, $ENV{$$hashref{'name'}}; |
| 510 |
> |
} |
| 511 |
|
} |
| 512 |
< |
elsif ( $self->_checkdefault($hashref) ) { |
| 513 |
< |
$self->{Envvalue}=$$hashref{'default'}; |
| 512 |
> |
my @paramlist=$self->_getparamsets($self->{tool}, |
| 513 |
> |
$$hashref{'name'}); |
| 514 |
> |
foreach $p ( @paramlist ) { |
| 515 |
> |
# -- only add them if there are the same number of variables |
| 516 |
> |
if ( $#{$p} == $self->{envcount}{$$hashref{'name'}} ) { |
| 517 |
> |
if ( !grep {$_ eq $$p[$self->{EnvironmentCount} |
| 518 |
> |
{$$hashref{'name'}}] } @menulist) { |
| 519 |
> |
push @menulist,$$p[$self->{EnvironmentCount} |
| 520 |
> |
{$$hashref{'name'}}]; |
| 521 |
> |
} |
| 522 |
> |
} |
| 523 |
> |
else { |
| 524 |
> |
$self->verbose("Ignoring tool params - not the same number". |
| 525 |
> |
" defined (".$#{$p}." != ". |
| 526 |
> |
$self->{envcount}{$$hashref{'name'}}.")"); |
| 527 |
> |
} |
| 528 |
|
} |
| 529 |
+ |
if ( $#menulist >=0 ) { |
| 530 |
+ |
print "Validating Values for Variable : ".$$hashref{'name'}."\n"; |
| 531 |
+ |
@menulist=$self->_validateparam($$hashref{'type'},@menulist); |
| 532 |
+ |
} |
| 533 |
+ |
# -- If theres only one option take it without asking |
| 534 |
+ |
if ( $#menulist == 0 && ( ! $self->interactive() )) { |
| 535 |
+ |
$val=$menulist[0]; |
| 536 |
+ |
} |
| 537 |
+ |
elsif ( $#menulist > 0 ) { |
| 538 |
+ |
my $in=$self->_askusermenu( |
| 539 |
+ |
"Multiple possibilities found for ". |
| 540 |
+ |
$$hashref{'name'}." ( occurance ". |
| 541 |
+ |
($self->{EnvironmentCount}{$$hashref{'name'}}+1)." ) ". |
| 542 |
+ |
"\nPlease Choose: ", |
| 543 |
+ |
(@menulist,"Other")); |
| 544 |
+ |
if ( $in <=$#menulist ) { |
| 545 |
+ |
$val=$menulist[$in]; |
| 546 |
+ |
} |
| 547 |
+ |
else { |
| 548 |
+ |
undef $val; |
| 549 |
+ |
} |
| 550 |
+ |
} |
| 551 |
|
} |
| 552 |
+ |
$self->{Envvalue}=$val; # single val parameter |
| 553 |
|
} |
| 554 |
|
} |
| 555 |
|
|
| 625 |
|
pop @{$self->{ARCHBLOCK}}; |
| 626 |
|
$self->{Arch}=$self->{ARCHBLOCK}[$#{$self->{ARCHBLOCK}}]; |
| 627 |
|
} |
| 451 |
– |
|
| 452 |
– |
|
