Changeset 25454
- Timestamp:
- 2012-04-23T10:37:28+12:00 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
gs2-extensions/tdb-edit/trunk/src/bin/script/TDBServer.pl
r25453 r25454 77 77 # Globally available - but once set these are read-only - so locking isn't 78 78 # an issue 79 my $use_harness = 0; 79 80 my $tdbexe = 'tdbcli'; 80 81 my $parent_pid = 0; 81 82 my $collection = ''; 82 83 my $no_daemon = 0; 83 my $debug = 0;84 my $debug = 1; 84 85 my $server; 85 86 my $server_host; … … 318 319 my $tid = shift @_; 319 320 my $result = "#ERROR#"; 320 # Synchronized debug log writing321 if ($debug)322 {323 lock($debug_log);324 $ |++;325 print "[" . time() . "|" . $tid . "|RECV] " . $data . "\n";326 $|--;327 }321 my $the_count = 0; 322 { 323 lock($msg_counter); 324 $msg_counter++; 325 $the_count = $msg_counter + 0; 326 # //unlock($msg_counter); 327 } 328 &debugPrint($the_count, $tid, 'RECV', $data); 328 329 # process special commands first 329 330 if ($data =~ /^#([arq]):(.*)$/) … … 403 404 # form <database>:<key>:<value> 404 405 # where: database is [d]oc, [i]ndex, or [s]rc 405 elsif ($data =~ /^([dis]): (.+)$/s)406 elsif ($data =~ /^([dis]):\[([^\]]+)\]([+?\-])(.+)$/s) 406 407 { 407 408 my $database = $1; 408 my $record = $2; 409 my $key = $2; 410 my $action = $3 411 my $payload = $4; 409 412 # Build path to database file 410 413 my $tdb_path = ''; … … 421 424 $tdb_path = &util::filename_cat($ENV{'GSDLHOME'}, 'collect', $collection, 'building', 'text', $collection . '.tdb'); 422 425 } 423 # Open harness to TDBCLI 424 my $the_count = 0; 425 { 426 lock($msg_counter); 427 $msg_counter++; 428 $the_count = $msg_counter + 0; 429 # //unlock($msg_counter); 430 } 431 my @tdb_command = ($tdbexe, $tdb_path, '-mid ' . $the_count); 432 my $buffer_to_tdb = ''; 433 my $buffer_from_tdb = ''; 434 my $tdb_harness = start(\@tdb_command, \$buffer_to_tdb, \$buffer_from_tdb); 435 # Check the harness worked 436 437 if (!pumpable $tdb_harness) 438 { 439 die("Error! Harness to " . $tdbexe . " has gone away!"); 440 } 441 # - write the data to the TDBCLI 442 $buffer_to_tdb = $record . "\n"; 443 my $write_msg = '#' . $the_count . ' writing: |' . $record . '| => '; 444 while (length($buffer_to_tdb)) 445 { 446 $write_msg .='.'; 447 pump($tdb_harness); 448 } 449 print STDERR $write_msg . "\n"; 450 # - read any response from TDBCLI 451 my $read_msg = '#' . $the_count . ' reading: '; 452 while ($buffer_from_tdb !~ /-{70}/) 453 { 454 $read_msg .= '.'; 455 pump($tdb_harness); 456 } 457 print STDERR $read_msg . ' => |' . $buffer_from_tdb . "|\n"; 458 # - not that this result doesn't include the [Server] prefix as it 459 # may be parsed for data by the client 460 $result = $buffer_from_tdb; 461 chomp($result); 462 # Finished with harness 463 finish($tdb_harness); 426 # Harnesses seem like goodly magic - but unfortunately may be broken 427 # magic. Testing on Medusa randomly hangs on the finish() function. 428 if ($use_harness) 429 { 430 my $record = '[' . $key . ']' . $action . $payload; 431 # Open harness to TDBCLI 432 my @tdb_command = ($tdbexe, $tdb_path, '-mid ' . $the_count); 433 my $buffer_to_tdb = ''; 434 my $buffer_from_tdb = ''; 435 my $tdb_harness = start(\@tdb_command, \$buffer_to_tdb, \$buffer_from_tdb); 436 # Check the harness worked 437 if (!pumpable $tdb_harness) 438 { 439 die("Error! Harness to " . $tdbexe . " has gone away!"); 440 } 441 # - write the data to the TDBCLI 442 $buffer_to_tdb = $record . "\n"; 443 my $write_msg = '#' . $the_count . ' writing: |' . $record . '| => '; 444 while (length($buffer_to_tdb)) 445 { 446 $write_msg .='.'; 447 pump($tdb_harness); 448 } 449 print STDERR $write_msg . "\n"; 450 # - read any response from TDBCLI 451 my $read_msg = '#' . $the_count . ' reading: '; 452 while ($buffer_from_tdb !~ /-{70}/) 453 { 454 $read_msg .= '.'; 455 pump($tdb_harness); 456 } 457 print STDERR $read_msg . ' => |' . $buffer_from_tdb . "|\n"; 458 # - not that this result doesn't include the [Server] prefix as it 459 # may be parsed for data by the client 460 $result = $buffer_from_tdb; 461 chomp($result); 462 # Finished with harness 463 finish($tdb_harness); 464 } 465 # Use different TDB tools depending on arguments 466 # - lookups using TDBGET 467 elsif ($action eq '?') 468 { 469 my $command = 'tdbget "' . $tdb_path . '" "' . $key . '"'; 470 &debugPrint($the_count, $tid, 'TDBGET', 'Command: ' . $command); 471 my $result = `$command`; 472 &debugPrint($the_count, $tid, 'TDBGET', 'Result: ' . $result); 473 if ($result =~ /-{70}/) 474 { 475 $result .= "-"x70 . "\n"; 476 } 477 } 478 # - adds, updates and deletes using TXT2TDB 479 elsif ($action eq '+' || $action eq '-') 480 { 481 my $command = 'txt2tdb "' . $tdb_path . '" -append'; 482 &debugPrint($the_count, $tid, 'TXT2TDB', 'Command: ' . $command); 483 open(my $infodb_handle, '| ' . $command) or die("Error! Failed to open pipe to TXT2TDB\n"); 484 print $infodb_handle '[' . $key . ']'; 485 if ($action eq '-') 486 { 487 print $infodb_handle $action; 488 } 489 print $infodb_handle $payload; 490 close($infodb_handle); 491 $result = "-"x70 . "\n"; 492 &debugPrint($the_count, $tid, 'TXT2TDB', 'Result: ' . $result); 493 } 494 else 495 { 496 die("Error! Unknown action: " . $action . "\n"); 497 } 464 498 } 465 499 # Synchronized debug log writing 500 &debugPrint($the_count, $tid, 'SEND', $result); 501 return $result; 502 } 503 504 sub debugPrint 505 { 506 my ($the_count, $tid, $type, $msg) = @_; 466 507 if ($debug) 467 508 { 468 509 lock($debug_log); 469 510 $|++; 470 print "[" . time() . " |" . $tid . "|SEND] " . $result. "\n\n";511 print "[" . time() . "] #" . $the_count . ", tid:" . $tid . ", act:" . $type . "\n" . $msg . "\n\n"; 471 512 $|--; 472 513 # //unlock($debug_log); 473 514 } 474 return $result;475 515 } 476 516
Note:
See TracChangeset
for help on using the changeset viewer.